diff options
Diffstat (limited to '')
25 files changed, 825 insertions, 733 deletions
diff --git a/stdlib/source/lux/control/concurrency/atom.lux b/stdlib/source/lux/control/concurrency/atom.lux index b82a24cca..5f3719ba8 100644 --- a/stdlib/source/lux/control/concurrency/atom.lux +++ b/stdlib/source/lux/control/concurrency/atom.lux @@ -6,8 +6,9 @@ [monad (#+ do)]] [control ["." function] - ["." io (#- run)]] + ["." io (#- run) ("#\." functor)]] [data + ["." product] [collection ["." array]]] [type @@ -71,16 +72,18 @@ {#.doc (doc "Updates an atom by applying a function to its current value." "If it fails to update it (because some other process wrote to it first), it will retry until it succeeds." "The retries will be done with the new values of the atom, as they show up.")} - (All [a] (-> (-> a a) (Atom a) (IO a))) + (All [a] (-> (-> a a) (Atom a) (IO [a a]))) (loop [_ []] (do io.monad [old (read atom) #let [new (f old)] - swapped? (compare_and_swap old new atom)] + swapped? (..compare_and_swap old new atom)] (if swapped? - (wrap new) + (wrap [old new]) (recur []))))) (def: #export (write value atom) - (All [a] (-> a (Atom a) (IO Any))) - (..update (function.constant value) atom)) + (All [a] (-> a (Atom a) (IO a))) + (|> atom + (..update (function.constant value)) + (io\map product.left))) diff --git a/stdlib/source/lux/control/concurrency/promise.lux b/stdlib/source/lux/control/concurrency/promise.lux index 96822700d..6f8a35f96 100644 --- a/stdlib/source/lux/control/concurrency/promise.lux +++ b/stdlib/source/lux/control/concurrency/promise.lux @@ -93,7 +93,7 @@ (def: (map f fa) (let [[fb resolve] (..promise [])] - (exec (io.run (await (|>> f resolve) fa)) + (exec (io.run (..await (|>> f resolve) fa)) fb)))) (structure: #export apply @@ -103,9 +103,9 @@ (def: (apply ff fa) (let [[fb resolve] (..promise [])] - (exec (io.run (await (function (_ f) - (await (|>> f resolve) fa)) - ff)) + (exec (io.run (..await (function (_ f) + (..await (|>> f resolve) fa)) + ff)) fb)))) (structure: #export monad @@ -117,9 +117,7 @@ (def: (join mma) (let [[ma resolve] (promise [])] - (exec (io.run (await (function (_ ma') - (await resolve ma')) - mma)) + (exec (io.run (..await (..await resolve) mma)) ma)))) (def: #export (and left right) @@ -171,17 +169,17 @@ {#.doc (doc "Runs an I/O computation on its own thread." "Returns a Promise that will eventually host its result.")} (All [a] (-> (IO a) (Promise a))) - (schedule 0)) + (..schedule 0)) (def: #export (delay time_millis value) {#.doc "Delivers a value after a certain period has passed."} (All [a] (-> Nat a (Promise a))) - (schedule time_millis (io value))) + (..schedule time_millis (io value))) (def: #export (wait time_millis) {#.doc "Returns a promise that will be resolved after the specified amount of milliseconds."} (-> Nat (Promise Any)) - (delay time_millis [])) + (..delay time_millis [])) (def: #export (time_out time_millis promise) {#.doc "Wait for a promise to be resolved within the specified amount of milliseconds."} diff --git a/stdlib/source/lux/control/concurrency/semaphore.lux b/stdlib/source/lux/control/concurrency/semaphore.lux index 5be5582de..0e8fa2b94 100644 --- a/stdlib/source/lux/control/concurrency/semaphore.lux +++ b/stdlib/source/lux/control/concurrency/semaphore.lux @@ -3,6 +3,7 @@ [abstract [monad (#+ do)]] [control + [pipe (#+ if>)] ["." io (#+ IO)] ["." try (#+ Try)] ["." exception (#+ exception:)]] @@ -48,23 +49,19 @@ (let [semaphore (:representation semaphore) [signal sink] (: [(Promise Any) (Resolver Any)] (promise.promise []))] - (exec (promise.future - (loop [_ []] + (exec (io.run + (with_expansions [<had_open_position?> (as_is (get@ #open_positions) (i.> -1))] (do io.monad - [state (atom.read semaphore) - #let [[ready? state'] (: [Bit State] - (if (i.> +0 (get@ #open_positions state)) - [true (|> state - (update@ #open_positions dec))] - [false (|> state - (update@ #open_positions dec) - (update@ #waiting_list (queue.push sink)))]))] - success? (atom.compare_and_swap state state' semaphore)] - (if success? - (if ready? - (sink []) - (wrap false)) - (recur []))))) + [[_ state'] (atom.update (|>> (update@ #open_positions dec) + (if> [<had_open_position?>] + [] + [(update@ #waiting_list (queue.push sink))])) + semaphore)] + (with_expansions [<go_ahead> (sink []) + <get_in_line> (wrap false)] + (if (|> state' <had_open_position?>) + <go_ahead> + <get_in_line>))))) signal))) (exception: #export (semaphore_is_maxed_out {max_positions Nat}) @@ -75,42 +72,25 @@ (Ex [k] (-> Semaphore (Promise (Try Int)))) (let [semaphore (:representation semaphore)] (promise.future - (loop [_ []] - (do {! io.monad} - [state (atom.read semaphore) - #let [[?sink state' maxed_out?] (: [(Maybe (Resolver Any)) State Bit] - (case (queue.peek (get@ #waiting_list state)) - #.None - (if (n.= (get@ #max_positions state) - (.nat (get@ #open_positions state))) - [#.None - state - true] - [#.None - (update@ #open_positions inc state) - false]) - - (#.Some head) - [(#.Some head) - (|> state - (update@ #open_positions inc) - (update@ #waiting_list queue.pop)) - false]))]] - (if maxed_out? - (wrap (exception.throw ..semaphore_is_maxed_out [(get@ #max_positions state)])) - (do ! - [#let [open_positions (get@ #open_positions state')] - success? (atom.compare_and_swap state state' semaphore)] - (if success? - (do ! - [_ (case ?sink - #.None - (wrap true) - - (#.Some sink) - (sink []))] - (wrap (#try.Success open_positions))) - (recur []))))))))) + (do {! io.monad} + [[pre post] (atom.update (function (_ state) + (if (i.= (.int (get@ #max_positions state)) + (get@ #open_positions state)) + state + (|> state + (update@ #open_positions inc) + (update@ #waiting_list queue.pop)))) + semaphore)] + (if (is? pre post) + (wrap (exception.throw ..semaphore_is_maxed_out [(get@ #max_positions pre)])) + (do ! + [_ (case (queue.peek (get@ #waiting_list pre)) + #.None + (wrap true) + + (#.Some sink) + (sink []))] + (wrap (#try.Success (get@ #open_positions post))))))))) ) (abstract: #export Mutex @@ -124,23 +104,26 @@ (def: acquire (-> Mutex (Promise Any)) - (|>> :representation wait)) + (|>> :representation ..wait)) (def: release (-> Mutex (Promise Any)) - (|>> :representation signal)) + (|>> :representation ..signal)) (def: #export (synchronize mutex procedure) (All [a] (-> Mutex (IO (Promise a)) (Promise a))) (do promise.monad - [_ (acquire mutex) + [_ (..acquire mutex) output (io.run procedure) - _ (release mutex)] + _ (..release mutex)] (wrap output))) ) -(def: #export limit (refinement.refinement (n.> 0))) -(type: #export Limit (:~ (refinement.type limit))) +(def: #export limit + (refinement.refinement (n.> 0))) + +(type: #export Limit + (:~ (refinement.type limit))) (abstract: #export Barrier {#limit Limit @@ -154,15 +137,15 @@ (-> Limit Barrier) (:abstraction {#limit limit #count (atom.atom 0) - #start_turnstile (semaphore 0) - #end_turnstile (semaphore 0)})) + #start_turnstile (..semaphore 0) + #end_turnstile (..semaphore 0)})) (def: (un_block times turnstile) (-> Nat Semaphore (Promise Any)) (loop [step 0] (if (n.< times step) (do promise.monad - [_ (..signal turnstile)] + [outcome (..signal turnstile)] (recur (inc step))) (\ promise.monad wrap [])))) @@ -172,11 +155,11 @@ (do promise.monad [#let [limit (refinement.un_refine (get@ #limit barrier)) goal <goal> - count (io.run (atom.update <update> (get@ #count barrier))) + [_ count] (io.run (atom.update <update> (get@ #count barrier))) reached? (n.= goal count)]] (if reached? - (un_block limit (get@ <turnstile> barrier)) - (wait (get@ <turnstile> barrier)))))] + (..un_block (dec limit) (get@ <turnstile> barrier)) + (..wait (get@ <turnstile> barrier)))))] [start inc limit #start_turnstile] [end dec 0 #end_turnstile] diff --git a/stdlib/source/lux/control/concurrency/thread.lux b/stdlib/source/lux/control/concurrency/thread.lux index 2ae0afec9..a34e050d5 100644 --- a/stdlib/source/lux/control/concurrency/thread.lux +++ b/stdlib/source/lux/control/concurrency/thread.lux @@ -5,7 +5,7 @@ [abstract ["." monad (#+ do)]] [control - ["ex" exception (#+ exception:)] + ["." exception (#+ exception:)] ["." io (#+ IO io)]] [data [collection @@ -153,6 +153,6 @@ (do ! [_ (monad.map ! (get@ #action) ready)] (run! [])) - (error! (ex.construct ..cannot_continue_running_threads [])))) + (error! (exception.construct ..cannot_continue_running_threads [])))) ))) )) diff --git a/stdlib/source/lux/target/js.lux b/stdlib/source/lux/target/js.lux index fb0e8948a..11285ad12 100644 --- a/stdlib/source/lux/target/js.lux +++ b/stdlib/source/lux/target/js.lux @@ -31,25 +31,27 @@ (-> (Code Any) Text) (|>> :representation)) - (template [<type> <brand> <super>+] - [(abstract: (<brand> brand) Any) - (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+)))))] + (template [<type> <super>+] + [(with_expansions [<brand> (template.identifier [<type> "'"])] + (abstract: (<brand> brand) Any) + (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))] - [Expression Expression' [Code]] - [Computation Computation' [Expression' Code]] - [Location Location' [Computation' Expression' Code]] - [Statement Statement' [Code]] + [Expression [Code]] + [Computation [Expression' Code]] + [Location [Computation' Expression' Code]] + [Statement [Code]] ) - (template [<type> <brand> <super>+] - [(abstract: #export <brand> Any) - (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+)))))] + (template [<type> <super>+] + [(with_expansions [<brand> (template.identifier [<type> "'"])] + (abstract: #export <brand> Any) + (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))] - [Var Var' [Location' Computation' Expression' Code]] - [Access Access' [Location' Computation' Expression' Code]] - [Literal Literal' [Computation' Expression' Code]] - [Loop Loop' [Statement' Code]] - [Label Label' [Code]] + [Var [Location' Computation' Expression' Code]] + [Access [Location' Computation' Expression' Code]] + [Literal [Computation' Expression' Code]] + [Loop [Statement' Code]] + [Label [Code]] ) (template [<name> <literal>] diff --git a/stdlib/source/lux/target/lua.lux b/stdlib/source/lux/target/lua.lux index fe4d0eb92..be46169dd 100644 --- a/stdlib/source/lux/target/lua.lux +++ b/stdlib/source/lux/target/lua.lux @@ -1,31 +1,28 @@ (.module: - [lux (#- Code int if cond function or and not let) + [lux (#- Location Code int if cond function or and not let) [control - [pipe (#+ case> cond> new>)] - [parser - ["s" code]]] + [pipe (#+ case> cond> new>)]] [data - [number - ["i" int] - ["f" frac]] ["." text ["%" format (#+ format)]] [collection ["." list ("#\." functor fold)]]] [macro - ["." template] - ["." code] - [syntax (#+ syntax:)]] + ["." template]] + [math + [number + ["i" int] + ["f" frac]]] [type abstract]]) -(def: input-separator ", ") -(def: statement-suffix ";") +(def: input_separator ", ") +(def: statement_suffix ";") (def: nest (-> Text Text) - (|>> (format text.new-line) - (text.replace-all text.new-line (format text.new-line text.tab)))) + (|>> (format text.new_line) + (text.replace_all text.new_line (format text.new_line text.tab)))) (abstract: #export (Code brand) Text @@ -38,26 +35,25 @@ (-> (Code Any) Text) (|>> :representation)) - (template [<type> <super>] - [(with-expansions [<brand> (template.identifier [<type> "'"])] - (`` (abstract: #export (<brand> brand) Any)) - (`` (type: #export (<type> brand) - (<super> (<brand> brand)))))] + (template [<type> <super>+] + [(with_expansions [<brand> (template.identifier [<type> "'"])] + (abstract: (<brand> brand) Any) + (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+))))))] - [Expression Code] - [Computation Expression] - [Location Computation] + [Expression [Code]] + [Computation [Expression' Code]] + [Location [Computation' Expression' Code]] + [Statement [Code]] ) - (template [<type> <super>] - [(with-expansions [<brand> (template.identifier [<type> "'"])] - (`` (abstract: #export <brand> Any)) - (`` (type: #export <type> (<super> <brand>))))] + (template [<type> <super>+] + [(with_expansions [<brand> (template.identifier [<type> "'"])] + (abstract: #export <brand> Any) + (`` (type: #export <type> (|> <brand> (~~ (template.splice <super>+))))))] - [Literal Computation] - [Var Location] - [Access Location] - [Statement Code] + [Literal [Computation' Expression' Code]] + [Var [Location' Computation' Expression' Code]] + [Access [Location' Computation' Expression' Code]] ) (def: #export nil @@ -78,13 +74,13 @@ (def: #export float (-> Frac Literal) - (|>> (cond> [(f.= f.positive-infinity)] + (|>> (cond> [(f.= f.positive_infinity)] [(new> "(1.0/0.0)" [])] - [(f.= f.negative-infinity)] + [(f.= f.negative_infinity)] [(new> "(-1.0/0.0)" [])] - [(f.= f.not-a-number)] + [(f.= f.not_a_number)] [(new> "(0.0/0.0)" [])] ## else @@ -94,74 +90,74 @@ (def: sanitize (-> Text Text) (`` (|>> (~~ (template [<find> <replace>] - [(text.replace-all <find> <replace>)] + [(text.replace_all <find> <replace>)] ["\" "\\"] [text.tab "\t"] - [text.vertical-tab "\v"] + [text.vertical_tab "\v"] [text.null "\0"] - [text.back-space "\b"] - [text.form-feed "\f"] - [text.new-line "\n"] - [text.carriage-return "\r"] - [text.double-quote (format "\" text.double-quote)] + [text.back_space "\b"] + [text.form_feed "\f"] + [text.new_line "\n"] + [text.carriage_return "\r"] + [text.double_quote (format "\" text.double_quote)] )) ))) (def: #export string (-> Text Literal) - (|>> ..sanitize (text.enclose' text.double-quote) :abstraction)) + (|>> ..sanitize (text.enclose' text.double_quote) :abstraction)) (def: #export array - (-> (List (Expression Any)) Literal) + (-> (List Expression) Literal) (|>> (list\map ..code) - (text.join-with ..input-separator) + (text.join_with ..input_separator) (text.enclose ["{" "}"]) :abstraction)) (def: #export table - (-> (List [Text (Expression Any)]) Literal) + (-> (List [Text Expression]) Literal) (|>> (list\map (.function (_ [key value]) (format key " = " (:representation value)))) - (text.join-with ..input-separator) + (text.join_with ..input_separator) (text.enclose ["{" "}"]) :abstraction)) (def: #export (nth idx array) - (-> (Expression Any) (Expression Any) Access) + (-> Expression Expression Access) (:abstraction (format (:representation array) "[" (:representation idx) "]"))) (def: #export (the field table) - (-> Text (Expression Any) (Computation Any)) + (-> Text Expression Computation) (:abstraction (format (:representation table) "." field))) (def: #export length - (-> (Expression Any) (Computation Any)) + (-> Expression Computation) (|>> :representation (text.enclose ["#(" ")"]) :abstraction)) (def: #export (apply/* args func) - (-> (List (Expression Any)) (Expression Any) (Computation Any)) + (-> (List Expression) Expression Computation) (|> args (list\map ..code) - (text.join-with ..input-separator) + (text.join_with ..input_separator) (text.enclose ["(" ")"]) (format (:representation func)) :abstraction)) (def: #export (do method table args) - (-> Text (Expression Any) (List (Expression Any)) (Computation Any)) + (-> Text Expression (List Expression) Computation) (|> args (list\map ..code) - (text.join-with ..input-separator) + (text.join_with ..input_separator) (text.enclose ["(" ")"]) (format (:representation table) ":" method) :abstraction)) (template [<op> <name>] [(def: #export (<name> parameter subject) - (-> (Expression Any) (Expression Any) (Expression Any)) + (-> Expression Expression Expression) (:abstraction (format "(" (:representation subject) " " <op> " " @@ -183,16 +179,16 @@ ["or" or] ["and" and] - ["|" bit-or] - ["&" bit-and] - ["~" bit-xor] + ["|" bit_or] + ["&" bit_and] + ["~" bit_xor] - ["<<" bit-shl] - [">>" bit-shr] + ["<<" bit_shl] + [">>" bit_shr] ) (def: #export (not subject) - (-> (Expression Any) (Expression Any)) + (-> Expression Expression) (:abstraction (format "(not " (:representation subject) ")"))) (def: #export var @@ -200,87 +196,87 @@ (|>> :abstraction)) (def: #export statement - (-> (Expression Any) Statement) - (|>> :representation (text.suffix ..statement-suffix) :abstraction)) + (-> Expression Statement) + (|>> :representation (text.suffix ..statement_suffix) :abstraction)) (def: #export (then pre! post!) (-> Statement Statement Statement) (:abstraction (format (:representation pre!) - text.new-line + text.new_line (:representation post!)))) (def: locations - (-> (List (Location Any)) Text) + (-> (List Location) Text) (|>> (list\map ..code) - (text.join-with ..input-separator))) + (text.join_with ..input_separator))) (def: #export (local vars) (-> (List Var) Statement) - (:abstraction (format "local " (..locations vars) ..statement-suffix))) + (:abstraction (format "local " (..locations vars) ..statement_suffix))) (def: #export (set vars value) - (-> (List (Location Any)) (Expression Any) Statement) - (:abstraction (format (..locations vars) " = " (:representation value) ..statement-suffix))) + (-> (List Location) Expression Statement) + (:abstraction (format (..locations vars) " = " (:representation value) ..statement_suffix))) (def: #export (let vars value) - (-> (List Var) (Expression Any) Statement) + (-> (List Var) Expression Statement) ($_ ..then (local vars) (set vars value))) (def: #export (if test then! else!) - (-> (Expression Any) Statement Statement Statement) + (-> Expression Statement Statement Statement) (:abstraction (format "if " (:representation test) - text.new-line "then" (..nest (:representation then!)) - text.new-line "else" (..nest (:representation else!)) - text.new-line "end" ..statement-suffix))) + text.new_line "then" (..nest (:representation then!)) + text.new_line "else" (..nest (:representation else!)) + text.new_line "end" ..statement_suffix))) (def: #export (when test then!) - (-> (Expression Any) Statement Statement) + (-> Expression Statement Statement) (:abstraction (format "if " (:representation test) - text.new-line "then" (..nest (:representation then!)) - text.new-line "end" ..statement-suffix))) + text.new_line "then" (..nest (:representation then!)) + text.new_line "end" ..statement_suffix))) (def: #export (while test body!) - (-> (Expression Any) Statement Statement) + (-> Expression Statement Statement) (:abstraction (format "while " (:representation test) " do" (..nest (:representation body!)) - text.new-line "end" ..statement-suffix))) + text.new_line "end" ..statement_suffix))) - (def: #export (for-in vars source body!) - (-> (List Var) (Expression Any) Statement Statement) + (def: #export (for_in vars source body!) + (-> (List Var) Expression Statement Statement) (:abstraction (format "for " (|> vars (list\map ..code) - (text.join-with ..input-separator)) + (text.join_with ..input_separator)) " in " (:representation source) " do" (..nest (:representation body!)) - text.new-line "end" ..statement-suffix))) + text.new_line "end" ..statement_suffix))) - (def: #export (for-step var from to step body!) - (-> Var (Expression Any) (Expression Any) (Expression Any) Statement + (def: #export (for_step var from to step body!) + (-> Var Expression Expression Expression Statement Statement) (:abstraction (format "for " (:representation var) " = " (:representation from) - ..input-separator (:representation to) - ..input-separator (:representation step) " do" + ..input_separator (:representation to) + ..input_separator (:representation step) " do" (..nest (:representation body!)) - text.new-line "end" ..statement-suffix))) + text.new_line "end" ..statement_suffix))) (def: #export (return value) - (-> (Expression Any) Statement) - (:abstraction (format "return " (:representation value) ..statement-suffix))) + (-> Expression Statement) + (:abstraction (format "return " (:representation value) ..statement_suffix))) (def: #export (closure args body!) - (-> (List Var) Statement (Expression Any)) + (-> (List Var) Statement Expression) (|> (format "function " (|> args ..locations (text.enclose ["(" ")"])) (..nest (:representation body!)) - text.new-line "end") + text.new_line "end") (text.enclose ["(" ")"]) :abstraction)) @@ -292,17 +288,17 @@ ..locations (text.enclose ["(" ")"])) (..nest (:representation body!)) - text.new-line "end" ..statement-suffix))) + text.new_line "end" ..statement_suffix))) (def: #export break Statement (|> "break" - (text.suffix ..statement-suffix) + (text.suffix ..statement_suffix) :abstraction)) ) (def: #export (cond clauses else!) - (-> (List [(Expression Any) Statement]) Statement Statement) + (-> (List [Expression Statement]) Statement Statement) (list\fold (.function (_ [test then!] next!) (..if test then! next!)) else! diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index d3951e5a3..2d1b56740 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -5,6 +5,7 @@ [abstract ["." monad (#+ do)]] [control + [pipe (#+ case>)] ["." try] ["." exception (#+ exception:)] ["." io] @@ -155,22 +156,18 @@ (def: #export (times amount test) (-> Nat Test Test) - (cond (n.= 0 amount) - (fail (exception.construct ..must_try_test_at_least_once [])) - - (n.= 1 amount) - test - - ## else - (do random.monad - [seed random.nat] - (function (_ prng) - (let [[prng' instance] (random.run (random.pcg32 [..pcg32_magic_inc seed]) test)] - [prng' (do promise.monad - [[counters documentation] instance] - (if (failed? counters) - (wrap [counters (times_failure seed documentation)]) - (product.right (random.run prng' (times (dec amount) test)))))]))))) + (case amount + 0 (..fail (exception.construct ..must_try_test_at_least_once [])) + 1 test + _ (do random.monad + [seed random.nat] + (function (_ prng) + (let [[prng' instance] (random.run (random.pcg32 [..pcg32_magic_inc seed]) test)] + [prng' (do promise.monad + [[counters documentation] instance] + (if (failed? counters) + (wrap [counters (times_failure seed documentation)]) + (|> test (times (dec amount)) (random.run prng') product.right)))]))))) (def: (tally duration counters) (-> Duration Counters Text) @@ -343,20 +340,18 @@ [seed random.nat #let [prng (random.pcg32 [..pcg32_magic_inc seed]) run! (: (-> Test Assertion) - (function (_ test) - (|> (case (|> test - (random.run prng) - product.right - io.io - "lux try") - (#try.Success output) - output - - (#try.Failure error) - (..assert (exception.construct ..error_during_execution [error]) false)) - io.io - promise.future - promise\join)))]] + (|>> (random.run prng) + product.right + io.io + "lux try" + (case> (#try.Success output) + output + + (#try.Failure error) + (..assert (exception.construct ..error_during_execution [error]) false)) + io.io + promise.future + promise\join))]] (wrap (do {! promise.monad} [assertions (monad.seq ! (list\map run! tests))] (wrap [(|> assertions diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux new file mode 100644 index 000000000..b431dc39b --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux @@ -0,0 +1,34 @@ +(.module: + [lux #* + ["." host] + [abstract + ["." monad (#+ do)]] + [control + ["<>" parser + ["<c>" code (#+ Parser)]]] + [data + [collection + ["." array (#+ Array)] + ["." dictionary] + ["." list]]] + ["." type + ["." check]] + ["@" target + ["_" lua]]] + [// + ["/" lux (#+ custom)] + [// + ["." bundle] + [// + ["." analysis #_ + ["#/." type]] + [// + ["." analysis (#+ Analysis Operation Phase Handler Bundle)] + [/// + ["." phase]]]]]]) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lua") + (|> bundle.empty + ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux index b9db6e702..2f1917de9 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux @@ -6,10 +6,11 @@ ["." function]] [data ["." product] - [number - ["f" frac]] [collection ["." dictionary]]] + [math + [number + ["f" frac]]] [target ["_" lua (#+ Expression Literal)]]] [//// @@ -24,45 +25,39 @@ (template: (!unary function) (|>> list _.apply/* (|> (_.var function)))) -(def: lux-procs +(def: lux_procs Bundle (|> /.empty (/.install "is" (binary (product.uncurry _.=))) (/.install "try" (unary //runtime.lux//try)))) -(def: i64-procs +(def: i64_procs Bundle (<| (/.prefix "i64") (|> /.empty - (/.install "and" (binary (product.uncurry _.bit-and))) - (/.install "or" (binary (product.uncurry _.bit-or))) - (/.install "xor" (binary (product.uncurry _.bit-xor))) - (/.install "left-shift" (binary (product.uncurry _.bit-shl))) - (/.install "logical-right-shift" (binary (product.uncurry //runtime.i64//logic-right-shift))) - (/.install "arithmetic-right-shift" (binary (product.uncurry _.bit-shr))) + (/.install "and" (binary (product.uncurry _.bit_and))) + (/.install "or" (binary (product.uncurry _.bit_or))) + (/.install "xor" (binary (product.uncurry _.bit_xor))) + (/.install "left-shift" (binary (product.uncurry _.bit_shl))) + (/.install "logical-right-shift" (binary (product.uncurry //runtime.i64//logic_right_shift))) (/.install "=" (binary (product.uncurry _.=))) (/.install "+" (binary (product.uncurry _.+))) (/.install "-" (binary (product.uncurry _.-))) - ))) - -(def: int-procs - Bundle - (<| (/.prefix "int") - (|> /.empty (/.install "<" (binary (product.uncurry _.<))) (/.install "*" (binary (product.uncurry _.*))) (/.install "/" (binary (product.uncurry _./))) (/.install "%" (binary (product.uncurry _.%))) - (/.install "frac" (unary (_./ (_.float +1.0)))) - (/.install "char" (unary (!unary "string.char")))))) + (/.install "f64" (unary (_./ (_.float +1.0)))) + (/.install "char" (unary (!unary "string.char"))) + ))) -(def: frac//decode - (Unary (Expression Any)) +(def: f64//decode + (Unary Expression) (|>> list _.apply/* (|> (_.var "tonumber")) _.return (_.closure (list)) //runtime.lux//try)) -(def: frac-procs +(def: f64_procs Bundle - (<| (/.prefix "frac") + (<| (/.prefix "f64") (|> /.empty (/.install "+" (binary (product.uncurry _.+))) (/.install "-" (binary (product.uncurry _.-))) @@ -71,23 +66,23 @@ (/.install "%" (binary (product.uncurry _.%))) (/.install "=" (binary (product.uncurry _.=))) (/.install "<" (binary (product.uncurry _.<))) - (/.install "int" (unary (!unary "math.floor"))) + (/.install "i64" (unary (!unary "math.floor"))) (/.install "encode" (unary (!unary "tostring"))) - (/.install "decode" (unary ..frac//decode))))) + (/.install "decode" (unary ..f64//decode))))) (def: (text//char [subjectO paramO]) - (Binary (Expression Any)) + (Binary Expression) (//runtime.text//char subjectO paramO)) (def: (text//clip [paramO extraO subjectO]) - (Trinary (Expression Any)) + (Trinary Expression) (//runtime.text//clip subjectO paramO extraO)) (def: (text//index [startO partO textO]) - (Trinary (Expression Any)) + (Trinary Expression) (//runtime.text//index textO partO startO)) -(def: text-procs +(def: text_procs Bundle (<| (/.prefix "text") (|> /.empty @@ -101,17 +96,16 @@ ))) (def: (io//log! messageO) - (Unary (Expression Any)) + (Unary Expression) (_.or (_.apply/* (list messageO) (_.var "print")) //runtime.unit)) -(def: io-procs +(def: io_procs Bundle (<| (/.prefix "io") (|> /.empty (/.install "log" (unary ..io//log!)) (/.install "error" (unary (!unary "error"))) - (/.install "exit" (unary (!unary "os.exit"))) (/.install "current-time" (nullary (function (_ _) (|> (_.var "os.time") (_.apply/* (list)) @@ -120,10 +114,9 @@ (def: #export bundle Bundle (<| (/.prefix "lux") - (|> lux-procs - (dictionary.merge i64-procs) - (dictionary.merge int-procs) - (dictionary.merge frac-procs) - (dictionary.merge text-procs) - (dictionary.merge io-procs) + (|> lux_procs + (dictionary.merge i64_procs) + (dictionary.merge f64_procs) + (dictionary.merge text_procs) + (dictionary.merge io_procs) ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux index 02197dc02..03913b84b 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux @@ -17,7 +17,7 @@ ["/#" // #_ ["#." reference] ["/#" // #_ - ["." extension] + ["#." extension] ["/#" // #_ [analysis (#+)] ["." synthesis] @@ -109,7 +109,7 @@ (/function.apply expression archive application) (#synthesis.Extension extension) - (extension.apply archive expression extension) + (///extension.apply archive expression extension) )) (def: #export generate diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux index 38f5125ea..1bcd569c7 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux @@ -2,8 +2,6 @@ [lux (#- case let if) [abstract ["." monad (#+ do)]] - [control - ["." exception (#+ exception:)]] [data ["." maybe] ["." text] diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux index 9fa7107bb..f62b04c4e 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux @@ -51,15 +51,15 @@ [Bundle /////generation.Bundle] ) +(type: #export (Generator i) + (-> Phase Archive i (Operation Expression))) + (type: #export Phase! (-> Phase Archive Synthesis (Operation Statement))) (type: #export (Generator! i) (-> Phase! Phase Archive i (Operation Statement))) -(type: #export (Generator i) - (-> Phase Archive i (Operation Expression))) - (def: prefix Text "LuxRuntime") @@ -108,12 +108,9 @@ (case declaration (#.Left name) (let [g!name (code.local_identifier name)] - (wrap (list (` (def: (~ runtime) + (wrap (list (` (def: #export (~ g!name) Var (~ runtime_name))) - - (` (def: #export (~ g!name) - (~ runtime))) (` (def: (~ (code.local_identifier (format "@" name))) Statement @@ -125,13 +122,10 @@ (let [g!name (code.local_identifier name) inputsC (list\map code.local_identifier inputs) inputs_typesC (list\map (function.constant (` _.Expression)) inputs)] - (wrap (list (` (def: ((~ runtime) (~+ inputsC)) + (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) (-> (~+ inputs_typesC) Computation) (_.apply/* (~ runtime_name) (list (~+ inputsC))))) - (` (def: #export (~ g!name) - (~ runtime))) - (` (def: (~ (code.local_identifier (format "@" name))) Statement (..feature (~ runtime_name) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux index 31ede85d1..2e3369915 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux @@ -3,19 +3,24 @@ [abstract [monad (#+ do)]]] ["." / #_ - [runtime (#+ Phase)] + [runtime (#+ Phase Phase!)] ["#." primitive] ["#." structure] - ["#." reference ("#\." system)] + ["#." reference] ["#." case] ["#." loop] ["#." function] - ["//#" /// #_ - ["#." extension] + ["/#" // #_ + ["#." reference] ["/#" // #_ - ["." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)]]]]]) + ["#." extension] + ["/#" // #_ + [analysis (#+)] + ["." synthesis] + ["//#" /// #_ + ["#." phase ("#\." monad)] + [reference (#+) + [variable (#+)]]]]]]]) (def: #export (generate archive synthesis) Phase @@ -35,7 +40,7 @@ (/structure.tuple generate archive members) (#synthesis.Reference value) - (/reference\reference archive value) + (//reference.reference /reference.system archive value) (^ (synthesis.branch/case case)) (/case.case generate archive case) @@ -46,6 +51,9 @@ (^ (synthesis.branch/if if)) (/case.if generate archive if) + (^ (synthesis.branch/get get)) + (/case.get generate archive get) + (^ (synthesis.loop/scope scope)) (/loop.scope generate archive scope) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux index b1861b93a..e6dad82e5 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux @@ -1,9 +1,7 @@ (.module: [lux (#- case let if) [abstract - [monad (#+ do)]] - [control - ["ex" exception (#+ exception:)]] + ["." monad (#+ do)]] [data ["." text] [collection @@ -12,27 +10,26 @@ [target ["_" lua (#+ Expression Var Statement)]]] ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] + ["#." runtime (#+ Operation Phase Phase! Generator Generator!)] + ["#." reference] ["#." primitive] ["/#" // #_ ["#." reference] ["/#" // #_ - [synthesis - ["/" case]] + ["#." synthesis #_ + ["#/." case]] ["/#" // #_ - ["#." synthesis (#+ Synthesis Path)] - ["/#" // #_ - ["/#" // #_ - [reference (#+ Register)] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]]) + ["#." synthesis (#+ Member Synthesis Path)] + ["//#" /// #_ + [reference + [variable (#+ Register)]] + ["#." phase ("#\." monad)] + [meta + [archive (#+ Archive)]]]]]]]) (def: #export register - (///reference.local _.var)) - -(def: #export capture - (///reference.foreign _.var)) + (-> Register Var) + (|>> (///reference.local //reference.system) :assume)) (def: #export (let generate archive [valueS register bodyS]) (Generator [Synthesis Register Synthesis]) @@ -45,8 +42,8 @@ (_.closure (list (..register register))) (_.apply/* (list valueO)))))) -(def: #export (record-get generate archive [valueS pathP]) - (Generator [Synthesis (List (Either Nat Nat))]) +(def: #export (get generate archive [pathP valueS]) + (Generator [(List Member) Synthesis]) (do ///////phase.monad [valueO (generate archive valueS)] (wrap (list\fold (function (_ side source) @@ -54,11 +51,11 @@ (^template [<side> <accessor>] [(<side> lefts) (<accessor> (_.int (.int lefts)))]) - ([#.Left //runtime.tuple//left] + ([#.Left //runtime.tuple//left] [#.Right //runtime.tuple//right]))] (method source))) valueO - pathP)))) + (list.reverse pathP))))) (def: #export (if generate archive [testS thenS elseS]) (Generator [Synthesis Synthesis Synthesis]) @@ -77,19 +74,19 @@ (def: @temp (_.var "lux_pm_temp")) (def: (push! value) - (-> (Expression Any) Statement) + (-> Expression Statement) (_.statement (|> (_.var "table.insert") (_.apply/* (list @cursor value))))) -(def: peek-and-pop - (Expression Any) +(def: peek_and_pop + Expression (|> (_.var "table.remove") (_.apply/* (list @cursor)))) (def: pop! Statement - (_.statement ..peek-and-pop)) + (_.statement ..peek_and_pop)) (def: peek - (Expression Any) + Expression (_.nth (_.length @cursor) @cursor)) (def: save! @@ -116,8 +113,8 @@ fail! (..push! @temp)))))] - [left-choice _.nil (<|)] - [right-choice (_.string "") inc] + [left_choice _.nil (<|)] + [right_choice (_.string "") inc] ) (def: (alternation pre! post!) @@ -131,81 +128,103 @@ ..restore! post!))) -(def: (pattern-matching' generate archive pathP) +(def: (pattern_matching' generate archive) (-> Phase Archive Path (Operation Statement)) - (.case pathP - (^ (/////synthesis.path/then bodyS)) - (///////phase\map _.return (generate archive bodyS)) - - #/////synthesis.Pop - (///////phase\wrap ..pop!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.let (list (..register register)) ..peek)) - - (^template [<tag> <format>] - [(^ (<tag> value)) - (///////phase\wrap (_.when (|> value <format> (_.= ..peek) _.not) - fail!))]) - ([/////synthesis.path/bit //primitive.bit] - [/////synthesis.path/i64 //primitive.i64] - [/////synthesis.path/f64 //primitive.f64] - [/////synthesis.path/text //primitive.text]) - - (^template [<complex> <simple> <choice>] - [(^ (<complex> idx)) - (///////phase\wrap (<choice> false idx)) - - (^ (<simple> idx nextP)) - (|> nextP - (pattern-matching' generate archive) - (///////phase\map (_.then (<choice> true idx))))]) - ([/////synthesis.side/left /////synthesis.simple-left-side ..left-choice] - [/////synthesis.side/right /////synthesis.simple-right-side ..right-choice]) - - (^ (/////synthesis.member/left 0)) - (///////phase\wrap (|> ..peek (_.nth (_.int +1)) ..push!)) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) - ([/////synthesis.member/left //runtime.tuple//left] - [/////synthesis.member/right //runtime.tuple//right]) - - (^ (/////synthesis.!bind-top register thenP)) - (do ///////phase.monad - [then! (pattern-matching' generate archive thenP)] - (///////phase\wrap ($_ _.then - (_.let (list (..register register)) ..peek-and-pop) - then!))) - - (^template [<tag> <combinator>] - [(^ (<tag> preP postP)) - (do ///////phase.monad - [pre! (pattern-matching' generate archive preP) - post! (pattern-matching' generate archive postP)] - (wrap (<combinator> pre! post!)))]) - ([/////synthesis.path/seq _.then] - [/////synthesis.path/alt ..alternation]))) - -(def: (pattern-matching generate archive pathP) + (function (recur pathP) + (.case pathP + (#/////synthesis.Then bodyS) + (///////phase\map _.return (generate archive bodyS)) + + #/////synthesis.Pop + (///////phase\wrap ..pop!) + + (#/////synthesis.Bind register) + (///////phase\wrap (_.let (list (..register register)) ..peek)) + + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail!))] + (wrap (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^template [<tag> <format>] + [(<tag> cons) + (do {! ///////phase.monad} + [clauses (monad.map ! (function (_ [match then]) + (do ! + [then! (recur then)] + (wrap [(_.= (|> match <format>) + ..peek) + then!]))) + (#.Cons cons))] + (wrap (_.cond clauses ..fail!)))]) + ([#/////synthesis.I64_Fork (<| _.int .int)] + [#/////synthesis.F64_Fork _.float] + [#/////synthesis.Text_Fork _.string]) + + (^template [<complex> <simple> <choice>] + [(^ (<complex> idx)) + (///////phase\wrap (<choice> false idx)) + + (^ (<simple> idx nextP)) + (///////phase\map (_.then (<choice> true idx)) (recur nextP))]) + ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] + [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) + + (^ (/////synthesis.member/left 0)) + (///////phase\wrap (|> ..peek (_.nth (_.int +1)) ..push!)) + + (^template [<pm> <getter>] + [(^ (<pm> lefts)) + (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (^ (/////synthesis.!bind_top register thenP)) + (do ///////phase.monad + [then! (recur thenP)] + (///////phase\wrap ($_ _.then + (_.let (list (..register register)) ..peek_and_pop) + then!))) + + (^template [<tag> <combinator>] + [(^ (<tag> preP postP)) + (do ///////phase.monad + [pre! (recur preP) + post! (recur postP)] + (wrap (<combinator> pre! post!)))]) + ([/////synthesis.path/seq _.then] + [/////synthesis.path/alt ..alternation])))) + +(def: (pattern_matching generate archive pathP) (-> Phase Archive Path (Operation Statement)) (do ///////phase.monad - [pattern-matching! (pattern-matching' generate archive pathP)] + [pattern_matching! (pattern_matching' generate archive pathP)] (wrap ($_ _.then (_.while (_.bool true) - pattern-matching!) - (_.statement (|> (_.var "error") (_.apply/* (list (_.string /.pattern-matching-error))))))))) + pattern_matching!) + (_.statement (|> (_.var "error") (_.apply/* (list (_.string ////synthesis/case.pattern_matching_error))))))))) (def: #export (case generate archive [valueS pathP]) (Generator [Synthesis Path]) (do ///////phase.monad [initG (generate archive valueS) - pattern-matching! (pattern-matching generate archive pathP)] + pattern_matching! (pattern_matching generate archive pathP)] (wrap (|> ($_ _.then (_.local (list @temp)) (_.let (list @cursor) (_.array (list initG))) (_.let (list @savepoint) (_.array (list))) - pattern-matching!) + pattern_matching!) (_.closure (list)) (_.apply/* (list)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux index 0d97b3b8c..7c07c8c6d 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux @@ -9,21 +9,22 @@ [collection ["." list ("#\." functor fold)]]] [target - ["_" lua (#+ Expression Statement)]]] + ["_" lua (#+ Var Expression Statement)]]] ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] + ["#." runtime (#+ Operation Phase Phase! Generator)] ["#." reference] ["#." case] ["/#" // #_ ["#." reference] ["//#" /// #_ - [analysis (#+ Variant Tuple Environment Abstraction Application Analysis)] + [analysis (#+ Variant Tuple Abstraction Application Analysis)] [synthesis (#+ Synthesis)] - ["#." generation] + ["#." generation (#+ Context)] ["//#" /// #_ - [reference (#+ Register Variable)] [arity (#+ Arity)] - ["#." phase]]]]]) + ["#." phase ("#\." monad)] + [reference + [variable (#+ Register Variable)]]]]]]) (def: #export (apply generate archive [functionS argsS+]) (Generator (Application Synthesis)) @@ -33,16 +34,17 @@ (wrap (_.apply/* argsO+ functionO)))) (def: #export capture - (///reference.foreign _.var)) + (-> Register Var) + (|>> (///reference.foreign //reference.system) :assume)) -(def: (with-closure function-name inits function-definition) - (-> Text (List (Expression Any)) Statement (Operation (Expression Any))) +(def: (with_closure function_name inits function_definition) + (-> Text (List Expression) Statement (Operation Expression)) (case inits #.Nil (do ///////phase.monad - [_ (/////generation.execute! function-definition) - _ (/////generation.save! function-name function-definition)] - (wrap (|> (_.var function-name) (_.apply/* inits)))) + [_ (/////generation.execute! function_definition) + _ (/////generation.save! function_name function_definition)] + (wrap (|> (_.var function_name) (_.apply/* inits)))) _ (do {! ///////phase.monad} @@ -51,8 +53,8 @@ (|> (list.enumeration inits) (list\map (|>> product.left ..capture))) ($_ _.then - function-definition - (_.return (_.var function-name))))] + function_definition + (_.return (_.var function_name))))] _ (/////generation.execute! directive) _ (/////generation.save! (_.code @closure) directive)] (wrap (_.apply/* inits @closure))))) @@ -63,48 +65,47 @@ (def: #export (function generate archive [environment arity bodyS]) (Generator (Abstraction Synthesis)) (do {! ///////phase.monad} - [[function-name bodyO] (/////generation.with-new-context + [[function_name bodyO] (/////generation.with_new_context archive (do ! - [function-name (\ ! map ///reference.artifact-name - /////generation.context)] - (/////generation.with-anchor (_.var function-name) + [function_name (\ ! map ///reference.artifact + (/////generation.context archive))] + (/////generation.with_anchor (_.var function_name) (generate archive bodyS)))) - closureO+ (: (Operation (List (Expression Any))) - (monad.map ! (\ //reference.system variable) environment)) - #let [function-name (///reference.artifact-name function-name) + closureO+ (monad.map ! (generate archive) environment) + #let [function_name (///reference.artifact function_name) @curried (_.var "curried") arityO (|> arity .int _.int) - @num-args (_.var "num_args") - @self (_.var function-name) - initialize-self! (_.let (list (//case.register 0)) @self) + @num_args (_.var "num_args") + @self (_.var function_name) + initialize_self! (_.let (list (//case.register 0)) @self) initialize! (list\fold (.function (_ post pre!) ($_ _.then pre! (_.let (list (..input post)) (_.nth (|> post inc .int _.int) @curried)))) - initialize-self! + initialize_self! (list.indices arity)) pack (|>> (list) _.apply/* (|> (_.var "table.pack"))) unpack (|>> (list) _.apply/* (|> (_.var "table.unpack"))) - @var-args (_.var "...")]] - (with-closure function-name closureO+ - (_.function @self (list @var-args) + @var_args (_.var "...")]] + (with_closure function_name closureO+ + (_.function @self (list @var_args) ($_ _.then - (_.let (list @curried) (pack @var-args)) - (_.let (list @num-args) (_.the "n" @curried)) - (_.cond (list [(|> @num-args (_.= (_.int +0))) + (_.let (list @curried) (pack @var_args)) + (_.let (list @num_args) (_.the "n" @curried)) + (_.cond (list [(|> @num_args (_.= (_.int +0))) (_.return @self)] - [(|> @num-args (_.= arityO)) + [(|> @num_args (_.= arityO)) ($_ _.then initialize! (_.return bodyO))] - [(|> @num-args (_.> arityO)) - (let [arity-inputs (//runtime.array//sub (_.int +0) arityO @curried) - extra-inputs (//runtime.array//sub arityO @num-args @curried)] + [(|> @num_args (_.> arityO)) + (let [arity_inputs (//runtime.array//sub (_.int +0) arityO @curried) + extra_inputs (//runtime.array//sub arityO @num_args @curried)] (_.return (|> @self - (_.apply/* (list (unpack arity-inputs))) - (_.apply/* (list (unpack extra-inputs))))))]) - ## (|> @num-args (_.< arityO)) - (_.return (_.closure (list @var-args) - (_.return (|> @self (_.apply/* (list (unpack (//runtime.array//concat @curried (pack @var-args)))))))))) + (_.apply/* (list (unpack arity_inputs))) + (_.apply/* (list (unpack extra_inputs))))))]) + ## (|> @num_args (_.< arityO)) + (_.return (_.closure (list @var_args) + (_.return (|> @self (_.apply/* (list (unpack (//runtime.array//concat @curried (pack @var_args)))))))))) ))) )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux index 4b405a8af..817ba118a 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux @@ -4,33 +4,36 @@ ["." monad (#+ do)]] [data ["." product] - [number - ["n" nat]] [text ["%" format (#+ format)]] [collection ["." list ("#\." functor)]]] + [math + [number + ["n" nat]]] [target ["_" lua (#+ Expression Var)]]] ["." // #_ - [runtime (#+ Operation Phase Generator)] + [runtime (#+ Operation Phase Phase! Generator Generator!)] ["#." case] ["///#" //// #_ [synthesis (#+ Scope Synthesis)] ["#." generation] ["//#" /// #_ - ["#." phase]]]]) + ["#." phase] + [reference + [variable (#+ Register)]]]]]) -(def: loop-name +(def: loop_name (-> Nat Var) (|>> %.nat (format "loop") _.var)) (def: #export (scope generate archive [start initsS+ bodyS]) (Generator (Scope Synthesis)) (do {! ///////phase.monad} - [@loop (\ ! map ..loop-name /////generation.next) + [@loop (\ ! map ..loop_name /////generation.next) initsO+ (monad.map ! (generate archive) initsS+) - bodyO (/////generation.with-anchor @loop + bodyO (/////generation.with_anchor @loop (generate archive bodyS)) #let [directive (_.function @loop (|> initsS+ list.enumeration diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux index 8b6fedb0b..965ac68b3 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux @@ -3,10 +3,10 @@ [target ["_" lua (#+ Expression)]]] [/// - ["/" reference]]) + [reference (#+ System)]]) -(def: #export system - (let [constant (: (-> Text (Expression Any)) - _.var) - variable constant] - (/.system constant variable))) +(structure: #export system + (System Expression) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux index c34a998a4..72f8576f5 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux @@ -1,36 +1,44 @@ (.module: - [lux (#- inc) + [lux (#- Location inc) + ["." meta] [abstract - [monad (#+ do)]] + ["." monad (#+ do)]] [control ["." function] - ["p" parser - ["s" code]]] + ["<>" parser + ["<.>" code]]] [data - [number (#+ hex) - ["." i64]] - ["." text - ["%" format (#+ format)]] + ["." product] + ["." text ("#\." hash) + ["%" format (#+ format)] + ["." encoding]] [collection - ["." list ("#\." functor)]]] + ["." list ("#\." functor)] + ["." row]]] ["." macro - ["." code] - [syntax (#+ syntax:)]] + [syntax (#+ syntax:)] + ["." code]] + [math + [number (#+ hex) + ["." i64]]] [target ["_" lua (#+ Expression Location Var Computation Literal Statement)]]] ["." /// #_ ["#." reference] ["//#" /// #_ - ["#." synthesis] - ["#." generation (#+ Buffer)] - ["//#" /// #_ + ["#." synthesis (#+ Synthesis)] + ["#." generation] + ["//#" /// (#+ Output) ["#." phase] + [reference + [variable (#+ Register)]] [meta - [archive (#+ Archive)]]]]]) + [archive (#+ Archive) + ["." artifact (#+ Registry)]]]]]]) (template [<name> <base>] [(type: #export <name> - (<base> Var (Expression Any) Statement))] + (<base> Var Expression Statement))] [Operation /////generation.Operation] [Phase /////generation.Phase] @@ -39,9 +47,16 @@ ) (type: #export (Generator i) - (-> Phase Archive i (Operation (Expression Any)))) + (-> Phase Archive i (Operation Expression))) + +(type: #export Phase! + (-> Phase Archive Synthesis (Operation Statement))) -(def: prefix Text "LuxRuntime") +(type: #export (Generator! i) + (-> Phase! Phase Archive i (Operation Statement))) + +(def: prefix + "LuxRuntime") (def: #export unit (_.string /////synthesis.unit)) @@ -51,173 +66,173 @@ (_.string "") _.nil)) -(def: #export variant-tag-field "_lux_tag") -(def: #export variant-flag-field "_lux_flag") -(def: #export variant-value-field "_lux_value") +(def: #export variant_tag_field "_lux_tag") +(def: #export variant_flag_field "_lux_flag") +(def: #export variant_value_field "_lux_value") (def: (variant' tag last? value) - (-> (Expression Any) (Expression Any) (Expression Any) Literal) - (_.table (list [..variant-tag-field tag] - [..variant-flag-field last?] - [..variant-value-field value]))) + (-> Expression Expression Expression Literal) + (_.table (list [..variant_tag_field tag] + [..variant_flag_field last?] + [..variant_value_field value]))) (def: #export (variant tag last? value) - (-> Nat Bit (Expression Any) Literal) + (-> Nat Bit Expression Literal) (variant' (_.int (.int tag)) (flag last?) value)) (def: #export none Literal - (..variant 0 #0 unit)) + (..variant 0 #0 ..unit)) (def: #export some - (-> (Expression Any) Literal) + (-> Expression Literal) (..variant 1 #1)) (def: #export left - (-> (Expression Any) Literal) + (-> Expression Literal) (..variant 0 #0)) (def: #export right - (-> (Expression Any) Literal) + (-> Expression Literal) (..variant 1 #1)) -(def: runtime-name - (-> Text Var) - (|>> ///reference.sanitize - (format ..prefix "_") - _.var)) - (def: (feature name definition) (-> Var (-> Var Statement) Statement) (definition name)) -(syntax: #export (with-vars {vars (s.tuple (p.some s.local-identifier))} +(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} body) - (wrap (list (` (let [(~+ (|> vars - (list\map (function (_ var) - (list (code.local-identifier var) - (` (_.var (~ (code.text (///reference.sanitize var)))))))) - list.concat))] - (~ body)))))) - -(syntax: (runtime: {declaration (p.or s.local-identifier - (s.form (p.and s.local-identifier - (p.some s.local-identifier))))} + (do {! meta.monad} + [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] + (wrap (list (` (let [(~+ (|> vars + (list.zip/2 ids) + (list\map (function (_ [id var]) + (list (code.local_identifier var) + (` (_.var (~ (code.text (format "v" (%.nat id))))))))) + list.concat))] + (~ body))))))) + +(syntax: (runtime: {declaration (<>.or <code>.local_identifier + (<code>.form (<>.and <code>.local_identifier + (<>.some <code>.local_identifier))))} code) - (case declaration - (#.Left name) - (macro.with-gensyms [g!_] - (let [nameC (code.local-identifier name) - code-nameC (code.local-identifier (format "@" name)) - runtime-nameC (` (runtime-name (~ (code.text name))))] - (wrap (list (` (def: #export (~ nameC) Var (~ runtime-nameC))) - (` (def: (~ code-nameC) - Statement - (..feature (~ runtime-nameC) - (function ((~ g!_) (~ nameC)) - (_.set (~ nameC) (~ code)))))))))) - - (#.Right [name inputs]) - (macro.with-gensyms [g!_] - (let [nameC (code.local-identifier name) - code-nameC (code.local-identifier (format "@" name)) - runtime-nameC (` (runtime-name (~ (code.text name)))) - inputsC (list\map code.local-identifier inputs) - inputs-typesC (list\map (function.constant (` (_.Expression Any))) - inputs)] - (wrap (list (` (def: #export ((~ nameC) (~+ inputsC)) - (-> (~+ inputs-typesC) (Computation Any)) - (_.apply/* (list (~+ inputsC)) (~ runtime-nameC)))) - (` (def: (~ code-nameC) - Statement - (..feature (~ runtime-nameC) - (function ((~ g!_) (~ g!_)) - (..with-vars [(~+ inputsC)] - (_.function (~ g!_) (list (~+ inputsC)) - (~ code))))))))))))) + (macro.with_gensyms [g!_ runtime] + (let [runtime_name (` (_.var (~ (code.text (%.code runtime)))))] + (case declaration + (#.Left name) + (macro.with_gensyms [g!_] + (let [g!name (code.local_identifier name)] + (wrap (list (` (def: #export (~ g!name) + Var + (~ runtime_name))) + + (` (def: (~ (code.local_identifier (format "@" name))) + Statement + (..feature (~ runtime_name) + (function ((~ g!_) (~ g!name)) + (_.set (~ g!name) (~ code)))))))))) + + (#.Right [name inputs]) + (macro.with_gensyms [g!_] + (let [g!name (code.local_identifier name) + inputsC (list\map code.local_identifier inputs) + inputs_typesC (list\map (function.constant (` _.Expression)) + inputs)] + (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) + (-> (~+ inputs_typesC) Computation) + (_.apply/* (list (~+ inputsC)) (~ runtime_name)))) + + (` (def: (~ (code.local_identifier (format "@" name))) + Statement + (..feature (~ runtime_name) + (function ((~ g!_) (~ g!_)) + (..with_vars [(~+ inputsC)] + (_.function (~ g!_) (list (~+ inputsC)) + (~ code))))))))))))))) (def: (nth index table) - (-> (Expression Any) (Expression Any) (Location Any)) + (-> Expression Expression Location) (_.nth (_.+ (_.int +1) index) table)) -(def: last-index (|>> _.length (_.- (_.int +1)))) +(def: last_index + (|>> _.length (_.- (_.int +1)))) ## No need to turn tuple//left and tuple//right into loops, as Lua ## does tail-call optimization. ## https://www.lua.org/pil/6.3.html (runtime: (tuple//left lefts tuple) - (with-vars [last-right] + (with_vars [last_right] ($_ _.then - (_.let (list last-right) (..last-index tuple)) - (_.if (_.> lefts last-right) + (_.let (list last_right) (..last_index tuple)) + (_.if (_.> lefts last_right) ## No need for recursion (_.return (..nth lefts tuple)) ## Needs recursion - (_.return (tuple//left (_.- last-right lefts) - (..nth last-right tuple))))))) + (_.return (tuple//left (_.- last_right lefts) + (..nth last_right tuple))))))) (runtime: (array//sub from to array) - (with-vars [temp idx] + (with_vars [temp idx] ($_ _.then (_.let (list temp) (_.array (list))) - (_.for-step idx from (_.- (_.int +1) to) (_.int +1) + (_.for_step idx from (_.- (_.int +1) to) (_.int +1) (|> (_.var "table.insert") (_.apply/* (list temp (..nth idx array))) _.statement)) (_.return temp)))) (runtime: (tuple//right lefts tuple) - (with-vars [last-right right-index] + (with_vars [last_right right_index] ($_ _.then - (_.let (list last-right) (..last-index tuple)) - (_.let (list right-index) (_.+ (_.int +1) lefts)) - (_.cond (list [(_.= last-right right-index) - (_.return (..nth right-index tuple))] - [(_.> last-right right-index) + (_.let (list last_right) (..last_index tuple)) + (_.let (list right_index) (_.+ (_.int +1) lefts)) + (_.cond (list [(_.= last_right right_index) + (_.return (..nth right_index tuple))] + [(_.> last_right right_index) ## Needs recursion. - (_.return (tuple//right (_.- last-right lefts) - (..nth last-right tuple)))]) - (_.return (array//sub right-index (_.length tuple) tuple))) + (_.return (tuple//right (_.- last_right lefts) + (..nth last_right tuple)))]) + (_.return (array//sub right_index (_.length tuple) tuple))) ))) (runtime: (sum//get sum wantsLast wantedTag) - (let [no-match! (_.return _.nil) - sum-tag (_.the ..variant-tag-field sum) - sum-flag (_.the ..variant-flag-field sum) - sum-value (_.the ..variant-value-field sum) - is-last? (_.= (_.string "") sum-flag) - test-recursion! (_.if is-last? + (let [no_match! (_.return _.nil) + sum_tag (_.the ..variant_tag_field sum) + sum_flag (_.the ..variant_flag_field sum) + sum_value (_.the ..variant_value_field sum) + is_last? (_.= (_.string "") sum_flag) + test_recursion! (_.if is_last? ## Must recurse. - (_.return (sum//get sum-value wantsLast (_.- sum-tag wantedTag))) - no-match!)] - (_.cond (list [(_.= sum-tag wantedTag) - (_.if (_.= wantsLast sum-flag) - (_.return sum-value) - test-recursion!)] + (_.return (sum//get sum_value wantsLast (_.- sum_tag wantedTag))) + no_match!)] + (_.cond (list [(_.= sum_tag wantedTag) + (_.if (_.= wantsLast sum_flag) + (_.return sum_value) + test_recursion!)] - [(_.> sum-tag wantedTag) - test-recursion!] + [(_.> sum_tag wantedTag) + test_recursion!] - [(_.and (_.< sum-tag wantedTag) + [(_.and (_.< sum_tag wantedTag) (_.= (_.string "") wantsLast)) - (_.return (variant' (_.- wantedTag sum-tag) sum-flag sum-value))]) + (_.return (variant' (_.- wantedTag sum_tag) sum_flag sum_value))]) - no-match!))) + no_match!))) (runtime: (array//copy array) - (with-vars [temp idx] + (with_vars [temp idx] ($_ _.then (_.let (list temp) (_.array (list))) - (<| (_.for-step idx (_.int +1) (_.length array) (_.int +1)) + (<| (_.for_step idx (_.int +1) (_.length array) (_.int +1)) (_.statement (|> (_.var "table.insert") (_.apply/* (list temp (_.nth idx array)))))) (_.return temp)))) (runtime: (array//concat left right) - (with-vars [temp idx] + (with_vars [temp idx] (let [copy! (function (_ input output) - (<| (_.for-step idx (_.int +1) (_.the "n" input) (_.int +1)) + (<| (_.for_step idx (_.int +1) (_.the "n" input) (_.int +1)) (_.statement (|> (_.var "table.insert") (_.apply/* (list output (_.nth idx input)))))))] ($_ _.then (_.let (list temp) (_.array (list))) @@ -237,7 +252,7 @@ )) (runtime: (lux//try risky) - (with-vars [success value] + (with_vars [success value] ($_ _.then (_.let (list success value) (|> risky (_.apply/* (list ..unit)) _.return (_.closure (list)) @@ -246,11 +261,11 @@ (_.return (..right value)) (_.return (..left value)))))) -(runtime: (lux//program-args raw) - (with-vars [tail head idx] +(runtime: (lux//program_args raw) + (with_vars [tail head idx] ($_ _.then (_.let (list tail) ..none) - (<| (_.for-step idx (_.length raw) (_.int +1) (_.int -1)) + (<| (_.for_step idx (_.length raw) (_.int +1) (_.int -1)) (_.set (list tail) (..some (_.array (list (_.nth idx raw) tail))))) (_.return tail)))) @@ -259,25 +274,25 @@ Statement ($_ _.then @lux//try - @lux//program-args + @lux//program_args )) -(runtime: (i64//logic-right-shift param subject) +(runtime: (i64//logic_right_shift param subject) (let [mask (|> (_.int +1) - (_.bit-shl (_.- param (_.int +64))) + (_.bit_shl (_.- param (_.int +64))) (_.- (_.int +1)))] (_.return (|> subject - (_.bit-shr param) - (_.bit-and mask))))) + (_.bit_shr param) + (_.bit_and mask))))) (def: runtime//i64 Statement ($_ _.then - @i64//logic-right-shift + @i64//logic_right_shift )) (runtime: (text//index subject param start) - (with-vars [idx] + (with_vars [idx] ($_ _.then (_.let (list idx) (_.apply/* (list subject param start (_.bool #1)) (_.var "string.find"))) @@ -286,7 +301,7 @@ (_.return (..some idx)))))) (runtime: (text//clip text from to) - (with-vars [size] + (with_vars [size] ($_ _.then (_.let (list size) (_.apply/* (list text) (_.var "string.len"))) (_.if (_.or (_.> size from) @@ -296,7 +311,7 @@ ))) (runtime: (text//char idx text) - (with-vars [char] + (with_vars [char] ($_ _.then (_.let (list char) (_.apply/* (list text idx) (_.var "string.byte"))) (_.if (_.= _.nil char) @@ -312,15 +327,15 @@ )) (runtime: (array//new size) - (with-vars [output idx] + (with_vars [output idx] ($_ _.then (_.let (list output) (_.array (list))) - (_.for-step idx (_.int +1) size (_.int +1) + (_.for_step idx (_.int +1) size (_.int +1) (_.statement (_.apply/* (list output ..unit) (_.var "table.insert")))) (_.return output)))) (runtime: (array//get array idx) - (with-vars [temp] + (with_vars [temp] ($_ _.then (_.let (list temp) (..nth idx array)) (_.if (_.or (_.= _.nil temp) @@ -366,9 +381,14 @@ (def: #export artifact ..prefix) (def: #export generate - (Operation (Buffer Statement)) - (/////generation.with-buffer - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! ..prefix ..runtime)] - /////generation.buffer))) + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! "0" ..runtime)] + (wrap [(|> artifact.empty + artifact.resource + product.right) + (row.row ["0" + (|> ..runtime + _.code + (\ encoding.utf8 encode))])]))) diff --git a/stdlib/source/lux/type/refinement.lux b/stdlib/source/lux/type/refinement.lux index bbf9630cc..f99c9216c 100644 --- a/stdlib/source/lux/type/refinement.lux +++ b/stdlib/source/lux/type/refinement.lux @@ -4,22 +4,22 @@ [predicate (#+ Predicate)]] ["." macro [syntax (#+ syntax:)]] - [type (#+ :by_example) + ["." type abstract]]) -(abstract: #export (Refined t r) +(abstract: #export (Refined t %) {#value t #predicate (Predicate t)} - {#.doc "A refined type 'r' of base type 't' using a predicate."} + {#.doc "A refined type '%' of base type 't' using a predicate."} - (type: #export (Refiner t r) - (-> t (Maybe (Refined t r)))) + (type: #export (Refiner t %) + (-> t (Maybe (Refined t %)))) (def: #export (refinement predicate) (All [t] - (Ex [r] - (-> (Predicate t) (Refiner t r)))) + (Ex [%] + (-> (Predicate t) (Refiner t %)))) (function (_ un_refined) (if (predicate un_refined) (#.Some (:abstraction {#value un_refined @@ -27,20 +27,20 @@ #.None))) (template [<name> <output> <slot>] - [(def: #export (<name> refined) - (All [t r] (-> (Refined t r) <output>)) - (|> refined :representation (get@ <slot>)))] + [(def: #export <name> + (All [t %] (-> (Refined t %) <output>)) + (|>> :representation (get@ <slot>)))] [un_refine t #value] [predicate (Predicate t) #predicate] ) (def: #export (lift transform) - (All [t r] + (All [t %] (-> (-> t t) - (-> (Refined t r) (Maybe (Refined t r))))) + (-> (Refined t %) (Maybe (Refined t %))))) (function (_ refined) - (let [[value predicate] (:representation refined) + (let [(^slots [#value #predicate]) (:representation refined) value' (transform value)] (if (predicate value') (#.Some (:abstraction {#value value' @@ -49,7 +49,7 @@ ) (def: #export (filter refiner values) - (All [t r] (-> (Refiner t r) (List t) (List (Refined t r)))) + (All [t %] (-> (Refiner t %) (List t) (List (Refined t %)))) (case values #.Nil #.Nil @@ -63,7 +63,7 @@ (filter refiner tail)))) (def: #export (partition refiner values) - (All [t r] (-> (Refiner t r) (List t) [(List (Refined t r)) (List t)])) + (All [t %] (-> (Refiner t %) (List t) [(List (Refined t %)) (List t)])) (case values #.Nil [#.Nil #.Nil] @@ -80,8 +80,8 @@ (#.Cons head no)])))) (syntax: #export (type refiner) - (macro.with_gensyms [g!t g!r] - (wrap (list (` ((~! :by_example) [(~ g!t) (~ g!r)] - {(..Refiner (~ g!t) (~ g!r)) + (macro.with_gensyms [g!t g!%] + (wrap (list (` ((~! type.:by_example) [(~ g!t) (~ g!%)] + {(..Refiner (~ g!t) (~ g!%)) (~ refiner)} - (..Refined (~ g!t) (~ g!r)))))))) + (..Refined (~ g!t) (~ g!%)))))))) diff --git a/stdlib/source/program/aedifex/artifact/versioning.lux b/stdlib/source/program/aedifex/artifact/versioning.lux index df9f7dfa3..41b3179d3 100644 --- a/stdlib/source/program/aedifex/artifact/versioning.lux +++ b/stdlib/source/program/aedifex/artifact/versioning.lux @@ -1,5 +1,5 @@ (.module: - [lux (#- Name Type) + [lux #* [abstract [equivalence (#+ Equivalence)] [monad (#+ do)]] @@ -10,6 +10,7 @@ ["<.>" text]]] [data ["." product] + ["." maybe] ["." text ["%" format]] [format @@ -24,96 +25,50 @@ ["." date (#+ Date)] ["." year] ["." month]]] - ["." // (#+ Version) - [type (#+ Type)] - ["#." value (#+ Build Value)] - ["#." time_stamp (#+ Time_Stamp) - ["#/." date] - ["#/." time]]]) + ["." // #_ + ["#." time] + ["#." snapshot (#+ Snapshot) + ["#/." version (#+ Version)]]]) (type: #export Versioning - {#time_stamp Time_Stamp - #build Build - #snapshot (List Type)}) + {#snapshot Snapshot + #last_updated Instant + #versions (List Version)}) (def: #export init - {#time_stamp (instant.from_millis +0) - #build 0 - #snapshot (list)}) + {#snapshot #//snapshot.Local + #last_updated instant.epoch + #versions (list)}) (def: #export equivalence (Equivalence Versioning) ($_ product.equivalence + //snapshot.equivalence instant.equivalence - n.equivalence - (list.equivalence text.equivalence) + (list.equivalence //snapshot/version.equivalence) )) (template [<definition> <tag>] [(def: <definition> xml.Tag ["" <tag>])] - [<extension> "extension"] - [<value> "value"] - [<updated> "updated"] - - [<timestamp> "timestamp"] - [<build_number> "buildNumber"] [<last_updated> "lastUpdated"] - [<snapshot_versions> "snapshotVersions"] - [<snapshot_version> "snapshotVersion"] - - [<snapshot> "snapshot"] - [<versioning> "versioning"] - ) - -(def: (instant_format value) - (%.Format Instant) - (%.format (//time_stamp/date.format (instant.date value)) - (//time_stamp/time.format (instant.time value)))) - -(template [<name> <type> <tag> <pre>] - [(def: <name> - (-> <type> XML) - (|>> <pre> #xml.Text list (#xml.Node <tag> xml.attributes)))] - - [format_extension Type ..<extension> (|>)] - [format_value Value ..<value> //value.format] - [format_updated Instant ..<updated> ..instant_format] - [format_time_stamp Instant ..<timestamp> //time_stamp.format] - [format_build_number Nat ..<build_number> %.nat] - [format_last_updated Instant ..<last_updated> ..instant_format] + [<versioning> "versioning"] ) -(def: (format_snapshot value type) - (-> Value Type XML) - (<| (#xml.Node ..<snapshot_version> xml.attributes) - (list (..format_extension type) - (..format_value value) - (let [[version time_stamp build] value] - (..format_updated time_stamp))))) +(def: format_last_updated + (-> Instant XML) + (|>> //time.format #xml.Text list (#xml.Node ..<last_updated> xml.attributes))) -(def: #export (format version (^slots [#time_stamp #build #snapshot])) - (-> Version Versioning XML) +(def: #export (format (^slots [#snapshot #last_updated #versions])) + (-> Versioning XML) (<| (#xml.Node ..<versioning> xml.attributes) - (list (<| (#xml.Node ..<snapshot> xml.attributes) - (list (..format_time_stamp time_stamp) - (..format_build_number build))) - (..format_last_updated time_stamp) - (<| (#xml.Node ..<snapshot_versions> xml.attributes) - (list\map (..format_snapshot [version time_stamp build]) - snapshot))))) - -(exception: #export (time_stamp_mismatch {expected Time_Stamp} {actual Text}) - (exception.report - ["Expected time-stamp" (instant_format expected)] - ["Actual time-stamp" actual])) - -(exception: #export (value_mismatch {expected Value} {actual Text}) - (exception.report - ["Expected" (//value.format expected)] - ["Actual" actual])) + (list (//snapshot.format snapshot) + (..format_last_updated last_updated) + (|> versions + (list\map //snapshot/version.format) + (#xml.Node ..<snapshot_versions> xml.attributes))))) (def: (sub tag parser) (All [a] (-> xml.Tag (Parser a) (Parser a))) @@ -127,50 +82,16 @@ (def: last_updated_parser (Parser Instant) - (<text>.embed (do <>.monad - [date //time_stamp/date.parser - time //time_stamp/time.parser] - (wrap (instant.from_date_time date time))) + (<text>.embed //time.parser (..text ..<last_updated>))) -(def: time_stamp_parser - (Parser Time_Stamp) - (<text>.embed //time_stamp.parser - (..text ..<timestamp>))) - -(def: build_parser - (Parser Build) - (<text>.embed (<>.codec n.decimal - (<text>.many <text>.decimal)) - (..text ..<build_number>))) - -(def: (snapshot_parser expected) - (-> Value (Parser Type)) - (<| (..sub ..<snapshot_version>) - (do <>.monad - [#let [[version time_stamp build] expected] - updated (<xml>.somewhere (..text ..<updated>)) - _ (<>.assert (exception.construct ..time_stamp_mismatch [time_stamp updated]) - (\ text.equivalence = (instant_format time_stamp) updated)) - actual (<xml>.somewhere (..text ..<value>)) - _ (<>.assert (exception.construct ..value_mismatch [expected actual]) - (\ text.equivalence = (//value.format expected) actual))] - (<xml>.somewhere (..text ..<extension>))))) - -(def: #export (parser version) - (-> Version (Parser Versioning)) +(def: #export parser + (Parser Versioning) (<| (..sub ..<versioning>) - (do <>.monad - [[time_stamp build] (<| <xml>.somewhere - (..sub ..<snapshot>) - (<>.and (<xml>.somewhere ..time_stamp_parser) - (<xml>.somewhere ..build_parser))) - last_updated (<xml>.somewhere ..last_updated_parser) - _ (<>.assert (exception.construct ..time_stamp_mismatch [time_stamp (instant_format last_updated)]) - (\ instant.equivalence = time_stamp last_updated)) - snapshot (<| <xml>.somewhere - (..sub ..<snapshot_versions>) - (<>.some (..snapshot_parser [version time_stamp build])))] - (wrap {#time_stamp time_stamp - #build build - #snapshot snapshot})))) + ($_ <>.and + (<xml>.somewhere //snapshot.parser) + (<xml>.somewhere ..last_updated_parser) + (<| <xml>.somewhere + (..sub ..<snapshot_versions>) + (<>.some //snapshot/version.parser)) + ))) diff --git a/stdlib/source/test/aedifex/artifact/versioning.lux b/stdlib/source/test/aedifex/artifact/versioning.lux index c0704440e..ab0e94236 100644 --- a/stdlib/source/test/aedifex/artifact/versioning.lux +++ b/stdlib/source/test/aedifex/artifact/versioning.lux @@ -13,14 +13,17 @@ [math ["." random (#+ Random)]]] {#program - ["." /]}) + ["." /]} + ["$." // #_ + ["#." snapshot + ["#/." version]]]) (def: #export random (Random /.Versioning) ($_ random.and + $//snapshot.random random.instant - random.nat - (random.list 5 (random.ascii/lower_alpha 3)) + (random.list 5 $//snapshot/version.random) )) (def: #export test @@ -32,12 +35,19 @@ ($equivalence.spec /.equivalence ..random)) (do random.monad - [expected ..random - version (random.ascii/upper_alpha 3)] + [expected ..random] (_.cover [/.format /.parser] (|> expected - (/.format version) - (<xml>.run (/.parser version)) + /.format + list + (<xml>.run /.parser) (try\map (\ /.equivalence = expected)) (try.default false)))) + (_.cover [/.init] + (|> /.init + /.format + list + (<xml>.run /.parser) + (try\map (\ /.equivalence = /.init)) + (try.default false))) ))) diff --git a/stdlib/source/test/lux/control/concurrency/atom.lux b/stdlib/source/test/lux/control/concurrency/atom.lux index c8496c210..ab86747e5 100644 --- a/stdlib/source/test/lux/control/concurrency/atom.lux +++ b/stdlib/source/test/lux/control/concurrency/atom.lux @@ -15,25 +15,49 @@ (def: #export test Test (<| (_.covering /._) - (do random.monad - [value random.nat - swap_value random.nat - set_value random.nat - #let [box (/.atom value)]] - ($_ _.and + ($_ _.and + (do random.monad + [expected random.nat + #let [box (/.atom expected)]] (_.cover [/.Atom /.atom /.read] - (n.= value - (io.run (/.read box)))) + (io.run + (do io.monad + [actual (/.read box)] + (wrap (is? expected actual)))))) + (do random.monad + [target random.nat + unknown (random.filter (|>> (is? target) not) random.nat) + expected random.nat + #let [box (/.atom target)]] (_.cover [/.compare_and_swap] - (and (io.run (/.compare_and_swap value swap_value box)) - (n.= swap_value - (io.run (/.read box))))) + (io.run + (do io.monad + [swapped_unknown? (/.compare_and_swap unknown expected box) + swapped_target? (/.compare_and_swap target expected box) + actual (/.read box)] + (wrap (and (not swapped_unknown?) + swapped_target? + (is? expected actual))))))) + (do random.monad + [init random.nat + shift random.nat + #let [box (/.atom init)]] (_.cover [/.update] - (exec (io.run (/.update inc box)) - (n.= (inc swap_value) - (io.run (/.read box))))) + (io.run + (do io.monad + [[pre post] (/.update (n.+ shift) box)] + (wrap (and (is? init pre) + (n.= (n.+ shift init) + post))))))) + (do random.monad + [pre random.nat + post random.nat + #let [box (/.atom pre)]] (_.cover [/.write] - (exec (io.run (/.write set_value box)) - (n.= set_value - (io.run (/.read box))))) - )))) + (io.run + (do io.monad + [old (/.write post box) + new (/.read box)] + (wrap (and (is? pre old) + (is? post new))))))) + ))) diff --git a/stdlib/source/test/lux/control/concurrency/semaphore.lux b/stdlib/source/test/lux/control/concurrency/semaphore.lux index 729e986c2..a8e64124c 100644 --- a/stdlib/source/test/lux/control/concurrency/semaphore.lux +++ b/stdlib/source/test/lux/control/concurrency/semaphore.lux @@ -154,26 +154,26 @@ _ false))) (do {! random.monad} - [limit (|> random.nat (\ ! map (|>> (n.% 10) (n.max 1)))) + [limit (\ ! map (|>> (n.% 9) inc) random.nat) #let [barrier (/.barrier (maybe.assume (/.limit limit))) resource (atom.atom "")]] (wrap (do {! promise.monad} - [#let [ending (|> "_" - (list.repeat limit) - (text.join_with "")) - ids (enum.range n.enum 0 (dec limit)) - waiters (list\map (function (_ id) - (exec (io.run (atom.update (|>> (format "_")) resource)) - (waiter resource barrier id))) - ids)] - _ (monad.seq ! waiters) + [#let [suffix "_" + expected_ending (|> suffix + (list.repeat limit) + (text.join_with "")) + expected_ids (enum.range n.enum 0 (dec limit))] + _ (|> expected_ids + (list\map (function (_ id) + (exec (io.run (atom.update (|>> (format suffix)) resource)) + (waiter resource barrier id)))) + (monad.seq !)) #let [outcome (io.run (atom.read resource))]] (_.cover' [/.barrier /.block] - (and (text.ends_with? ending outcome) + (and (text.ends_with? expected_ending outcome) (list.every? (function (_ id) (text.contains? (%.nat id) outcome)) - ids) - ))))) + expected_ids)))))) ))) (def: #export test diff --git a/stdlib/source/test/lux/type.lux b/stdlib/source/test/lux/type.lux index b1d205e4a..0b3f3b4d8 100644 --- a/stdlib/source/test/lux/type.lux +++ b/stdlib/source/test/lux/type.lux @@ -22,6 +22,7 @@ ["#." dynamic] ["#." implicit] ["#." quotient] + ["#." refinement] ["#." resource]]) (def: short @@ -171,5 +172,6 @@ /dynamic.test /implicit.test /quotient.test + /refinement.test /resource.test ))) diff --git a/stdlib/source/test/lux/type/refinement.lux b/stdlib/source/test/lux/type/refinement.lux new file mode 100644 index 000000000..260f5f51f --- /dev/null +++ b/stdlib/source/test/lux/type/refinement.lux @@ -0,0 +1,88 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [predicate (#+ Predicate)] + [monad (#+ do)]] + [data + ["." maybe ("#\." monad)] + [collection + ["." list ("#\." functor)]]] + [math + ["." random] + [number + ["n" nat]]]] + {1 + ["." /]}) + +(def: _refiner + (/.refinement (n.> 123))) + +(def: _type + (/.type _refiner)) + +(def: #export test + Test + (<| (_.covering /._) + (_.for [/.Refined]) + (do {! random.monad} + [raw random.nat + modulus (\ ! map (|>> (n.% 10) (n.+ 2)) random.nat) + #let [predicate (: (Predicate Nat) + (|>> (n.% modulus) (n.= 0)))] + total_raws (\ ! map (|>> (n.% 20) inc) random.nat) + raws (random.list total_raws random.nat)] + ($_ _.and + (_.for [/.Refiner] + ($_ _.and + (_.cover [/.refinement] + (case (/.refinement predicate raw) + (#.Some refined) + (predicate raw) + + #.None + (not (predicate raw)))) + (_.cover [/.predicate] + (|> (/.refinement predicate modulus) + (maybe\map (|>> /.predicate (is? predicate))) + (maybe.default false))) + )) + (_.cover [/.un_refine] + (|> (/.refinement predicate modulus) + (maybe\map (|>> /.un_refine (n.= modulus))) + (maybe.default false))) + (_.cover [/.lift] + (and (|> (/.refinement predicate modulus) + (maybe\map (/.lift (n.+ modulus))) + maybe\join + (maybe\map (|>> /.un_refine (n.= (n.+ modulus modulus)))) + (maybe.default false)) + (|> (/.refinement predicate modulus) + (maybe\map (/.lift (n.+ (inc modulus)))) + maybe\join + (maybe\map (|>> /.un_refine (n.= (n.+ modulus (inc modulus))))) + (maybe.default false) + not))) + (_.cover [/.filter] + (let [expected (list.filter predicate raws) + actual (/.filter (/.refinement predicate) raws)] + (and (n.= (list.size expected) + (list.size actual)) + (\ (list.equivalence n.equivalence) = + expected + (list\map /.un_refine actual))))) + (_.cover [/.partition] + (let [expected (list.filter predicate raws) + [actual alternative] (/.partition (/.refinement predicate) raws)] + (and (n.= (list.size expected) + (list.size actual)) + (n.= (n.- (list.size expected) total_raws) + (list.size alternative)) + (\ (list.equivalence n.equivalence) = + expected + (list\map /.un_refine actual))))) + (_.cover [/.type] + (exec (: (Maybe .._type) + (.._refiner raw)) + true)) + )))) |