diff options
Diffstat (limited to '')
12 files changed, 647 insertions, 575 deletions
diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux index 8ffd78b2e..d3176cd4b 100644 --- a/stdlib/source/lux/macro.lux +++ b/stdlib/source/lux/macro.lux @@ -373,13 +373,12 @@ {#.doc (doc "Generates a unique name as an Code node (ready to be used in code templates)." "A prefix can be given (or just be empty text) to better identify the code for debugging purposes.")} (-> Text (Meta Code)) - (function (_ compiler) - (#try.Success [(update@ #.seed inc compiler) - (|> compiler - (get@ #.seed) - (:: n.decimal encode) - ($_ text@compose "__gensym__" prefix) - [""] code.identifier)]))) + (do ..monad + [id ..count] + (wrap (|> id + (:: n.decimal encode) + ($_ text@compose "__gensym__" prefix) + [""] code.identifier)))) (def: (get-local-identifier ast) (-> Code (Meta Text)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux index 473390cd9..4ec689361 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux @@ -4,8 +4,7 @@ ["." monad (#+ do)]] [control ["<>" parser - ["<c>" code (#+ Parser)]] - pipe] + ["<c>" code (#+ Parser)]]] [data [collection ["." array (#+ Array)] @@ -14,185 +13,187 @@ ["." check]] [target ["_" js]]] - ["." // #_ + [// ["/" lux (#+ custom)] - ["/#" // - ["#." bundle] - ["/#" // ("#@." monad) + [// + ["." bundle] + [// [analysis - [".A" type]] - ["/#" // #_ - ["#." analysis (#+ Analysis Operation Phase Handler Bundle)]]]]]) + ["." type]] + [// + ["." analysis (#+ Analysis Operation Phase Handler Bundle)] + [/// + ["." phase]]]]]]) (def: array::new Handler (custom [<c>.any - (function (_ extension phase lengthC) - (do ////.monad - [lengthA (typeA.with-type Nat - (phase lengthC)) - [var-id varT] (typeA.with-env check.var) - _ (typeA.infer (type (Array varT)))] - (wrap (#/////analysis.Extension extension (list lengthA)))))])) + (function (_ extension phase archive lengthC) + (do phase.monad + [lengthA (type.with-type Nat + (phase archive lengthC)) + [var-id varT] (type.with-env check.var) + _ (type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list lengthA)))))])) (def: array::length Handler (custom [<c>.any - (function (_ extension phase arrayC) - (do ////.monad - [[var-id varT] (typeA.with-env check.var) - arrayA (typeA.with-type (type (Array varT)) - (phase arrayC)) - _ (typeA.infer Nat)] - (wrap (#/////analysis.Extension extension (list arrayA)))))])) + (function (_ extension phase archive arrayC) + (do phase.monad + [[var-id varT] (type.with-env check.var) + arrayA (type.with-type (type (Array varT)) + (phase archive arrayC)) + _ (type.infer Nat)] + (wrap (#analysis.Extension extension (list arrayA)))))])) (def: array::read Handler (custom [(<>.and <c>.any <c>.any) - (function (_ extension phase [indexC arrayC]) - (do ////.monad - [indexA (typeA.with-type Nat - (phase indexC)) - [var-id varT] (typeA.with-env check.var) - arrayA (typeA.with-type (type (Array varT)) - (phase arrayC)) - _ (typeA.infer varT)] - (wrap (#/////analysis.Extension extension (list indexA arrayA)))))])) + (function (_ extension phase archive [indexC arrayC]) + (do phase.monad + [indexA (type.with-type Nat + (phase archive indexC)) + [var-id varT] (type.with-env check.var) + arrayA (type.with-type (type (Array varT)) + (phase archive arrayC)) + _ (type.infer varT)] + (wrap (#analysis.Extension extension (list indexA arrayA)))))])) (def: array::write Handler (custom [($_ <>.and <c>.any <c>.any <c>.any) - (function (_ extension phase [indexC valueC arrayC]) - (do ////.monad - [indexA (typeA.with-type Nat - (phase indexC)) - [var-id varT] (typeA.with-env check.var) - valueA (typeA.with-type varT - (phase valueC)) - arrayA (typeA.with-type (type (Array varT)) - (phase arrayC)) - _ (typeA.infer (type (Array varT)))] - (wrap (#/////analysis.Extension extension (list indexA valueA arrayA)))))])) + (function (_ extension phase archive [indexC valueC arrayC]) + (do phase.monad + [indexA (type.with-type Nat + (phase archive indexC)) + [var-id varT] (type.with-env check.var) + valueA (type.with-type varT + (phase archive valueC)) + arrayA (type.with-type (type (Array varT)) + (phase archive arrayC)) + _ (type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) (def: array::delete Handler (custom [($_ <>.and <c>.any <c>.any) - (function (_ extension phase [indexC arrayC]) - (do ////.monad - [indexA (typeA.with-type Nat - (phase indexC)) - [var-id varT] (typeA.with-env check.var) - arrayA (typeA.with-type (type (Array varT)) - (phase arrayC)) - _ (typeA.infer (type (Array varT)))] - (wrap (#/////analysis.Extension extension (list indexA arrayA)))))])) + (function (_ extension phase archive [indexC arrayC]) + (do phase.monad + [indexA (type.with-type Nat + (phase archive indexC)) + [var-id varT] (type.with-env check.var) + arrayA (type.with-type (type (Array varT)) + (phase archive arrayC)) + _ (type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list indexA arrayA)))))])) (def: bundle::array Bundle - (<| (///bundle.prefix "array") - (|> ///bundle.empty - (///bundle.install "new" array::new) - (///bundle.install "length" array::length) - (///bundle.install "read" array::read) - (///bundle.install "write" array::write) - (///bundle.install "delete" array::delete) + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "new" array::new) + (bundle.install "length" array::length) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + (bundle.install "delete" array::delete) ))) (def: object::new Handler (custom [($_ <>.and <c>.any (<c>.tuple (<>.some <c>.any))) - (function (_ extension phase [constructorC inputsC]) - (do {@ ////.monad} - [constructorA (typeA.with-type Any - (phase constructorC)) - inputsA (monad.map @ (|>> phase (typeA.with-type Any)) inputsC) - _ (typeA.infer .Any)] - (wrap (#/////analysis.Extension extension (list& constructorA inputsA)))))])) + (function (_ extension phase archive [constructorC inputsC]) + (do {@ phase.monad} + [constructorA (type.with-type Any + (phase archive constructorC)) + inputsA (monad.map @ (|>> (phase archive) (type.with-type Any)) inputsC) + _ (type.infer .Any)] + (wrap (#analysis.Extension extension (list& constructorA inputsA)))))])) (def: object::get Handler (custom [($_ <>.and <c>.text <c>.any) - (function (_ extension phase [fieldC objectC]) - (do ////.monad - [objectA (typeA.with-type Any - (phase objectC)) - _ (typeA.infer .Any)] - (wrap (#/////analysis.Extension extension (list (/////analysis.text fieldC) - objectA)))))])) + (function (_ extension phase archive [fieldC objectC]) + (do phase.monad + [objectA (type.with-type Any + (phase archive objectC)) + _ (type.infer .Any)] + (wrap (#analysis.Extension extension (list (analysis.text fieldC) + objectA)))))])) (def: object::do Handler (custom [($_ <>.and <c>.text <c>.any (<c>.tuple (<>.some <c>.any))) - (function (_ extension phase [methodC objectC inputsC]) - (do {@ ////.monad} - [objectA (typeA.with-type Any - (phase objectC)) - inputsA (monad.map @ (|>> phase (typeA.with-type Any)) inputsC) - _ (typeA.infer .Any)] - (wrap (#/////analysis.Extension extension (list& (/////analysis.text methodC) - objectA - inputsA)))))])) + (function (_ extension phase archive [methodC objectC inputsC]) + (do {@ phase.monad} + [objectA (type.with-type Any + (phase archive objectC)) + inputsA (monad.map @ (|>> (phase archive) (type.with-type Any)) inputsC) + _ (type.infer .Any)] + (wrap (#analysis.Extension extension (list& (analysis.text methodC) + objectA + inputsA)))))])) (def: bundle::object Bundle - (<| (///bundle.prefix "object") - (|> ///bundle.empty - (///bundle.install "new" object::new) - (///bundle.install "get" object::get) - (///bundle.install "do" object::do) - (///bundle.install "null" (/.nullary Any)) - (///bundle.install "null?" (/.unary Any Bit)) - (///bundle.install "undefined" (/.nullary Any)) - (///bundle.install "undefined?" (/.unary Any Bit)) + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "new" object::new) + (bundle.install "get" object::get) + (bundle.install "do" object::do) + (bundle.install "null" (/.nullary Any)) + (bundle.install "null?" (/.unary Any Bit)) + (bundle.install "undefined" (/.nullary Any)) + (bundle.install "undefined?" (/.unary Any Bit)) ))) (def: js::constant Handler (custom [<c>.text - (function (_ extension phase name) - (do ////.monad - [_ (typeA.infer Any)] - (wrap (#/////analysis.Extension extension (list (/////analysis.text name))))))])) + (function (_ extension phase archive name) + (do phase.monad + [_ (type.infer Any)] + (wrap (#analysis.Extension extension (list (analysis.text name))))))])) (def: js::apply Handler (custom [($_ <>.and <c>.any (<>.some <c>.any)) - (function (_ extension phase [abstractionC inputsC]) - (do {@ ////.monad} - [abstractionA (typeA.with-type Any - (phase abstractionC)) - inputsA (monad.map @ (|>> phase (typeA.with-type Any)) inputsC) - _ (typeA.infer Any)] - (wrap (#/////analysis.Extension extension (list& abstractionA inputsA)))))])) + (function (_ extension phase archive [abstractionC inputsC]) + (do {@ phase.monad} + [abstractionA (type.with-type Any + (phase archive abstractionC)) + inputsA (monad.map @ (|>> (phase archive) (type.with-type Any)) inputsC) + _ (type.infer Any)] + (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) (def: js::type-of Handler (custom [<c>.any - (function (_ extension phase objectC) - (do ////.monad - [objectA (typeA.with-type Any - (phase objectC)) - _ (typeA.infer .Text)] - (wrap (#/////analysis.Extension extension (list objectA)))))])) + (function (_ extension phase archive objectC) + (do phase.monad + [objectA (type.with-type Any + (phase archive objectC)) + _ (type.infer .Text)] + (wrap (#analysis.Extension extension (list objectA)))))])) (def: #export bundle Bundle - (<| (///bundle.prefix "js") - (|> ///bundle.empty - (///bundle.install "constant" js::constant) - (///bundle.install "apply" js::apply) - (///bundle.install "type-of" js::type-of) + (<| (bundle.prefix "js") + (|> bundle.empty + (bundle.install "constant" js::constant) + (bundle.install "apply" js::apply) + (bundle.install "type-of" js::type-of) (dictionary.merge bundle::array) (dictionary.merge bundle::object) ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux index e7cebfdbf..114242fd7 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux @@ -10,13 +10,15 @@ ["#." case] ["#." loop] ["#." function] - ["//#" /// #_ - ["." extension] + ["/#" // #_ + ["#." reference] ["/#" // #_ - [analysis (#+)] - ["." synthesis] - ["//#" /// #_ - ["#." phase ("#@." monad)]]]]]) + ["." extension] + ["/#" // #_ + [analysis (#+)] + ["." synthesis] + ["//#" /// #_ + ["#." phase ("#@." monad)]]]]]]) (def: #export (generate archive synthesis) Phase @@ -36,7 +38,7 @@ (/structure.tuple generate archive members) (#synthesis.Reference value) - (/reference@reference archive value) + (//reference.reference /reference.system archive value) (^ (synthesis.branch/case case)) (/case.case generate archive case) @@ -47,6 +49,9 @@ (^ (synthesis.branch/if if)) (/case.if generate archive if) + (^ (synthesis.branch/get get)) + (/case.get generate archive get) + (^ (synthesis.loop/scope scope)) (/loop.scope generate archive scope) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux index 2be5ac6cd..1dc91abe2 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux @@ -1,10 +1,11 @@ (.module: [lux (#- case let if) [abstract - [monad (#+ do)]] + ["." monad (#+ do)]] [control ["ex" exception (#+ exception:)]] [data + ["." maybe] ["." text] [number ["n" nat]] @@ -22,15 +23,17 @@ ["#." synthesis #_ ["#/." case]] ["/#" // #_ - ["#." synthesis (#+ Synthesis Path)] + ["#." synthesis (#+ Member Synthesis Path)] ["//#" /// #_ - [reference (#+ Register)] + [reference + [variable (#+ Register)]] ["#." phase ("#@." monad)] [meta [archive (#+ Archive)]]]]]]]) (def: #export register - (///reference.local _.var)) + (-> Register Var) + (|>> (///reference.local //reference.system) :assume)) (def: #export (let generate archive [valueS register bodyS]) (Generator [Synthesis Register Synthesis]) @@ -42,8 +45,16 @@ (_.return bodyO)) (list valueO))))) -(def: #export (record-get generate archive [valueS pathP]) - (Generator [Synthesis (List (Either Nat Nat))]) +(def: #export (if generate archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (generate archive testS) + thenO (generate archive thenS) + elseO (generate archive elseS)] + (wrap (_.? testO thenO elseO)))) + +(def: #export (get generate archive [pathP valueS]) + (Generator [(List Member) Synthesis]) (do ///////phase.monad [valueO (generate archive valueS)] (wrap (list@fold (function (_ side source) @@ -55,15 +66,7 @@ [#.Right //runtime.tuple//right]))] (method source))) valueO - pathP)))) - -(def: #export (if generate archive [testS thenS elseS]) - (Generator [Synthesis Synthesis Synthesis]) - (do ///////phase.monad - [testO (generate archive testS) - thenO (generate archive thenS) - elseO (generate archive elseS)] - (wrap (_.? testO thenO elseO)))) + (list.reverse pathP))))) (def: @savepoint (_.var "lux_pm_cursor_savepoint")) (def: @cursor (_.var "lux_pm_cursor")) @@ -115,9 +118,9 @@ (_.set @temp (|> idx <prep> .int _.i32 (//runtime.sum//get ..peek-cursor <flag>))) (.if simple? (_.when (_.= _.null @temp) - fail-pm!) + ..fail-pm!) (_.if (_.= _.null @temp) - fail-pm! + ..fail-pm! (push-cursor! @temp)))))] [left-choice _.null (<|)] @@ -135,92 +138,125 @@ ..restore-cursor! post!))) -(def: (pattern-matching' generate archive pathP) - (-> Phase Archive Path (Operation Statement)) - (.case pathP - (^ (/////synthesis.path/then bodyS)) - (do ///////phase.monad - [body! (generate archive bodyS)] - (wrap (_.return body!))) - - #/////synthesis.Pop - (///////phase@wrap pop-cursor!) - - (#/////synthesis.Bind register) - (///////phase@wrap (_.define (..register register) ..peek-cursor)) - - (^template [<tag> <format> <=>] - (^ (<tag> value)) - (///////phase@wrap (_.when (|> value <format> (<=> ..peek-cursor) _.not) - fail-pm!))) - ([/////synthesis.path/bit //primitive.bit _.=] - [/////synthesis.path/i64 (<| //primitive.i64 .int) //runtime.i64//=] - [/////synthesis.path/f64 //primitive.f64 _.=] - [/////synthesis.path/text //primitive.text _.=]) - - (^template [<complex> <simple> <choice>] - (^ (<complex> idx)) - (///////phase@wrap (<choice> false idx)) - - (^ (<simple> idx nextP)) - (|> nextP - (pattern-matching' generate archive) - (:: ///////phase.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)) - (///////phase@wrap (push-cursor! (_.at (_.i32 +0) ..peek-cursor))) - - ## Extra optimization - (^ (/////synthesis.path/seq - (/////synthesis.member/left 0) - (/////synthesis.!bind-top register thenP))) - (do ///////phase.monad - [then! (pattern-matching' generate archive thenP)] - (///////phase@wrap ($_ _.then - (_.define (..register register) (_.at (_.i32 +0) ..peek-cursor)) - then!))) - - (^template [<pm> <getter>] - (^ (<pm> lefts)) - (///////phase@wrap (push-cursor! (<getter> (_.i32 (.int lefts)) ..peek-cursor))) +(def: (pattern-matching' generate archive) + (-> Phase Archive + (-> Path (Operation Statement))) + (function (recur pathP) + (.case pathP + (#/////synthesis.Then bodyS) + (do ///////phase.monad + [body! (generate archive bodyS)] + (wrap (_.return body!))) + + #/////synthesis.Pop + (///////phase@wrap pop-cursor!) + + (#/////synthesis.Bind register) + (///////phase@wrap (_.define (..register register) ..peek-cursor)) + + (#/////synthesis.Bit-Fork when thenP elseP) + (do {@ ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail-pm!))] + (wrap (.if when + (_.if ..peek-cursor + then! + else!) + (_.if ..peek-cursor + else! + then!)))) + + (#/////synthesis.I64-Fork cons) + (do {@ ///////phase.monad} + [clauses (monad.map @ (function (_ [match then]) + (do @ + [then! (recur then)] + (wrap [(//runtime.i64//= (//primitive.i64 (.int match)) + ..peek-cursor) + then!]))) + (#.Cons cons))] + (wrap (_.cond clauses ..fail-pm!))) + + (^template [<tag> <format> <type>] + (<tag> cons) + (do {@ ///////phase.monad} + [cases (monad.map @ (function (_ [match then]) + (:: @ map (|>> [(list (<format> match))]) (recur then))) + (#.Cons cons))] + (wrap (_.switch ..peek-cursor + cases + (#.Some ..fail-pm!))))) + ([#/////synthesis.F64-Fork //primitive.f64 Frac] + [#/////synthesis.Text-Fork //primitive.text Text]) + + (^template [<complex> <simple> <choice>] + (^ (<complex> idx)) + (///////phase@wrap (<choice> false idx)) + + (^ (<simple> idx nextP)) + (|> nextP + recur + (:: ///////phase.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)) + (///////phase@wrap (push-cursor! (_.at (_.i32 +0) ..peek-cursor))) ## Extra optimization (^ (/////synthesis.path/seq - (<pm> lefts) + (/////synthesis.member/left 0) (/////synthesis.!bind-top register thenP))) (do ///////phase.monad - [then! (pattern-matching' generate archive thenP)] + [then! (recur thenP)] (///////phase@wrap ($_ _.then - (_.define (..register register) (<getter> (_.i32 (.int lefts)) ..peek-cursor)) - then!)))) - ([/////synthesis.member/left //runtime.tuple//left] - [/////synthesis.member/right //runtime.tuple//right]) - - (^ (/////synthesis.!bind-top register thenP)) - (do ///////phase.monad - [then! (pattern-matching' generate archive thenP)] - (///////phase@wrap ($_ _.then - (_.define (..register register) ..peek-and-pop-cursor) - then!))) - - (^ (/////synthesis.!multi-pop nextP)) - (.let [[extra-pops nextP'] (////synthesis/case.count-pops nextP)] + (_.define (..register register) (_.at (_.i32 +0) ..peek-cursor)) + then!))) + + (^template [<pm> <getter>] + (^ (<pm> lefts)) + (///////phase@wrap (push-cursor! (<getter> (_.i32 (.int lefts)) ..peek-cursor))) + + ## Extra optimization + (^ (/////synthesis.path/seq + (<pm> lefts) + (/////synthesis.!bind-top register thenP))) + (do ///////phase.monad + [then! (recur thenP)] + (///////phase@wrap ($_ _.then + (_.define (..register register) (<getter> (_.i32 (.int lefts)) ..peek-cursor)) + then!)))) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (^ (/////synthesis.!bind-top register thenP)) (do ///////phase.monad - [next! (pattern-matching' generate archive nextP')] + [then! (recur thenP)] (///////phase@wrap ($_ _.then - (multi-pop-cursor! (n.+ 2 extra-pops)) - next!)))) - - (^template [<tag> <combinator>] - (^ (<tag> leftP rightP)) - (do ///////phase.monad - [left! (pattern-matching' generate archive leftP) - right! (pattern-matching' generate archive rightP)] - (wrap (<combinator> left! right!)))) - ([/////synthesis.path/seq _.then] - [/////synthesis.path/alt alternation]))) + (_.define (..register register) ..peek-and-pop-cursor) + then!))) + + (^ (/////synthesis.!multi-pop nextP)) + (.let [[extra-pops nextP'] (////synthesis/case.count-pops nextP)] + (do ///////phase.monad + [next! (recur nextP')] + (///////phase@wrap ($_ _.then + (multi-pop-cursor! (n.+ 2 extra-pops)) + next!)))) + + (^template [<tag> <combinator>] + (^ (<tag> leftP rightP)) + (do ///////phase.monad + [left! (recur leftP) + right! (recur rightP)] + (wrap (<combinator> left! right!)))) + ([/////synthesis.path/seq _.then] + [/////synthesis.path/alt alternation])))) (def: (pattern-matching generate archive pathP) (-> Phase Archive Path (Operation Statement)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux index 4a61407da..b2b77ca08 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux @@ -22,7 +22,8 @@ ["#." generation] ["//#" /// #_ [arity (#+ Arity)] - [reference (#+ Register Variable)] + [reference + [variable (#+ Register Variable)]] ["#." phase ("#@." monad)]]]]]) (def: #export (apply generate archive [functionS argsS+]) @@ -40,7 +41,8 @@ function-definition _ - (let [capture (///reference.foreign _.var) + (let [capture (: (-> Register Var) + (|>> (///reference.foreign //reference.system) :assume)) closure (_.closure (|> (list.enumerate inits) (list@map (|>> product.left capture))) (_.return function-definition))] @@ -56,18 +58,15 @@ (def: #export (function generate archive [environment arity bodyS]) (Generator (Abstraction Synthesis)) (do {@ ///////phase.monad} - [[function-name bodyO] (/////generation.with-new-context + [[function-name bodyO] (/////generation.with-new-context archive (do @ - [function-name (:: @ map ///reference.artifact-name - /////generation.context)] + [function-name (:: @ map ///reference.artifact + (/////generation.context archive))] (/////generation.with-anchor (_.var function-name) (generate archive bodyS)))) - #let [capture (:: //reference.system variable)] - closureO+ (: (Operation (List Expression)) - (monad.map @ capture environment)) #let [arityO (|> arity .int _.i32) @num-args (_.var "num_args") - @self (_.var (///reference.artifact-name function-name)) + @self (_.var (///reference.artifact function-name)) apply-poly (.function (_ args func) (|> func (_.do "apply" (list _.null args)))) initialize-self! (_.define (//case.register 0) @self) @@ -77,7 +76,7 @@ (_.define (..input post) (_.at (_.i32 (.int post)) @@arguments)))) initialize-self! (list.indices arity))]] - (with-closure closureO+ + (with-closure (list@map (///reference.variable //reference.system) environment) (_.function @self (list) ($_ _.then (_.define @num-args (_.the "length" @@arguments)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux index 183b35650..b748318e5 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux @@ -3,9 +3,10 @@ [target ["_" js (#+ Expression)]]] [/// - ["/" reference]]) + [reference (#+ System)]]) -(def: #export system - (let [constant (: (-> Text Expression) _.var) - variable constant] - (/.system constant variable))) +(structure: #export system + (System Expression) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux index ddcc765a2..9356f7f8d 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux @@ -1,18 +1,21 @@ (.module: [lux #* [abstract - [monad (#+ do)]] + ["." monad (#+ do)]] [control ["." function] ["p" parser ["s" code]]] [data + ["." product] [number (#+ hex) ["." i64]] ["." text - ["%" format (#+ format)]] + ["%" format (#+ format)] + ["." encoding]] [collection - ["." list ("#@." functor)]]] + ["." list ("#@." functor)] + ["." row]]] ["." macro ["." code] [syntax (#+ syntax:)]] @@ -23,10 +26,11 @@ ["//#" /// #_ ["#." synthesis] ["#." generation (#+ Buffer)] - ["//#" /// #_ + ["//#" /// (#+ Output) ["#." phase] [meta - [archive (#+ Archive)]]]]] + [archive (#+ Archive) + ["." artifact (#+ Registry)]]]]]] ) (template [<name> <base>] @@ -42,7 +46,9 @@ (type: #export (Generator i) (-> Phase Archive i (Operation Expression))) -(def: prefix Text "LuxRuntime") +(def: prefix + Text + "LuxRuntime") (def: #export high (-> (I64 Any) (I64 Any)) @@ -87,64 +93,57 @@ (-> Expression Computation) (..variant (_.i32 +1) (flag #1))) -(def: variable - (-> Text Var) - (|>> ///reference.sanitize - _.var)) - -(def: runtime-name - (-> Text Var) - (|>> ///reference.sanitize - (format ..prefix "$") - _.var)) - (def: (feature name definition) (-> Var (-> Var Expression) Statement) (_.define name (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 (///reference.sanitize var)))))))) - list.concat))] - (~ body)))))) + (do {@ macro.monad} + [ids (monad.seq @ (list.repeat (list.size vars) macro.count))] + (wrap (list (` (let [(~+ (|> vars + (list.zip2 ids) + (list@map (function (_ [id var]) + (list (code.local-identifier var) + (` (_.var (~ (code.text (format "v" (%.nat id))))))))) + 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)) - (~ 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)) inputs)] - (wrap (list (` (def: #export ((~ nameC) (~+ inputsC)) - (-> (~+ inputs-typesC) Computation) - (_.apply/* (~ runtime-nameC) (list (~+ inputsC))))) - (` (def: (~ code-nameC) - Statement - (..feature (~ runtime-nameC) - (function ((~ g!_) (~ g!_)) - (..with-vars [(~+ inputsC)] - (_.function (~ g!_) (list (~+ inputsC)) - (~ code))))))))))))) + (do macro.monad + [id macro.count + #let [identifier (format ..prefix (%.nat id)) + runtime-nameC (` (_.var (~ (code.text identifier))))]] + (case declaration + (#.Left name) + (macro.with-gensyms [g!_] + (let [nameC (code.local-identifier name)] + (wrap (list (` (def: #export (~ nameC) Var (~ runtime-nameC))) + (` (def: (~ (code.local-identifier (format "@" name))) + Statement + (..feature (~ runtime-nameC) + (function ((~ g!_) (~ nameC)) + (~ code))))))))) + + (#.Right [name inputs]) + (macro.with-gensyms [g!_] + (let [nameC (code.local-identifier name) + code-nameC (code.local-identifier (format "@" name)) + inputsC (list@map code.local-identifier inputs) + inputs-typesC (list@map (function.constant (` _.Expression)) inputs)] + (wrap (list (` (def: #export ((~ nameC) (~+ inputsC)) + (-> (~+ inputs-typesC) Computation) + (_.apply/* (~ runtime-nameC) (list (~+ inputsC))))) + (` (def: (~ (code.local-identifier (format "@" name))) + Statement + (..feature (~ runtime-nameC) + (function ((~ g!_) (~ g!_)) + (..with-vars [(~+ inputsC)] + (_.function (~ g!_) (list (~+ inputsC)) + (~ code)))))))))))))) (runtime: (lux//try op) (with-vars [ex] @@ -725,6 +724,7 @@ (def: runtime Statement ($_ _.then + _.use-strict runtime//lux runtime//structure runtime//i64 @@ -734,14 +734,18 @@ runtime//array )) -(def: #export artifact Text prefix) +(def: #export artifact + Text + prefix) (def: #export generate - (Operation (Buffer Statement)) - (/////generation.with-buffer - (do ///////phase.monad - [_ (/////generation.save! true ["" ..prefix] - ($_ _.then - _.use-strict - ..runtime))] - /////generation.buffer))) + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.save! true ["" "0"] ..runtime)] + (wrap [(|> artifact.empty + artifact.resource + product.right) + (row.row ["0" + (|> ..runtime + _.code + encoding.to-utf8)])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux index 84efa7c50..d2a4c21e0 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux @@ -1,98 +1,61 @@ (.module: [lux #* - [abstract - [monad (#+ do)]] - [control - pipe] [data - ["." text - ["%" format (#+ format)]]] - [type (#+ :share)]] + [text + ["%" format (#+ format)]]]] ["." //// #_ - [synthesis (#+ Synthesis)] ["#." generation (#+ Context)] ["//#" /// #_ - ["#." reference (#+ Register Variable Reference)] - ["#." phase ("#@." monad)] + ["." reference (#+ Reference) + ["." variable (#+ Register Variable)]] + ["." phase ("#@." monad)] [meta [archive (#+ Archive)]]]]) +(def: #export (artifact [module artifact]) + (-> Context Text) + (format "lux_" "m" (%.nat module) "a" (%.nat artifact))) + (signature: #export (System expression) - (: (-> Register expression) - local) - (: (-> Register expression) - foreign) - (: (All [anchor directive] - (-> Variable (////generation.Operation anchor expression directive))) - variable) - (: (All [anchor directive] - (-> Archive Name (////generation.Operation anchor expression directive))) + (: (-> Text expression) constant) - (: (All [anchor directive] - (-> Archive Reference (////generation.Operation anchor expression directive))) - reference)) + (: (-> Text expression) + variable)) -(def: (variable-maker prefix variable) - (All [expression] - (-> Text (-> Text expression) - (-> Register expression))) - (|>> %.nat (format prefix) variable)) +(def: #export (constant system archive name) + (All [anchor expression directive] + (-> (System expression) Archive Name + (////generation.Operation anchor expression directive expression))) + (phase@map (|>> ..artifact (:: system constant)) + (////generation.remember archive name))) (template [<sigil> <name>] - [(def: #export <name> + [(def: #export (<name> system) (All [expression] - (-> (-> Text expression) + (-> (System expression) (-> Register expression))) - (variable-maker <sigil>))] + (|>> %.nat (format <sigil>) (:: system variable)))] ["f" foreign] ["l" local] ) -(def: #export sanitize - (-> Text Text) - (|>> (text.replace-all "-" "_") - (text.replace-all "?" "Q") - (text.replace-all "@" "A"))) - -(def: #export (artifact-name [module id]) - (-> Context Text) - (format "lux_" "m" (%.nat module) "a" (%.nat id))) - -(def: #export (system constant variable) +(def: #export (variable system variable) (All [expression] - (-> (-> Text expression) (-> Text expression) - (System expression))) - (let [local (..local variable) - foreign (..foreign variable) - variable (:share [expression] - {(-> Text expression) - variable} - {(All [anchor directive] - (-> Variable (////generation.Operation anchor expression directive))) - (|>> (case> (#//////reference.Local register) - (local register) - - (#//////reference.Foreign register) - (foreign register)) - //////phase@wrap)}) - constant (:share [expression] - {(-> Text expression) - constant} - {(All [anchor directive] - (-> Archive Name (////generation.Operation anchor expression directive))) - (function (_ archive name) - (|> (////generation.remember archive name) - (//////phase@map (|>> ..artifact-name constant))))})] - (structure - (def: local local) - (def: foreign foreign) - (def: variable variable) - (def: constant constant) - (def: (reference archive reference) - (case reference - (#//////reference.Constant value) - (constant archive value) - - (#//////reference.Variable value) - (variable value)))))) + (-> (System expression) Variable expression)) + (case variable + (#variable.Local register) + (..local system register) + + (#variable.Foreign register) + (..foreign system register))) + +(def: #export (reference system archive reference) + (All [anchor expression directive] + (-> (System expression) Archive Reference (////generation.Operation anchor expression directive expression))) + (case reference + (#reference.Constant value) + (..constant system archive value) + + (#reference.Variable value) + (phase@wrap (..variable system value)))) diff --git a/stdlib/source/lux/tool/compiler/meta/packager/js.lux b/stdlib/source/lux/tool/compiler/meta/packager/js.lux deleted file mode 100644 index e4c52af5a..000000000 --- a/stdlib/source/lux/tool/compiler/meta/packager/js.lux +++ /dev/null @@ -1,36 +0,0 @@ -(.module: - [lux #* - [control - [pipe (#+ case>)] - ["." function]] - [data - [binary (#+ Binary)] - ["." product] - ["." text - ["." encoding]] - [collection - ["." row] - ["." list ("#@." monad fold)]]] - [target - ["_" js]] - [tool - [compiler - [phase - [generation (#+ Output)]]]]]) - -(def: #export (package outputs) - (-> (Output _.Statement) Binary) - (|> outputs - row.to-list - (list@map (|>> product.right - row.to-list - (list@map product.right))) - list@join - (case> (#.Cons head tail) - (|> (list@fold (function.flip _.then) head tail) - (: _.Statement) - _.code - encoding.to-utf8) - - #.Nil - (encoding.to-utf8 "")))) diff --git a/stdlib/source/lux/tool/compiler/meta/packager/script.lux b/stdlib/source/lux/tool/compiler/meta/packager/script.lux new file mode 100644 index 000000000..f391e43a8 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/meta/packager/script.lux @@ -0,0 +1,106 @@ +(.module: + [lux (#- Module Definition) + [type (#+ :share)] + ["." host (#+ import: do-to)] + [abstract + ["." monad (#+ Monad do)]] + [control + ["." try (#+ Try)] + [concurrency + ["." promise (#+ Promise)]] + [security + ["!" capability]]] + [data + ["." binary (#+ Binary)] + ["." text + ["%" format (#+ format)] + ["." encoding]] + [number + ["n" nat]] + [collection + ["." row (#+ Row)] + ["." list ("#@." functor fold)]]] + [target + [jvm + [encoding + ["." name]]]] + [world + ["." file (#+ File Directory)]]] + [program + [compositor + ["." static (#+ Static)]]] + ["." // (#+ Packager) + [// + ["." archive + ["." descriptor (#+ Module)] + ["." artifact]] + ["." io #_ + ["#" archive]] + [// + [language + ["$" lux + [generation (#+ Context)] + [phase + [generation + [jvm + ["." runtime (#+ Definition)]]]]]]]]]) + +## TODO: Delete ASAP +(type: (Action ! a) + (! (Try a))) + +(def: (write-artifact monad file-system static context) + (All [!] + (-> (Monad !) (file.System !) Static Context + (Action ! Binary))) + (do (try.with monad) + [artifact (let [[module artifact] context] + (!.use (:: file-system file) [(io.artifact file-system static module (%.nat artifact))]))] + (!.use (:: artifact content) []))) + +(def: (write-module monad file-system static sequence [module artifacts] so-far) + (All [! directive] + (-> (Monad !) (file.System !) Static (-> directive directive directive) [archive.ID (List artifact.ID)] directive + (Action ! directive))) + (monad.fold (:assume (try.with monad)) + (function (_ artifact so-far) + (do (try.with monad) + [content (..write-artifact monad file-system static [module artifact]) + content (:: monad wrap (encoding.from-utf8 content))] + (wrap (sequence so-far + (:share [directive] + {directive + so-far} + {directive + (:assume artifact)}))))) + so-far + artifacts)) + +(def: #export (package header to-code sequence) + (All [! directive] + (-> directive + (-> directive Text) + (-> directive directive directive) + (Packager !))) + (function (package monad file-system static archive program) + (do {@ (try.with monad)} + [cache (:share [!] + {(Monad !) + monad} + {(! (Try (Directory !))) + (:assume (!.use (:: file-system directory) [(get@ #static.target static)]))}) + order (|> archive + archive.archived + (monad.map try.monad (function (_ module) + (do try.monad + [[descriptor document] (archive.find module archive) + module-id (archive.id module archive)] + (wrap (|> descriptor + (get@ #descriptor.registry) + artifact.artifacts + row.to-list + (list@map (|>> (get@ #artifact.id))) + [module-id]))))) + (:: monad wrap))] + (:: @ map (|>> to-code encoding.to-utf8) + (monad.fold @ (..write-module monad file-system static sequence) header order))))) diff --git a/stdlib/source/program/compositor/cli.lux b/stdlib/source/program/compositor/cli.lux index e0bcd6e00..03235bbad 100644 --- a/stdlib/source/program/compositor/cli.lux +++ b/stdlib/source/program/compositor/cli.lux @@ -1,6 +1,7 @@ (.module: [lux (#- Module Source) [control + [pipe (#+ case>)] ["<>" parser ["." cli (#+ Parser)]]] [tool @@ -31,10 +32,10 @@ (Parser <type>) (cli.named <long> cli.any))] - [source "--source" Source] - [library "--library" Library] - [target "--target" Target] - [module "--module" Module] + [^source "--source" Source] + [^library "--library" Library] + [^target "--target" Target] + [^module "--module" Module] ) (def: #export service @@ -42,18 +43,25 @@ ($_ <>.or (<>.after (cli.this "build") ($_ <>.and - (<>.some ..source) - (<>.some ..library) - ..target - ..module)) + (<>.some ..^source) + (<>.some ..^library) + ..^target + ..^module)) (<>.after (cli.this "repl") ($_ <>.and - (<>.some ..source) - (<>.some ..library) - ..target - ..module)) + (<>.some ..^source) + (<>.some ..^library) + ..^target + ..^module)) (<>.after (cli.this "export") ($_ <>.and - (<>.some ..source) - ..target)) + (<>.some ..^source) + ..^target)) )) + +(def: #export target + (-> Service Target) + (|>> (case> (^or (#Compilation [sources libraries target module]) + (#Interpretation [sources libraries target module]) + (#Export [sources target])) + target))) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index e2d9fb258..8ce6b58b5 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -1,153 +1,139 @@ -(.with-expansions [<host-modules> (.as-is [runtime (#+)] - [primitive (#+)] - [structure (#+)] - [reference (#+)] - [case (#+)] - [loop (#+)] - [function (#+)] - [extension (#+)])] - (.module: - ["/" lux #* - [abstract - [monad (#+ do)] - [predicate (#+ Predicate)]] - [control - ["." io (#+ io)] - [function - [mixin (#+)]] - [parser - [cli (#+ program:)]]] - [data - ["." name] - [number - ["." i64] - ["n" nat] - ["i" int] - ["r" rev] - ["f" frac]]] - ["." math] - ["_" test (#+ Test)] - ## These modules do not need to be tested. - [type - [variance (#+)]] - [locale (#+) - [language (#+)] - [territory (#+)]] - ["%" data/text/format (#+ format)] - [math - ["." random (#+ Random) ("#@." functor)]] - ## TODO: Test these modules - [data - [format - [css (#+)] - [markdown (#+)]]] - ["@" target - [js (#+)] - [python (#+)] - [lua (#+)] - [ruby (#+)] - [php (#+)] - [common-lisp (#+)] - [scheme (#+)]] - ## [tool - ## [compiler - ## [language - ## [lux - ## [phase - ## [generation - ## [jvm (#+) - ## <host-modules>] - ## [js (#+) - ## <host-modules>] - ## [python (#+) - ## <host-modules>] - ## [lua (#+) - ## <host-modules>] - ## [ruby (#+) - ## <host-modules>] - ## ## [php (#+) - ## ## <host-modules>] - ## ## [common-lisp (#+) - ## ## <host-modules>] - ## ## [scheme (#+) - ## ## <host-modules>] - ## ] - ## [extension - ## [generation - ## [jvm (#+)] - ## [js (#+)] - ## [python (#+)] - ## [lua (#+)] - ## [ruby (#+)]]]]]]]] - ## [control - ## ["._" predicate] - ## [function - ## ["._" contract]] - ## [monad - ## ["._" free]] - ## [parser - ## [type (#+)]]] - ## [data - ## ["._" env] - ## ["._" trace] - ## ["._" store] - ## [format - ## ["._" context] - ## ["._" html] - ## ["._" css] - ## ["._" binary]] - ## [collection - ## [tree - ## [rose - ## ["._" parser]]] - ## [dictionary - ## ["._" plist]] - ## [set - ## ["._" multi]]] - ## [text - ## ["._" buffer]]] - ## ["._" macro] - ## [type - ## ["._" unit] - ## ["._" refinement] - ## ["._" quotient]] - ## [world - ## ["._" environment] - ## ["._" console]] - ## [compiler - ## ["._" cli] - ## ["._" default - ## ["._" evaluation] - ## [phase - ## ["._" generation] - ## [extension - ## ["._" directive]]] - ## ["._default" cache]] - ## [meta - ## ["._meta" io - ## ["._meta_io" context] - ## ["._meta_io" archive]] - ## ["._meta" archive] - ## ["._meta" cache]]] - ## ["._" interpreter - ## ["._interpreter" type]] - ] - ## TODO: Must have 100% coverage on tests. - ["." / #_ - ["#." abstract] - ["#." control] - ["#." data] - ["#." macro] - ["#." math] - ["#." time] - ## ["#." tool] - ["#." type] - ["#." world] - ["#." host] - ["#." extension] - ["#." target #_ - ["#/." jvm]]] - )) +(.module: + ["/" lux #* + [abstract + [monad (#+ do)] + [predicate (#+ Predicate)]] + [control + ["." io (#+ io)] + [function + [mixin (#+)]] + [parser + [cli (#+ program:)]]] + [data + ["." name] + [number + ["." i64] + ["n" nat] + ["i" int] + ["r" rev] + ["f" frac]]] + ["." math] + ["_" test (#+ Test)] + ## These modules do not need to be tested. + [type + [variance (#+)]] + [locale (#+) + [language (#+)] + [territory (#+)]] + ["%" data/text/format (#+ format)] + [math + ["." random (#+ Random) ("#@." functor)]] + ## TODO: Test these modules + [data + [format + [css (#+)] + [markdown (#+)]]] + ["@" target + [js (#+)] + [python (#+)] + [lua (#+)] + [ruby (#+)] + [php (#+)] + [common-lisp (#+)] + [scheme (#+)]] + [tool + [compiler + [language + [lux + [phase + [generation + [jvm (#+)] + [js (#+)] + ## [python (#+)] + ## [lua (#+)] + ## [ruby (#+)] + ## [php (#+)] + ## [common-lisp (#+)] + ## [scheme (#+)] + ] + [extension + [generation + [jvm (#+)] + [js (#+)] + ## [python (#+)] + ## [lua (#+)] + ## [ruby (#+)] + ]] + ]]]]] + ## [control + ## ["._" predicate] + ## [function + ## ["._" contract]] + ## [monad + ## ["._" free]] + ## [parser + ## [type (#+)]]] + ## [data + ## ["._" env] + ## ["._" trace] + ## ["._" store] + ## [format + ## ["._" context] + ## ["._" html] + ## ["._" css] + ## ["._" binary]] + ## [collection + ## [tree + ## [rose + ## ["._" parser]]] + ## [dictionary + ## ["._" plist]] + ## [set + ## ["._" multi]]] + ## [text + ## ["._" buffer]]] + ## ["._" macro] + ## [type + ## ["._" unit] + ## ["._" refinement] + ## ["._" quotient]] + ## [world + ## ["._" environment] + ## ["._" console]] + ## [compiler + ## ["._" cli] + ## ["._" default + ## ["._" evaluation] + ## [phase + ## ["._" generation] + ## [extension + ## ["._" directive]]] + ## ["._default" cache]] + ## [meta + ## ["._meta" io + ## ["._meta_io" context] + ## ["._meta_io" archive]] + ## ["._meta" archive] + ## ["._meta" cache]]] + ## ["._" interpreter + ## ["._interpreter" type]] + ] + ## TODO: Must have 100% coverage on tests. + ["." / #_ + ["#." abstract] + ["#." control] + ["#." data] + ["#." macro] + ["#." math] + ["#." time] + ## ["#." tool] + ["#." type] + ["#." world] + ["#." host] + ["#." extension] + ["#." target #_ + ["#/." jvm]]] + ) ## TODO: Get rid of this ASAP (template: (!bundle body) |