diff options
| -rw-r--r-- | stdlib/source/lux/lang/compiler.lux | 46 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/extension.lux | 13 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/synthesis.lux | 118 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/synthesis/case.lux | 51 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/synthesis/expression.lux | 17 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/synthesis/function.lux | 19 | ||||
| -rw-r--r-- | stdlib/test/test/lux/lang/synthesis/case.lux | 10 | ||||
| -rw-r--r-- | stdlib/test/test/lux/lang/synthesis/function.lux | 16 | ||||
| -rw-r--r-- | stdlib/test/test/lux/lang/synthesis/primitive.lux | 4 | ||||
| -rw-r--r-- | stdlib/test/test/lux/lang/synthesis/structure.lux | 9 |
10 files changed, 155 insertions, 148 deletions
diff --git a/stdlib/source/lux/lang/compiler.lux b/stdlib/source/lux/lang/compiler.lux new file mode 100644 index 000000000..c2f9af1e2 --- /dev/null +++ b/stdlib/source/lux/lang/compiler.lux @@ -0,0 +1,46 @@ +(.module: + lux + (lux (control [state] + ["ex" exception #+ Exception exception:] + [monad #+ do]) + (data [product] + [error #+ Error]) + [function])) + +(type: #export (Operation s o) + (state.State' Error s o)) + +(def: #export (run state operation) + (All [s o] + (-> s (Operation s o) (Error o))) + (|> state + operation + (:: error.Monad<Error> map product.right))) + +(def: #export (throw exception parameters) + (All [e] (-> (Exception e) e Operation)) + (state.lift error.Monad<Error> + (ex.throw exception parameters))) + +(def: #export (localized transform) + (All [s o] + (-> (-> s s) + (-> (Operation s o) (Operation s o)))) + (function (_ operation) + (function (_ state) + (case (operation (transform state)) + (#error.Error error) + (#error.Error error) + + (#error.Success [state' output]) + (#error.Success [state output]))))) + +(def: #export (with-state state) + (All [s o] (-> s (-> (Operation s o) (Operation s o)))) + (localized (function.constant state))) + +(def: #export Monad<Operation> + (state.Monad<State'> error.Monad<Error>)) + +(type: #export (Compiler s i o) + (-> i (Operation s o))) diff --git a/stdlib/source/lux/lang/extension.lux b/stdlib/source/lux/lang/extension.lux index 6da453148..d9eb90fc9 100644 --- a/stdlib/source/lux/lang/extension.lux +++ b/stdlib/source/lux/lang/extension.lux @@ -7,8 +7,9 @@ (coll (dictionary ["dict" unordered #+ Dict]))) [macro]) [// #+ Eval] - (// [".L" analysis #+ Analyser] - [".L" synthesis #+ Synthesizer])) + [//compiler #+ Operation Compiler] + [//analysis #+ Analyser] + [//synthesis #+ Synthesizer]) (do-template [<name>] [(exception: #export (<name> {message Text}) @@ -26,11 +27,13 @@ ) (type: #export Analysis - (-> Analyser Eval (List Code) (Meta analysisL.Analysis))) + (-> Analyser Eval (List Code) (Meta //analysis.Analysis))) (type: #export Synthesis - (-> Synthesizer (List analysisL.Analysis) - (synthesisL.Operation synthesisL.Synthesis))) + (-> Synthesizer + (Compiler //synthesis.State + (List //analysis.Analysis) + //synthesis.Synthesis))) (type: #export Translation (-> (List Code) (Meta Code))) diff --git a/stdlib/source/lux/lang/synthesis.lux b/stdlib/source/lux/lang/synthesis.lux index d68b535dc..359ef445a 100644 --- a/stdlib/source/lux/lang/synthesis.lux +++ b/stdlib/source/lux/lang/synthesis.lux @@ -1,15 +1,11 @@ (.module: [lux #- Scope] - (lux (control [state] - ["ex" exception #+ Exception exception:] - [monad #+ do]) - (data [product] - [error #+ Error] - [number] - (coll (dictionary ["dict" unordered #+ Dict]))) - [function]) + (lux (control [monad #+ do]) + (data [error #+ Error] + (coll (dictionary ["dict" unordered #+ Dict])))) [//reference #+ Register Variable Reference] - [//analysis #+ Environment Special Analysis]) + [//analysis #+ Environment Special Analysis] + [//compiler #+ Operation Compiler]) (type: #export Arity Nat) @@ -32,12 +28,6 @@ #direct? false #locals +0}) -(type: (Operation' s o) - (state.State' Error s o)) - -(type: #export (Compiler s i o) - (-> i (Operation' ..State o))) - (type: #export Primitive (#Bool Bool) (#I64 I64) @@ -132,84 +122,42 @@ (type: #export Abstraction (Abstraction' Synthesis)) -(type: #export (Operation a) - (Operation' ..State a)) - (def: #export unit Text "") (type: #export Synthesizer (Compiler ..State Analysis Synthesis)) -(def: #export (throw exception parameters) - (All [e] (-> (Exception e) e Operation')) - (state.lift error.Monad<Error> - (ex.throw exception parameters))) - -(def: #export (run synthesizer analysis) - (-> Synthesizer Analysis (Error Synthesis)) - (:: error.Monad<Error> map product.right - (synthesizer analysis ..init))) - -(def: (localized' transform) - (-> (-> State State) - (All [a] (-> (Operation a) (Operation a)))) - (function (_ operation) - (function (_ state) - (case (operation (transform state)) - (#error.Error error) - (#error.Error error) - - (#error.Success [state' output]) - (#error.Success [state output]))))) - -(def: (localized transform) - (-> (-> State State) - (-> Synthesizer Synthesizer)) - (function (_ synthesize) - (function (_ analysis) - (localized' transform (synthesize analysis))))) - -(do-template [<operation> <synthesizer> <value>] - [(def: #export <operation> - (All [a] (-> (Operation a) (Operation a))) - (localized' (set@ #direct? <value>))) - - (def: #export <synthesizer> - (-> Synthesizer Synthesizer) - (localized (set@ #direct? <value>)))] - - [indirectly' indirectly false] - [directly' directly true] - ) +(do-template [<name> <value>] + [(def: #export <name> + (All [a] (-> (Operation ..State a) (Operation ..State a))) + (//compiler.localized (set@ #direct? <value>)))] -(do-template [<operation> <synthesizer> <type> <tag>] - [(def: #export (<operation> value) - (-> <type> (All [a] (-> (Operation a) (Operation a)))) - (localized' (set@ <tag> value))) + [indirectly false] + [directly true] + ) - (def: #export (<synthesizer> value) - (-> <type> (-> Synthesizer Synthesizer)) - (localized (set@ <tag> value)))] +(do-template [<name> <type> <tag>] + [(def: #export (<name> value) + (-> <type> (All [a] (-> (Operation ..State a) (Operation ..State a)))) + (//compiler.localized (set@ <tag> value)))] - [with-scope-arity' with-scope-arity Arity #scope-arity] - [with-resolver' with-resolver Resolver #resolver] - [with-locals' with-locals Nat #locals] + [with-scope-arity Arity #scope-arity] + [with-resolver Resolver #resolver] + [with-locals Nat #locals] ) -(def: #export (with-state value) - (-> ..State (-> Synthesizer Synthesizer)) - (localized (function.constant value))) - -(def: #export (with-abstraction-state arity resolver) - (-> Arity Resolver (-> Synthesizer Synthesizer)) - (with-state {#scope-arity arity - #resolver resolver - #direct? true - #locals arity})) +(def: #export (with-abstraction arity resolver) + (All [o] + (-> Arity Resolver + (-> (Operation ..State o) (Operation ..State o)))) + (//compiler.with-state {#scope-arity arity + #resolver resolver + #direct? true + #locals arity})) (do-template [<name> <tag> <type>] [(def: #export <name> - (Operation <type>) + (Operation ..State <type>) (function (_ state) (#error.Success [state (get@ <tag> state)])))] @@ -219,13 +167,11 @@ [locals #locals Nat] ) -(def: #export Operation@Monad (state.Monad<State'> error.Monad<Error>)) - -(def: #export with-new-local' - (All [a] (-> (Operation a) (Operation a))) - (<<| (do Operation@Monad +(def: #export with-new-local + (All [a] (-> (Operation ..State a) (Operation ..State a))) + (<<| (do //compiler.Monad<Operation> [locals ..locals]) - (..with-locals' (inc locals)))) + (..with-locals (inc locals)))) (do-template [<name> <tag>] [(template: #export (<name> content) diff --git a/stdlib/source/lux/lang/synthesis/case.lux b/stdlib/source/lux/lang/synthesis/case.lux index 5fe32e62d..85065393d 100644 --- a/stdlib/source/lux/lang/synthesis/case.lux +++ b/stdlib/source/lux/lang/synthesis/case.lux @@ -10,12 +10,13 @@ [number "frac/" Eq<Frac>] (coll [list "list/" Fold<List> Monoid<List>]))) [///reference] + [///compiler #+ Operation "operation/" Monad<Operation>] [///analysis #+ Pattern Match Analysis] - [// #+ Path Synthesis Operation] + [// #+ Path Synthesis] [//function]) (def: (path' pattern bodyC) - (-> Pattern (Operation Path) (Operation Path)) + (-> Pattern (Operation //.State Path) (Operation //.State Path)) (case pattern (#///analysis.Simple simple) (case simple @@ -24,9 +25,8 @@ (^template [<from> <to>] (<from> value) - (:: //.Operation@Monad map - (|>> (#//.Seq (#//.Test (|> value <to>)))) - bodyC)) + (operation/map (|>> (#//.Seq (#//.Test (|> value <to>)))) + bodyC)) ([#///analysis.Bool #//.Bool] [#///analysis.Nat (<| #//.I64 .i64)] [#///analysis.Int (<| #//.I64 .i64)] @@ -35,21 +35,21 @@ [#///analysis.Text #//.Text])) (#///analysis.Bind register) - (do //.Operation@Monad - [arity //.scope-arity] - (:: @ map (|>> (#//.Seq (#//.Bind (if (//function.nested? arity) - (n/+ (dec arity) register) - register)))) - (//.with-new-local' bodyC))) + (<| (do ///compiler.Monad<Operation> + [arity //.scope-arity]) + (:: @ map (|>> (#//.Seq (#//.Bind (if (//function.nested? arity) + (n/+ (dec arity) register) + register))))) + //.with-new-local + bodyC) (#///analysis.Complex _) (case (///analysis.variant-pattern pattern) (#.Some [lefts right? value-pattern]) - (:: //.Operation@Monad map - (|>> (#//.Seq (#//.Access (#//.Side (if right? - (#.Right lefts) - (#.Left lefts)))))) - (path' value-pattern bodyC)) + (operation/map (|>> (#//.Seq (#//.Access (#//.Side (if right? + (#.Right lefts) + (#.Left lefts)))))) + (path' value-pattern bodyC)) #.None (let [tuple (///analysis.tuple-pattern pattern) @@ -64,18 +64,17 @@ (|> (if (or last? (is? bodyC thenC)) thenC - (:: //.Operation@Monad map (|>> (#//.Seq #//.Pop)) thenC)) + (operation/map (|>> (#//.Seq #//.Pop)) thenC)) (path' tuple/member) - (:: //.Operation@Monad map - (|>> (#//.Seq (#//.Access (#//.Member (if last? - (#.Right (dec tuple/idx)) - (#.Left tuple/idx))))))))))) + (operation/map (|>> (#//.Seq (#//.Access (#//.Member (if last? + (#.Right (dec tuple/idx)) + (#.Left tuple/idx))))))))))) bodyC (list.reverse (list.enumerate tuple))))))) (def: #export (path synthesize pattern bodyA) - (-> //.Synthesizer Pattern Analysis (Operation Path)) - (path' pattern (:: //.Operation@Monad map (|>> #//.Then) (synthesize bodyA)))) + (-> //.Synthesizer Pattern Analysis (Operation //.State Path)) + (path' pattern (operation/map (|>> #//.Then) (synthesize bodyA)))) (def: #export (weave leftP rightP) (-> Path Path Path) @@ -124,8 +123,8 @@ <default>))) (def: #export (synthesize synthesize^ inputA [headB tailB+]) - (-> //.Synthesizer Analysis Match (Operation Synthesis)) - (do //.Operation@Monad + (-> //.Synthesizer Analysis Match (Operation //.State Synthesis)) + (do ///compiler.Monad<Operation> [inputS (synthesize^ inputA)] (case [headB tailB+] [[(#///analysis.Bind inputR) headB/bodyA] @@ -139,7 +138,7 @@ _ (do @ [arity //.scope-arity - headB/bodyS (//.with-new-local' + headB/bodyS (//.with-new-local (synthesize^ headB/bodyA))] (wrap (//.branch/let [inputS (if (//function.nested? arity) diff --git a/stdlib/source/lux/lang/synthesis/expression.lux b/stdlib/source/lux/lang/synthesis/expression.lux index aab092777..2985d2d08 100644 --- a/stdlib/source/lux/lang/synthesis/expression.lux +++ b/stdlib/source/lux/lang/synthesis/expression.lux @@ -6,6 +6,7 @@ (coll [list "list/" Functor<List>] (dictionary ["dict" unordered #+ Dict])))) [///reference] + [///compiler "operation/" Monad<Operation>] [///analysis #+ Analysis] [///extension #+ Extension] [// #+ Synthesis] @@ -35,8 +36,6 @@ [#///analysis.Int #//.I64] [#///analysis.Deg #//.I64]))) -(open: "operation/" //.Operation@Monad) - (def: #export (synthesizer extensions) (-> (Extension ///extension.Synthesis) //.Synthesizer) (function (synthesize analysis) @@ -47,17 +46,17 @@ (#///analysis.Structure composite) (case (///analysis.variant analysis) (#.Some variant) - (do //.Operation@Monad + (do ///compiler.Monad<Operation> [valueS (synthesize (get@ #///analysis.value variant))] (wrap (#//.Structure (#//.Variant (set@ #///analysis.value valueS variant))))) _ - (do //.Operation@Monad + (do ///compiler.Monad<Operation> [tupleS (monad.map @ synthesize (///analysis.tuple analysis))] (wrap (#//.Structure (#//.Tuple tupleS))))) (#///analysis.Apply _) - (//function.apply (//.indirectly synthesize) analysis) + (//function.apply (|>> synthesize //.indirectly) analysis) (#///analysis.Function environmentA bodyA) (//function.function synthesize environmentA bodyA) @@ -65,10 +64,10 @@ (#///analysis.Special name args) (case (dict.get name extensions) #.None - (//.throw unknown-synthesis-extension name) + (///compiler.throw unknown-synthesis-extension name) (#.Some extension) - (extension (//.indirectly synthesize) args)) + (extension (|>> synthesize //.indirectly) args)) (#///analysis.Reference reference) (case reference @@ -76,7 +75,7 @@ (operation/wrap (#//.Reference reference)) (#///reference.Variable var) - (do //.Operation@Monad + (do ///compiler.Monad<Operation> [resolver //.resolver] (case var (#///reference.Local register) @@ -96,5 +95,5 @@ (wrap (|> resolver (dict.get var) (maybe.default var) #///reference.Variable #//.Reference))))) (#///analysis.Case inputA branchesAB+) - (//case.synthesize (//.indirectly synthesize) inputA branchesAB+) + (//case.synthesize (|>> synthesize //.indirectly) inputA branchesAB+) ))) diff --git a/stdlib/source/lux/lang/synthesis/function.lux b/stdlib/source/lux/lang/synthesis/function.lux index 8014c3b4a..cc40bea4d 100644 --- a/stdlib/source/lux/lang/synthesis/function.lux +++ b/stdlib/source/lux/lang/synthesis/function.lux @@ -9,12 +9,11 @@ (coll [list "list/" Functor<List> Monoid<List> Fold<List>] (dictionary ["dict" unordered #+ Dict])))) [///reference #+ Variable] + [///compiler #+ Operation] [///analysis #+ Environment Analysis] [// #+ Arity Synthesis Synthesizer] [//loop]) -(def: Operation@Monad (state.Monad<State'> error.Monad<Error>)) - (def: #export nested? (-> Arity Bool) (n/> +1)) @@ -72,16 +71,16 @@ "") (def: return - (All [a] (-> (Maybe a) (//.Operation a))) + (All [a] (-> (Maybe a) (Operation //.State a))) (|>> (case> (#.Some output) - (:: Operation@Monad wrap output) + (:: ///compiler.Monad<Operation> wrap output) #.None - (//.throw cannot-prepare-function-body [])))) + (///compiler.throw cannot-prepare-function-body [])))) (def: #export (function synthesize environment body) - (-> Synthesizer Environment Analysis (//.Operation Synthesis)) - (do Operation@Monad + (-> Synthesizer Environment Analysis (Operation //.State Synthesis)) + (do ///compiler.Monad<Operation> [direct? //.direct? arity //.scope-arity resolver //.resolver @@ -115,9 +114,9 @@ (list/fold (.function (_ var resolver') (dict.put var var resolver')) //.fresh-resolver - down-environment)) - synthesize' (//.with-abstraction-state function-arity resolver' synthesize)] - bodyS (synthesize' body)] + down-environment))] + bodyS (//.with-abstraction function-arity resolver' + (synthesize body))] (case bodyS (^ (//.function/abstraction [env' down-arity' bodyS'])) (let [arity' (inc down-arity')] diff --git a/stdlib/test/test/lux/lang/synthesis/case.lux b/stdlib/test/test/lux/lang/synthesis/case.lux index f2541ee0e..228ed2920 100644 --- a/stdlib/test/test/lux/lang/synthesis/case.lux +++ b/stdlib/test/test/lux/lang/synthesis/case.lux @@ -4,6 +4,7 @@ pipe) (data [error "error/" Functor<Error>]) (lang ["///." reference] + ["///." compiler] [".L" analysis #+ Branch Analysis] ["//" synthesis #+ Synthesis] (synthesis [".S" expression]) @@ -24,7 +25,8 @@ (list)]])]] (test "Dummy variables created to mask expressions get eliminated during synthesis." (|> maskA - (//.run (expressionS.synthesizer extensionL.empty)) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) (error/map (//primitive.corresponds? maskedA)) (error.default false)))))) @@ -41,7 +43,8 @@ (list)]])]] (test "Can detect and reify simple 'let' expressions." (|> letA - (//.run (expressionS.synthesizer extensionL.empty)) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) (case> (^ (#error.Success (//.branch/let [inputS registerS outputS]))) (and (n/= registerA registerS) (//primitive.corresponds? inputA inputS) @@ -68,7 +71,8 @@ (analysisL.control/case [inputA [elseB (list thenB)]]))]] (test "Can detect and reify simple 'if' expressions." (|> ifA - (//.run (expressionS.synthesizer extensionL.empty)) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) (case> (^ (#error.Success (//.branch/if [inputS thenS elseS]))) (and (//primitive.corresponds? inputA inputS) (//primitive.corresponds? thenA thenS) diff --git a/stdlib/test/test/lux/lang/synthesis/function.lux b/stdlib/test/test/lux/lang/synthesis/function.lux index c0cfc5587..65a4825e3 100644 --- a/stdlib/test/test/lux/lang/synthesis/function.lux +++ b/stdlib/test/test/lux/lang/synthesis/function.lux @@ -12,6 +12,7 @@ (dictionary ["dict" unordered #+ Dict]) (set ["set" unordered]))) (lang ["///." reference #+ Variable "variable/" Equality<Variable>] + ["///." compiler] [".L" analysis #+ Analysis] ["//" synthesis #+ Arity Synthesis] (synthesis [".S" expression]) @@ -106,7 +107,8 @@ ($_ seq (test "Nested functions will get folded together." (|> function//constant - (//.run (expressionS.synthesizer extensionL.empty)) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) (case> (^ (#error.Success (//.function/abstraction [environment arity output]))) (and (n/= arity//constant arity) (//primitive.corresponds? prediction//constant output)) @@ -115,7 +117,8 @@ (n/= +0 arity//constant)))) (test "Folded functions provide direct access to environment variables." (|> function//environment - (//.run (expressionS.synthesizer extensionL.empty)) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (///reference.variable output))]))) (and (n/= arity//environment arity) (variable/= prediction//environment output)) @@ -124,7 +127,8 @@ false))) (test "Folded functions properly offset local variables." (|> function//local - (//.run (expressionS.synthesizer extensionL.empty)) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (///reference.variable output))]))) (and (n/= arity//local arity) (variable/= prediction//local output)) @@ -142,7 +146,8 @@ ($_ seq (test "Can synthesize function application." (|> (analysisL.apply [funcA argsA]) - (//.run (expressionS.synthesizer extensionL.empty)) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) (case> (^ (#error.Success (//.function/apply [funcS argsS]))) (and (//primitive.corresponds? funcA funcS) (list.every? (product.uncurry //primitive.corresponds?) @@ -152,7 +157,8 @@ false))) (test "Function application on no arguments just synthesizes to the function itself." (|> (analysisL.apply [funcA (list)]) - (//.run (expressionS.synthesizer extensionL.empty)) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) (case> (#error.Success funcS) (//primitive.corresponds? funcA funcS) diff --git a/stdlib/test/test/lux/lang/synthesis/primitive.lux b/stdlib/test/test/lux/lang/synthesis/primitive.lux index ffe0eb795..1c8368204 100644 --- a/stdlib/test/test/lux/lang/synthesis/primitive.lux +++ b/stdlib/test/test/lux/lang/synthesis/primitive.lux @@ -7,6 +7,7 @@ text/format) [lang] (lang [".L" extension] + ["///." compiler] [".L" analysis #+ Analysis] ["//" synthesis #+ Synthesis] (synthesis [".S" expression])) @@ -74,7 +75,8 @@ (~~ (do-template [<desc> <analysis> <synthesis> <sample>] [(test (format "Can synthesize " <desc> ".") (|> (#analysisL.Primitive (<analysis> <sample>)) - (//.run (expressionS.synthesizer extensionL.empty)) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) (case> (#error.Success (#//.Primitive (<synthesis> value))) (is? <sample> value) diff --git a/stdlib/test/test/lux/lang/synthesis/structure.lux b/stdlib/test/test/lux/lang/synthesis/structure.lux index a8e298bf5..e61386044 100644 --- a/stdlib/test/test/lux/lang/synthesis/structure.lux +++ b/stdlib/test/test/lux/lang/synthesis/structure.lux @@ -7,7 +7,8 @@ [product] [error] (coll [list])) - (lang [".L" analysis] + (lang ["///." compiler] + [".L" analysis] ["//" synthesis #+ Synthesis] (synthesis [".S" expression]) [".L" extension]) @@ -24,7 +25,8 @@ ($_ seq (test "Can synthesize variants." (|> (analysisL.sum-analysis size tagA memberA) - (//.run (expressionS.synthesizer extensionL.empty)) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) (case> (#error.Success (#//.Structure (#//.Variant [leftsS right?S valueS]))) (let [tagS (if right?S (inc leftsS) leftsS)] (and (n/= tagA tagS) @@ -43,7 +45,8 @@ ($_ seq (test "Can synthesize tuple." (|> (analysisL.product-analysis membersA) - (//.run (expressionS.synthesizer extensionL.empty)) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) (case> (#error.Success (#//.Structure (#//.Tuple membersS))) (and (n/= size (list.size membersS)) (list.every? (product.uncurry //primitive.corresponds?) |