diff options
Diffstat (limited to '')
17 files changed, 1370 insertions, 19 deletions
diff --git a/stdlib/source/lux/data/number/nat.lux b/stdlib/source/lux/data/number/nat.lux index f5258db23..9212e0ad5 100644 --- a/stdlib/source/lux/data/number/nat.lux +++ b/stdlib/source/lux/data/number/nat.lux @@ -42,7 +42,7 @@ (def: * n/*) (def: / n//) (def: % n/%) - (def: (negate value) (n/- (:: ..interval top) value)) + (def: (negate value) (n/- value 0)) (def: abs function.identity) (def: (signum x) (case x diff --git a/stdlib/source/lux/host/lua.lux b/stdlib/source/lux/host/lua.lux new file mode 100644 index 000000000..ca72f1678 --- /dev/null +++ b/stdlib/source/lux/host/lua.lux @@ -0,0 +1,308 @@ +(.module: + [lux (#- Code int if cond function or and not let) + [control + [pipe (#+ case> cond> new>)]] + [data + [number + ["." frac]] + ["." text + format] + [collection + ["." list ("#@." functor fold)]]] + [macro + ["." template] + ["." code] + ["s" syntax (#+ syntax:)]] + [type + abstract]]) + +(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)))) + +(abstract: #export (Code brand) + {} + + Text + + (def: #export manual + (-> Text Code) + (|>> :abstraction)) + + (def: #export code + (-> (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)))))] + + [Expression Code] + [Computation Expression] + [Location Computation] + ) + + (template [<type> <super>] + [(with-expansions [<brand> (template.identifier [<type> "'"])] + (`` (abstract: #export <brand> {} Any)) + (`` (type: #export <type> (<super> <brand>))))] + + [Literal Computation] + [Var Location] + [Access Location] + [Statement Code] + ) + + (def: #export nil + Literal + (:abstraction "nil")) + + (def: #export bool + (-> Bit Literal) + (|>> (case> #0 "false" + #1 "true") + :abstraction)) + + (def: #export (int value) + (-> Int Literal) + (:abstraction (.if (i/< +0 value) + (%i value) + (%n (.nat value))))) + + (def: #export float + (-> Frac Literal) + (|>> (cond> [(f/= frac.positive-infinity)] + [(new> "(1.0/0.0)" [])] + + [(f/= frac.negative-infinity)] + [(new> "(-1.0/0.0)" [])] + + [(f/= frac.not-a-number)] + [(new> "(0.0/0.0)" [])] + + ## else + [%f]) + :abstraction)) + + (def: sanitize + (-> Text Text) + (`` (|>> (~~ (template [<find> <replace>] + [(text.replace-all <find> <replace>)] + + ["\" "\\"] + [text.tab "\t"] + [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)] + )) + ))) + + (def: #export string + (-> Text Literal) + (|>> ..sanitize (text.enclose' text.double-quote) :abstraction)) + + (def: #export array + (-> (List (Expression Any)) Literal) + (|>> (list@map ..code) + (text.join-with ..input-separator) + (text.enclose ["{" "}"]) + :abstraction)) + + (def: #export table + (-> (List [Text (Expression Any)]) Literal) + (|>> (list@map (.function (_ [key value]) + (format key " = " (:representation value)))) + (text.join-with ..input-separator) + (text.enclose ["{" "}"]) + :abstraction)) + + (def: #export (nth idx array) + (-> (Expression Any) (Expression Any) Access) + (:abstraction (format (:representation array) "[" (:representation idx) "]"))) + + (def: #export (the field table) + (-> Text (Expression Any) (Computation Any)) + (:abstraction (format (:representation table) "." field))) + + (def: #export length + (-> (Expression Any) (Computation Any)) + (|>> :representation + (text.enclose ["#(" ")"]) + :abstraction)) + + (def: #export (apply/* args func) + (-> (List (Expression Any)) (Expression Any) (Computation Any)) + (|> args + (list@map ..code) + (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)) + (|> args + (list@map ..code) + (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)) + (:abstraction (format "(" + (:representation subject) + " " <op> " " + (:representation parameter) + ")")))] + + ["==" =] + ["<" <] + ["<=" <=] + [">" >] + [">=" >=] + ["+" +] + ["-" -] + ["*" *] + ["/" /] + ["//" //] + ["%" %] + [".." concat] + + ["or" or] + ["and" and] + ["|" bit-or] + ["&" bit-and] + ["~" bit-xor] + + ["<<" bit-shl] + [">>" bit-shr] + ) + + (def: #export (not subject) + (-> (Expression Any) (Expression Any)) + (:abstraction (format "(not " (:representation subject) ")"))) + + (def: #export var + (-> Text Var) + (|>> :abstraction)) + + (def: #export statement + (-> (Expression Any) Statement) + (|>> :representation (text.suffix ..statement-suffix) :abstraction)) + + (def: #export (then pre! post!) + (-> Statement Statement Statement) + (:abstraction + (format (:representation pre!) + text.new-line + (:representation post!)))) + + (def: locations + (-> (List (Location Any)) Text) + (|>> (list@map ..code) + (text.join-with ..input-separator))) + + (def: #export (local vars) + (-> (List Var) Statement) + (: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))) + + (def: #export (let vars value) + (-> (List Var) (Expression Any) Statement) + ($_ ..then + (local vars) + (set vars value))) + + (def: #export (if test then! else!) + (-> (Expression Any) 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))) + + (def: #export (when test then!) + (-> (Expression Any) Statement Statement) + (:abstraction (format "if " (:representation test) + text.new-line "then" (..nest (:representation then!)) + text.new-line "end" ..statement-suffix))) + + (def: #export (while test body!) + (-> (Expression Any) Statement Statement) + (:abstraction + (format "while " (:representation test) " do" + (..nest (:representation body!)) + text.new-line "end" ..statement-suffix))) + + (def: #export (for-in vars source body!) + (-> (List Var) (Expression Any) Statement Statement) + (:abstraction + (format "for " (|> vars + (list@map ..code) + (text.join-with ..input-separator)) + " in " (:representation source) " do" + (..nest (:representation body!)) + text.new-line "end" ..statement-suffix))) + + (def: #export (for-step var from to step body!) + (-> Var (Expression Any) (Expression Any) (Expression Any) Statement + Statement) + (:abstraction + (format "for " (:representation var) + " = " (:representation from) + ..input-separator (:representation to) + ..input-separator (:representation step) " do" + (..nest (:representation body!)) + text.new-line "end" ..statement-suffix))) + + (def: #export (return value) + (-> (Expression Any) Statement) + (:abstraction (format "return " (:representation value) ..statement-suffix))) + + (def: #export (closure args body!) + (-> (List Var) Statement (Expression Any)) + (|> (format "function " (|> args + ..locations + (text.enclose ["(" ")"])) + (..nest (:representation body!)) + text.new-line "end") + (text.enclose ["(" ")"]) + :abstraction)) + + (def: #export (function name args body!) + (-> Var (List Var) Statement Statement) + (:abstraction + (format "function " (:representation name) + (|> args + ..locations + (text.enclose ["(" ")"])) + (..nest (:representation body!)) + text.new-line "end" ..statement-suffix))) + + (def: #export break + Statement + (|> "break" + (text.suffix ..statement-suffix) + :abstraction)) + ) + +(def: #export (cond clauses else!) + (-> (List [(Expression Any) Statement]) Statement Statement) + (list@fold (.function (_ [test then!] next!) + (..if test then! next!)) + else! + (list.reverse clauses))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/lua.lux b/stdlib/source/lux/tool/compiler/phase/generation/lua.lux new file mode 100644 index 000000000..480c473bf --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/lua.lux @@ -0,0 +1,60 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]]] + [/ + [runtime (#+ Phase)] + ["." primitive] + ["." structure] + ["." reference ("#@." system)] + ["." case] + ["." loop] + ["." function] + ["." /// + ["." extension] + [// + ["." synthesis]]]]) + +(def: #export (generate synthesis) + Phase + (case synthesis + (^template [<tag> <generator>] + (^ (<tag> value)) + (:: ///.monad wrap (<generator> value))) + ([synthesis.bit primitive.bit] + [synthesis.i64 primitive.i64] + [synthesis.f64 primitive.f64] + [synthesis.text primitive.text]) + + (^ (synthesis.variant variantS)) + (structure.variant generate variantS) + + (^ (synthesis.tuple members)) + (structure.tuple generate members) + + (#synthesis.Reference value) + (reference@reference value) + + (^ (synthesis.branch/case case)) + (case.case generate case) + + (^ (synthesis.branch/let let)) + (case.let generate let) + + (^ (synthesis.branch/if if)) + (case.if generate if) + + (^ (synthesis.loop/scope scope)) + (loop.scope generate scope) + + (^ (synthesis.loop/recur updates)) + (loop.recur generate updates) + + (^ (synthesis.function/abstraction abstraction)) + (function.function generate abstraction) + + (^ (synthesis.function/apply application)) + (function.apply generate application) + + (#synthesis.Extension extension) + (extension.apply generate extension))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/lua/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/lua/case.lux new file mode 100644 index 000000000..13683f0ca --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/lua/case.lux @@ -0,0 +1,216 @@ +(.module: + [lux (#- case let if) + [abstract + [monad (#+ do)]] + [control + ["ex" exception (#+ exception:)]] + [data + ["." text + format] + [collection + ["." list ("#@." functor fold)] + ["." set]]] + [host + ["_" lua (#+ Expression Var Statement)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase)] + ["#." reference] + ["#." primitive] + ["#/" // + ["#." reference] + ["#/" // ("#@." monad) + [synthesis + ["." case]] + ["#/" // #_ + ["." reference (#+ Register)] + ["#." synthesis (#+ Synthesis Path)]]]]]) + +(def: #export register + (///reference.local _.var)) + +(def: #export capture + (///reference.foreign _.var)) + +(def: #export (let generate [valueS register bodyS]) + (-> Phase [Synthesis Register Synthesis] + (Operation (Expression Any))) + (do ////.monad + [valueO (generate valueS) + bodyO (generate bodyS)] + ## TODO: Find some way to do 'let' without paying the price of the closure. + (wrap (|> bodyO + _.return + (_.closure (list (..register register))) + (_.apply/* (list valueO)))))) + +(def: #export (record-get generate valueS pathP) + (-> Phase Synthesis (List (Either Nat Nat)) + (Operation (Expression Any))) + (do ////.monad + [valueO (generate valueS)] + (wrap (list@fold (function (_ side source) + (.let [method (.case side + (^template [<side> <accessor>] + (<side> lefts) + (<accessor> (_.int (.int lefts)))) + ([#.Left //runtime.tuple//left] + [#.Right //runtime.tuple//right]))] + (method source))) + valueO + pathP)))) + +(def: #export (if generate [testS thenS elseS]) + (-> Phase [Synthesis Synthesis Synthesis] + (Operation (Expression Any))) + (do ////.monad + [testO (generate testS) + thenO (generate thenS) + elseO (generate elseS)] + (wrap (|> (_.if testO + (_.return thenO) + (_.return elseO)) + (_.closure (list)) + (_.apply/* (list)))))) + +(def: @savepoint (_.var "lux_pm_savepoint")) +(def: @cursor (_.var "lux_pm_cursor")) +(def: @temp (_.var "lux_pm_temp")) + +(def: (push! value) + (-> (Expression Any) Statement) + (_.statement (|> (_.var "table.insert") (_.apply/* (list @cursor value))))) + +(def: peek-and-pop + (Expression Any) + (|> (_.var "table.remove") (_.apply/* (list @cursor)))) + +(def: pop! + Statement + (_.statement ..peek-and-pop)) + +(def: peek + (Expression Any) + (_.nth (_.length @cursor) @cursor)) + +(def: save! + Statement + (_.statement (|> (_.var "table.insert") + (_.apply/* (list @savepoint + (//runtime.array//copy @cursor)))))) + +(def: restore! + Statement + (_.set (list @cursor) (|> (_.var "table.remove") (_.apply/* (list @savepoint))))) + +(def: fail! _.break) + +(exception: #export unrecognized-path) + +(template [<name> <flag> <prep>] + [(def: (<name> simple? idx) + (-> Bit Nat Statement) + ($_ _.then + (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))) + (.if simple? + (_.when (_.= _.nil @temp) + fail!) + (_.if (_.= _.nil @temp) + fail! + (..push! @temp)))))] + + [left-choice _.nil (<|)] + [right-choice (_.string "") inc] + ) + +(def: (alternation pre! post!) + (-> Statement Statement Statement) + ($_ _.then + (_.while (_.bool true) + ($_ _.then + ..save! + pre!)) + ($_ _.then + ..restore! + post!))) + +(def: (pattern-matching' generate pathP) + (-> Phase Path (Operation Statement)) + (.case pathP + (^ (/////synthesis.path/then bodyS)) + (:: ////.monad map _.return (generate bodyS)) + + #/////synthesis.Pop + (////@wrap ..pop!) + + (#/////synthesis.Bind register) + (////@wrap (_.let (list (..register register)) ..peek)) + + (^template [<tag> <format>] + (^ (<tag> value)) + (////@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)) + (////@wrap (<choice> false idx)) + + (^ (<simple> idx nextP)) + (|> nextP + (pattern-matching' generate) + (:: ////.monad 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)) + (////@wrap (|> ..peek (_.nth (_.int +1)) ..push!)) + + (^template [<pm> <getter>] + (^ (<pm> lefts)) + (////@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 ////.monad + [then! (pattern-matching' generate thenP)] + (////@wrap ($_ _.then + (_.let (list (..register register)) ..peek-and-pop) + then!))) + + (^template [<tag> <combinator>] + (^ (<tag> preP postP)) + (do ////.monad + [pre! (pattern-matching' generate preP) + post! (pattern-matching' generate postP)] + (wrap (<combinator> pre! post!)))) + ([/////synthesis.path/seq _.then] + [/////synthesis.path/alt ..alternation]) + + _ + (////.throw unrecognized-path []))) + +(def: (pattern-matching generate pathP) + (-> Phase Path (Operation Statement)) + (do ////.monad + [pattern-matching! (pattern-matching' generate pathP)] + (wrap ($_ _.then + (_.while (_.bool true) + pattern-matching!) + (_.statement (|> (_.var "error") (_.apply/* (list (_.string case.pattern-matching-error))))))))) + +(def: #export (case generate [valueS pathP]) + (-> Phase [Synthesis Path] (Operation (Expression Any))) + (do ////.monad + [initG (generate valueS) + pattern-matching! (pattern-matching generate pathP)] + (wrap (|> ($_ _.then + (_.local (list @temp)) + (_.let (list @cursor) (_.array (list initG))) + (_.let (list @savepoint) (_.array (list))) + pattern-matching!) + (_.closure (list)) + (_.apply/* (list)))))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/lua/extension.lux b/stdlib/source/lux/tool/compiler/phase/generation/lua/extension.lux new file mode 100644 index 000000000..a40b4953f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/lua/extension.lux @@ -0,0 +1,15 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common] + ["." host]]) + +(def: #export bundle + Bundle + (|> common.bundle + (dictionary.merge host.bundle))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/lua/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/lua/extension/common.lux new file mode 100644 index 000000000..6d060f0bf --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/lua/extension/common.lux @@ -0,0 +1,145 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function]] + [data + ["." product] + [collection + ["." dictionary]]] + [host (#+ import:) + ["_" lua (#+ Expression Literal)]]] + ["." /// #_ + ["#." runtime (#+ Operation Phase Handler Bundle)] + ["#." primitive] + [// + [extension (#+ Nullary Unary Binary Trinary + nullary unary binary trinary)] + [// + [extension + ["." bundle]]]]]) + +(template: (!unary function) + (|>> list _.apply/* (|> (_.var function)))) + +(def: lux-procs + Bundle + (|> bundle.empty + (bundle.install "is" (binary (product.uncurry _.=))) + (bundle.install "try" (unary ///runtime.lux//try)))) + +(def: i64-procs + Bundle + (<| (bundle.prefix "i64") + (|> bundle.empty + (bundle.install "and" (binary (product.uncurry _.bit-and))) + (bundle.install "or" (binary (product.uncurry _.bit-or))) + (bundle.install "xor" (binary (product.uncurry _.bit-xor))) + (bundle.install "left-shift" (binary (product.uncurry _.bit-shl))) + (bundle.install "logical-right-shift" (binary (product.uncurry ///runtime.i64//logic-right-shift))) + (bundle.install "arithmetic-right-shift" (binary (product.uncurry _.bit-shr))) + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "+" (binary (product.uncurry _.+))) + (bundle.install "-" (binary (product.uncurry _.-))) + ))) + +(def: int-procs + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "*" (binary (product.uncurry _.*))) + (bundle.install "/" (binary (product.uncurry _./))) + (bundle.install "%" (binary (product.uncurry _.%))) + (bundle.install "frac" (unary (_./ (_.float +1.0)))) + (bundle.install "char" (unary (!unary "string.char")))))) + +(import: #long java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(template [<name> <const>] + [(def: (<name> _) + (Nullary Literal) + (_.float <const>))] + + [frac//smallest (java/lang/Double::MIN_VALUE)] + [frac//min (f/* -1.0 (java/lang/Double::MAX_VALUE))] + [frac//max (java/lang/Double::MAX_VALUE)] + ) + +(def: frac//decode + (Unary (Expression Any)) + (|>> list _.apply/* (|> (_.var "tonumber")) _.return (_.closure (list)) ///runtime.lux//try)) + +(def: frac-procs + Bundle + (<| (bundle.prefix "frac") + (|> bundle.empty + (bundle.install "+" (binary (product.uncurry _.+))) + (bundle.install "-" (binary (product.uncurry _.-))) + (bundle.install "*" (binary (product.uncurry _.*))) + (bundle.install "/" (binary (product.uncurry _./))) + (bundle.install "%" (binary (product.uncurry _.%))) + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "smallest" (nullary frac//smallest)) + (bundle.install "min" (nullary frac//min)) + (bundle.install "max" (nullary frac//max)) + (bundle.install "int" (unary (!unary "math.floor"))) + (bundle.install "encode" (unary (!unary "tostring"))) + (bundle.install "decode" (unary ..frac//decode))))) + +(def: (text//char [subjectO paramO]) + (Binary (Expression Any)) + (///runtime.text//char subjectO paramO)) + +(def: (text//clip [paramO extraO subjectO]) + (Trinary (Expression Any)) + (///runtime.text//clip subjectO paramO extraO)) + +(def: (text//index [startO partO textO]) + (Trinary (Expression Any)) + (///runtime.text//index textO partO startO)) + +(def: text-procs + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "concat" (binary (product.uncurry (function.flip _.concat)))) + (bundle.install "index" (trinary text//index)) + (bundle.install "size" (unary (|>> list _.apply/* (|> (_.var "string.len"))))) + (bundle.install "char" (binary (product.uncurry ///runtime.text//char))) + (bundle.install "clip" (trinary text//clip)) + ))) + +(def: (io//log! messageO) + (Unary (Expression Any)) + (_.or (_.apply/* (list messageO) (_.var "print")) + ///runtime.unit)) + +(def: io-procs + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary ..io//log!)) + (bundle.install "error" (unary (!unary "error"))) + (bundle.install "exit" (unary (!unary "os.exit"))) + (bundle.install "current-time" (nullary (function (_ _) + (|> (_.var "os.time") + (_.apply/* (list)) + (_.* (_.int +1,000))))))))) + +(def: #export bundle + 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) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/lua/extension/host.lux b/stdlib/source/lux/tool/compiler/phase/generation/lua/extension/host.lux new file mode 100644 index 000000000..9c178e79c --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/lua/extension/host.lux @@ -0,0 +1,25 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [data + ["." product] + [collection + ["." dictionary]]] + [host + ["_" lua (#+ Expression)]]] + ["." /// #_ + ["#." runtime (#+ Handler Bundle)] + ["#/" // #_ + ["#." extension (#+ Nullary Unary Binary Trinary Variadic + nullary unary binary trinary variadic)] + ["#/" // + ["#." extension + ["." bundle]] + ["#/" // #_ + ["#." synthesis]]]]]) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lua") + bundle.empty)) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/lua/function.lux b/stdlib/source/lux/tool/compiler/phase/generation/lua/function.lux new file mode 100644 index 000000000..517af6550 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/lua/function.lux @@ -0,0 +1,106 @@ +(.module: + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [control + pipe] + [data + ["." product] + [text + format] + [collection + ["." list ("#@." functor fold)]]] + [host + ["_" lua (#+ Expression Statement)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase)] + ["#." reference] + ["#." case] + ["#/" // + ["#." reference] + ["#/" // + ["." // #_ + [reference (#+ Register Variable)] + [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] + [synthesis (#+ Synthesis)]]]]]) + +(def: #export (apply generate [functionS argsS+]) + (-> Phase (Application Synthesis) (Operation (Expression Any))) + (do ////.monad + [functionO (generate functionS) + argsO+ (monad.map @ generate argsS+)] + (wrap (_.apply/* argsO+ functionO)))) + +(def: #export capture + (///reference.foreign _.var)) + +(def: (with-closure function-name inits function-definition) + (-> Text (List (Expression Any)) Statement (Operation (Expression Any))) + (case inits + #.Nil + (do ////.monad + [_ (///.save! ["" function-name] + function-definition)] + (wrap (|> (_.var function-name) (_.apply/* inits)))) + + _ + (do ////.monad + [@closure (:: @ map _.var (///.gensym "closure")) + _ (///.save! ["" (_.code @closure)] + (_.function @closure + (|> (list.enumerate inits) + (list@map (|>> product.left ..capture))) + ($_ _.then + function-definition + (_.return (_.var function-name)))))] + (wrap (_.apply/* inits @closure))))) + +(def: input + (|>> inc //case.register)) + +(def: #export (function generate [environment arity bodyS]) + (-> Phase (Abstraction Synthesis) (Operation (Expression Any))) + (do ////.monad + [[function-name bodyO] (///.with-context + (do @ + [function-name ///.context] + (///.with-anchor (_.var function-name) + (generate bodyS)))) + closureO+ (: (Operation (List (Expression Any))) + (monad.map @ (:: //reference.system variable) environment)) + #let [@curried (_.var "curried") + arityO (|> arity .int _.int) + @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! + (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) + ($_ _.then + (_.let (list @curried) (pack @var-args)) + (_.let (list @num-args) (_.the "n" @curried)) + (_.cond (list [(|> @num-args (_.= (_.int +0))) + (_.return @self)] + [(|> @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)] + (_.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)))))))))) + ))) + )) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/lua/loop.lux b/stdlib/source/lux/tool/compiler/phase/generation/lua/loop.lux new file mode 100644 index 000000000..41ebb4766 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/lua/loop.lux @@ -0,0 +1,40 @@ +(.module: + [lux (#- Scope) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + [text + format] + [collection + ["." list ("#@." functor)]]] + [host + ["_" lua (#+ Expression)]]] + ["." // #_ + [runtime (#+ Operation Phase)] + ["#." case] + ["#/" // + ["#/" // + [// + [synthesis (#+ Scope Synthesis)]]]]]) + +(def: #export (scope generate [start initsS+ bodyS]) + (-> Phase (Scope Synthesis) (Operation (Expression Any))) + (do ////.monad + [@loop (:: @ map (|>> %n (format "loop") _.var) ///.next) + initsO+ (monad.map @ generate initsS+) + bodyO (///.with-anchor @loop + (generate bodyS)) + _ (///.save! ["" (_.code @loop)] + (_.function @loop (|> initsS+ + list.enumerate + (list@map (|>> product.left (n/+ start) //case.register))) + (_.return bodyO)))] + (wrap (_.apply/* initsO+ @loop)))) + +(def: #export (recur generate argsS+) + (-> Phase (List Synthesis) (Operation (Expression Any))) + (do ////.monad + [@scope ///.anchor + argsO+ (monad.map @ generate argsS+)] + (wrap (_.apply/* argsO+ @scope)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/lua/primitive.lux b/stdlib/source/lux/tool/compiler/phase/generation/lua/primitive.lux new file mode 100644 index 000000000..47ccf5006 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/lua/primitive.lux @@ -0,0 +1,27 @@ +(.module: + [lux (#- i64) + [control + [pipe (#+ cond> new>)]] + [data + [number + ["." frac]]] + [host + ["_" lua (#+ Literal)]]] + ["." // #_ + ["#." runtime]]) + +(def: #export bit + (-> Bit Literal) + _.bool) + +(def: #export i64 + (-> (I64 Any) Literal) + (|>> .int _.int)) + +(def: #export f64 + (-> Frac Literal) + _.float) + +(def: #export text + (-> Text Literal) + _.string) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/lua/reference.lux b/stdlib/source/lux/tool/compiler/phase/generation/lua/reference.lux new file mode 100644 index 000000000..62c69e8bc --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/lua/reference.lux @@ -0,0 +1,11 @@ +(.module: + [lux #* + [host + ["_" lua (#+ Expression)]]] + [// + [// + ["." reference]]]) + +(def: #export system + (reference.system (: (-> Text (Expression Any)) _.var) + (: (-> Text (Expression Any)) _.var))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/lua/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/lua/runtime.lux new file mode 100644 index 000000000..5e45682d1 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/lua/runtime.lux @@ -0,0 +1,358 @@ +(.module: + [lux (#- inc) + [abstract + [monad (#+ do)]] + [control + ["." function] + ["p" parser]] + [data + [number (#+ hex) + ["." i64]] + ["." text + format] + [collection + ["." list ("#@." functor)]]] + ["." macro + ["." code] + ["s" syntax (#+ syntax:)]] + [host + ["_" lua (#+ Expression Location Var Computation Literal Statement)]]] + ["." /// + ["//." // + [// + ["/////." name] + ["." synthesis]]]] + ) + +(template [<name> <base>] + [(type: #export <name> + (<base> Var (Expression Any) Statement))] + + [Operation ///.Operation] + [Phase ///.Phase] + [Handler ///.Handler] + [Bundle ///.Bundle] + ) + +(def: prefix Text "LuxRuntime") + +(def: #export unit (_.string synthesis.unit)) + +(def: (flag value) + (-> Bit Literal) + (if value + (_.string "") + _.nil)) + +(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]))) + +(def: #export (variant tag last? value) + (-> Nat Bit (Expression Any) Literal) + (variant' (_.int (.int tag)) + (flag last?) + value)) + +(def: #export none + Literal + (..variant 0 #0 unit)) + +(def: #export some + (-> (Expression Any) Literal) + (..variant 1 #1)) + +(def: #export left + (-> (Expression Any) Literal) + (..variant 0 #0)) + +(def: #export right + (-> (Expression Any) Literal) + (..variant 1 #1)) + +(def: runtime-name + (-> Text Var) + (|>> /////name.normalize + (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))} + body) + (wrap (list (` (let [(~+ (|> vars + (list@map (function (_ var) + (list (code.local-identifier var) + (` (_.var (~ (code.text (/////name.normalize var)))))))) + list.concat))] + (~ body)))))) + +(syntax: (runtime: {declaration (p.or s.local-identifier + (s.form (p.and s.local-identifier + (p.some s.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))))))))))))) + +(def: (nth index table) + (-> (Expression Any) (Expression Any) (Location Any)) + (_.nth (_.+ (_.int +1) index) table)) + +(def: last-index (|>> _.length (_.- (_.int +1)))) + +(runtime: (tuple//left lefts tuple) + (with-vars [last-right] + ($_ _.then + (_.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))))))) + +(runtime: (array//sub from to array) + (with-vars [temp idx] + ($_ _.then + (_.let (list temp) (_.array (list))) + (_.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] + ($_ _.then + (_.let (list last-right) (..last-index tuple)) + (_.let (list right-index) (_.+ (_.int +1) lefts)) + (_.cond (list [(_.= right-index last-right) + (_.return (..nth right-index tuple))] + [(_.> right-index last-right) + ## Needs recursion. + (_.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? + ## 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!)] + + [(_.> sum-tag wantedTag) + test-recursion!] + + [(_.and (_.< sum-tag wantedTag) + (_.= (_.string "") wantsLast)) + (_.return (variant' (_.- wantedTag sum-tag) sum-flag sum-value))]) + + no-match!))) + +(runtime: (array//copy array) + (with-vars [temp idx] + ($_ _.then + (_.let (list temp) (_.array (list))) + (<| (_.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] + (let [copy! (function (_ input output) + (<| (_.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))) + (copy! left temp) + (copy! right temp) + (_.return temp))))) + +(def: runtime//adt + Statement + ($_ _.then + @tuple//left + @array//sub + @tuple//right + @sum//get + @array//copy + @array//concat)) + +(runtime: (lux//try risky) + (with-vars [success value] + ($_ _.then + (_.let (list success value) (|> risky (_.apply/* (list ..unit)) + _.return (_.closure (list)) + list _.apply/* (|> (_.var "pcall")))) + (_.if success + (_.return (..right value)) + (_.return (..left value)))))) + +(runtime: (lux//program-args raw) + (with-vars [tail head idx] + ($_ _.then + (_.let (list tail) ..none) + (<| (_.for-step idx (_.length raw) (_.int +1) (_.int -1)) + (_.set (list tail) (..some (_.array (list (_.nth idx raw) + tail))))) + (_.return tail)))) + +(def: runtime//lux + Statement + ($_ _.then + @lux//try + @lux//program-args)) + +(runtime: (i64//logic-right-shift param subject) + (let [mask (|> (_.int +1) + (_.bit-shl (_.- param (_.int +64))) + (_.- (_.int +1)))] + (_.return (|> subject + (_.bit-shr param) + (_.bit-and mask))))) + +(def: runtime//i64 + Statement + ($_ _.then + @i64//logic-right-shift + )) + +(runtime: (text//index subject param start) + (with-vars [idx] + ($_ _.then + (_.let (list idx) (_.apply/* (list subject param start (_.bool #1)) + (_.var "string.find"))) + (_.if (_.= _.nil idx) + (_.return ..none) + (_.return (..some idx)))))) + +(runtime: (text//clip text from to) + (with-vars [size] + ($_ _.then + (_.let (list size) (_.apply/* (list text) (_.var "string.len"))) + (_.if (_.or (_.> size from) + (_.> size to)) + (_.return ..none) + (_.return (..some (_.apply/* (list text from to) (_.var "string.sub"))))) + ))) + +(runtime: (text//char idx text) + (with-vars [char] + ($_ _.then + (_.let (list char) (_.apply/* (list text idx) (_.var "string.byte"))) + (_.if (_.= _.nil char) + (_.return ..none) + (_.return (..some char)))))) + +(def: runtime//text + Statement + ($_ _.then + @text//index + @text//clip + @text//char)) + +(runtime: (array//new size) + (with-vars [output idx] + ($_ _.then + (_.let (list output) (_.array (list))) + (_.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] + ($_ _.then + (_.let (list temp) (..nth idx array)) + (_.if (_.or (_.= _.nil temp) + (_.= ..unit temp)) + (_.return ..none) + (_.return (..some temp)))))) + +(runtime: (array//put array idx value) + ($_ _.then + (_.set (list (..nth idx array)) value) + (_.return array))) + +(def: runtime//array + Statement + ($_ _.then + @array//new + @array//get + @array//put + )) + +(runtime: (box//write value box) + ($_ _.then + (_.set (list (_.nth (_.int +1) box)) value) + (_.return ..unit))) + +(def: runtime//box + Statement + @box//write) + +(def: runtime + Statement + ($_ _.then + runtime//adt + runtime//lux + runtime//i64 + runtime//text + runtime//array + runtime//box + )) + +(def: #export artifact ..prefix) + +(def: #export generate + (Operation Any) + (///.with-buffer + (do ////.monad + [_ (///.save! ["" ..prefix] ..runtime)] + (///.save-buffer! ..artifact)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/lua/structure.lux b/stdlib/source/lux/tool/compiler/phase/generation/lua/structure.lux new file mode 100644 index 000000000..2fab4daf0 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/lua/structure.lux @@ -0,0 +1,36 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [host + ["_" lua (#+ Expression)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase)] + ["#." primitive] + ["#//" /// + ["#/" // #_ + [analysis (#+ Variant Tuple)] + ["#." synthesis (#+ Synthesis)]]]]) + +(def: #export (tuple generate elemsS+) + (-> Phase (Tuple Synthesis) (Operation (Expression Any))) + (case elemsS+ + #.Nil + (:: ////.monad wrap (//primitive.text /////synthesis.unit)) + + (#.Cons singletonS #.Nil) + (generate singletonS) + + _ + (|> elemsS+ + (monad.map ////.monad generate) + (:: ////.monad map _.array)))) + +(def: #export (variant generate [lefts right? valueS]) + (-> Phase (Variant Synthesis) (Operation (Expression Any))) + (:: ////.monad map + (//runtime.variant (if right? + (inc lefts) + lefts) + right?) + (generate valueS))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/python/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/python/runtime.lux index 0b84f4741..bdb0a8d2b 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/python/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/python/runtime.lux @@ -39,35 +39,35 @@ (def: #export unit (_.string synthesis.unit)) (def: (flag value) - (-> Bit (Computation Any)) + (-> Bit Literal) (if value (_.string "") _.none)) (def: (variant' tag last? value) - (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) + (-> (Expression Any) (Expression Any) (Expression Any) Literal) (_.tuple (list tag last? value))) (def: #export (variant tag last? value) - (-> Nat Bit (Expression Any) (Computation Any)) + (-> Nat Bit (Expression Any) Literal) (variant' (_.int (.int tag)) (flag last?) value)) (def: #export none - (Computation Any) + Literal (..variant 0 #0 unit)) (def: #export some - (-> (Expression Any) (Computation Any)) + (-> (Expression Any) Literal) (..variant 1 #1)) (def: #export left - (-> (Expression Any) (Computation Any)) + (-> (Expression Any) Literal) (..variant 0 #0)) (def: #export right - (-> (Expression Any) (Computation Any)) + (-> (Expression Any) Literal) (..variant 1 #1)) (def: runtime-name diff --git a/stdlib/source/lux/tool/compiler/phase/generation/ruby/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/ruby/case.lux index 01b405dff..18979b0fa 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/ruby/case.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/ruby/case.lux @@ -11,7 +11,7 @@ ["." list ("#@." functor fold)] ["." set]]] [host - ["_" ruby (#+ Expression LVar Statement)]]] + ["_" ruby (#+ Expression Statement)]]] ["." // #_ ["#." runtime (#+ Operation Phase)] ["#." reference] @@ -97,7 +97,7 @@ (Statement Any) (_.set (list @cursor) (|> @savepoint (_.do "pop" (list))))) -(def: fail-pm! _.break) +(def: fail! _.break) (exception: #export unrecognized-path) @@ -114,9 +114,9 @@ (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))) (.if simple? (_.when (_.= _.nil @temp) - fail-pm!) + fail!) (_.if (_.= _.nil @temp) - fail-pm! + fail! (..push! @temp)))))] [left-choice _.nil (<|)] @@ -149,7 +149,7 @@ (^template [<tag> <format>] (^ (<tag> value)) (////@wrap (_.when (|> value <format> (_.= ..peek) _.not) - fail-pm!))) + fail!))) ([/////synthesis.path/bit //primitive.bit] [/////synthesis.path/i64 //primitive.i64] [/////synthesis.path/f64 //primitive.f64] diff --git a/stdlib/source/lux/tool/compiler/phase/generation/ruby/primitive.lux b/stdlib/source/lux/tool/compiler/phase/generation/ruby/primitive.lux index 4ec058ffe..3fa59aaf4 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/ruby/primitive.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/ruby/primitive.lux @@ -6,22 +6,22 @@ [number ["." frac]]] [host - ["_" ruby (#+ Expression)]]] + ["_" ruby (#+ Literal)]]] ["." // #_ ["#." runtime]]) (def: #export bit - (-> Bit (Expression Any)) + (-> Bit Literal) _.bool) (def: #export i64 - (-> (I64 Any) (Expression Any)) + (-> (I64 Any) Literal) (|>> .int _.int)) (def: #export f64 - (-> Frac (Expression Any)) + (-> Frac Literal) _.float) (def: #export text - (-> Text (Expression Any)) + (-> Text Literal) _.string) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index f73319739..21e529ecc 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -3,8 +3,8 @@ [structure (#+)] [reference (#+)] [case (#+)] - [function (#+)] [loop (#+)] + [function (#+)] [extension (#+) [common (#+)] [host (#+)]])] @@ -38,6 +38,7 @@ [host [js (#+)] [python (#+)] + [lua (#+)] [ruby (#+)] [scheme (#+)]] [tool @@ -48,6 +49,8 @@ <host-modules>] [python (#+) <host-modules>] + [lua (#+) + <host-modules>] [ruby (#+) <host-modules>] [scheme (#+) @@ -381,4 +384,5 @@ ## (_.seed 16966479879996440699) ## (_.seed 16140950815046933697) ## (_.seed 8804587020128699091) + ## (_.seed 9353282359333487462) ..test)) |