diff options
Diffstat (limited to 'stdlib/source')
27 files changed, 774 insertions, 284 deletions
diff --git a/stdlib/source/lux/control/parser/analysis.lux b/stdlib/source/lux/control/parser/analysis.lux index fe8b4c4f0..824e2a83c 100644 --- a/stdlib/source/lux/control/parser/analysis.lux +++ b/stdlib/source/lux/control/parser/analysis.lux @@ -35,29 +35,19 @@ (list.interpose " ") (text.join-with "")))) -## TODO: Use "type:" ASAP. -(def: Input Type (type (List Analysis))) - -(exception: #export (cannot-parse {input ..Input}) +(exception: #export (cannot-parse {input (List Analysis)}) (exception.report ["Input" (exception.enumerate /.%analysis input)])) -(exception: #export (unconsumed-input {input ..Input}) +(exception: #export (unconsumed-input {input (List Analysis)}) (exception.report ["Input" (exception.enumerate /.%analysis input)])) -(exception: #export (wrong-arity {expected Arity} {actual Arity}) - (exception.report - ["Expected" (%.nat expected)] - ["Actual" (%.nat actual)])) - -(exception: #export empty-input) - (type: #export Parser - (//.Parser ..Input)) + (//.Parser (List Analysis))) (def: #export (run parser input) - (All [a] (-> (Parser a) ..Input (Try a))) + (All [a] (-> (Parser a) (List Analysis) (Try a))) (case (parser input) (#try.Failure error) (#try.Failure error) @@ -73,7 +63,7 @@ (function (_ input) (case input #.Nil - (exception.throw ..empty-input []) + (exception.throw ..cannot-parse input) (#.Cons [head tail]) (#try.Success [tail head])))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux index 27bc09652..c9bc95612 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux @@ -1,6 +1,7 @@ (.module: [lux (#- nat int rev) [abstract + [equivalence (#+ Equivalence)] [monad (#+ do)]] [control ["." function] @@ -9,8 +10,12 @@ [data ["." product] ["." maybe] + ["." bit ("#@." equivalence)] [number - ["n" nat]] + ["n" nat] + ["i" int] + ["r" rev] + ["f" frac]] ["." text ("#@." equivalence) ["%" format (#+ Format format)]] [collection @@ -21,7 +26,8 @@ [/// [arity (#+ Arity)] [version (#+ Version)] - ["." reference (#+ Register Variable Reference)] + ["." reference (#+ Reference) + ["." variable (#+ Register Variable)]] ["." phase]]]) (type: #export #rec Primitive @@ -76,6 +82,103 @@ (type: #export Match (Match' Analysis)) +(structure: primitive-equivalence + (Equivalence Primitive) + + (def: (= reference sample) + (case [reference sample] + [#Unit #Unit] + true + + (^template [<tag> <=>] + [(<tag> reference) (<tag> sample)] + (<=> reference sample)) + ([#Bit bit@=] + [#Nat n.=] + [#Int i.=] + [#Rev r.=] + [#Frac f.=] + [#Text text@=]) + + _ + false))) + +(structure: (composite-equivalence (^open "/@.")) + (All [a] (-> (Equivalence a) (Equivalence (Composite a)))) + + (def: (= reference sample) + (case [reference sample] + [(#Variant [reference-lefts reference-right? reference-value]) + (#Variant [sample-lefts sample-right? sample-value])] + (and (n.= reference-lefts sample-lefts) + (bit@= reference-right? sample-right?) + (/@= reference-value sample-value)) + + [(#Tuple reference) (#Tuple sample)] + (:: (list.equivalence /@=) = reference sample) + + _ + false))) + +(structure: pattern-equivalence + (Equivalence Pattern) + + (def: (= reference sample) + (case [reference sample] + [(#Simple reference) (#Simple sample)] + (:: primitive-equivalence = reference sample) + + [(#Complex reference) (#Complex sample)] + (:: (composite-equivalence =) = reference sample) + + [(#Bind reference) (#Bind sample)] + (n.= reference sample) + + _ + false))) + +(structure: (branch-equivalence equivalence) + (-> (Equivalence Analysis) (Equivalence Branch)) + + (def: (= [reference-pattern reference-body] [sample-pattern sample-body]) + (and (:: pattern-equivalence = reference-pattern sample-pattern) + (:: equivalence = reference-body sample-body)))) + +(structure: #export equivalence + (Equivalence Analysis) + + (def: (= reference sample) + (case [reference sample] + [(#Primitive reference) (#Primitive sample)] + (:: primitive-equivalence = reference sample) + + [(#Structure reference) (#Structure sample)] + (:: (composite-equivalence =) = reference sample) + + [(#Reference reference) (#Reference sample)] + (:: reference.equivalence = reference sample) + + [(#Case [reference-analysis reference-match]) + (#Case [sample-analysis sample-match])] + (and (= reference-analysis sample-analysis) + (:: (list.equivalence (branch-equivalence =)) = (#.Cons reference-match) (#.Cons sample-match))) + + [(#Function [reference-environment reference-analysis]) + (#Function [sample-environment sample-analysis])] + (and (= reference-analysis sample-analysis) + (:: (list.equivalence variable.equivalence) = reference-environment sample-environment)) + + [(#Apply [reference-input reference-abstraction]) + (#Apply [sample-input sample-abstraction])] + (and (= reference-input sample-input) + (= reference-abstraction sample-abstraction)) + + [(#Extension reference) (#Extension sample)] + (:: (extension.equivalence =) = reference sample) + + _ + false))) + (template [<name> <tag>] [(template: #export (<name> content) (<tag> content))] @@ -104,7 +207,7 @@ (n.= (dec size) tag)) (template: #export (no-op value) - (|> 1 #reference.Local #reference.Variable #..Reference + (|> 1 #variable.Local #reference.Variable #..Reference (#..Function (list)) (#..Apply value))) @@ -207,12 +310,7 @@ (text.enclose ["[" "]"]))) (#Reference reference) - (case reference - (#reference.Variable variable) - (reference.%variable variable) - - (#reference.Constant constant) - (%.name constant)) + (reference.format reference) (#Case analysis match) "{?}" @@ -221,7 +319,7 @@ (|> (%analysis body) (format " ") (format (|> environment - (list@map reference.%variable) + (list@map variable.format) (text.join-with " ") (text.enclose ["[" "]"]))) (text.enclose ["(" ")"])) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux index d68d3fed7..ffa635109 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux @@ -18,7 +18,8 @@ [// ["/" analysis (#+ Operation Phase)] [/// - ["." reference (#+ Register Variable)] + [reference + ["." variable (#+ Register Variable)]] ["#" phase]]]]) (type: Local (Bindings Text [Type Register])) @@ -36,7 +37,7 @@ (get@ [#.locals #.mappings]) (plist.get name) (maybe@map (function (_ [type value]) - [type (#reference.Local value)])))) + [type (#variable.Local value)])))) (def: (captured? name scope) (-> Text Scope Bit) @@ -51,7 +52,7 @@ (case mappings (#.Cons [_name [_source-type _source-ref]] mappings') (if (text@= name _name) - (#.Some [_source-type (#reference.Foreign idx)]) + (#.Some [_source-type (#variable.Foreign idx)]) (recur (inc idx) mappings')) #.Nil @@ -87,7 +88,7 @@ (..reference name top-outer)) [ref inner'] (list@fold (: (-> Scope [Variable (List Scope)] [Variable (List Scope)]) (function (_ scope ref+inner) - [(#reference.Foreign (get@ [#.captured #.counter] scope)) + [(#variable.Foreign (get@ [#.captured #.counter] scope)) (#.Cons (update@ #.captured (: (-> Foreign Foreign) (|>> (update@ #.counter inc) @@ -101,11 +102,8 @@ (#.Some [ref-type ref])])) ))))) -(exception: #export (cannot-create-local-binding-without-a-scope) - "") - -(exception: #export (invalid-scope-alteration) - "") +(exception: #export cannot-create-local-binding-without-a-scope) +(exception: #export invalid-scope-alteration) (def: #export (with-local [name type] action) (All [a] (-> [Text Type] (Operation a) (Operation a))) @@ -195,10 +193,10 @@ (-> Ref Variable) (case ref (#.Local register) - (#reference.Local register) + (#variable.Local register) (#.Captured register) - (#reference.Foreign register))) + (#variable.Foreign register))) (def: #export (environment scope) (-> Scope (List Variable)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux index 8498c0321..2cc5c42b8 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux @@ -1,6 +1,7 @@ (.module: [lux (#- Name) [abstract + [equivalence (#+ Equivalence)] ["." monad (#+ do)]] [control ["." function] @@ -19,8 +20,15 @@ (type: #export Name Text) -(type: #export (Extension i) - [Name (List i)]) +(type: #export (Extension a) + [Name (List a)]) + +(structure: #export (equivalence input-equivalence) + (All [a] (-> (Equivalence a) (Equivalence (Extension a)))) + + (def: (= [reference-name reference-inputs] [sample-name sample-inputs]) + (and (text@= reference-name sample-name) + (:: (list.equivalence input-equivalence) = reference-inputs sample-inputs)))) (with-expansions [<Bundle> (as-is (Dictionary Name (Handler s i o)))] (type: #export (Handler s i o) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux index 026b31c70..005563f1a 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux @@ -63,7 +63,8 @@ ["#." generation] [/// ["#" phase] - ["#." reference (#+ Variable)] + [reference (#+) + ["#." variable (#+ Variable)]] [meta ["." archive (#+ Archive)]]]]]]) @@ -897,6 +898,9 @@ (^ (//////synthesis.branch/if [testS thenS elseS])) (//////synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)]) + (^ (//////synthesis.branch/get [path recordS])) + (//////synthesis.branch/get [path (recur recordS)]) + (^ (//////synthesis.loop/scope [offset initsS+ bodyS])) (//////synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)]) @@ -1006,14 +1010,14 @@ ## Combine them. list@join ## Remove duplicates. - (set.from-list //////reference.hash) + (set.from-list //////variable.hash) set.to-list) global-mapping (|> total-environment ## Give them names as "foreign" variables. list.enumerate (list@map (function (_ [id capture]) - [capture (#//////reference.Foreign id)])) - (dictionary.from-list //////reference.hash)) + [capture (#//////variable.Foreign id)])) + (dictionary.from-list //////variable.hash)) normalized-methods (list@map (function (_ [environment [ownerT name strict-fp? annotations vars @@ -1022,11 +1026,11 @@ (let [local-mapping (|> environment list.enumerate (list@map (function (_ [foreign-id capture]) - [(#//////reference.Foreign foreign-id) + [(#//////variable.Foreign foreign-id) (|> global-mapping (dictionary.get capture) maybe.assume)])) - (dictionary.from-list //////reference.hash))] + (dictionary.from-list //////variable.hash))] [ownerT name strict-fp? annotations vars self-name arguments returnT exceptionsT diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux index b552f16d5..5ede5f926 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux @@ -53,6 +53,9 @@ (^ (synthesis.branch/if [conditionS thenS elseS])) (/case.if generate archive [conditionS thenS elseS]) + (^ (synthesis.branch/get [path recordS])) + (/case.get generate archive [path recordS]) + (^ (synthesis.loop/scope scope)) (/loop.scope generate archive scope) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux index 9abfe1f55..0d94ac026 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux @@ -7,7 +7,9 @@ [data [number ["." i32] - ["n" nat]]] + ["n" nat]] + [collection + ["." list ("#@." fold)]]] [target [jvm ["_" bytecode (#+ Label Bytecode) ("#@." monad)] @@ -21,8 +23,9 @@ ["." synthesis (#+ Path Synthesis)] ["." generation] [/// - [reference (#+ Register)] - ["." phase ("operation@." monad)]]]]) + ["." phase ("operation@." monad)] + [reference + [variable (#+ Register)]]]]]) (def: equals-name "equals") @@ -65,6 +68,25 @@ (//runtime.get //runtime.stack-tail) (_.checkcast //type.stack))) +(def: (left-projection lefts) + (-> Nat (Bytecode Any)) + ($_ _.compose + (_.checkcast //type.tuple) + (..int lefts) + (.case lefts + 0 + _.aaload + + lefts + //runtime.left-projection))) + +(def: (right-projection lefts) + (-> Nat (Bytecode Any)) + ($_ _.compose + (_.checkcast //type.tuple) + (..int lefts) + //runtime.right-projection)) + (def: (path' stack-depth @else @end phase archive path) (-> Nat Label Label (Generator Path)) (.case path @@ -138,25 +160,15 @@ [synthesis.side/right //runtime.right-flag .inc]) (^ (synthesis.member/left lefts)) - (operation@wrap (.let [optimized-projection (.case lefts - 0 - _.aaload - - lefts - //runtime.left-projection)] - ($_ _.compose - ..peek - (_.checkcast //type.tuple) - (..int lefts) - optimized-projection - //runtime.push))) + (operation@wrap ($_ _.compose + ..peek + (..left-projection lefts) + //runtime.push)) (^ (synthesis.member/right lefts)) (operation@wrap ($_ _.compose ..peek - (_.checkcast //type.tuple) - (..int lefts) - //runtime.right-projection + (..right-projection lefts) //runtime.push)) ## Extra optimization @@ -253,6 +265,21 @@ (_.astore register) bodyG)))) +(def: #export (get phase archive [path recordS]) + (Generator [(List synthesis.Member) Synthesis]) + (do phase.monad + [recordG (phase archive recordS)] + (wrap (list@fold (function (_ step so-far) + (.let [next (.case step + (#.Left lefts) + (..left-projection lefts) + + (#.Right lefts) + (..right-projection lefts))] + (_.compose so-far next))) + recordG + path)))) + (def: #export (case phase archive [valueS path]) (Generator [Synthesis Path]) (do phase.monad diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux index 788919379..4359d7815 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux @@ -52,9 +52,10 @@ [synthesis (#+ Synthesis Abstraction Apply)] ["." generation] [/// - [reference (#+ Register)] ["." arity (#+ Arity)] - ["." phase]]]]]) + ["." phase] + [reference + [variable (#+ Register)]]]]]]) (def: #export (with archive @begin class environment arity body) (-> Archive Label External Environment Arity (Bytecode Any) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux index c491039b9..13865b17e 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux @@ -17,7 +17,8 @@ ["#." type] ["#." reference] [////// - [reference (#+ Register)]]]) + [reference + [variable (#+ Register)]]]]) (def: #export type ////type.value) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux index b9e97ddfd..14b4f6cab 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux @@ -18,7 +18,8 @@ [//// [analysis (#+ Environment)] [/// - [reference (#+ Register)]]]]]) + [reference + [variable (#+ Register)]]]]]]) (def: #export (closure environment) (-> Environment (List (Type Value))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux index b44cb4102..57271de30 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux @@ -25,8 +25,9 @@ ["//#" /// #_ ["#." reference] [////// - [reference (#+ Register)] - ["." arity (#+ Arity)]]]]]]) + ["." arity (#+ Arity)] + [reference + [variable (#+ Register)]]]]]]]) (def: #export (initial amount) (-> Nat (Bytecode Any)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux index 592c798ec..cafb6ceeb 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux @@ -42,7 +42,8 @@ [analysis (#+ Environment)] [/// [arity (#+ Arity)] - ["." reference (#+ Register)]]]]]]) + [reference + [variable (#+ Register)]]]]]]]) (def: (increment by) (-> Nat (Bytecode Any)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux index 5c39bd145..cf1ad20df 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux @@ -35,8 +35,9 @@ [//// [analysis (#+ Environment)] [/// - [reference (#+ Register)] - ["." arity (#+ Arity)]]]]]]) + ["." arity (#+ Arity)] + [reference + [variable (#+ Register)]]]]]]]) (def: #export name "<init>") diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux index 5e07ea35a..0f79b6e86 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux @@ -20,8 +20,9 @@ ["." synthesis (#+ Path Synthesis)] ["." generation] [/// - [reference (#+ Register)] - ["." phase]]]]) + ["." phase] + [reference + [variable (#+ Register)]]]]]) (def: (invariant? register changeS) (-> Register Synthesis Bit) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux index 7bd43b8aa..b21c899e0 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux @@ -20,7 +20,8 @@ ["." generation] [/// ["#" phase ("operation@." monad)] - ["." reference (#+ Register Variable)] + [reference + ["." variable (#+ Register Variable)]] [meta [archive (#+ Archive)]]]]]]) @@ -51,10 +52,10 @@ (def: #export (variable archive variable) (-> Archive Variable (Operation (Bytecode Any))) (case variable - (#reference.Local variable) + (#variable.Local variable) (operation@wrap (_.aload variable)) - (#reference.Foreign variable) + (#variable.Foreign variable) (..foreign archive variable))) (def: #export (constant archive name) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux index 304629c6f..41153f29c 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux @@ -50,7 +50,8 @@ [/// ["#" phase] [arity (#+ Arity)] - [reference (#+ Register)] + [reference + [variable (#+ Register)]] ["." meta [io (#+ lux-context)] [archive (#+ Archive)]]]]]]) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux index 149d3e69a..8d3b7b2d5 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux @@ -20,8 +20,9 @@ ["#." analysis (#+ Pattern Match Analysis)] ["/" synthesis (#+ Path Synthesis Operation Phase)] [/// - ["#." reference (#+ Variable)] ["#" phase ("#@." monad)] + ["#." reference + ["#/." variable (#+ Register Variable)]] [meta [archive (#+ Archive)]]]]]) @@ -76,11 +77,11 @@ (list.reverse (list.enumerate tuple)))) )) -(def: #export (path archive synthesize pattern bodyA) +(def: (path archive synthesize pattern bodyA) (-> Archive Phase Pattern Analysis (Operation Path)) (path' pattern true (///@map (|>> #/.Then) (synthesize archive bodyA)))) -(def: #export (weave leftP rightP) +(def: (weave leftP rightP) (-> Path Path Path) (with-expansions [<default> (as-is (#/.Alt leftP rightP))] (case [leftP rightP] @@ -126,54 +127,127 @@ _ <default>))) +(def: (get patterns @selection) + (-> (///analysis.Tuple ///analysis.Pattern) Register (List /.Member)) + (loop [lefts 0 + patterns patterns] + (with-expansions [<failure> (as-is (list)) + <continue> (as-is (recur (inc lefts) + tail)) + <member> (as-is (if (list.empty? tail) + (#.Right (dec lefts)) + (#.Left lefts)))] + (case patterns + #.Nil + <failure> + + (#.Cons head tail) + (case head + (#///analysis.Simple #///analysis.Unit) + <continue> + + (#///analysis.Bind register) + (if (n.= @selection register) + (list <member>) + <continue>) + + (#///analysis.Complex (#///analysis.Tuple sub-patterns)) + (case (get sub-patterns @selection) + #.Nil + <continue> + + sub-members + (list& <member> sub-members)) + + _ + <failure>))))) + +(def: #export (synthesize-case synthesize archive input [headB tailB+]) + (-> Phase Archive Synthesis Match (Operation Synthesis)) + (let [[[lastP lastA] prevsPA] (|> (#.Cons headB tailB+) + list.reverse + (case> (#.Cons [lastP lastA] prevsPA) + [[lastP lastA] prevsPA] + + _ + (undefined)))] + (do {@ ///.monad} + [lastSP (path archive synthesize lastP lastA) + prevsSP+ (monad.map @ (product.uncurry (path archive synthesize)) prevsPA)] + (wrap (/.branch/case [input (list@fold weave lastSP prevsSP+)]))))) + +(template: (!masking <variable> <output>) + [[(#///analysis.Bind <variable>) + (#///analysis.Reference (///reference.local <output>))] + (list)]) + +(def: #export (synthesize-masking synthesize archive input @variable @output) + (-> Phase Archive Synthesis Register Register (Operation Synthesis)) + (if (n.= @variable @output) + (///@wrap input) + (..synthesize-case synthesize archive input (!masking @variable @output)))) + +(def: #export (synthesize-let synthesize archive input @variable body) + (-> Phase Archive Synthesis Register Analysis (Operation Synthesis)) + (do ///.monad + [body (/.with-new-local + (synthesize archive body))] + (wrap (/.branch/let [input @variable body])))) + +(def: #export (synthesize-if synthesize archive test then else) + (-> Phase Archive Synthesis Analysis Analysis (Operation Synthesis)) + (do ///.monad + [then (synthesize archive then) + else (synthesize archive else)] + (wrap (/.branch/if [test then else])))) + +(template: (!get <patterns> <output>) + [[(///analysis.pattern/tuple <patterns>) + (#///analysis.Reference (///reference.local <output>))] + (.list)]) + +(def: #export (synthesize-get synthesize archive input patterns @member) + (-> Phase Archive Synthesis (///analysis.Tuple ///analysis.Pattern) Register (Operation Synthesis)) + (case (..get patterns @member) + #.Nil + (..synthesize-case synthesize archive input (!get patterns @member)) + + path + (case input + (^ (/.branch/get [sub-path sub-input])) + (///@wrap (/.branch/get [(list@compose path sub-path) sub-input])) + + _ + (///@wrap (/.branch/get [path input]))))) + (def: #export (synthesize synthesize^ [headB tailB+] archive inputA) (-> Phase Match Phase) (do {@ ///.monad} [inputS (synthesize^ archive inputA)] - (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 @ - [headB/bodyS (/.with-new-local - (synthesize^ archive headB/bodyA))] - (wrap (/.branch/let [inputS inputR headB/bodyS]))))) - - <if> - (as-is (^or (^ [[(///analysis.pattern/bit #1) thenA] - (list [(///analysis.pattern/bit #0) elseA])]) - (^ [[(///analysis.pattern/bit #0) elseA] - (list [(///analysis.pattern/bit #1) thenA])])) - (do @ - [thenS (synthesize^ archive thenA) - elseS (synthesize^ archive 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 archive synthesize^ lastP lastA) - prevsSP+ (monad.map @ (product.uncurry (path archive synthesize^)) prevsPA)] - (wrap (/.branch/case [inputS (list@fold weave lastSP prevsSP+)])))))] - (case [headB tailB+] - <let> - <if> - <case>)))) + (case [headB tailB+] + (^ (!masking @variable @output)) + (..synthesize-masking synthesize^ archive inputS @variable @output) + + [[(#///analysis.Bind @variable) body] + #.Nil] + (..synthesize-let synthesize^ archive inputS @variable body) + + (^or (^ [[(///analysis.pattern/bit #1) then] + (list [(///analysis.pattern/bit #0) else])]) + (^ [[(///analysis.pattern/bit #1) then] + (list [(///analysis.pattern/unit) else])]) + + (^ [[(///analysis.pattern/bit #0) else] + (list [(///analysis.pattern/bit #1) then])]) + (^ [[(///analysis.pattern/bit #0) else] + (list [(///analysis.pattern/unit) then])])) + (..synthesize-if synthesize^ archive inputS then else) + + (^ (!get patterns @member)) + (..synthesize-get synthesize^ archive inputS patterns @member) + + match + (..synthesize-case synthesize^ archive inputS match)))) (def: #export (count-pops path) (-> Path [Nat Path]) @@ -194,13 +268,13 @@ (def: empty Storage - {#bindings (set.new ///reference.hash) - #dependencies (set.new ///reference.hash)}) + {#bindings (set.new ///reference/variable.hash) + #dependencies (set.new ///reference/variable.hash)}) ## TODO: Use this to declare all local variables at the beginning of ## script functions. ## That way, it should be possible to do cheap "let" expressions, -## since the variable will exist before hand so no closure will need +## since the variable will exist beforehand, so no closure will need ## to be created for it. ## Apply this trick to JS, Python et al. (def: #export (storage path) @@ -210,7 +284,7 @@ path-storage ..empty] (case path (^ (/.path/bind register)) - (update@ #bindings (set.add (#///reference.Local register)) + (update@ #bindings (set.add (#///reference/variable.Local register)) path-storage) (^or (^ (/.path/seq left right)) @@ -245,7 +319,7 @@ (^ (/.branch/let [inputS register exprS])) (list@fold for-synthesis - (update@ #bindings (set.add (#///reference.Local register)) + (update@ #bindings (set.add (#///reference/variable.Local register)) synthesis-storage) (list inputS exprS)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux index 02258a7b1..e34c78f71 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux @@ -9,8 +9,7 @@ ["." text ["%" format (#+ format)]] [collection - ["." list ("#@." functor monoid fold)] - ["dict" dictionary (#+ Dictionary)]]]] + ["." list ("#@." functor monoid fold)]]]] ["." // #_ ["#." loop (#+ Transform)] ["//#" /// #_ @@ -18,13 +17,14 @@ ["/" synthesis (#+ Path Synthesis Operation Phase)] [/// [arity (#+ Arity)] - ["#." reference (#+ Register Variable)] + ["#." reference + ["#/." variable (#+ Register Variable)]] ["." phase ("#@." monad)]]]]) (exception: #export (cannot-find-foreign-variable-in-environment {foreign Register} {environment Environment}) (ex.report ["Foreign" (%.nat foreign)] ["Environment" (|> environment - (list@map ////reference.%variable) + (list@map ////reference/variable.format) (text.join-with " "))])) (def: arity-arguments @@ -98,10 +98,10 @@ (monad.map phase.monad (function (_ variable) (case variable - (#////reference.Local register) - (phase@wrap (#////reference.Local (inc register))) + (#////reference/variable.Local register) + (phase@wrap (#////reference/variable.Local (inc register))) - (#////reference.Foreign register) + (#////reference/variable.Foreign register) (find-foreign super register))) sub)) @@ -127,10 +127,10 @@ (case reference (#////reference.Variable variable) (case variable - (#////reference.Local register) + (#////reference/variable.Local register) (phase@wrap (/.variable/local (inc register))) - (#////reference.Foreign register) + (#////reference/variable.Foreign register) (|> register (find-foreign environment) (phase@map (|>> /.variable)))) @@ -154,6 +154,11 @@ thenS' (grow environment thenS) elseS' (grow environment elseS)] (wrap (/.branch/if [testS' thenS' elseS']))) + + (#/.Get members inputS) + (do phase.monad + [inputS' (grow environment inputS)] + (wrap (/.branch/get [members inputS']))) (#/.Case [inputS pathS]) (do phase.monad diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux index f4cc28012..5aa644e18 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux @@ -5,11 +5,11 @@ [control ["p" parser]] [data - ["." maybe ("#;." monad)] + ["." maybe ("#@." monad)] [number ["n" nat]] [collection - ["." list ("#;." functor)]]] + ["." list ("#@." functor)]]] [macro ["." code] ["." syntax]]] @@ -20,7 +20,8 @@ ["#." analysis (#+ Environment)] ["/" synthesis (#+ Path Abstraction Synthesis)] [/// - ["#." reference (#+ Register Variable)]]]]) + ["#." reference + ["#/." variable (#+ Register Variable)]]]]]) (type: #export (Transform a) (-> a (Maybe a))) @@ -44,7 +45,7 @@ (-> Synthesis Bit) (case exprS (^ (self)) - improper + ..improper (#/.Structure structure) (case structure @@ -69,7 +70,7 @@ (proper? bodyS) _ - proper))) + ..proper))) (#/.Let inputS register bodyS) (and (proper? inputS) @@ -78,7 +79,10 @@ (#/.If inputS thenS elseS) (and (proper? inputS) (proper? thenS) - (proper? elseS))) + (proper? elseS)) + + (#/.Get members inputS) + (proper? inputS)) (#/.Loop loopS) (case loopS @@ -92,7 +96,7 @@ (#/.Function functionS) (case functionS (#/.Abstraction environment arity bodyS) - (list.every? ///reference.self? environment) + (list.every? ///reference/variable.self? environment) (#/.Apply funcS argsS) (and (proper? funcS) @@ -102,7 +106,7 @@ (list.every? proper? argsS) _ - proper)) + ..proper)) (def: (path-recursion synthesis-recursion) (-> (Transform Synthesis) (Transform Path)) @@ -118,10 +122,10 @@ #.None)) (#/.Seq leftS rightS) - (maybe;map (|>> (#/.Seq leftS)) (recur rightS)) + (maybe@map (|>> (#/.Seq leftS)) (recur rightS)) (#/.Then bodyS) - (maybe;map (|>> #/.Then) (synthesis-recursion bodyS)) + (maybe@map (|>> #/.Then) (synthesis-recursion bodyS)) _ #.None))) @@ -137,10 +141,10 @@ (#/.Case inputS pathS) (|> pathS (path-recursion recur) - (maybe;map (|>> (#/.Case inputS) #/.Branch #/.Control))) + (maybe@map (|>> (#/.Case inputS) #/.Branch #/.Control))) (#/.Let inputS register bodyS) - (maybe;map (|>> (#/.Let inputS register) #/.Branch #/.Control) + (maybe@map (|>> (#/.Let inputS register) #/.Branch #/.Control) (recur bodyS)) (#/.If inputS thenS elseS) @@ -152,7 +156,10 @@ (maybe.default thenS thenS') (maybe.default elseS elseS')) #/.Branch #/.Control)) - #.None))) + #.None)) + + (#/.Get members inputS) + #.None) (^ (#/.Function (recursive-apply argsS))) (if (n.= arity (list.size argsS)) @@ -169,7 +176,7 @@ (-> Environment (Transform Variable)) (function (_ variable) (case variable - (#///reference.Foreign register) + (#///reference/variable.Foreign register) (list.nth register environment) _ @@ -191,7 +198,7 @@ ([#/.Alt] [#/.Seq]) (#/.Then bodyS) - (|> bodyS adjust-synthesis (maybe;map (|>> #/.Then))) + (|> bodyS adjust-synthesis (maybe@map (|>> #/.Then))) _ (#.Some pathS)))) @@ -213,7 +220,7 @@ (#///analysis.Tuple membersS+) (|> membersS+ (monad.map maybe.monad recur) - (maybe;map (|>> #///analysis.Tuple #/.Structure)))) + (maybe@map (|>> #///analysis.Tuple #/.Structure)))) (#/.Reference reference) (case reference @@ -226,7 +233,7 @@ (^ (///reference.foreign register)) (|> scope-environment (list.nth register) - (maybe;map (|>> #///reference.Variable #/.Reference)))) + (maybe@map (|>> #///reference.Variable #/.Reference)))) (^ (/.branch/case [inputS pathS])) (do maybe.monad @@ -260,7 +267,7 @@ (^ (/.loop/recur argsS)) (|> argsS (monad.map maybe.monad recur) - (maybe;map (|>> /.loop/recur))) + (maybe@map (|>> /.loop/recur))) (^ (/.function/abstraction [environment arity bodyS])) @@ -279,7 +286,7 @@ (#/.Extension [name argsS]) (|> argsS (monad.map maybe.monad recur) - (maybe;map (|>> [name] #/.Extension))) + (maybe@map (|>> [name] #/.Extension))) _ (#.Some exprS)))) @@ -292,5 +299,5 @@ (proper? bodyS)) (|> bodyS (adjust environment num-locals) - (maybe;map (|>> [(inc num-locals) inits] /.loop/scope))) + (maybe@map (|>> [(inc num-locals) inits] /.loop/scope))) #.None))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux index 7519df0a2..a88d986fc 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux @@ -6,15 +6,15 @@ [control ["ex" exception (#+ exception:)]] [data - ["." bit ("#;." equivalence)] - ["." text ("#;." equivalence) + ["." bit ("#@." equivalence)] + ["." text ("#@." equivalence) ["%" format (#+ Format format)]] [number ["n" nat] ["i" int] ["f" frac]] [collection - ["." list ("#;." functor)] + ["." list ("#@." functor)] ["." dictionary (#+ Dictionary)]]]] ["." // #_ ["#." analysis (#+ Environment Composite Analysis)] @@ -22,7 +22,8 @@ ["." extension (#+ Extension)]] [/// [arity (#+ Arity)] - ["#." reference (#+ Register Variable Reference)] + ["#." reference (#+ Reference) + ["#/." variable (#+ Register Variable)]] ["#." phase]]]) (type: #export Resolver (Dictionary Variable Variable)) @@ -32,7 +33,7 @@ (def: #export fresh-resolver Resolver - (dictionary.new //reference.hash)) + (dictionary.new //reference/variable.hash)) (def: #export init State @@ -75,6 +76,7 @@ (type: #export (Branch s) (#Let s Register s) (#If s s s) + (#Get (List Member) s) (#Case s (Path' s))) (type: #export (Scope s) @@ -246,6 +248,7 @@ [branch/case #..Branch #..Case] [branch/let #..Branch #..Let] [branch/if #..Branch #..If] + [branch/get #..Branch #..Get] [loop/recur #..Loop #..Recur] [loop/scope #..Loop #..Scope] @@ -331,12 +334,12 @@ (#//analysis.Tuple members) (|> members - (list;map %synthesis) + (list@map %synthesis) (text.join-with " ") (text.enclose ["[" "]"]))) (#Reference reference) - (//reference.%reference reference) + (//reference.format reference) (#Control control) (case control @@ -346,14 +349,14 @@ (|> (%synthesis body) (format (%.nat arity) " ") (format (|> environment - (list;map //reference.%variable) + (list@map //reference/variable.format) (text.join-with " ") (text.enclose ["[" "]"])) " ") (text.enclose ["(" ")"])) (#Apply func args) - (|> (list;map %synthesis args) + (|> (list@map %synthesis args) (text.join-with " ") (format (%synthesis func) " ") (text.enclose ["(" ")"]))) @@ -367,6 +370,12 @@ (#If test then else) (|> (format (%synthesis test) " " (%synthesis then) " " (%synthesis else)) (text.enclose ["(#if " ")"])) + + (#Get members record) + (|> (format (%.list (%path' %synthesis) + (list@map (|>> #Member #Access) members)) + " " (%synthesis record)) + (text.enclose ["(#get " ")"])) (#Case input path) (|> (format (%synthesis input) " " (%path' %synthesis path)) @@ -377,7 +386,7 @@ "???") (#Extension [name args]) - (|> (list;map %synthesis args) + (|> (list@map %synthesis args) (text.join-with " ") (format (%.text name)) (text.enclose ["(" ")"])))) @@ -392,9 +401,9 @@ (^template [<tag> <eq> <format>] [(<tag> reference') (<tag> sample')] (<eq> reference' sample')) - ([#Bit bit;= %.bit] + ([#Bit bit@= %.bit] [#F64 f.= %.frac] - [#Text text;= %.text]) + [#Text text@= %.text]) [(#I64 reference') (#I64 sample')] (i.= (.int reference') (.int sample')) diff --git a/stdlib/source/lux/tool/compiler/reference.lux b/stdlib/source/lux/tool/compiler/reference.lux index 79f6c921e..abcbe1162 100644 --- a/stdlib/source/lux/tool/compiler/reference.lux +++ b/stdlib/source/lux/tool/compiler/reference.lux @@ -1,46 +1,38 @@ (.module: [lux #* [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)]] + [equivalence (#+ Equivalence)]] [control - pipe] + [pipe (#+ case>)]] [data + ["." name] [number ["n" nat]] [text - ["%" format (#+ Format format)]]]]) + ["%" format (#+ Format)]]]] + ["." / #_ + ["#." variable (#+ Variable)]]) -(type: #export Register Nat) - -(type: #export Variable - (#Local Register) - (#Foreign Register)) +(type: #export Constant + Name) (type: #export Reference (#Variable Variable) - (#Constant Name)) + (#Constant Constant)) + +(structure: #export equivalence + (Equivalence Reference) -(structure: #export equivalence (Equivalence Variable) (def: (= reference sample) (case [reference sample] - (^template [<tag>] - [(<tag> reference') (<tag> sample')] - (n.= reference' sample')) - ([#Local] [#Foreign]) + (^template [<tag> <equivalence>] + [(<tag> reference) (<tag> sample)] + (:: <equivalence> = reference sample)) + ([#Variable /variable.equivalence] + [#Constant name.equivalence]) _ - #0))) - -(structure: #export hash (Hash Variable) - (def: &equivalence ..equivalence) - (def: (hash var) - (case var - (#Local register) - (n.* 1 register) - - (#Foreign register) - (n.* 2 register)))) + false))) (template [<name> <family> <tag>] [(template: #export (<name> content) @@ -48,8 +40,8 @@ <tag> content))] - [local #..Variable #..Local] - [foreign #..Variable #..Foreign] + [local #..Variable #/variable.Local] + [foreign #..Variable #/variable.Foreign] ) (template [<name> <tag>] @@ -63,29 +55,10 @@ (def: #export self Reference (..local 0)) -(def: #export self? - (-> Variable Bit) - (|>> ..variable - (case> (^ (..local 0)) - #1 - - _ - #0))) - -(def: #export (%variable variable) - (Format Variable) - (case variable - (#Local local) - (format "+" (%.nat local)) - - (#Foreign foreign) - (format "-" (%.nat foreign)))) - -(def: #export (%reference reference) +(def: #export format (Format Reference) - (case reference - (#Variable variable) - (%variable variable) - - (#Constant constant) - (%.name constant))) + (|>> (case> (#Variable variable) + (/variable.format variable) + + (#Constant constant) + (%.name constant)))) diff --git a/stdlib/source/lux/tool/compiler/reference/variable.lux b/stdlib/source/lux/tool/compiler/reference/variable.lux new file mode 100644 index 000000000..10c080c6e --- /dev/null +++ b/stdlib/source/lux/tool/compiler/reference/variable.lux @@ -0,0 +1,59 @@ +(.module: + [lux #* + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]] + [control + [pipe (#+ case>)]] + [data + [number + ["n" nat] + ["i" int]] + [text + ["%" format (#+ Format)]]]]) + +(type: #export Register Nat) + +(type: #export Variable + (#Local Register) + (#Foreign Register)) + +(structure: #export equivalence + (Equivalence Variable) + + (def: (= reference sample) + (case [reference sample] + (^template [<tag>] + [(<tag> reference') (<tag> sample')] + (n.= reference' sample')) + ([#Local] [#Foreign]) + + _ + #0))) + +(structure: #export hash + (Hash Variable) + + (def: &equivalence ..equivalence) + (def: hash + (|>> (case> (#Local register) + register + + (#Foreign register) + (|> register .int (i.* -1) .nat))))) + +(def: #export self? + (-> Variable Bit) + (|>> (case> (^ (#Local 0)) + true + + _ + false))) + +(def: #export format + (Format Variable) + (|>> (case> (#Local local) + (%.format "+" (%.nat local)) + + (#Foreign foreign) + (%.format "-" (%.nat foreign))))) diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index 56be46610..7fc1c428d 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -20,6 +20,7 @@ ["#." try] ["#." io] ["#." parser + ["#/." analysis] ["#/." text] ["#/." cli]] ["#." pipe] @@ -57,6 +58,7 @@ Test ($_ _.and /parser.test + /parser/analysis.test /parser/text.test /parser/cli.test )) diff --git a/stdlib/source/test/lux/control/parser/analysis.lux b/stdlib/source/test/lux/control/parser/analysis.lux new file mode 100644 index 000000000..397b2c779 --- /dev/null +++ b/stdlib/source/test/lux/control/parser/analysis.lux @@ -0,0 +1,146 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." try] + ["." exception] + ["<>" parser]] + [data + ["." name ("#@." equivalence)] + ["." bit ("#@." equivalence)] + ["." text ("#@." equivalence)] + [number + ["n" nat] + ["i" int] + ["f" frac] + ["r" rev]] + [collection + ["." list]]] + [math + ["." random (#+ Random)]] + [tool + [compiler + [reference (#+ Constant)] + [language + [lux + ["." analysis]]]]]] + {1 + ["." /]}) + +(template: (!expect <expectation> <computation>) + (case <computation> + <expectation> + true + + _ + false)) + +(def: constant + (Random Constant) + (random.and (random.unicode 10) + (random.unicode 10))) + +(def: #export test + Test + (<| (_.covering /._) + (_.with-cover [/.Parser]) + (do {@ random.monad} + [] + (`` ($_ _.and + (do {@ random.monad} + [expected (:: @ map (|>> analysis.bit) random.bit)] + (_.cover [/.run /.any] + (|> (list expected) + (/.run /.any) + (case> (#try.Success actual) + (:: analysis.equivalence = expected actual) + + (#try.Failure _) + false)))) + (~~ (template [<query> <check> <random> <analysis> <=>] + [(do {@ random.monad} + [expected <random>] + (_.cover [<query>] + (|> (list (<analysis> expected)) + (/.run <query>) + (case> (#try.Success actual) + (<=> expected actual) + + (#try.Failure _) + false)))) + (do {@ random.monad} + [expected <random>] + (_.cover [<check>] + (|> (list (<analysis> expected)) + (/.run (<check> expected)) + (!expect (#try.Success _)))))] + + [/.bit /.bit! random.bit analysis.bit bit@=] + [/.nat /.nat! random.nat analysis.nat n.=] + [/.int /.int! random.int analysis.int i.=] + [/.frac /.frac! random.frac analysis.frac f.=] + [/.rev /.rev! random.rev analysis.rev r.=] + [/.text /.text! (random.unicode 10) analysis.text text@=] + [/.local /.local! random.nat analysis.variable/local n.=] + [/.foreign /.foreign! random.nat analysis.variable/foreign n.=] + [/.constant /.constant! ..constant analysis.constant name@=] + )) + (do {@ random.monad} + [expected random.bit] + (_.cover [/.tuple] + (|> (list (analysis.tuple (list (analysis.bit expected)))) + (/.run (/.tuple /.bit)) + (case> (#try.Success actual) + (bit@= expected actual) + + (#try.Failure _) + false)))) + (do {@ random.monad} + [dummy random.bit] + (_.cover [/.end?] + (and (|> (/.run /.end? (list)) + (!expect (#try.Success #1))) + (|> (/.run (do <>.monad + [verdict /.end? + _ /.bit] + (wrap verdict)) + (list (analysis.bit dummy))) + (!expect (#try.Success #0)))))) + (do {@ random.monad} + [dummy random.bit] + (_.cover [/.end!] + (and (|> (/.run /.end! (list)) + (!expect (#try.Success _))) + (|> (/.run /.end! (list (analysis.bit dummy))) + (!expect (#try.Failure _)))))) + (do {@ random.monad} + [expected random.bit] + (_.cover [/.cannot-parse] + (and (|> (list (analysis.bit expected)) + (/.run /.nat) + (case> (#try.Success _) + false + + (#try.Failure error) + (exception.match? /.cannot-parse error))) + (|> (list) + (/.run /.bit) + (case> (#try.Success _) + false + + (#try.Failure error) + (exception.match? /.cannot-parse error)))))) + (do {@ random.monad} + [expected random.bit] + (_.cover [/.unconsumed-input] + (|> (list (analysis.bit expected) (analysis.bit expected)) + (/.run /.bit) + (case> (#try.Success _) + false + + (#try.Failure error) + (exception.match? /.unconsumed-input error))))) + ))))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux index 5f9f14321..d084e0210 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux @@ -1,15 +1,19 @@ (.module: [lux #* - [abstract ["." monad (#+ do)]] - [data - ["." name] - [number - ["n" nat]]] - ["r" math/random (#+ Random) ("#@." monad)] ["_" test (#+ Test)] + [abstract + ["." monad (#+ do)]] [control pipe - ["." try ("#@." functor)]]] + ["." try ("#@." functor)]] + [data + ["." sum] + [number + ["n" nat]] + [collection + ["." list ("#@." fold monoid)]]] + [math + ["." random (#+ Random) ("#@." monad)]]] ["." // #_ ["#." primitive]] {1 @@ -22,32 +26,33 @@ ["#." analysis (#+ Branch Analysis)] ["#." synthesis (#+ Synthesis)] [/// - ["#." reference] + ["#." reference + [variable (#+ Register)]] ["." phase] [meta ["." archive]]]]]]]}) -(def: dummy-vars +(def: masking-test Test - (do {@ r.monad} + (do {@ random.monad} [maskedA //primitive.primitive - temp (|> r.nat (:: @ map (n.% 100))) + temp (|> random.nat (:: @ map (n.% 100))) #let [maskA (////analysis.control/case [maskedA [[(#////analysis.Bind temp) (#////analysis.Reference (////reference.local temp))] (list)]])]] - (_.test "Dummy variables created to mask expressions get eliminated during synthesis." - (|> maskA - (//.phase archive.empty) - (phase.run [///bundle.empty ////synthesis.init]) - (try@map (//primitive.corresponds? maskedA)) - (try.default false))))) + (_.cover [/.synthesize-masking] + (|> maskA + (//.phase archive.empty) + (phase.run [///bundle.empty ////synthesis.init]) + (try@map (//primitive.corresponds? maskedA)) + (try.default false))))) -(def: let-expr +(def: let-test Test - (do r.monad - [registerA r.nat + (do random.monad + [registerA random.nat inputA //primitive.primitive outputA //primitive.primitive #let [letA (////analysis.control/case @@ -55,22 +60,22 @@ [[(#////analysis.Bind registerA) outputA] (list)]])]] - (_.test "Can detect and reify simple 'let' expressions." - (|> letA - (//.phase archive.empty) - (phase.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.branch/let [inputS registerS outputS]))) - (and (n.= registerA registerS) - (//primitive.corresponds? inputA inputS) - (//primitive.corresponds? outputA outputS)) + (_.cover [/.synthesize-let] + (|> letA + (//.phase archive.empty) + (phase.run [///bundle.empty ////synthesis.init]) + (case> (^ (#try.Success (////synthesis.branch/let [inputS registerS outputS]))) + (and (n.= registerA registerS) + (//primitive.corresponds? inputA inputS) + (//primitive.corresponds? outputA outputS)) - _ - false))))) + _ + false))))) -(def: if-expr +(def: if-test Test - (do r.monad - [then|else r.bit + (do random.monad + [then|else random.bit inputA //primitive.primitive thenA //primitive.primitive elseA //primitive.primitive @@ -83,23 +88,83 @@ ifA (if then|else (////analysis.control/case [inputA [thenB (list elseB)]]) (////analysis.control/case [inputA [elseB (list thenB)]]))]] - (_.test "Can detect and reify simple 'if' expressions." - (|> ifA - (//.phase archive.empty) - (phase.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.branch/if [inputS thenS elseS]))) - (and (//primitive.corresponds? inputA inputS) - (//primitive.corresponds? thenA thenS) - (//primitive.corresponds? elseA elseS)) + (_.cover [/.synthesize-if] + (|> ifA + (//.phase archive.empty) + (phase.run [///bundle.empty ////synthesis.init]) + (case> (^ (#try.Success (////synthesis.branch/if [inputS thenS elseS]))) + (and (//primitive.corresponds? inputA inputS) + (//primitive.corresponds? thenA thenS) + (//primitive.corresponds? elseA elseS)) + + _ + false))))) + +(def: random-member + (Random ////synthesis.Member) + (do {@ random.monad} + [lefts (|> random.nat (:: @ map (n.% 10))) + right? random.bit] + (wrap (if right? + (#.Right lefts) + (#.Left lefts))))) + +(def: random-path + (Random (////analysis.Tuple ////synthesis.Member)) + (do {@ random.monad} + [size-1 (|> random.nat (:: @ map (|>> (n.% 10) inc)))] + (random.list size-1 ..random-member))) + +(def: (get-pattern path) + (-> (////analysis.Tuple ////synthesis.Member) + (Random [////analysis.Pattern Register])) + (do random.monad + [@member random.nat] + (wrap [(list@fold (function (_ member inner) + (case member + (#.Left lefts) + (////analysis.pattern/tuple + (list@compose (list.repeat lefts (////analysis.pattern/unit)) + (list inner (////analysis.pattern/unit)))) + + (#.Right lefts) + (////analysis.pattern/tuple + (list@compose (list.repeat (inc lefts) (////analysis.pattern/unit)) + (list inner))))) + (#////analysis.Bind @member) + (list.reverse path)) + @member]))) + +(def: get-test + Test + (do {@ random.monad} + [recordA (|> random.nat + (:: @ map (|>> ////analysis.nat)) + (random.list 10) + (:: @ map (|>> ////analysis.tuple))) + pathA ..random-path + [pattern @member] (get-pattern pathA) + #let [getA (////analysis.control/case [recordA [[pattern + (#////analysis.Reference (////reference.local @member))] + (list)]])]] + (_.cover [/.synthesize-get] + (|> getA + (//.phase archive.empty) + (phase.run [///bundle.empty ////synthesis.init]) + (case> (^ (#try.Success (////synthesis.branch/get [pathS recordS]))) + (and (:: (list.equivalence (sum.equivalence n.= n.=)) = pathA pathS) + (//primitive.corresponds? recordA recordS)) - _ - false))))) + _ + false))))) (def: #export test Test - (<| (_.context (name.module (name-of /._))) + (<| (_.covering /._) + (_.with-cover [/.synthesize]) ($_ _.and - ..dummy-vars - ..let-expr - ..if-expr + ..masking-test + ..let-test + ..if-test + ..get-test ))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux index 799a8a526..7350881b1 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux @@ -16,7 +16,7 @@ ["n" nat]] [collection ["." list ("#@." functor fold)] - ["dict" dictionary (#+ Dictionary)] + ["." dictionary (#+ Dictionary)] ["." set]]]] ["." // #_ ["#." primitive]] @@ -31,7 +31,8 @@ ["#." synthesis (#+ Synthesis)] [/// [arity (#+ Arity)] - ["#." reference (#+ Variable) ("variable@." equivalence)] + ["#." reference + ["." variable (#+ Variable) ("#@." equivalence)]] ["." phase] [meta ["." archive]]]]]]]}) @@ -61,16 +62,16 @@ (do {@ r.monad} [num-locals (|> r.nat (:: @ map (|>> (n.% 100) (n.max 10)))) #let [indices (list.n/range 0 (dec num-locals)) - local-env (list@map (|>> #////reference.Local) indices) - foreign-env (list@map (|>> #////reference.Foreign) indices)] + local-env (list@map (|>> #variable.Local) indices) + foreign-env (list@map (|>> #variable.Foreign) indices)] [arity bodyA predictionA] (: (Random [Arity Analysis Variable]) (loop [arity 1 current-env foreign-env] (let [current-env/size (list.size current-env) resolver (list@fold (function (_ [idx var] resolver) - (dict.put idx var resolver)) + (dictionary.put idx var resolver)) (: (Dictionary Nat Variable) - (dict.new n.hash)) + (dictionary.new n.hash)) (list.enumerate current-env))] (do @ [nest? r.bit] @@ -83,7 +84,7 @@ (list@map (function (_ pick) (maybe.assume (list.nth pick current-env))) picks)) - #let [picked-env (list@map (|>> #////reference.Foreign) picks)]] + #let [picked-env (list@map (|>> #variable.Foreign) picks)]] (wrap [arity (#////analysis.Function picked-env bodyA) predictionA])) @@ -91,7 +92,7 @@ [chosen (pick (list.size current-env))] (wrap [arity (#////analysis.Reference (////reference.foreign chosen)) - (maybe.assume (dict.get chosen resolver))])))))))] + (maybe.assume (dictionary.get chosen resolver))])))))))] (wrap [arity (#////analysis.Function local-env bodyA) predictionA]))) @@ -111,7 +112,7 @@ [chosen (|> r.nat (:: @ map (|>> (n.% 100) (n.max 2))))] (wrap [arity (#////analysis.Reference (////reference.local chosen)) - (|> chosen (n.+ (dec arity)) #////reference.Local)]))))) + (|> chosen (n.+ (dec arity)) #variable.Local)]))))) (def: abstraction Test diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/primitive.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/primitive.lux index cd7fe54eb..40f9efad4 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/primitive.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/primitive.lux @@ -1,14 +1,18 @@ (.module: [lux (#- primitive) [abstract ["." monad (#+ do)]] + [control + [pipe (#+ case>)] + ["." try]] [data ["%" text/format (#+ format)] - ["." name]] + ["." name] + [number + ["n" nat]] + [collection + ["." list]]] ["r" math/random (#+ Random) ("#@." monad)] - ["_" test (#+ Test)] - [control - pipe - ["." try]]] + ["_" test (#+ Test)]] {1 ["." / #_ ["/#" // @@ -54,6 +58,14 @@ [#////analysis.Frac (|>) #////synthesis.F64 (|>)] [#////analysis.Text (|>) #////synthesis.Text (|>)] )) + + (^ [(////analysis.tuple expected) + (////synthesis.tuple actual)]) + (and (n.= (list.size expected) + (list.size actual)) + (list.every? (function (_ [expected actual]) + (corresponds? expected actual)) + (list.zip2 expected actual))) _ false))) |