diff options
Diffstat (limited to 'stdlib')
25 files changed, 1911 insertions, 99 deletions
diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index 72c6dbb86..640bff8a2 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -91,10 +91,10 @@ (def: succ <succ>) (def: pred <pred>))] - [Nat Order<Nat> inc dec] - [Int Order<Int> inc dec] + [Nat Order<Nat> inc dec] + [Int Order<Int> inc dec] [Frac Order<Frac> (f/+ ("lux frac smallest")) (f/- ("lux frac smallest"))] - [Deg Order<Deg> inc dec] + [Deg Order<Deg> inc dec] ) (do-template [<type> <enum> <top> <bottom>] diff --git a/stdlib/source/lux/lang.lux b/stdlib/source/lux/lang.lux index 2259b615b..322b9f655 100644 --- a/stdlib/source/lux/lang.lux +++ b/stdlib/source/lux/lang.lux @@ -16,6 +16,10 @@ (type: #export Eval (-> Type Code (Meta Any))) +(type: #export Version Text) + +(def: #export version Version "0.6.0") + (def: #export (fail message) (All [a] (-> Text (Meta a))) (do macro.Monad<Meta> diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/analysis.lux index 0996ad1f4..6efa934d8 100644 --- a/stdlib/source/lux/lang/analysis.lux +++ b/stdlib/source/lux/lang/analysis.lux @@ -77,7 +77,11 @@ (type: #export (Tuple a) (List a)) -(type: #export Application [Analysis (List Analysis)]) +(type: #export Arity Nat) + +(type: #export (Abstraction c) [Environment Arity c]) + +(type: #export (Application c) [c (List c)]) (def: (last? size tag) (-> Nat Tag Bool) @@ -131,7 +135,7 @@ ) (def: #export (apply [func args]) - (-> Application Analysis) + (-> (Application Analysis) Analysis) (list/fold (function (_ arg func) (#Apply arg func)) func args)) (type: #export Analyser @@ -180,7 +184,7 @@ ) (def: #export (application analysis) - (-> Analysis Application) + (-> Analysis (Application Analysis)) (case analysis (#Apply head func) (let [[func' tail] (application func)] diff --git a/stdlib/source/lux/lang/extension.lux b/stdlib/source/lux/lang/extension.lux index d9eb90fc9..7edac52c3 100644 --- a/stdlib/source/lux/lang/extension.lux +++ b/stdlib/source/lux/lang/extension.lux @@ -4,16 +4,16 @@ ["ex" exception #+ exception:]) (data ["e" error] [text] - (coll (dictionary ["dict" unordered #+ Dict]))) - [macro]) + (coll (dictionary ["dict" unordered #+ Dict])))) [// #+ Eval] [//compiler #+ Operation Compiler] [//analysis #+ Analyser] - [//synthesis #+ Synthesizer]) + [//synthesis #+ Synthesizer] + [//translation #+ Translator]) (do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] + [(exception: #export (<name> {extension Text}) + extension)] [unknown-analysis] [unknown-synthesis] @@ -27,7 +27,10 @@ ) (type: #export Analysis - (-> Analyser Eval (List Code) (Meta //analysis.Analysis))) + (-> Analyser Eval + (Compiler .Lux + (List Code) + //analysis.Analysis))) (type: #export Synthesis (-> Synthesizer @@ -35,8 +38,11 @@ (List //analysis.Analysis) //synthesis.Synthesis))) -(type: #export Translation - (-> (List Code) (Meta Code))) +(type: #export (Translation anchor code) + (-> (Translator anchor code) + (Compiler (//translation.State anchor code) + (List //synthesis.Synthesis) + code))) (type: #export Statement (-> (List Code) (Meta Any))) @@ -72,14 +78,14 @@ (do-template [<name> <type> <category> <exception>] [(def: #export (<name> name) (-> Text (Meta <type>)) - (do macro.Monad<Meta> + (do //compiler.Monad<Operation> [extensions ..get] (case (dict.get name (get@ <category> extensions)) (#.Some extension) (wrap extension) #.None - (//.throw <exception> name))))] + (//compiler.throw <exception> name))))] [find-analysis Analysis #analysis unknown-analysis] [find-synthesis Synthesis #synthesis unknown-synthesis] @@ -91,25 +97,30 @@ (All [e] (Extension e)) (dict.new text.Hash<Text>)) -(do-template [<all> <type> <category>] +(do-template [<params> <all> <state> <type> <category>] [(def: #export <all> - (Meta (Extension <type>)) + (All <params> (Operation <state> (Extension <type>))) (|> ..get - (:: macro.Monad<Meta> map (get@ <category>))))] - - [all-analyses Analysis #analysis] - [all-syntheses Synthesis #synthesis] - [all-translations Translation #translation] - [all-statements Statement #statement] + (:: //compiler.Monad<Operation> map (get@ <category>))))] + + [[] all-analyses .Lux + Analysis #analysis] + [[] all-syntheses //synthesis.State + Synthesis #synthesis] + [[anchor code] all-translations (//translation.State anchor code) + Translation #translation] + [[] all-statements Any + Statement #statement] ) (do-template [<name> <type> <category> <exception>] [(def: #export (<name> name extension) (-> Text <type> (Meta Any)) - (do macro.Monad<Meta> + (do //compiler.Monad<Operation> [extensions ..get - _ (//.assert <exception> name - (not (dict.contains? name (get@ <category> extensions)))) + _ (if (not (dict.contains? name (get@ <category> extensions))) + (wrap []) + (//compiler.throw <exception> name)) _ (..set (update@ <category> (dict.put name extension) extensions))] (wrap [])))] diff --git a/stdlib/source/lux/lang/extension/synthesis.lux b/stdlib/source/lux/lang/extension/synthesis.lux new file mode 100644 index 000000000..c48f3e3a5 --- /dev/null +++ b/stdlib/source/lux/lang/extension/synthesis.lux @@ -0,0 +1,9 @@ +(.module: + lux + (lux (data [text] + (coll (dictionary ["dict" unordered #+ Dict])))) + [//]) + +(def: #export defaults + (Dict Text //.Synthesis) + (dict.new text.Hash<Text>)) diff --git a/stdlib/source/lux/lang/extension/translation.lux b/stdlib/source/lux/lang/extension/translation.lux new file mode 100644 index 000000000..bc95ed1f4 --- /dev/null +++ b/stdlib/source/lux/lang/extension/translation.lux @@ -0,0 +1,9 @@ +(.module: + lux + (lux (data [text] + (coll (dictionary ["dict" unordered #+ Dict])))) + [//]) + +(def: #export defaults + (Dict Text //.Translation) + (dict.new text.Hash<Text>)) diff --git a/stdlib/source/lux/lang/host/scheme.lux b/stdlib/source/lux/lang/host/scheme.lux new file mode 100644 index 000000000..f6e7b1834 --- /dev/null +++ b/stdlib/source/lux/lang/host/scheme.lux @@ -0,0 +1,302 @@ +(.module: + [lux #- Code' Code int or and if function cond when let] + (lux (control pipe) + (data [text] + text/format + [number] + (coll [list "list/" Functor<List> Fold<List>])) + (type abstract))) + +(abstract: Global' {} Any) +(abstract: Var' {} Any) +(abstract: Computation' {} Any) +(abstract: (Expression' k) {} Any) + +(abstract: (Code' k) + {} + + Text + + (type: #export Code (Ex [k] (Code' k))) + (type: #export Expression (Code' (Ex [k] (Expression' k)))) + (type: #export Global (Code' (Expression' Global'))) + (type: #export Computation (Code' (Expression' Computation'))) + (type: #export Var (Code' (Expression' Var'))) + + (type: #export Arguments + {#mandatory (List Var) + #rest (Maybe Var)}) + + (def: #export code (-> Code Text) (|>> @representation)) + + (def: #export var (-> Text Var) (|>> @abstraction)) + + (def: (arguments [vars rest]) + (-> Arguments Code) + (case rest + (#.Some rest) + (case vars + #.Nil + rest + + _ + (|> (format " . " (@representation rest)) + (format (|> vars + (list/map ..code) + (text.join-with " "))) + (text.enclose ["(" ")"]) + @abstraction)) + + #.None + (|> vars + (list/map ..code) + (text.join-with " ") + (text.enclose ["(" ")"]) + @abstraction))) + + (def: #export nil + Computation + (@abstraction "'()")) + + (def: #export bool + (-> Bool Computation) + (|>> (case> true "#t" + false "#f") + @abstraction)) + + (def: #export int + (-> Int Computation) + (|>> %i @abstraction)) + + (def: #export float + (-> Frac Computation) + (|>> (cond> [(f/= number.positive-infinity)] + [(new> "+inf.0")] + + [(f/= number.negative-infinity)] + [(new> "-inf.0")] + + [number.not-a-number?] + [(new> "+nan.0")] + + ## else + [%f]) + @abstraction)) + + (def: #export positive-infinity Computation (..float number.positive-infinity)) + (def: #export negative-infinity Computation (..float number.negative-infinity)) + (def: #export not-a-number Computation (..float number.not-a-number)) + + (def: #export string + (-> Text Computation) + (|>> %t @abstraction)) + + (def: #export symbol + (-> Text Computation) + (|>> (format "'") @abstraction)) + + (def: #export global + (-> Text Global) + (|>> @abstraction)) + + (def: form + (-> (List Code) Text) + (|>> (list/map ..code) + (text.join-with " ") + (text.enclose ["(" ")"]))) + + (def: #export (apply/* func args) + (-> Expression (List Expression) Computation) + (@abstraction (..form (#.Cons func args)))) + + (do-template [<name> <function>] + [(def: #export <name> + (-> (List Expression) Computation) + (apply/* (..global <function>)))] + + [vector/* "vector"] + [list/* "list"] + ) + + (def: #export (apply/0 func) + (-> Expression Computation) + (..apply/* func (list))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> (apply/0 (..global <scheme-name>)))] + + [newline/0 "newline"] + ) + + (def: #export (apply/1 func) + (-> Expression (-> Expression Computation)) + (|>> (list) (..apply/* func))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> (apply/1 (..global <scheme-name>)))] + + [exact/1 "exact"] + [integer->char/1 "integer->char"] + [number->string/1 "number->string"] + [string/1 "string"] + [length/1 "length"] + [values/1 "values"] + [null?/1 "null?"] + [car/1 "car"] + [cdr/1 "cdr"] + [raise/1 "raise"] + [error-object-message/1 "error-object-message"] + [make-vector/1 "make-vector"] + [vector-length/1 "vector-length"] + [not/1 "not"] + [string-length/1 "string-length"] + [string-hash/1 "string-hash"] + [reverse/1 "reverse"] + [display/1 "display"] + [exit/1 "exit"] + ) + + (def: #export (apply/2 func) + (-> Expression (-> Expression Expression Computation)) + (.function (_ _0 _1) + (..apply/* func (list _0 _1)))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> (apply/2 (..global <scheme-name>)))] + + [append/2 "append"] + [cons/2 "cons"] + [make-vector/2 "make-vector"] + [vector-ref/2 "vector-ref"] + [list-tail/2 "list-tail"] + [map/2 "map"] + [string-ref/2 "string-ref"] + [string-append/2 "string-append"] + ) + + (do-template [<lux-name> <scheme-name>] + [(def: #export (<lux-name> param subject) + (-> Expression Expression Computation) + (..apply/2 (..global <scheme-name>) subject param))] + + [=/2 "="] + [eq?/2 "eq?"] + [eqv?/2 "eqv?"] + [</2 "<"] + [<=/2 "<="] + [>/2 ">"] + [>=/2 ">="] + [string=?/2 "string=?"] + [string<?/2 "string<?"] + [+/2 "+"] + [-/2 "-"] + [//2 "/"] + [*/2 "*"] + [expt/2 "expt"] + [remainder/2 "remainder"] + [quotient/2 "quotient"] + [mod/2 "mod"] + [arithmetic-shift/2 "arithmetic-shift"] + [bit-and/2 "bitwise-and"] + [bit-or/2 "bitwise-ior"] + [bit-xor/2 "bitwise-xor"] + ) + + (def: #export (apply/3 func) + (-> Expression (-> Expression Expression Expression Computation)) + (.function (_ _0 _1 _2) + (..apply/* func (list _0 _1 _2)))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> (apply/3 (..global <scheme-name>)))] + + [substring/3 "substring"] + [vector-set!/3 "vector-set!"] + ) + + (def: #export (vector-copy!/5 _0 _1 _2 _3 _4) + (-> Expression Expression Expression Expression Expression + Computation) + (..apply/* (..global "vector-copy!") + (list _0 _1 _2 _3 _4))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> + (-> (List Expression) Computation) + (|>> (list& (..global <scheme-name>)) ..form @abstraction))] + + [or "or"] + [and "and"] + ) + + (do-template [<lux-name> <scheme-name> <var> <pre>] + [(def: #export (<lux-name> bindings body) + (-> (List [<var> Expression]) Expression Computation) + (@abstraction + (..form (list (..global <scheme-name>) + (|> bindings + (list/map (.function (_ [binding/name binding/value]) + (@abstraction + (..form (list (<pre> binding/name) + binding/value))))) + ..form + @abstraction) + body))))] + + [let "let" Var .id] + [let* "let*" Var .id] + [letrec "letrec" Var .id] + [let-values "let-values" Arguments ..arguments] + [let*-values "let*-values" Arguments ..arguments] + [letrec-values "letrec-values" Arguments ..arguments] + ) + + (def: #export (if test then else) + (-> Expression Expression Expression Computation) + (@abstraction + (..form (list (..global "if") test then else)))) + + (def: #export (when test then) + (-> Expression Expression Computation) + (@abstraction + (..form (list (..global "when") test then)))) + + (def: #export (cond clauses else) + (-> (List [Expression Expression]) Expression Computation) + (|> (list/fold (.function (_ [test then] next) + (if test then next)) + else + (list.reverse clauses)) + @representation + @abstraction)) + + (def: #export (lambda arguments body) + (-> Arguments Expression Computation) + (@abstraction + (..form (list (..global "lambda") + (..arguments arguments) + body)))) + + (def: #export (define name arguments body) + (-> Var Arguments Expression Computation) + (@abstraction + (..form (list (..global "define") + (|> arguments + (update@ #mandatory (|>> (#.Cons name))) + ..arguments) + body)))) + + (def: #export begin + (-> (List Expression) Computation) + (|>> (#.Cons (..global "begin")) ..form @abstraction)) + + (def: #export (set! name value) + (-> Var Expression Computation) + (@abstraction + (..form (list (..global "set!") name value)))) + + (def: #export (with-exception-handler handler body) + (-> Expression Expression Computation) + (@abstraction + (..form (list (..global "with-exception-handler") handler body)))) + ) diff --git a/stdlib/source/lux/lang/init.lux b/stdlib/source/lux/lang/init.lux index 9c909942e..40a7fc69c 100644 --- a/stdlib/source/lux/lang/init.lux +++ b/stdlib/source/lux/lang/init.lux @@ -1,10 +1,11 @@ (.module: lux + [//] (// ["//." target] [".L" extension] (extension [".E" analysis] - ## [".E" synthesis] - ## [".E" translation] + [".E" synthesis] + [".E" translation] ## [".E" statement] ))) @@ -26,10 +27,6 @@ #.var-counter +0 #.var-bindings (list)}) -(type: #export Version Text) - -(def: #export version Version "0.6.0") - (`` (def: #export info Info {#.target (for {(~~ (static //target.common-lisp)) //target.common-lisp @@ -41,7 +38,7 @@ (~~ (static //target.r)) //target.r (~~ (static //target.ruby)) //target.ruby (~~ (static //target.scheme)) //target.scheme}) - #.version ..version + #.version //.version #.mode #.Build})) (def: #export (compiler host) @@ -57,8 +54,8 @@ #.seed +0 #.scope-type-vars (list) #.extensions {#extensionL.analysis analysisE.defaults - #extensionL.synthesis (:!! []) ## synthesisE.defaults - #extensionL.translation (:!! []) ## translationE.defaults + #extensionL.synthesis synthesisE.defaults + #extensionL.translation translationE.defaults #extensionL.statement (:!! []) ## statementE.defaults } #.host host}) diff --git a/stdlib/source/lux/lang/name.lux b/stdlib/source/lux/lang/name.lux new file mode 100644 index 000000000..1053eb76f --- /dev/null +++ b/stdlib/source/lux/lang/name.lux @@ -0,0 +1,47 @@ +(.module: + lux + (lux (data [maybe] + [text] + text/format))) + +(def: (sanitize char) + (-> Nat Text) + (case char + (^ (char "*")) "_ASTER_" + (^ (char "+")) "_PLUS_" + (^ (char "-")) "_DASH_" + (^ (char "/")) "_SLASH_" + (^ (char "\\")) "_BSLASH_" + (^ (char "_")) "_UNDERS_" + (^ (char "%")) "_PERCENT_" + (^ (char "$")) "_DOLLAR_" + (^ (char "'")) "_QUOTE_" + (^ (char "`")) "_BQUOTE_" + (^ (char "@")) "_AT_" + (^ (char "^")) "_CARET_" + (^ (char "&")) "_AMPERS_" + (^ (char "=")) "_EQ_" + (^ (char "!")) "_BANG_" + (^ (char "?")) "_QM_" + (^ (char ":")) "_COLON_" + (^ (char ".")) "_PERIOD_" + (^ (char ",")) "_COMMA_" + (^ (char "<")) "_LT_" + (^ (char ">")) "_GT_" + (^ (char "~")) "_TILDE_" + (^ (char "|")) "_PIPE_" + _ (text.from-code char))) + +(def: #export (normalize name) + (-> Text Text) + (let [name/size (text.size name)] + (loop [idx +0 + output ""] + (if (n/< name/size idx) + (recur (inc idx) + (|> (text.nth idx name) maybe.assume sanitize (format output))) + output)))) + +(def: #export (definition [module name]) + (-> Ident Text) + (format (normalize module) "___" (normalize name))) diff --git a/stdlib/source/lux/lang/synthesis.lux b/stdlib/source/lux/lang/synthesis.lux index cc43ea0b3..1bf06cdd0 100644 --- a/stdlib/source/lux/lang/synthesis.lux +++ b/stdlib/source/lux/lang/synthesis.lux @@ -5,11 +5,9 @@ (coll (dictionary ["dict" unordered #+ Dict])))) [// #+ Extension] [//reference #+ Register Variable Reference] - [//analysis #+ Environment Analysis] + [//analysis #+ Environment Arity Analysis] [//compiler #+ Operation Compiler]) -(type: #export Arity Nat) - (type: #export Resolver (Dict Variable Variable)) (type: #export State @@ -66,8 +64,7 @@ (type: #export (Branch s) (#Case s (Path' s)) (#Let s Register s) - (#If s s s) - (#Exec s)) + (#If s s s)) (type: #export (Scope s) {#start Register @@ -111,6 +108,29 @@ [path/text #..Text] ) +(do-template [<name> <kind>] + [(template: #export (<name> content) + (.<| #..Access + <kind> + content))] + + [path/side #..Side] + [path/member #..Member] + ) + +(do-template [<name> <kind> <side>] + [(template: #export (<name> content) + (.<| #..Access + <kind> + <side> + content))] + + [side/left #..Side #.Left] + [side/right #..Side #.Right] + [member/left #..Member #.Left] + [member/right #..Member #.Right] + ) + (do-template [<name> <tag>] [(template: #export (<name> content) (<tag> content))] @@ -186,25 +206,34 @@ (do-template [<name> <tag>] [(template: #export (<name> content) - (<| #..Reference + (<| #..Structure <tag> content))] + [variant #..Variant] + [tuple #..Tuple] + ) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (.<| #..Reference + <tag> + content))] + [variable/local //reference.local] [variable/foreign //reference.foreign] ) (do-template [<name> <family> <tag>] [(template: #export (<name> content) - (<| #..Control - <family> - <tag> - content))] + (.<| #..Control + <family> + <tag> + content))] [branch/case #..Branch #..Case] [branch/let #..Branch #..Let] [branch/if #..Branch #..If] - [branch/exec #..Branch #..Exec] [loop/scope #..Loop #..Scope] [loop/recur #..Loop #..Recur] diff --git a/stdlib/source/lux/lang/synthesis/case.lux b/stdlib/source/lux/lang/synthesis/case.lux index 85065393d..b7f224168 100644 --- a/stdlib/source/lux/lang/synthesis/case.lux +++ b/stdlib/source/lux/lang/synthesis/case.lux @@ -126,45 +126,52 @@ (-> //.Synthesizer Analysis Match (Operation //.State Synthesis)) (do ///compiler.Monad<Operation> [inputS (synthesize^ inputA)] - (case [headB tailB+] - [[(#///analysis.Bind inputR) headB/bodyA] - #.Nil] - (case headB/bodyA - (^ (#///analysis.Reference (///reference.local outputR))) - (wrap (if (n/= inputR outputR) - inputS - (//.branch/exec inputS))) - - _ - (do @ - [arity //.scope-arity - headB/bodyS (//.with-new-local - (synthesize^ headB/bodyA))] - (wrap (//.branch/let [inputS - (if (//function.nested? arity) - (n/+ (dec arity) inputR) - inputR) - headB/bodyS])))) - - (^or (^ [[(///analysis.pattern/bool true) thenA] - (list [(///analysis.pattern/bool false) elseA])]) - (^ [[(///analysis.pattern/bool false) elseA] - (list [(///analysis.pattern/bool true) thenA])])) - (do @ - [thenS (synthesize^ thenA) - elseS (synthesize^ elseA)] - (wrap (//.branch/if [inputS thenS elseS]))) - - _ - (let [[[lastP lastA] prevsPA] (|> (#.Cons headB tailB+) - list.reverse - (case> (#.Cons [lastP lastA] prevsPA) - [[lastP lastA] prevsPA] - - _ - (undefined)))] - (do @ - [lastSP (path synthesize^ lastP lastA) - prevsSP+ (monad.map @ (product.uncurry (path synthesize^)) prevsPA)] - (wrap (//.branch/case [inputS (list/fold weave lastSP prevsSP+)])))) - ))) + (with-expansions [<unnecesary-let> + (as-is (^multi (^ (#///analysis.Reference (///reference.local outputR))) + (n/= inputR outputR)) + (wrap inputS)) + + <let> + (as-is [[(#///analysis.Bind inputR) headB/bodyA] + #.Nil] + (case headB/bodyA + <unnecesary-let> + + _ + (do @ + [arity //.scope-arity + headB/bodyS (//.with-new-local + (synthesize^ headB/bodyA))] + (wrap (//.branch/let [inputS + (if (//function.nested? arity) + (n/+ (dec arity) inputR) + inputR) + headB/bodyS]))))) + + <if> + (as-is (^or (^ [[(///analysis.pattern/bool true) thenA] + (list [(///analysis.pattern/bool false) elseA])]) + (^ [[(///analysis.pattern/bool false) elseA] + (list [(///analysis.pattern/bool true) thenA])])) + (do @ + [thenS (synthesize^ thenA) + elseS (synthesize^ elseA)] + (wrap (//.branch/if [inputS thenS elseS])))) + + <case> + (as-is _ + (let [[[lastP lastA] prevsPA] (|> (#.Cons headB tailB+) + list.reverse + (case> (#.Cons [lastP lastA] prevsPA) + [[lastP lastA] prevsPA] + + _ + (undefined)))] + (do @ + [lastSP (path synthesize^ lastP lastA) + prevsSP+ (monad.map @ (product.uncurry (path synthesize^)) prevsPA)] + (wrap (//.branch/case [inputS (list/fold weave lastSP prevsSP+)])))))] + (case [headB tailB+] + <let> + <if> + <case>)))) diff --git a/stdlib/source/lux/lang/synthesis/function.lux b/stdlib/source/lux/lang/synthesis/function.lux index cc40bea4d..35b9e047e 100644 --- a/stdlib/source/lux/lang/synthesis/function.lux +++ b/stdlib/source/lux/lang/synthesis/function.lux @@ -10,8 +10,8 @@ (dictionary ["dict" unordered #+ Dict])))) [///reference #+ Variable] [///compiler #+ Operation] - [///analysis #+ Environment Analysis] - [// #+ Arity Synthesis Synthesizer] + [///analysis #+ Environment Arity Analysis] + [// #+ Synthesis Synthesizer] [//loop]) (def: #export nested? diff --git a/stdlib/source/lux/lang/synthesis/loop.lux b/stdlib/source/lux/lang/synthesis/loop.lux index 6aab72213..eb57eb7ad 100644 --- a/stdlib/source/lux/lang/synthesis/loop.lux +++ b/stdlib/source/lux/lang/synthesis/loop.lux @@ -60,9 +60,6 @@ _ proper))) - (#//.Exec bodyS) - (proper? bodyS) - (#//.Let inputS register bodyS) (and (proper? inputS) (proper? bodyS)) @@ -131,9 +128,6 @@ (path-recursion recur) (maybe/map (|>> (#//.Case inputS) #//.Branch #//.Control))) - (#//.Exec bodyS) - (maybe/map (|>> //.branch/exec) (recur bodyS)) - (#//.Let inputS register bodyS) (maybe/map (|>> (#//.Let inputS register) #//.Branch #//.Control) (recur bodyS)) diff --git a/stdlib/source/lux/lang/translation.lux b/stdlib/source/lux/lang/translation.lux new file mode 100644 index 000000000..c117bc019 --- /dev/null +++ b/stdlib/source/lux/lang/translation.lux @@ -0,0 +1,164 @@ +(.module: + lux + (lux (control ["ex" exception #+ exception:] + [monad #+ do]) + (data [maybe "maybe/" Functor<Maybe>] + [error #+ Error] + [text] + text/format + (coll [sequence #+ Sequence] + (dictionary ["dict" unordered #+ Dict]))) + (world [file #+ File])) + [//name] + [//reference #+ Register] + [//compiler #+ Operation Compiler] + [//synthesis #+ Synthesis]) + +(do-template [<name>] + [(exception: #export (<name>) + "")] + + [no-active-buffer] + [no-anchor] + ) + +(exception: #export (cannot-interpret {message Text}) + message) + +(type: #export Context + {#scope-name Text + #inner-functions Nat}) + +(sig: #export (Host code) + (: (-> code (Error Any)) + execute!) + (: (-> code (Error Any)) + evaluate!)) + +(type: #export (Buffer code) (Sequence [Ident code])) + +(type: #export (Artifacts code) (Dict File (Buffer code))) + +(type: #export (State anchor code) + {#context Context + #anchor (Maybe anchor) + #host (Host code) + #buffer (Maybe (Buffer code)) + #artifacts (Artifacts code)}) + +(type: #export (Translator anchor code) + (Compiler (State anchor code) Synthesis code)) + +(def: #export (init host) + (All [anchor code] (-> (Host code) (..State anchor code))) + {#context {#scope-name "" + #inner-functions +0} + #anchor #.None + #host host + #buffer #.None + #artifacts (dict.new text.Hash<Text>)}) + +(def: #export (with-context expr) + (All [anchor code output] + (-> (Operation (..State anchor code) output) + (Operation (..State anchor code) [Text output]))) + (function (_ state) + (let [[old-scope old-inner] (get@ #context state) + new-scope (format old-scope "c___" (%i (.int old-inner)))] + (case (expr (set@ #context [new-scope +0] state)) + (#error.Success [state' output]) + (#error.Success [(set@ #context [old-scope (inc old-inner)] state') + [new-scope output]]) + + (#error.Error error) + (#error.Error error))))) + +(def: #export context + (All [anchor code] (Operation (..State anchor code) Text)) + (function (_ state) + (#error.Success [state + (|> state + (get@ #context) + (get@ #scope-name))]))) + +(do-template [<tag> + <with-declaration> <with-type> <with-value> + <get> <get-type> <exception>] + [(def: #export <with-declaration> + (All [anchor code output] <with-type>) + (function (_ body) + (function (_ state) + (case (body (set@ <tag> (#.Some <with-value>) state)) + (#error.Success [state' output]) + (#error.Success [(set@ <tag> (get@ <tag> state) state') + output]) + + (#error.Error error) + (#error.Error error))))) + + (def: #export <get> + (All [anchor code] (Operation (..State anchor code) <get-type>)) + (function (_ state) + (case (get@ <tag> state) + (#.Some output) + (#error.Success [state output]) + + #.None + (ex.throw <exception> []))))] + + [#anchor + (with-anchor anchor) + (-> anchor (Operation (..State anchor code) output) + (Operation (..State anchor code) output)) + anchor + anchor anchor no-anchor] + + [#buffer + with-buffer + (-> (Operation (..State anchor code) output) + (Operation (..State anchor code) output)) + sequence.empty + buffer (Buffer code) no-active-buffer] + ) + +(def: #export artifacts + (All [anchor code] + (Operation (..State anchor code) (Artifacts code))) + (function (_ state) + (#error.Success [state (get@ #artifacts state)]))) + +(do-template [<name>] + [(def: #export (<name> code) + (All [anchor code] + (-> code (Operation (..State anchor code) Any))) + (function (_ state) + (case (:: (get@ #host state) <name> code) + (#error.Error error) + (ex.throw cannot-interpret error) + + (#error.Success output) + (#error.Success [state output]))))] + + [execute!] + [evaluate!] + ) + +(def: #export (save! name code) + (All [anchor code] + (-> Ident code (Operation (..State anchor code) Any))) + (do //compiler.Monad<Operation> + [_ (execute! code)] + (function (_ state) + (#error.Success [(update@ #buffer + (maybe/map (sequence.add [name code])) + state) + []])))) + +(def: #export (save-buffer! target) + (All [anchor code] + (-> File (Operation (..State anchor code) Any))) + (do //compiler.Monad<Operation> + [buffer ..buffer] + (function (_ state) + (#error.Success [(update@ #artifacts (dict.put target buffer) state) + []])))) diff --git a/stdlib/source/lux/lang/translation/scheme/case.jvm.lux b/stdlib/source/lux/lang/translation/scheme/case.jvm.lux new file mode 100644 index 000000000..e5d12a005 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/case.jvm.lux @@ -0,0 +1,170 @@ +(.module: + [lux #- case let if] + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [number] + [text] + text/format + (coll [list "list/" Functor<List> Fold<List>] + (set ["set" unordered #+ Set])))) + (//// [reference #+ Register] + (host ["_" scheme #+ Expression Computation Var]) + [compiler #+ "operation/" Monad<Operation>] + [synthesis #+ Synthesis Path]) + [//runtime #+ Operation Translator] + [//reference]) + +(def: #export (let translate [valueS register bodyS]) + (-> Translator [Synthesis Register Synthesis] + (Operation Computation)) + (do compiler.Monad<Operation> + [valueO (translate valueS) + bodyO (translate bodyS)] + (wrap (_.let (list [(//reference.local' register) valueO]) + bodyO)))) + +(def: #export (record-get translate valueS pathP) + (-> Translator Synthesis (List [Nat Bool]) + (Operation Expression)) + (do compiler.Monad<Operation> + [valueO (translate valueS)] + (wrap (list/fold (function (_ [idx tail?] source) + (.let [method (.if tail? + //runtime.product//right + //runtime.product//left)] + (method source (_.int (:! Int idx))))) + valueO + pathP)))) + +(def: #export (if translate [testS thenS elseS]) + (-> Translator [Synthesis Synthesis Synthesis] + (Operation Computation)) + (do compiler.Monad<Operation> + [testO (translate testS) + thenO (translate thenS) + elseO (translate elseS)] + (wrap (_.if testO thenO elseO)))) + +(def: @savepoint (_.var "lux_pm_cursor_savepoint")) + +(def: @cursor (_.var "lux_pm_cursor")) + +(def: top _.length/1) + +(def: (push! value var) + (-> Expression Var Computation) + (_.set! var (_.cons/2 value var))) + +(def: (pop! var) + (-> Var Computation) + (_.set! var var)) + +(def: (push-cursor! value) + (-> Expression Computation) + (push! value @cursor)) + +(def: save-cursor! + Computation + (push! @cursor @savepoint)) + +(def: restore-cursor! + Computation + (_.set! @cursor (_.car/1 @savepoint))) + +(def: cursor-top + Computation + (_.car/1 @cursor)) + +(def: pop-cursor! + Computation + (pop! @cursor)) + +(def: pm-error (_.string "PM-ERROR")) + +(def: fail-pm! (_.raise/1 pm-error)) + +(def: @temp (_.var "lux_pm_temp")) + +(exception: #export (unrecognized-path) + "") + +(def: $alt_error (_.var "alt_error")) + +(def: (pm-catch handler) + (-> Expression Computation) + (_.lambda [(list $alt_error) #.None] + (_.if (|> $alt_error (_.eqv?/2 pm-error)) + handler + (_.raise/1 $alt_error)))) + +(def: (pattern-matching' translate pathP) + (-> Translator Path (Operation Expression)) + (.case pathP + (^ (synthesis.path/then bodyS)) + (translate bodyS) + + #synthesis.Pop + (operation/wrap pop-cursor!) + + (#synthesis.Bind register) + (operation/wrap (_.define (//reference.local' register) [(list) #.None] + cursor-top)) + + (^template [<tag> <format> <=>] + (^ (<tag> value)) + (operation/wrap (_.when (|> value <format> (<=> cursor-top) _.not/1) + fail-pm!))) + ([synthesis.path/bool _.bool _.eqv?/2] + [synthesis.path/i64 _.int _.=/2] + [synthesis.path/f64 _.float _.=/2] + [synthesis.path/text _.string _.eqv?/2]) + + (^template [<pm> <flag> <prep>] + (^ (<pm> idx)) + (operation/wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get cursor-top <flag>))]) + (_.if (_.null?/1 @temp) + fail-pm! + (push-cursor! @temp))))) + ([synthesis.side/left _.nil (<|)] + [synthesis.side/right (_.string "") inc]) + + (^template [<pm> <getter> <prep>] + (^ (<pm> idx)) + (operation/wrap (|> idx <prep> .int _.int (<getter> cursor-top) push-cursor!))) + ([synthesis.member/left //runtime.product//left (<|)] + [synthesis.member/right //runtime.product//right inc]) + + (^template [<tag> <computation>] + (^ (<tag> [leftP rightP])) + (do compiler.Monad<Operation> + [leftO (pattern-matching' translate leftP) + rightO (pattern-matching' translate rightP)] + (wrap <computation>))) + ([synthesis.path/seq (_.begin (list leftO + rightO))] + [synthesis.path/alt (_.with-exception-handler + (pm-catch (_.begin (list restore-cursor! + rightO))) + (_.lambda [(list) #.None] + (_.begin (list save-cursor! + leftO))))]) + + _ + (compiler.throw unrecognized-path []))) + +(def: (pattern-matching translate pathP) + (-> Translator Path (Operation Computation)) + (do compiler.Monad<Operation> + [pattern-matching! (pattern-matching' translate pathP)] + (wrap (_.with-exception-handler + (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching."))) + (_.lambda [(list) #.None] + pattern-matching!))))) + +(def: #export (case translate [valueS pathP]) + (-> Translator [Synthesis Path] (Operation Computation)) + (do compiler.Monad<Operation> + [valueO (translate valueS)] + (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))] + [@savepoint (_.list/* (list))]))) + (pattern-matching translate pathP)))) diff --git a/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux b/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux new file mode 100644 index 000000000..96bb17126 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux @@ -0,0 +1,53 @@ +(.module: + lux + (lux (control [monad #+ do])) + (//// [compiler] + [synthesis] + [extension]) + [//runtime #+ Translator] + [//primitive] + [//structure] + [//reference] + [//function] + [//case]) + +(def: #export (translate synthesis) + Translator + (case synthesis + (^template [<tag> <generator>] + (^ (<tag> value)) + (<generator> value)) + ([synthesis.bool //primitive.bool] + [synthesis.i64 //primitive.i64] + [synthesis.f64 //primitive.f64] + [synthesis.text //primitive.text]) + + (^ (synthesis.variant variantS)) + (//structure.variant translate variantS) + + (^ (synthesis.tuple members)) + (//structure.tuple translate members) + + (#synthesis.Reference reference) + (//reference.reference reference) + + (^ (synthesis.function/apply application)) + (//function.apply translate application) + + (^ (synthesis.function/abstraction abstraction)) + (//function.function translate abstraction) + + (^ (synthesis.branch/case case)) + (//case.case translate case) + + (^ (synthesis.branch/let let)) + (//case.let translate let) + + (^ (synthesis.branch/if if)) + (//case.if translate if) + + (#synthesis.Extension [extension argsS]) + (do compiler.Monad<Operation> + [extension (extension.find-translation extension)] + (extension argsS)) + )) diff --git a/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux b/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux new file mode 100644 index 000000000..6475caf68 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux @@ -0,0 +1,32 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [maybe] + text/format + (coll (dictionary ["dict" unordered #+ Dict])))) + (//// [reference #+ Register Variable] + (host ["_" scheme #+ Computation]) + [compiler "operation/" Monad<Operation>] + [synthesis #+ Synthesis]) + [//runtime #+ Operation Translator] + [/common] + ## [/host] + ) + +(exception: #export (unknown-extension {message Text}) + message) + +(def: extensions + /common.Bundle + (|> /common.extensions + ## (dict.merge /host.extensions) + )) + +(def: #export (extension translate name args) + (-> Translator Text (List Synthesis) + (Operation Computation)) + (<| (maybe.default (compiler.throw unknown-extension (%t name))) + (do maybe.Monad<Maybe> + [ext (dict.get name extensions)] + (wrap (ext translate args))))) diff --git a/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux new file mode 100644 index 000000000..140045aaf --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux @@ -0,0 +1,389 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data ["e" error] + [product] + [text] + text/format + [number #+ hex] + (coll [list "list/" Functor<List>] + (dictionary ["dict" unordered #+ Dict]))) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax:]) + [host]) + (///// (host ["_" scheme #+ Expression Computation]) + [compiler] + [synthesis #+ Synthesis]) + [///runtime #+ Operation Translator]) + +## [Types] +(type: #export Extension + (-> Translator (List Synthesis) (Operation Computation))) + +(type: #export Bundle + (Dict Text Extension)) + +(syntax: (Vector {size s.nat} elemT) + (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export Nullary (-> (Vector +0 Expression) Computation)) +(type: #export Unary (-> (Vector +1 Expression) Computation)) +(type: #export Binary (-> (Vector +2 Expression) Computation)) +(type: #export Trinary (-> (Vector +3 Expression) Computation)) +(type: #export Variadic (-> (List Expression) Computation)) + +## [Utils] +(def: #export (install name unnamed) + (-> Text (-> Text Extension) + (-> Bundle Bundle)) + (dict.put name (unnamed name))) + +(def: #export (prefix prefix bundle) + (-> Text Bundle Bundle) + (|> bundle + dict.entries + (list/map (function (_ [key val]) [(format prefix " " key) val])) + (dict.from-list text.Hash<Text>))) + +(exception: #export (wrong-arity {extension Text} {expected Nat} {actual Nat}) + (ex.report ["Extension" (%t extension)] + ["Expected" (|> expected .int %i)] + ["Actual" (|> actual .int %i)])) + +(syntax: (arity: {name s.local-symbol} {arity s.nat}) + (with-gensyms [g!_ g!extension g!name g!translate g!inputs] + (do @ + [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!extension)) + (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) + (-> Text ..Extension)) + (function ((~ g!_) (~ g!name)) + (function ((~ g!_) (~ g!translate) (~ g!inputs)) + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do compiler.Monad<Operation> + [(~+ (|> g!input+ + (list/map (function (_ g!input) + (list g!input (` ((~ g!translate) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) + + (~' _) + (compiler.throw wrong-arity [(~ g!name) +1 (list.size (~ g!inputs))]))))))))))) + +(arity: nullary +0) +(arity: unary +1) +(arity: binary +2) +(arity: trinary +3) + +(def: #export (variadic extension) + (-> Variadic (-> Text Extension)) + (function (_ extension-name) + (function (_ translate inputsS) + (do compiler.Monad<Operation> + [inputsI (monad.map @ translate inputsS)] + (wrap (extension inputsI)))))) + +## [Extensions] +## [[Lux]] +(def: extensions/lux + Bundle + (|> (dict.new text.Hash<Text>) + (install "is?" (binary (product.uncurry _.eq?/2))) + (install "try" (unary ///runtime.lux//try)))) + +## [[Bits]] +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [bit//and _.bit-and/2] + [bit//or _.bit-or/2] + [bit//xor _.bit-xor/2] + ) + +(def: (bit//left-shift [subjectO paramO]) + Binary + (_.arithmetic-shift/2 (_.remainder/2 (_.int 64) paramO) + subjectO)) + +(def: (bit//arithmetic-right-shift [subjectO paramO]) + Binary + (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int 64)) (_.*/2 (_.int -1))) + subjectO)) + +(def: (bit//logical-right-shift [subjectO paramO]) + Binary + (///runtime.bit//logical-right-shift (_.remainder/2 (_.int 64) paramO) subjectO)) + +(def: extensions/bit + Bundle + (<| (prefix "bit") + (|> (dict.new text.Hash<Text>) + (install "and" (binary bit//and)) + (install "or" (binary bit//or)) + (install "xor" (binary bit//xor)) + (install "left-shift" (binary bit//left-shift)) + (install "logical-right-shift" (binary bit//logical-right-shift)) + (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) + ))) + +## [[Arrays]] +(def: (array//new size0) + Unary + (_.make-vector/2 size0 _.nil)) + +(def: (array//get [arrayO idxO]) + Binary + (///runtime.array//get arrayO idxO)) + +(def: (array//put [arrayO idxO elemO]) + Trinary + (///runtime.array//put arrayO idxO elemO)) + +(def: (array//remove [arrayO idxO]) + Binary + (///runtime.array//put arrayO idxO _.nil)) + +(def: extensions/array + Bundle + (<| (prefix "array") + (|> (dict.new text.Hash<Text>) + (install "new" (unary array//new)) + (install "get" (binary array//get)) + (install "put" (trinary array//put)) + (install "remove" (binary array//remove)) + (install "size" (unary _.vector-length/1)) + ))) + +## [[Numbers]] +(host.import java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(do-template [<name> <const> <encode>] + [(def: (<name> _) + Nullary + (<encode> <const>))] + + [frac//smallest Double::MIN_VALUE _.float] + [frac//min (f/* -1.0 Double::MAX_VALUE) _.float] + [frac//max Double::MAX_VALUE _.float] + ) + +(do-template [<name> <frac>] + [(def: (<name> _) + Nullary + (_.float <frac>))] + + [frac//not-a-number number.not-a-number] + [frac//positive-infinity number.positive-infinity] + [frac//negative-infinity number.negative-infinity] + ) + +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (|> subjectO (<op> paramO)))] + + [int//+ _.+/2] + [int//- _.-/2] + [int//* _.*/2] + [int/// _.quotient/2] + [int//% _.remainder/2] + ) + +(do-template [<name> <op>] + [(def: (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [frac//+ _.+/2] + [frac//- _.-/2] + [frac//* _.*/2] + [frac/// _.//2] + [frac//% _.mod/2] + [frac//= _.=/2] + [frac//< _.</2] + + [text//= _.string=?/2] + [text//< _.string<?/2] + ) + +(do-template [<name> <cmp>] + [(def: (<name> [subjectO paramO]) + Binary + (<cmp> paramO subjectO))] + + [int//= _.=/2] + [int//< _.</2] + ) + +(def: int//char (|>> _.integer->char/1 _.string/1)) + +(def: extensions/int + Bundle + (<| (prefix "int") + (|> (dict.new text.Hash<Text>) + (install "+" (binary int//+)) + (install "-" (binary int//-)) + (install "*" (binary int//*)) + (install "/" (binary int///)) + (install "%" (binary int//%)) + (install "=" (binary int//=)) + (install "<" (binary int//<)) + (install "to-frac" (unary (|>> (_.//2 (_.float 1.0))))) + (install "char" (unary int//char))))) + +(def: extensions/frac + Bundle + (<| (prefix "frac") + (|> (dict.new text.Hash<Text>) + (install "+" (binary frac//+)) + (install "-" (binary frac//-)) + (install "*" (binary frac//*)) + (install "/" (binary frac///)) + (install "%" (binary frac//%)) + (install "=" (binary frac//=)) + (install "<" (binary frac//<)) + (install "smallest" (nullary frac//smallest)) + (install "min" (nullary frac//min)) + (install "max" (nullary frac//max)) + (install "not-a-number" (nullary frac//not-a-number)) + (install "positive-infinity" (nullary frac//positive-infinity)) + (install "negative-infinity" (nullary frac//negative-infinity)) + (install "to-int" (unary _.exact/1)) + (install "encode" (unary _.number->string/1)) + (install "decode" (unary ///runtime.frac//decode))))) + +## [[Text]] +(def: (text//char [subjectO paramO]) + Binary + (_.string/1 (_.string-ref/2 subjectO paramO))) + +(def: (text//clip [subjectO startO endO]) + Trinary + (_.substring/3 subjectO startO endO)) + +(def: extensions/text + Bundle + (<| (prefix "text") + (|> (dict.new text.Hash<Text>) + (install "=" (binary text//=)) + (install "<" (binary text//<)) + (install "concat" (binary (product.uncurry _.string-append/2))) + (install "size" (unary _.string-length/1)) + (install "char" (binary text//char)) + (install "clip" (trinary text//clip))))) + +## [[Math]] +(def: (math//pow [subject param]) + Binary + (_.expt/2 param subject)) + +(def: math-func + (-> Text Unary) + (|>> _.global _.apply/1)) + +(def: extensions/math + Bundle + (<| (prefix "math") + (|> (dict.new text.Hash<Text>) + (install "cos" (unary (math-func "cos"))) + (install "sin" (unary (math-func "sin"))) + (install "tan" (unary (math-func "tan"))) + (install "acos" (unary (math-func "acos"))) + (install "asin" (unary (math-func "asin"))) + (install "atan" (unary (math-func "atan"))) + (install "exp" (unary (math-func "exp"))) + (install "log" (unary (math-func "log"))) + (install "ceil" (unary (math-func "ceiling"))) + (install "floor" (unary (math-func "floor"))) + (install "pow" (binary math//pow)) + ))) + +## [[IO]] +(def: (io//log input) + Unary + (_.begin (list (_.display/1 input) + _.newline/0))) + +(def: (void code) + (-> Expression Computation) + (_.begin (list code (_.string synthesis.unit)))) + +(def: extensions/io + Bundle + (<| (prefix "io") + (|> (dict.new text.Hash<Text>) + (install "log" (unary (|>> io//log ..void))) + (install "error" (unary _.raise/1)) + (install "exit" (unary _.exit/1)) + (install "current-time" (nullary (function (_ _) (///runtime.io//current-time (_.string synthesis.unit)))))))) + +## [[Atoms]] +(def: atom//new + Unary + (|>> (list) _.vector/*)) + +(def: (atom//read atom) + Unary + (_.vector-ref/2 atom (_.int 0))) + +(def: (atom//compare-and-swap [atomO oldO newO]) + Trinary + (///runtime.atom//compare-and-swap atomO oldO newO)) + +(def: extensions/atom + Bundle + (<| (prefix "atom") + (|> (dict.new text.Hash<Text>) + (install "new" (unary atom//new)) + (install "read" (unary atom//read)) + (install "compare-and-swap" (trinary atom//compare-and-swap))))) + +## [[Box]] +(def: (box//write [valueO boxO]) + Binary + (///runtime.box//write valueO boxO)) + +(def: extensions/box + Bundle + (<| (prefix "box") + (|> (dict.new text.Hash<Text>) + (install "new" (unary atom//new)) + (install "read" (unary atom//read)) + (install "write" (binary box//write))))) + +## [[Processes]] +(def: (process//parallelism-level []) + Nullary + (_.int 1)) + +(def: extensions/process + Bundle + (<| (prefix "process") + (|> (dict.new text.Hash<Text>) + (install "parallelism-level" (nullary process//parallelism-level)) + (install "schedule" (binary (product.uncurry ///runtime.process//schedule))) + ))) + +## [Bundles] +(def: #export extensions + Bundle + (<| (prefix "lux") + (|> extensions/lux + (dict.merge extensions/bit) + (dict.merge extensions/int) + (dict.merge extensions/frac) + (dict.merge extensions/text) + (dict.merge extensions/array) + (dict.merge extensions/math) + (dict.merge extensions/io) + (dict.merge extensions/atom) + (dict.merge extensions/box) + (dict.merge extensions/process) + ))) diff --git a/stdlib/source/lux/lang/translation/scheme/function.jvm.lux b/stdlib/source/lux/lang/translation/scheme/function.jvm.lux new file mode 100644 index 000000000..11c64076c --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/function.jvm.lux @@ -0,0 +1,85 @@ +(.module: + [lux #- function] + (lux (control [monad #+ do] + pipe) + (data [product] + text/format + (coll [list "list/" Functor<List>]))) + (//// [reference #+ Register Variable] + [name] + [compiler "operation/" Monad<Operation>] + [analysis #+ Variant Tuple Environment Arity Abstraction Application Analysis] + [synthesis #+ Synthesis] + (host ["_" scheme #+ Expression Computation Var])) + [///] + [//runtime #+ Operation Translator] + [//primitive] + [//reference]) + +(def: #export (apply translate [functionS argsS+]) + (-> Translator (Application Synthesis) (Operation Computation)) + (do compiler.Monad<Operation> + [functionO (translate functionS) + argsO+ (monad.map @ translate argsS+)] + (wrap (_.apply/* functionO argsO+)))) + +(def: (with-closure function-name inits function-definition) + (-> Text (List Expression) Computation (Operation Computation)) + (let [@closure (_.var (format function-name "___CLOSURE"))] + (operation/wrap + (case inits + #.Nil + function-definition + + _ + (_.letrec (list [@closure + (_.lambda [(|> (list.enumerate inits) + (list/map (|>> product.left //reference.foreign'))) + #.None] + function-definition)]) + (_.apply/* @closure inits)))))) + +(def: @curried (_.var "curried")) +(def: @missing (_.var "missing")) + +(def: input + (|>> inc //reference.local')) + +(def: #export (function translate [environment arity bodyS]) + (-> Translator (Abstraction Synthesis) (Operation Computation)) + (do compiler.Monad<Operation> + [[function-name bodyO] (///.with-context + (do @ + [function-name ///.context] + (///.with-anchor (_.var function-name) + (translate bodyS)))) + closureO+ (monad.map @ //reference.variable environment) + #let [arityO (|> arity .int _.int) + @num-args (_.var "num_args") + @function (_.var function-name) + apply-poly (.function (_ args func) + (_.apply/2 (_.global "apply") func args))]] + (with-closure function-name closureO+ + (_.letrec (list [@function (_.lambda [(list) (#.Some @curried)] + (_.let (list [@num-args (_.length/1 @curried)]) + (<| (_.if (|> @num-args (_.=/2 arityO)) + (<| (_.let (list [(//reference.local' +0) @function])) + (_.let-values (list [[(|> (list.n/range +0 (dec arity)) + (list/map ..input)) + #.None] + (_.apply/2 (_.global "apply") (_.global "values") @curried)])) + bodyO)) + (_.if (|> @num-args (_.>/2 arityO)) + (let [arity-args (//runtime.slice (_.int 0) arityO @curried) + output-func-args (//runtime.slice arityO + (|> @num-args (_.-/2 arityO)) + @curried)] + (|> @function + (apply-poly arity-args) + (apply-poly output-func-args)))) + ## (|> @num-args (_.</2 arityO)) + (_.lambda [(list) (#.Some @missing)] + (|> @function + (apply-poly (_.append/2 @curried @missing)))))))]) + @function)) + )) diff --git a/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux b/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux new file mode 100644 index 000000000..6f305336e --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux @@ -0,0 +1,39 @@ +(.module: + [lux #- loop] + (lux (control [monad #+ do]) + (data [product] + [text] + text/format + (coll [list "list/" Functor<List>])) + [macro]) + [////] + (//// [name] + (host ["_" scheme #+ Computation Var]) + [compiler "operation/" Monad<Operation>] + [synthesis #+ Synthesis]) + [///] + [//runtime #+ Operation Translator] + [//reference]) + +(def: @loop (_.var "loop")) + +(def: #export (loop translate offset initsS+ bodyS) + (-> Translator Nat (List Synthesis) Synthesis + (Operation Computation)) + (do compiler.Monad<Operation> + [initsO+ (monad.map @ translate initsS+) + bodyO (///.with-anchor @loop + (translate bodyS))] + (wrap (_.letrec (list [@loop (_.lambda [(|> initsS+ + list.enumerate + (list/map (|>> product.left (n/+ offset) //reference.local'))) + #.None] + bodyO)]) + (_.apply/* @loop initsO+))))) + +(def: #export (recur translate argsS+) + (-> Translator (List Synthesis) (Operation Computation)) + (do compiler.Monad<Operation> + [@loop ///.anchor + argsO+ (monad.map @ translate argsS+)] + (wrap (_.apply/* @loop argsO+)))) diff --git a/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux new file mode 100644 index 000000000..ac775fa82 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux @@ -0,0 +1,22 @@ +(.module: + [lux #- i64] + [/// #+ State] + (//// [compiler #+ "operation/" Monad<Operation>] + (host ["_" scheme #+ Expression])) + [//runtime #+ Operation]) + +(def: #export bool + (-> Bool (Operation Expression)) + (|>> _.bool operation/wrap)) + +(def: #export i64 + (-> (I64 Any) (Operation Expression)) + (|>> .int _.int operation/wrap)) + +(def: #export f64 + (-> Frac (Operation Expression)) + (|>> _.float operation/wrap)) + +(def: #export text + (-> Text (Operation Expression)) + (|>> _.string operation/wrap)) diff --git a/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux b/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux new file mode 100644 index 000000000..453d4edb6 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux @@ -0,0 +1,54 @@ +(.module: + lux + (lux (control pipe) + (data text/format)) + (//// [reference #+ Register Variable Reference] + [name] + [compiler "operation/" Monad<Operation>] + [analysis #+ Variant Tuple] + [synthesis #+ Synthesis] + (host ["_" scheme #+ Expression Var])) + [//runtime #+ Operation Translator] + [//primitive]) + +(do-template [<name> <prefix>] + [(def: #export <name> + (-> Register Var) + (|>> .int %i (format <prefix>) _.var))] + + [local' "l"] + [foreign' "f"] + ) + +(def: #export variable' + (-> Variable Var) + (|>> (case> (#reference.Local register) + (local' register) + + (#reference.Foreign register) + (foreign' register)))) + +(def: #export variable + (-> Variable (Operation Var)) + (|>> ..variable' + operation/wrap)) + +(def: #export constant' + (-> Ident Var) + (|>> name.definition _.var)) + +(def: #export constant + (-> Ident (Operation Var)) + (|>> constant' operation/wrap)) + +(def: #export reference' + (-> Reference Expression) + (|>> (case> (#reference.Constant value) + (..constant' value) + + (#reference.Variable value) + (..variable' value)))) + +(def: #export reference + (-> Reference (Operation Expression)) + (|>> reference' operation/wrap)) diff --git a/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux new file mode 100644 index 000000000..b30aff3a2 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux @@ -0,0 +1,362 @@ +(.module: + lux + (lux (control ["p" parser "p/" Monad<Parser>] + [monad #+ do]) + (data [number #+ hex] + text/format + (coll [list "list/" Monad<List>])) + [function] + (macro [code] + ["s" syntax #+ syntax:])) + [/// #+ State] + (//// [name] + [compiler] + [analysis #+ Variant] + [synthesis] + (host ["_" scheme #+ Expression Computation Var]))) + +(type: #export Operation + (compiler.Operation (State Var Expression))) + +(type: #export Translator + (///.Translator Var Expression)) + +(def: prefix Text "LuxRuntime") + +(def: unit (_.string synthesis.unit)) + +(def: #export variant-tag "lux-variant") + +(def: (flag value) + (-> Bool Computation) + (if value + (_.string "") + _.nil)) + +(def: (variant' tag last? value) + (-> Expression Expression Expression Computation) + (<| (_.cons/2 (_.symbol ..variant-tag)) + (_.cons/2 tag) + (_.cons/2 last?) + value)) + +(def: #export (variant [lefts right? value]) + (-> (Variant Expression) Computation) + (variant' (_.int (.int lefts)) (flag right?) value)) + +(def: #export none + Computation + (variant [+0 false ..unit])) + +(def: #export some + (-> Expression Computation) + (|>> [+0 true] ..variant)) + +(def: #export left + (-> Expression Computation) + (|>> [+0 false] ..variant)) + +(def: #export right + (-> Expression Computation) + (|>> [+0 true] ..variant)) + +(def: declaration + (s.Syntax [Text (List Text)]) + (p.either (p.seq s.local-symbol (p/wrap (list))) + (s.form (p.seq s.local-symbol (p.some s.local-symbol))))) + +(syntax: (runtime: {[name args] declaration} + definition) + (let [implementation (code.local-symbol (format "@@" name)) + runtime (format prefix "__" (name.normalize name)) + @runtime (` (_.var (~ (code.text runtime)))) + argsC+ (list/map code.local-symbol args) + argsLC+ (list/map (|>> name.normalize (format "LRV__") code.text (~) (_.var) (`)) + args) + declaration (` ((~ (code.local-symbol name)) + (~+ argsC+))) + type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) + _.Computation))] + (wrap (list (` (def: (~' #export) (~ declaration) + (~ type) + (~ (case argsC+ + #.Nil + @runtime + + _ + (` (_.apply/* (~ @runtime) (list (~+ argsC+)))))))) + (` (def: (~ implementation) + _.Computation + (~ (case argsC+ + #.Nil + (` (_.define (~ @runtime) [(list) #.None] (~ definition))) + + _ + (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) + (list/map (function (_ [left right]) + (list left right))) + list/join))] + (_.define (~ @runtime) [(list (~+ argsLC+)) #.None] + (~ definition)))))))))))) + +(runtime: (slice offset length list) + (<| (_.if (_.null?/1 list) + list) + (_.if (|> offset (_.>/2 (_.int 0))) + (slice (|> offset (_.-/2 (_.int 1))) + length + (_.cdr/1 list))) + (_.if (|> length (_.>/2 (_.int 0))) + (_.cons/2 (_.car/1 list) + (slice offset + (|> length (_.-/2 (_.int 1))) + (_.cdr/1 list)))) + _.nil)) + +(syntax: #export (with-vars {vars (s.tuple (p.many s.local-symbol))} + body) + (wrap (list (` (let [(~+ (|> vars + (list/map (function (_ var) + (list (code.local-symbol var) + (` (_.var (~ (code.text (format "LRV__" (name.normalize var))))))))) + list/join))] + (~ body)))))) + +(runtime: (lux//try op) + (with-vars [error] + (_.with-exception-handler + (_.lambda [(list error) #.None] + (..left error)) + (_.lambda [(list) #.None] + (..right (_.apply/* op (list ..unit))))))) + +(runtime: (lux//program-args program-args) + (with-vars [@loop @input @output] + (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] + (_.if (_.eqv?/2 _.nil @input) + @output + (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) + (_.apply/2 @loop (_.reverse/1 program-args) ..none)))) + +(def: runtime//lux + Computation + (_.begin (list @@lux//try + @@lux//program-args))) + +(def: minimum-index-length + (-> Expression Computation) + (|>> (_.+/2 (_.int 1)))) + +(def: product-element + (-> Expression Expression Computation) + (function.flip _.vector-ref/2)) + +(def: (product-tail product) + (-> Expression Computation) + (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int 1))))) + +(def: (updated-index min-length product) + (-> Expression Expression Computation) + (|> min-length (_.-/2 (_.length/1 product)))) + +(runtime: (product//left product index) + (let [@index_min_length (_.var "index_min_length")] + (_.begin + (list (_.define @index_min_length [(list) #.None] + (minimum-index-length index)) + (_.if (|> product _.length/1 (_.>/2 @index_min_length)) + ## No need for recursion + (product-element index product) + ## Needs recursion + (product//left (product-tail product) + (updated-index @index_min_length product))))))) + +(runtime: (product//right product index) + (let [@index_min_length (_.var "index_min_length") + @product_length (_.var "product_length") + @slice (_.var "slice") + last-element? (|> @product_length (_.=/2 @index_min_length)) + needs-recursion? (|> @product_length (_.</2 @index_min_length))] + (_.begin + (list + (_.define @index_min_length [(list) #.None] (minimum-index-length index)) + (_.define @product_length [(list) #.None] (_.length/1 product)) + (<| (_.if last-element? + (product-element index product)) + (_.if needs-recursion? + (product//right (product-tail product) + (updated-index @index_min_length product))) + ## Must slice + (_.begin + (list (_.define @slice [(list) #.None] + (_.make-vector/1 (|> @product_length (_.-/2 index)))) + (_.vector-copy!/5 @slice (_.int 0) product index @product_length) + @slice))))))) + +(runtime: (sum//get sum last? wanted-tag) + (with-vars [variant-tag sum-tag sum-flag sum-value] + (let [no-match _.nil + is-last? (|> sum-flag (_.eqv?/2 (_.string ""))) + test-recursion (_.if is-last? + ## Must recurse. + (sum//get sum-value + (|> wanted-tag (_.-/2 sum-tag)) + last?) + no-match)] + (<| (_.let-values (list [[(list variant-tag sum-tag sum-flag sum-value) #.None] + (_.apply/* (_.global "apply") (list (_.global "values") sum))])) + (_.if (|> wanted-tag (_.=/2 sum-tag)) + (_.if (|> sum-flag (_.eqv?/2 last?)) + sum-value + test-recursion)) + (_.if (|> wanted-tag (_.>/2 sum-tag)) + test-recursion) + (_.if (_.and (list (|> last? (_.eqv?/2 (_.string ""))) + (|> wanted-tag (_.</2 sum-tag)))) + (variant' (|> sum-tag (_.-/2 wanted-tag)) sum-flag sum-value)) + no-match)))) + +(def: runtime//adt + Computation + (_.begin (list @@product//left + @@product//right + @@sum//get))) + +(runtime: (bit//logical-right-shift shift input) + (_.if (_.=/2 (_.int 0) shift) + input + (|> input + (_.arithmetic-shift/2 (_.*/2 (_.int -1) shift)) + (_.bit-and/2 (_.int (hex "7FFFFFFFFFFFFFFF")))))) + +(def: runtime//bit + Computation + (_.begin (list @@bit//logical-right-shift))) + +(runtime: (frac//decode input) + (with-vars [@output] + (_.let (list [@output ((_.apply/1 (_.global "string->number")) input)]) + (_.if (_.and (list (_.not/1 (_.=/2 @output @output)) + (_.not/1 (_.eqv?/2 (_.string "+nan.0") input)))) + ..none + (..some @output))))) + +(def: runtime//frac + Computation + (_.begin + (list @@frac//decode))) + +(def: (check-index-out-of-bounds array idx body) + (-> Expression Expression Expression Computation) + (_.if (|> idx (_.<=/2 (_.length/1 array))) + body + (_.raise/1 (_.string "Array index out of bounds!")))) + +(runtime: (array//get array idx) + (with-vars [@temp] + (<| (check-index-out-of-bounds array idx) + (_.let (list [@temp (_.vector-ref/2 array idx)]) + (_.if (|> @temp (_.eqv?/2 _.nil)) + ..none + (..some @temp)))))) + +(runtime: (array//put array idx value) + (<| (check-index-out-of-bounds array idx) + (_.begin + (list (_.vector-set!/3 array idx value) + array)))) + +(def: runtime//array + Computation + (_.begin + (list @@array//get + @@array//put))) + +(runtime: (atom//compare-and-swap atom old new) + (with-vars [@temp] + (_.let (list [@temp (_.vector-ref/2 atom (_.int 0))]) + (_.if (_.eq?/2 old @temp) + (_.begin + (list (_.vector-set!/3 atom (_.int 0) new) + (_.bool true))) + (_.bool false))))) + +(def: runtime//atom + Computation + @@atom//compare-and-swap) + +(runtime: (box//write value box) + (_.begin + (list + (_.vector-set!/3 box (_.int 0) value) + ..unit))) + +(def: runtime//box + Computation + (_.begin (list @@box//write))) + +(runtime: (io//current-time _) + (|> (_.apply/* (_.global "current-second") (list)) + (_.*/2 (_.int 1_000)) + _.exact/1)) + +(def: runtime//io + (_.begin (list @@io//current-time))) + +(def: process//incoming + Var + (_.var (name.normalize "process//incoming"))) + +(runtime: (process//loop _) + (_.when (_.not/1 (_.null?/1 process//incoming)) + (with-vars [queue process] + (_.let (list [queue process//incoming]) + (_.begin (list (_.set! process//incoming (_.list/* (list))) + (_.map/2 (_.lambda [(list process) #.None] + (_.apply/1 process ..unit)) + queue) + (process//loop ..unit))))))) + +(runtime: (process//schedule milli-seconds procedure) + (let [process//future (function (_ process) + (_.set! process//incoming (_.cons/2 process process//incoming)))] + (_.begin + (list + (_.if (_.=/2 (_.int 0) milli-seconds) + (process//future procedure) + (with-vars [@start @process @now @ignored] + (_.let (list [@start (io//current-time ..unit)]) + (_.letrec (list [@process (_.lambda [(list) (#.Some @ignored)] + (_.let (list [@now (io//current-time ..unit)]) + (_.if (|> @now (_.-/2 @start) (_.>=/2 milli-seconds)) + (_.apply/1 procedure ..unit) + (process//future @process))))]) + (process//future @process))))) + ..unit)))) + +(def: runtime//process + Computation + (_.begin (list (_.define process//incoming [(list) #.None] (_.list/* (list))) + @@process//loop + @@process//schedule))) + +(def: runtime + Computation + (_.begin (list @@slice + runtime//lux + runtime//bit + runtime//adt + runtime//frac + runtime//array + runtime//atom + runtime//box + runtime//io + runtime//process + ))) + +(def: #export translate + (Operation Any) + (///.with-buffer + (do compiler.Monad<Operation> + [_ (///.save! ["" ..prefix] ..runtime)] + (///.save-buffer! "")))) diff --git a/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux b/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux new file mode 100644 index 000000000..a11434594 --- /dev/null +++ b/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux @@ -0,0 +1,29 @@ +(.module: + lux + (lux (control [monad #+ do])) + (//// [compiler] + [analysis #+ Variant Tuple] + [synthesis #+ Synthesis] + (host ["_" scheme #+ Expression])) + [//runtime #+ Operation Translator] + [//primitive]) + +(def: #export (tuple translate elemsS+) + (-> Translator (Tuple Synthesis) (Operation Expression)) + (case elemsS+ + #.Nil + (//primitive.text synthesis.unit) + + (#.Cons singletonS #.Nil) + (translate singletonS) + + _ + (do compiler.Monad<Operation> + [elemsT+ (monad.map @ translate elemsS+)] + (wrap (_.vector/* elemsT+))))) + +(def: #export (variant translate [lefts right? valueS]) + (-> Translator (Variant Synthesis) (Operation Expression)) + (do compiler.Monad<Operation> + [valueT (translate valueS)] + (wrap (//runtime.variant [lefts right? valueT])))) diff --git a/stdlib/test/test/lux/lang/synthesis/function.lux b/stdlib/test/test/lux/lang/synthesis/function.lux index 38a8dd8a2..c7b16de27 100644 --- a/stdlib/test/test/lux/lang/synthesis/function.lux +++ b/stdlib/test/test/lux/lang/synthesis/function.lux @@ -13,8 +13,8 @@ (set ["set" unordered]))) (lang ["///." reference #+ Variable "variable/" Equality<Variable>] ["///." compiler] - [".L" analysis #+ Analysis] - ["//" synthesis #+ Arity Synthesis] + [".L" analysis #+ Arity Analysis] + ["//" synthesis #+ Synthesis] (synthesis [".S" expression]) [".L" extension]) ["r" math/random] |