diff options
Diffstat (limited to '')
6 files changed, 182 insertions, 146 deletions
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux index 44b627b6c..33e94f89a 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux @@ -50,42 +50,46 @@ (phase@wrap (#/.Primitive (..primitive analysis'))) (#///analysis.Structure structure) - (case structure - (#///analysis.Variant variant) - (do phase.monad - [valueS (phase' (get@ #///analysis.value variant))] - (wrap (/.variant (set@ #///analysis.value valueS variant)))) + (/.with-currying? false + (case structure + (#///analysis.Variant variant) + (do phase.monad + [valueS (phase' (get@ #///analysis.value variant))] + (wrap (/.variant (set@ #///analysis.value valueS variant)))) - (#///analysis.Tuple tuple) - (|> tuple - (monad.map phase.monad phase') - (phase@map (|>> /.tuple)))) + (#///analysis.Tuple tuple) + (|> tuple + (monad.map phase.monad phase') + (phase@map (|>> /.tuple))))) (#///analysis.Reference reference) (phase@wrap (#/.Reference reference)) (#///analysis.Case inputA branchesAB+) - (/case.synthesize phase branchesAB+ archive inputA) + (/.with-currying? false + (/case.synthesize phase branchesAB+ archive inputA)) (^ (///analysis.no-op value)) (phase' value) (#///analysis.Apply _) - (/function.apply phase archive analysis) + (/.with-currying? false + (/function.apply phase archive analysis)) (#///analysis.Function environmentA bodyA) (/function.abstraction phase environmentA archive bodyA) (#///analysis.Extension name args) - (function (_ state) - (|> (//extension.apply archive phase [name args]) - (phase.run' state) - (case> (#try.Success output) - (#try.Success output) - - (#try.Failure _) - (<| (phase.run' state) - (do {@ phase.monad} - [argsS+ (monad.map @ phase' args)] - (wrap (#/.Extension [name argsS+]))))))) + (/.with-currying? false + (function (_ state) + (|> (//extension.apply archive phase [name args]) + (phase.run' state) + (case> (#try.Success output) + (#try.Success output) + + (#try.Failure _) + (|> args + (monad.map phase.monad phase') + (phase@map (|>> [name] #/.Extension)) + (phase.run' state)))))) ))) 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 890722aeb..358a63c31 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 @@ -3,19 +3,20 @@ [abstract ["." monad (#+ do)]] [control - [pipe (#+ case>)] ["." exception (#+ exception:)]] [data ["." maybe] ["." text ["%" format (#+ format)]] + [number + ["n" nat]] [collection ["." list ("#@." functor monoid fold)]]]] ["." // #_ ["#." loop (#+ Transform)] ["//#" /// #_ ["#." analysis (#+ Environment Analysis)] - ["/" synthesis (#+ Path Synthesis Operation Phase)] + ["/" synthesis (#+ Path Abstraction Synthesis Operation Phase)] [/// [arity (#+ Arity)] ["#." reference @@ -52,11 +53,14 @@ (with-expansions [<apply> (as-is (/.function/apply [funcS argsS]))] (case funcS (^ (/.function/abstraction functionS)) - (do @ - [locals /.locals] - (wrap (|> functionS - (//loop.optimization locals argsS) - (maybe.default <apply>)))) + (if (n.= (get@ #/.arity functionS) + (list.size argsS)) + (do @ + [locals /.locals] + (wrap (|> functionS + (//loop.optimization true locals argsS) + (maybe.default <apply>)))) + (wrap <apply>)) (^ (/.function/apply [funcS' argsS'])) (wrap (/.function/apply [funcS' (list@compose argsS' argsS)])) @@ -211,13 +215,31 @@ (def: #export (abstraction phase environment archive bodyA) (-> Phase Environment Phase) (do {@ phase.monad} - [bodyS (/.with-locals 2 - (phase archive bodyA))] - (case bodyS - (^ (/.function/abstraction [env' down-arity' bodyS'])) - (|> bodyS' - (grow env') - (:: @ map (|>> [environment (inc down-arity')] /.function/abstraction))) - - _ - (wrap (/.function/abstraction [environment 1 bodyS]))))) + [currying? /.currying? + bodyS (/.with-currying? true + (/.with-locals 2 + (phase archive bodyA))) + abstraction (: (Operation Abstraction) + (case bodyS + (^ (/.function/abstraction [env' down-arity' bodyS'])) + (|> bodyS' + (grow env') + (:: @ map (function (_ body) + {#/.environment environment + #/.arity (inc down-arity') + #/.body body}))) + + _ + (wrap {#/.environment environment + #/.arity 1 + #/.body bodyS})))] + (wrap (if currying? + (/.function/abstraction abstraction) + (case (//loop.optimization false 1 (list) abstraction) + (#.Some loop-body) + (/.function/abstraction {#/.environment environment + #/.arity (get@ #/.arity abstraction) + #/.body loop-body}) + + #.None + (/.function/abstraction abstraction)))))) 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 b4a43ce23..9301292f8 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 @@ -23,14 +23,18 @@ (-> Register (-> Register Register)) (|>> dec (n.+ offset))) -(def: (variable-optimization offset environment variable) - (-> Register Environment (Transform Variable)) +(def: (variable-optimization true-loop? offset environment variable) + (-> Bit Register Environment (Transform Variable)) (case variable (^ (variable.self)) - #.None + (if true-loop? + #.None + (#.Some variable)) (#variable.Foreign register) - (list.nth register environment) + (if true-loop? + (list.nth register environment) + (#.Some variable)) (#variable.Local register) (#.Some (#variable.Local (register-optimization offset register))))) @@ -58,8 +62,8 @@ _ (#.Some path)))) -(def: (body-optimization offset scope-environment arity expr) - (-> Register Environment Arity (Transform Synthesis)) +(def: (body-optimization true-loop? offset scope-environment arity expr) + (-> Bit Register Environment Arity (Transform Synthesis)) (loop [return? true expr expr] (case expr @@ -83,7 +87,9 @@ (#/.Reference reference) (case reference (^ (#reference.Variable (variable.self))) - #.None + (if true-loop? + #.None + (#.Some expr)) (^ (reference.constant constant)) (#.Some expr) @@ -92,9 +98,11 @@ (#.Some (#/.Reference (reference.local (register-optimization offset register)))) (^ (reference.foreign register)) - (|> scope-environment - (list.nth register) - (maybe@map (|>> #reference.Variable #/.Reference)))) + (if true-loop? + (|> scope-environment + (list.nth register) + (maybe@map (|>> /.variable))) + (#.Some expr))) (^ (/.branch/case [input path])) (do maybe.monad @@ -137,35 +145,35 @@ (^ (/.function/abstraction [environment arity body])) (do {@ maybe.monad} - [environment' (monad.map @ (variable-optimization offset scope-environment) + [environment' (monad.map @ (variable-optimization true-loop? offset scope-environment) environment)] (wrap (/.function/abstraction [environment' arity body]))) (^ (/.function/apply [abstraction arguments])) (do {! maybe.monad} [arguments' (monad.map maybe.monad (recur false) arguments)] - (case abstraction - (^ (#/.Reference (#reference.Variable (variable.self)))) - (if (and return? - (n.= arity (list.size arguments))) - (wrap (/.loop/recur arguments')) - #.None) - - _ - (do ! - [abstraction' (recur false abstraction)] - (wrap (/.function/apply [abstraction' arguments']))))) + (with-expansions [<application> (as-is (do ! + [abstraction' (recur false abstraction)] + (wrap (/.function/apply [abstraction' arguments']))))] + (case abstraction + (^ (#/.Reference (#reference.Variable (variable.self)))) + (if (and return? + (n.= arity (list.size arguments))) + (wrap (/.loop/recur arguments')) + (if true-loop? + #.None + <application>)) + + _ + <application>))) (#/.Extension [name args]) (|> args (monad.map maybe.monad (recur false)) (maybe@map (|>> [name] #/.Extension)))))) -(def: #export (optimization offset inits functionS) - (-> Register (List Synthesis) Abstraction (Maybe Synthesis)) - (if (n.= (get@ #/.arity functionS) - (list.size inits)) - (|> (get@ #/.body functionS) - (body-optimization offset (get@ #/.environment functionS) (get@ #/.arity functionS)) - (maybe@map (|>> [offset inits] /.loop/scope))) - #.None)) +(def: #export (optimization true-loop? offset inits functionS) + (-> Bit Register (List Synthesis) Abstraction (Maybe Synthesis)) + (|> (get@ #/.body functionS) + (body-optimization true-loop? offset (get@ #/.environment functionS) (get@ #/.arity functionS)) + (maybe@map (|>> [offset inits] /.loop/scope)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux index 06f84d90d..c010b05c3 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux @@ -27,10 +27,13 @@ ["." reference (#+ Reference) ["." variable (#+ Register Variable)]]]]) -(type: #export Resolver (Dictionary Variable Variable)) +(type: #export Resolver + (Dictionary Variable Variable)) (type: #export State - {#locals Nat}) + {#locals Nat + ## https://en.wikipedia.org/wiki/Currying + #currying? Bit}) (def: #export fresh-resolver Resolver @@ -38,7 +41,8 @@ (def: #export init State - {#locals 0}) + {#locals 0 + #currying? false}) (type: #export Primitive (#Bit Bit) @@ -180,25 +184,17 @@ (def: #export unit Text "") -(template [<name> <type> <tag>] - [(def: #export (<name> value) +(template [<with> <query> <tag> <type>] + [(def: #export (<with> value) (-> <type> (All [a] (-> (Operation a) (Operation a)))) - (extension.temporary (set@ <tag> value)))] + (extension.temporary (set@ <tag> value))) - [with-locals Nat #locals] - ) - -(def: #export (with-abstraction arity resolver) - (-> Arity Resolver - (All [a] (-> (Operation a) (Operation a)))) - (extension.with-state {#locals arity})) - -(template [<name> <tag> <type>] - [(def: #export <name> + (def: #export <query> (Operation <type>) (extension.read (get@ <tag>)))] - [locals #locals Nat] + [with-locals locals #locals Nat] + [with-currying? currying? #currying? Bit] ) (def: #export with-new-local diff --git a/stdlib/source/test/lux/control/parser/cli.lux b/stdlib/source/test/lux/control/parser/cli.lux index 210a1b5b5..2c781e4fc 100644 --- a/stdlib/source/test/lux/control/parser/cli.lux +++ b/stdlib/source/test/lux/control/parser/cli.lux @@ -1,76 +1,82 @@ (.module: [lux #* - [data - ["." name]] - ["M" abstract/monad (#+ Monad do)] ["_" test (#+ Test)] - ["r" math/random] + [abstract + [monad (#+ do)]] [control - pipe ["." try] - ["p" parser]] + ["<>" parser]] [data [number ["n" nat ("#@." decimal)]] ["." text ("#@." equivalence)] [collection - ["." list]]]] + ["." list]]] + [math + ["." random]]] {1 ["." /]}) +(template: (!expect <pattern> <value>) + (case <value> + <pattern> + true + + _ + false)) + (def: #export test Test - (<| (_.context (name.module (name-of /._))) - (do {@ r.monad} - [num-args (|> r.nat (:: @ map (n.% 10))) - #let [gen-arg (:: @ map n@encode r.nat)] - yes gen-arg - #let [gen-ignore (r.filter (|>> (text@= yes) not) - (r.unicode 5))] - no gen-ignore - pre-ignore (r.list 5 gen-ignore) - post-ignore (r.list 5 gen-ignore)] + (<| (_.covering /._) + (_.with-cover [/.Parser]) + (do {@ random.monad} + [expected (:: @ map n@encode random.nat) + #let [random-dummy (random.filter (|>> (text@= expected) not) + (random.unicode 5))] + dummy random-dummy + short (random.unicode 1) + long (random.unicode 2) + pre-ignore (random.list 5 random-dummy) + post-ignore (random.list 5 random-dummy)] ($_ _.and - (_.test "Can read any argument." - (|> (/.run /.any (list yes)) - (case> (#try.Failure _) - #0 - - (#try.Success arg) - (text@= arg yes)))) - (_.test "Can test tokens." - (and (|> (/.run (/.this yes) (list yes)) - (case> (#try.Failure _) - #0 - - (#try.Success _) - #1)) - (|> (/.run (/.this yes) (list no)) - (case> (#try.Failure _) - #1 - - (#try.Success _) - #0)))) - (_.test "Can use custom token parsers." - (|> (/.run (/.parse n@decode) (list yes)) - (case> (#try.Failure _) - #0 - - (#try.Success parsed) - (text@= (n@encode parsed) - yes)))) - (_.test "Can query if there are any more inputs." - (and (|> (/.run /.end (list)) - (case> (#try.Success []) #1 _ #0)) - (|> (/.run (p.not /.end) (list yes)) - (case> (#try.Success []) #0 _ #1)))) - (_.test "Can parse CLI input anywhere." - (|> (/.run (|> (/.somewhere (/.this yes)) - (p.before (p.some /.any))) - (list.concat (list pre-ignore (list yes) post-ignore))) - (case> (#try.Failure _) - #0 - - (#try.Success _) - #1))) + (_.cover [/.run /.any] + (|> (/.run /.any (list expected)) + (!expect (^multi (#try.Success actual) + (text@= expected actual))))) + (_.cover [/.parse] + (|> (/.run (/.parse n@decode) (list expected)) + (!expect (^multi (#try.Success actual) + (text@= expected + (n@encode actual)))))) + (_.cover [/.this] + (and (|> (/.run (/.this expected) (list expected)) + (!expect (#try.Success _))) + (|> (/.run (/.this expected) (list dummy)) + (!expect (#try.Failure _))))) + (_.cover [/.somewhere] + (|> (/.run (|> (/.somewhere (/.this expected)) + (<>.before (<>.some /.any))) + (list.concat (list pre-ignore (list expected) post-ignore))) + (!expect (#try.Success _)))) + (_.cover [/.end] + (and (|> (/.run /.end (list)) + (!expect (#try.Success _))) + (|> (/.run (<>.not /.end) (list expected)) + (!expect (#try.Failure _))))) + (_.cover [/.named] + (|> (/.run (/.named dummy /.any) (list dummy expected)) + (!expect (^multi (#try.Success actual) + (text@= expected actual))))) + (_.cover [/.parameter] + (and (|> (/.run (/.parameter [short long] /.any) + (list short expected)) + (!expect (^multi (#try.Success actual) + (text@= expected actual)))) + (|> (/.run (/.parameter [short long] /.any) + (list long expected)) + (!expect (^multi (#try.Success actual) + (text@= expected actual)))) + (|> (/.run (/.parameter [short long] /.any) + (list dummy expected)) + (!expect (#try.Failure _))))) )))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/loop.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/loop.lux index adb98ba3a..e42e139d1 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/loop.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/loop.lux @@ -273,7 +273,7 @@ (random.list arity)) [_ [expected iteration]] (..scenario expected-offset arity 0)] (_.cover [/.Transform /.optimization /.register-optimization] - (case (/.optimization expected-offset expected-inits + (case (/.optimization true expected-offset expected-inits {#//.environment (|> expected-offset list.indices (list@map (|>> #variable.Local))) |