diff options
Diffstat (limited to 'stdlib')
| -rw-r--r-- | stdlib/source/lux/lang/analysis.lux | 157 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/analysis/reference.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/analysis/structure.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/synthesis.lux | 137 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/synthesis/case.lux | 170 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/synthesis/expression.lux | 225 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/synthesis/function.lux | 103 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/synthesis/loop.lux | 56 | ||||
| -rw-r--r-- | stdlib/test/test/lux/lang/analysis/reference.lux | 4 | ||||
| -rw-r--r-- | stdlib/test/test/lux/lang/synthesis/case.lux | 89 | ||||
| -rw-r--r-- | stdlib/test/test/lux/lang/synthesis/function.lux | 37 |
11 files changed, 661 insertions, 323 deletions
diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/analysis.lux index 3cac8d7b2..87cd99120 100644 --- a/stdlib/source/lux/lang/analysis.lux +++ b/stdlib/source/lux/lang/analysis.lux @@ -1,6 +1,7 @@ (.module: [lux #- nat int deg] - (lux (control [equality #+ Eq]) + (lux (control [equality #+ Equality] + [hash #+ Hash]) [function] (data (coll [list "list/" Fold<List>])))) @@ -26,11 +27,19 @@ (#Complex (Composite Pattern)) (#Bind Register)) +(type: #export (Branch' e) + {#when Pattern + #then e}) + (type: #export Variable (#Local Register) (#Foreign Register)) -(struct: #export _ (Eq Variable) +(type: #export Reference + (#Variable Variable) + (#Constant Ident)) + +(struct: #export _ (Equality Variable) (def: (= reference sample) (case [reference sample] (^template [<tag>] @@ -41,8 +50,18 @@ _ false))) -(type: #export (Match p e) - [[p e] (List [p e])]) +(struct: #export _ (Hash Variable) + (def: eq Equality<Variable>) + (def: (hash var) + (case var + (#Local register) + (n/* +1 register) + + (#Foreign register) + (n/* +2 register)))) + +(type: #export (Match' e) + [(Branch' e) (List (Branch' e))]) (type: #export Environment (List Variable)) @@ -54,13 +73,46 @@ (type: #export #rec Analysis (#Primitive Primitive) (#Structure (Composite Analysis)) - (#Variable Variable) - (#Constant Ident) - (#Case Analysis (Match Pattern Analysis)) + (#Reference Reference) + (#Case Analysis (Match' Analysis)) (#Function Environment Analysis) (#Apply Analysis Analysis) (#Special (Special Analysis))) +(type: #export Branch + (Branch' Analysis)) + +(type: #export Match + (Match' Analysis)) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (<tag> content))] + + [control/case #Case] + ) + +(do-template [<name> <family> <tag>] + [(template: #export (<name> content) + (<| #Reference + <family> + <tag> + content))] + + [variable/local #..Variable #..Local] + [variable/foreign #..Variable #..Foreign] + ) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (<| #Reference + <tag> + content))] + + [reference/variable #..Variable] + [reference/constant #..Constant] + ) + (do-template [<name> <type> <tag>] [(def: #export <name> (-> <type> Analysis) @@ -87,15 +139,13 @@ (-> Nat Tag Bool) (n/= (dec size) tag)) -(def: #export (no-op value) - (-> Analysis Analysis) - (let [identity (#Function (list) (#Variable (#Local +1)))] - (#Apply value identity))) +(template: #export (no-op value) + (#Apply value (#Function (list) (#Reference (#Variable (#Local +1)))))) (do-template [<name> <type> <structure> <prep-value>] [(def: #export (<name> size tag value) (-> Nat Tag <type> <type>) - (let [left (function.const (|>> #.Left #Sum <structure>)) + (let [left (function.constant (|>> #.Left #Sum <structure>)) right (|>> #.Right #Sum <structure>)] (if (last? size tag) (if (n/= +1 tag) @@ -141,37 +191,47 @@ (type: #export Analyser (-> Code (Meta Analysis))) -(def: #export (tuple analysis) - (-> Analysis (Tuple Analysis)) - (case analysis - (#Structure (#Product left right)) - (#.Cons left (tuple right)) +(do-template [<name> <type> <tag>] + [(def: #export (<name> value) + (-> <type> (Tuple <type>)) + (case value + (<tag> (#Product left right)) + (#.Cons left (<name> right)) - _ - (list analysis))) - -(def: #export (variant analysis) - (-> Analysis (Maybe (Variant Analysis))) - (loop [lefts +0 - variantA analysis] - (case variantA - (#Structure (#Sum (#.Left valueA))) - (case valueA - (#Structure (#Sum _)) - (recur (inc lefts) valueA) - - _ - (#.Some {#lefts lefts - #right? false - #value valueA})) - - (#Structure (#Sum (#.Right valueA))) - (#.Some {#lefts lefts - #right? true - #value valueA}) + _ + (list value)))] - _ - #.None))) + [tuple Analysis #Structure] + [tuple-pattern Pattern #Complex] + ) + +(do-template [<name> <type> <tag>] + [(def: #export (<name> value) + (-> <type> (Maybe (Variant <type>))) + (loop [lefts +0 + variantA value] + (case variantA + (<tag> (#Sum (#.Left valueA))) + (case valueA + (<tag> (#Sum _)) + (recur (inc lefts) valueA) + + _ + (#.Some {#lefts lefts + #right? false + #value valueA})) + + (<tag> (#Sum (#.Right valueA))) + (#.Some {#lefts lefts + #right? true + #value valueA}) + + _ + #.None)))] + + [variant Analysis #Structure] + [variant-pattern Pattern #Complex] + ) (def: #export (application analysis) (-> Analysis Application) @@ -191,3 +251,18 @@ _ false)) + +(template: #export (pattern/unit) + (#..Simple #..Unit)) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (#..Simple (<tag> content)))] + + [pattern/bool #..Bool] + [pattern/nat #..Nat] + [pattern/int #..Int] + [pattern/deg #..Deg] + [pattern/frac #..Frac] + [pattern/text #..Text] + ) diff --git a/stdlib/source/lux/lang/analysis/reference.lux b/stdlib/source/lux/lang/analysis/reference.lux index 4192ed118..e00edc178 100644 --- a/stdlib/source/lux/lang/analysis/reference.lux +++ b/stdlib/source/lux/lang/analysis/reference.lux @@ -21,7 +21,7 @@ _ (do @ [_ (typeA.infer actualT)] - (:: @ map (|>> #analysisL.Constant) + (:: @ map (|>> analysisL.reference/constant) (macro.normalize def-name)))))) (def: (variable var-name) @@ -32,7 +32,7 @@ (#.Some [actualT ref]) (do @ [_ (typeA.infer actualT)] - (wrap (#.Some (#analysisL.Variable ref)))) + (wrap (#.Some (analysisL.reference/variable ref)))) #.None (wrap #.None)))) diff --git a/stdlib/source/lux/lang/analysis/structure.lux b/stdlib/source/lux/lang/analysis/structure.lux index 4e91baad7..bc527cd49 100644 --- a/stdlib/source/lux/lang/analysis/structure.lux +++ b/stdlib/source/lux/lang/analysis/structure.lux @@ -185,7 +185,7 @@ code.tuple analyse (typeA.with-type tailT) - (:: @ map analysis.no-op)))))) + (:: @ map (|>> analysis.no-op))))))) (def: #export (product analyse membersC) (-> Analyser (List Code) (Meta Analysis)) diff --git a/stdlib/source/lux/lang/synthesis.lux b/stdlib/source/lux/lang/synthesis.lux index 4bb83ac5e..c26564001 100644 --- a/stdlib/source/lux/lang/synthesis.lux +++ b/stdlib/source/lux/lang/synthesis.lux @@ -1,16 +1,18 @@ (.module: [lux #- Scope] (lux (control [state] - ["ex" exception #+ Exception exception:]) + ["ex" exception #+ Exception exception:] + [monad #+ do]) (data [product] [error #+ Error] [number] - (coll (dictionary ["dict" unordered #+ Dict])))) - [//analysis #+ Register Variable Environment Special Analysis]) + (coll (dictionary ["dict" unordered #+ Dict]))) + [function]) + [//analysis #+ Register Variable Reference Environment Special Analysis]) (type: #export Arity Nat) -(type: #export Resolver (Dict Register Variable)) +(type: #export Resolver (Dict Variable Variable)) (type: #export State {#scope-arity Arity @@ -18,10 +20,14 @@ #direct? Bool #locals Nat}) +(def: #export fresh-resolver + Resolver + (dict.new //analysis.Hash<Variable>)) + (def: #export init State {#scope-arity +0 - #resolver (dict.new number.Hash<Nat>) + #resolver fresh-resolver #direct? false #locals +0}) @@ -41,11 +47,24 @@ (#Variant (//analysis.Variant a)) (#Tuple (//analysis.Tuple a))) +(type: #export Side + (Either Nat Nat)) + +(type: #export Member + (Either Nat Nat)) + +(type: #export Access + (#Side Side) + (#Member Member)) + (type: #export (Path' s) + #Pop + (#Test Primitive) + (#Access Access) (#Bind Register) (#Alt (Path' s) (Path' s)) (#Seq (Path' s) (Path' s)) - (#Exec s)) + (#Then s)) (type: #export (Abstraction' s) {#environment Environment @@ -55,7 +74,8 @@ (type: #export (Branch s) (#Case s (Path' s)) (#Let s Register s) - (#If s s s)) + (#If s s s) + (#Exec s)) (type: #export (Scope s) {#start Register @@ -78,13 +98,36 @@ (type: #export #rec Synthesis (#Primitive Primitive) (#Structure (Structure Synthesis)) - (#Variable Variable) + (#Reference Reference) (#Control (Control Synthesis)) (#Special (Special Synthesis))) (type: #export Path (Path' Synthesis)) +(def: #export path/pop + Path + #Pop) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (#..Test (<tag> content)))] + + [path/bool #..Bool] + [path/i64 #..I64] + [path/f64 #..F64] + [path/text #..Text] + ) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (<tag> content))] + + [path/alt #..Alt] + [path/seq #..Seq] + [path/then #..Then] + ) + (type: #export Abstraction (Abstraction' Synthesis)) @@ -106,21 +149,62 @@ (:: error.Monad<Error> map product.right (synthesizer analysis ..init))) -(def: (localized transform) +(def: (localized' transform) (-> (-> State State) - (-> Synthesizer Synthesizer)) - (function (scope synthesizer) - (function (synthesize analysis state) - (case (synthesize analysis (transform 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: #export indirectly - (-> Synthesizer Synthesizer) - (localized (set@ #direct? false))) +(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 [<operation> <synthesizer> <type> <tag>] + [(def: #export (<operation> value) + (-> <type> (All [a] (-> (Operation a) (Operation a)))) + (localized' (set@ <tag> value))) + + (def: #export (<synthesizer> value) + (-> <type> (-> Synthesizer Synthesizer)) + (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] + ) + +(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})) (do-template [<name> <tag> <type>] [(def: #export <name> @@ -129,10 +213,30 @@ (#error.Success [state (get@ <tag> state)])))] [scope-arity #scope-arity Arity] + [resolver #resolver Resolver] [direct? #direct? Bool] [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 + [locals ..locals]) + (..with-locals' (inc locals)))) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (<| #..Reference + #//analysis.Variable + <tag> + content))] + + [variable/local #//analysis.Local] + [variable/foreign #//analysis.Foreign] + ) + (do-template [<name> <family> <tag>] [(template: #export (<name> content) (<| #..Control @@ -143,6 +247,7 @@ [branch/case #..Branch #..Case] [branch/let #..Branch #..Let] [branch/if #..Branch #..If] + [branch/exec #..Branch #..Exec] [loop/scope #..Loop #..Scope] [loop/recur #..Loop #..Recur] diff --git a/stdlib/source/lux/lang/synthesis/case.lux b/stdlib/source/lux/lang/synthesis/case.lux new file mode 100644 index 000000000..ca7524072 --- /dev/null +++ b/stdlib/source/lux/lang/synthesis/case.lux @@ -0,0 +1,170 @@ +(.module: + lux + (lux (control [equality #+ Eq] + pipe + [monad #+ do]) + (data [product] + [bool "bool/" Eq<Bool>] + [text "text/" Eq<Text>] + text/format + [number "frac/" Eq<Frac>] + (coll [list "list/" Fold<List> Monoid<List>]))) + [///analysis #+ Pattern Match Analysis] + [// #+ Path Synthesis Operation] + [//function]) + +(def: (path' pattern bodyC) + (-> Pattern (Operation Path) (Operation Path)) + (case pattern + (#///analysis.Simple simple) + (case simple + #///analysis.Unit + bodyC + + (^template [<from> <to>] + (<from> value) + (:: //.Operation@Monad map + (|>> (#//.Seq (#//.Test (|> value <to>)))) + bodyC)) + ([#///analysis.Bool #//.Bool] + [#///analysis.Nat (<| #//.I64 .i64)] + [#///analysis.Int (<| #//.I64 .i64)] + [#///analysis.Deg (<| #//.I64 .i64)] + [#///analysis.Frac #//.F64] + [#///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))) + + (#///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)) + + #.None + (let [tuple (///analysis.tuple-pattern pattern) + tuple/last (dec (list.size tuple))] + (list/fold (function (_ [tuple/idx tuple/member] thenC) + (case tuple/member + (#///analysis.Simple #///analysis.Unit) + thenC + + _ + (let [last? (n/= tuple/last tuple/idx)] + (|> (if (or last? + (is? bodyC thenC)) + thenC + (:: //.Operation@Monad map (|>> (#//.Seq #//.Pop)) thenC)) + (path' tuple/member) + (:: //.Operation@Monad 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)))) + +(def: #export (weave leftP rightP) + (-> Path Path Path) + (with-expansions [<default> (as-is (#//.Alt leftP rightP))] + (case [leftP rightP] + [(#//.Seq preL postL) + (#//.Seq preR postR)] + (case (weave preL preR) + (#//.Alt _) + <default> + + weavedP + (#//.Seq weavedP (weave postL postR))) + + [#//.Pop #//.Pop] + rightP + + (^template [<tag> <eq>] + [(#//.Test (<tag> leftV)) + (#//.Test (<tag> rightV))] + (if (<eq> leftV rightV) + rightP + <default>)) + ([#//.Bool bool/=] + [#//.I64 (:! (Eq I64) i/=)] + [#//.F64 frac/=] + [#//.Text text/=]) + + (^template [<access> <side>] + [(#//.Access (<access> (<side> leftL))) + (#//.Access (<access> (<side> rightL)))] + (if (n/= leftL rightL) + rightP + <default>)) + ([#//.Side #.Left] + [#//.Side #.Right] + [#//.Member #.Left] + [#//.Member #.Right]) + + [(#//.Bind leftR) (#//.Bind rightR)] + (if (n/= leftR rightR) + rightP + <default>) + + _ + <default>))) + +(def: #export (synthesize synthesize^ inputA [headB tailB+]) + (-> //.Synthesizer Analysis Match (Operation Synthesis)) + (do //.Operation@Monad + [inputS (synthesize^ inputA)] + (case [headB tailB+] + [[(#///analysis.Bind inputR) headB/bodyA] + #.Nil] + (case headB/bodyA + (^ (///analysis.variable/local outputR)) + (wrap (if (n/= inputR outputR) + inputS + (//.branch/exec inputS))) + + _ + (do @ + [arity //.scope-arity + headB/bodyS (//.with-new-local' + (synthesize^ headB/bodyA))] + (wrap (//.branch/let [inputS + (if (//function.nested? arity) + (n/+ (dec arity) inputR) + inputR) + headB/bodyS])))) + + (^or (^ [[(///analysis.pattern/bool true) thenA] + (list [(///analysis.pattern/bool false) elseA])]) + (^ [[(///analysis.pattern/bool false) elseA] + (list [(///analysis.pattern/bool true) thenA])])) + (do @ + [thenS (synthesize^ thenA) + elseS (synthesize^ elseA)] + (wrap (//.branch/if [inputS thenS elseS]))) + + _ + (let [[[lastP lastA] prevsPA] (|> (#.Cons headB tailB+) + list.reverse + (case> (#.Cons [lastP lastA] prevsPA) + [[lastP lastA] prevsPA] + + _ + (undefined)))] + (do @ + [lastSP (path synthesize^ lastP lastA) + prevsSP+ (monad.map @ (product.uncurry (path synthesize^)) prevsPA)] + (wrap (//.branch/case [inputS (list/fold weave lastSP prevsSP+)])))) + ))) diff --git a/stdlib/source/lux/lang/synthesis/expression.lux b/stdlib/source/lux/lang/synthesis/expression.lux index 1167e975a..d556048b3 100644 --- a/stdlib/source/lux/lang/synthesis/expression.lux +++ b/stdlib/source/lux/lang/synthesis/expression.lux @@ -1,147 +1,67 @@ (.module: [lux #- primitive] (lux (control [monad #+ do] - ["ex" exception #+ exception:] - [state]) + ["ex" exception #+ exception:]) (data [maybe] - [error] - [number] - [product] - text/format - (coll [list "list/" Functor<List> Fold<List> Monoid<List>] - (dictionary ["dict" unordered #+ Dict]))) - (macro [code] - ["s" syntax]) - [lang] - (lang [".L" analysis #+ Analysis] - [".L" extension #+ Extension])) + (coll [list "list/" Functor<List>] + (dictionary ["dict" unordered #+ Dict])))) + [///analysis #+ Analysis] + [///extension #+ Extension] [// #+ Synthesis] [//function] - ## (luxc (lang (synthesis [".S" case] - ## [".S" loop]) - ## [".L" variable #+ Variable]) - ## ) - ) + [//case]) (exception: #export (unknown-synthesis-extension {name Text}) name) -## (def: init-env (List Variable) (list)) -## (def: init-resolver (Dict Int Int) (dict.new number.Hash<Int>)) - -## (def: (prepare-body inner-arity arity body) -## (-> ls.Arity ls.Arity Synthesis Synthesis) -## (if (//function.nested? inner-arity) -## body -## (loopS.reify-recursion arity body))) - -## (def: (let$ register inputS bodyS) -## (-> Nat Synthesis Synthesis Synthesis) -## (` ("lux let" (~ (code.nat register)) (~ inputS) (~ bodyS)))) - -## (def: (if$ testS thenS elseS) -## (-> Synthesis Synthesis Synthesis Synthesis) -## (` ("lux if" (~ testS) -## (~ thenS) -## (~ elseS)))) - -## (def: (variant$ tag last? valueS) -## (-> Nat Bool Synthesis Synthesis) -## (` ((~ (code.nat tag)) (~ (code.bool last?)) (~ valueS)))) - -## (def: (var$ var) -## (-> Variable Synthesis) -## (` ((~ (code.int var))))) - -## (def: (procedure$ name argsS) -## (-> Text (List Synthesis) Synthesis) -## (` ((~ (code.text name)) (~+ argsS)))) - -## (def: (call$ funcS argsS) -## (-> Synthesis (List Synthesis) Synthesis) -## (` ("lux call" (~ funcS) (~+ argsS)))) - -## (def: (synthesize-case arity num-locals synthesize inputA branchesA) -## (-> ls.Arity Nat (-> Nat Analysis Synthesis) -## Analysis (List [la.Pattern Analysis]) -## Synthesis) -## (let [inputS (synthesize num-locals inputA)] -## (case (list.reverse branchesA) -## (^multi (^ (list [(^code ("lux case bind" (~ [_ (#.Nat input-register)]))) -## (^code ((~ [_ (#.Int var)])))])) -## (not (variableL.captured? var)) -## (n/= input-register (variableL.local-register var))) -## inputS - -## (^ (list [(^code ("lux case bind" (~ [_ (#.Nat register)]))) bodyA])) -## (let$ (if (//function.nested? arity) -## (n/+ (dec arity) register) -## register) -## inputS -## (synthesize (inc num-locals) bodyA)) - -## (^or (^ (list [(^code true) thenA] [(^code false) elseA])) -## (^ (list [(^code false) elseA] [(^code true) thenA]))) -## (if$ inputS (synthesize num-locals thenA) (synthesize num-locals elseA)) - -## (#.Cons [lastP lastA] prevsPA) -## (let [transform-branch (: (-> la.Pattern Analysis ls.Path) -## (caseS.path arity num-locals synthesize)) -## pathS (list/fold caseS.weave -## (transform-branch lastP lastA) -## (list/map (product.uncurry transform-branch) prevsPA))] -## (` ("lux case" (~ inputS) (~ pathS)))) - -## _ -## (undefined) -## ))) - (def: (primitive analysis) - (-> analysisL.Primitive //.Primitive) + (-> ///analysis.Primitive //.Primitive) (case analysis - #analysisL.Unit + #///analysis.Unit (#//.Text //.unit) (^template [<analysis> <synthesis>] (<analysis> value) (<synthesis> value)) - ([#analysisL.Bool #//.Bool] - [#analysisL.Frac #//.F64] - [#analysisL.Text #//.Text]) + ([#///analysis.Bool #//.Bool] + [#///analysis.Frac #//.F64] + [#///analysis.Text #//.Text]) (^template [<analysis> <synthesis>] (<analysis> value) (<synthesis> (.i64 value))) - ([#analysisL.Nat #//.I64] - [#analysisL.Int #//.I64] - [#analysisL.Deg #//.I64]))) + ([#///analysis.Nat #//.I64] + [#///analysis.Int #//.I64] + [#///analysis.Deg #//.I64]))) -(def: Compiler@Monad (state.Monad<State'> error.Monad<Error>)) -(open: "compiler/" Compiler@Monad) +(open: "operation/" //.Operation@Monad) (def: #export (synthesizer extensions) - (-> (Extension extensionL.Synthesis) //.Synthesizer) + (-> (Extension ///extension.Synthesis) //.Synthesizer) (function (synthesize analysis) (case analysis - (#analysisL.Primitive analysis') - (compiler/wrap (#//.Primitive (..primitive analysis'))) + (#///analysis.Primitive analysis') + (operation/wrap (#//.Primitive (..primitive analysis'))) - (#analysisL.Structure composite) - (case (analysisL.variant analysis) + (#///analysis.Structure composite) + (case (///analysis.variant analysis) (#.Some variant) - (do Compiler@Monad - [valueS (synthesize (get@ #analysisL.value variant))] - (wrap (#//.Structure (#//.Variant (set@ #analysisL.value valueS variant))))) + (do //.Operation@Monad + [valueS (synthesize (get@ #///analysis.value variant))] + (wrap (#//.Structure (#//.Variant (set@ #///analysis.value valueS variant))))) _ - (do Compiler@Monad - [tupleS (monad.map @ synthesize (analysisL.tuple analysis))] + (do //.Operation@Monad + [tupleS (monad.map @ synthesize (///analysis.tuple analysis))] (wrap (#//.Structure (#//.Tuple tupleS))))) - (#analysisL.Apply _) + (#///analysis.Apply _) (//function.apply (//.indirectly synthesize) analysis) - (#analysisL.Special name args) + (#///analysis.Function environmentA bodyA) + (//function.function synthesize environmentA bodyA) + + (#///analysis.Special name args) (case (dict.get name extensions) #.None (//.throw unknown-synthesis-extension name) @@ -149,62 +69,31 @@ (#.Some extension) (extension (//.indirectly synthesize) args)) - _ - (undefined) - - ## (^code ((~ [_ (#.Int var)]))) - ## (if (variableL.local? var) - ## (if (//function.nested? arity) - ## (if (variableL.self? var) - ## (call$ (var$ 0) (|> (list.n/range +1 (dec arity)) - ## (list/map (|>> variableL.local code.int (~) () (`))))) - ## (var$ (//function.adjust-var arity var))) - ## (var$ var)) - ## (var$ (maybe.default var (dict.get var resolver)))) - - ## (^code ("lux case" (~ inputA) (~ [_ (#.Record branchesA)]))) - ## (synthesize-case arity num-locals (//.indirectly synthesize) inputA branchesA) - - ## (^multi (^code ("lux function" [(~+ scope)] (~ bodyA))) - ## [(s.run scope (p.some s.int)) (#error.Success raw-env)]) - ## (let [function-arity (if direct? - ## (inc arity) - ## +1) - ## env (list/map (function (_ closure) - ## (case (dict.get closure resolver) - ## (#.Some resolved) - ## (if (and (variableL.local? resolved) - ## (//function.nested? arity) - ## (|> resolved variableL.local-register (n/>= arity))) - ## (//function.adjust-var arity resolved) - ## resolved) - - ## #.None - ## (if (and (variableL.local? closure) - ## (//function.nested? arity)) - ## (//function.adjust-var arity closure) - ## closure))) - ## raw-env) - ## env-vars (: (List Variable) - ## (case raw-env - ## #.Nil (list) - ## _ (|> (list.size raw-env) dec (list.n/range +0) (list/map variableL.captured)))) - ## resolver' (if (and (//function.nested? function-arity) - ## direct?) - ## (list/fold (function (_ [from to] resolver') - ## (dict.put from to resolver')) - ## init-resolver - ## (list.zip2 env-vars env)) - ## (list/fold (function (_ var resolver') - ## (dict.put var var resolver')) - ## init-resolver - ## env-vars))] - ## (case (recur function-arity resolver' true function-arity bodyA) - ## (^ [_ (#.Form (list [_ (#.Text "lux function")] [_ (#.Nat unmerged-arity)] env' bodyS'))]) - ## (let [merged-arity (inc unmerged-arity)] - ## (function$ merged-arity env - ## (prepare-body function-arity merged-arity bodyS'))) - - ## bodyS - ## (function$ +1 env (prepare-body function-arity +1 bodyS)))) + (#///analysis.Reference reference) + (case reference + (#///analysis.Constant constant) + (operation/wrap (#//.Reference reference)) + + (#///analysis.Variable var) + (do //.Operation@Monad + [resolver //.resolver] + (case var + (#///analysis.Local register) + (do @ + [arity //.scope-arity] + (wrap (if (//function.nested? arity) + (if (n/= +0 register) + (|> (dec arity) + (list.n/range +1) + (list/map (|>> //.variable/local)) + [(//.variable/local +0)] + //.function/apply) + (#//.Reference (#///analysis.Variable (//function.adjust arity false var)))) + (#//.Reference (#///analysis.Variable var))))) + + (#///analysis.Foreign register) + (wrap (|> resolver (dict.get var) (maybe.default var) #///analysis.Variable #//.Reference))))) + + (#///analysis.Case inputA branchesAB+) + (//case.synthesize (//.indirectly synthesize) inputA branchesAB+) ))) diff --git a/stdlib/source/lux/lang/synthesis/function.lux b/stdlib/source/lux/lang/synthesis/function.lux index 7b989d975..4bd6846e2 100644 --- a/stdlib/source/lux/lang/synthesis/function.lux +++ b/stdlib/source/lux/lang/synthesis/function.lux @@ -1,21 +1,33 @@ (.module: - lux + [lux #- function] (lux (control [monad #+ do] - [state]) - (data [maybe] + [state] + pipe + ["ex" exception #+ exception:]) + (data [maybe "maybe/" Monad<Maybe>] [error] - (coll [list "list/" Monoid<List>])) - (lang [".L" analysis #+ Variable Analysis])) - [// #+ Arity Synthesizer] + (coll [list "list/" Functor<List> Monoid<List> Fold<List>] + (dictionary ["dict" unordered #+ Dict]))) + (lang [".L" analysis #+ Variable Environment Analysis])) + [// #+ Arity Synthesis Synthesizer] [//loop]) -(def: nested? +(def: Operation@Monad (state.Monad<State'> error.Monad<Error>)) + +(def: #export nested? (-> Arity Bool) (n/> +1)) -## (def: (adjust-var outer var) -## (-> Arity Variable Variable) -## (|> outer dec .int (i/+ var))) +(def: #export (adjust up-arity after? var) + (-> Arity Bool Variable Variable) + (case var + (#analysisL.Local register) + (if (and after? (n/>= up-arity register)) + (#analysisL.Local (n/+ (dec up-arity) register)) + var) + + _ + var)) (def: (unfold apply) (-> Analysis [Analysis (List Analysis)]) @@ -30,7 +42,7 @@ (def: #export (apply synthesize) (-> Synthesizer Synthesizer) - (function (_ exprA) + (.function (_ exprA) (let [[funcA argsA] (unfold exprA)] (do (state.Monad<State'> error.Monad<Error>) [funcS (synthesize funcA) @@ -47,3 +59,72 @@ _ (wrap (//.function/apply [funcS argsS]))))))) + +(def: (prepare up down) + (-> Arity Arity (//loop.Transform Synthesis)) + (.function (_ body) + (if (nested? up) + (#.Some body) + (//loop.recursion down body)))) + +(exception: #export (cannot-prepare-function-body {_ []}) + "") + +(def: return + (All [a] (-> (Maybe a) (//.Operation a))) + (|>> (case> (#.Some output) + (:: Operation@Monad wrap output) + + #.None + (//.throw cannot-prepare-function-body [])))) + +(def: #export (function synthesize environment body) + (-> Synthesizer Environment Analysis (//.Operation Synthesis)) + (do Operation@Monad + [direct? //.direct? + arity //.scope-arity + resolver //.resolver + #let [function-arity (if direct? + (inc arity) + +1) + up-environment (if (nested? arity) + (list/map (.function (_ closure) + (case (dict.get closure resolver) + (#.Some resolved) + (adjust arity true resolved) + + #.None + (adjust arity false closure))) + environment) + environment) + down-environment (: (List Variable) + (case environment + #.Nil + (list) + + _ + (|> (list.size environment) dec (list.n/range +0) + (list/map (|>> #analysisL.Foreign))))) + resolver' (if (and (nested? function-arity) + direct?) + (list/fold (.function (_ [from to] resolver') + (dict.put from to resolver')) + //.fresh-resolver + (list.zip2 down-environment up-environment)) + (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)] + (case bodyS + (^ (//.function/abstraction [env' down-arity' bodyS'])) + (let [arity' (inc down-arity')] + (|> (prepare function-arity arity' bodyS') + (maybe/map (|>> [up-environment arity'] //.function/abstraction)) + ..return)) + + _ + (|> (prepare function-arity +1 bodyS) + (maybe/map (|>> [up-environment +1] //.function/abstraction)) + ..return)))) diff --git a/stdlib/source/lux/lang/synthesis/loop.lux b/stdlib/source/lux/lang/synthesis/loop.lux index 476cf27b4..4dcc25873 100644 --- a/stdlib/source/lux/lang/synthesis/loop.lux +++ b/stdlib/source/lux/lang/synthesis/loop.lux @@ -9,7 +9,7 @@ [///analysis #+ Register Variable Environment] [// #+ Path Abstraction Synthesis]) -(type: (Transform a) +(type: #export (Transform a) (-> a (Maybe a))) (def: (some? maybe) @@ -18,11 +18,21 @@ (#.Some _) true #.None false)) +(template: #export (self-reference) + (#//.Reference (#///analysis.Variable (#///analysis.Local +0)))) + +(template: (recursive-apply args) + (#//.Apply (self-reference) args)) + (def: proper Bool true) +(def: improper Bool false) (def: (proper? exprS) (-> Synthesis Bool) (case exprS + (^ (self-reference)) + improper + (#//.Structure structure) (case structure (#//.Variant variantS) @@ -31,9 +41,6 @@ (#//.Tuple membersS+) (list.every? proper? membersS+)) - (#//.Variable var) - (not (///analysis.self? var)) - (#//.Control controlS) (case controlS (#//.Branch branchS) @@ -45,12 +52,15 @@ (^or (#//.Alt leftS rightS) (#//.Seq leftS rightS)) (and (recur leftS) (recur rightS)) - (#//.Exec bodyS) + (#//.Then bodyS) (proper? bodyS) _ proper))) + (#//.Exec bodyS) + (proper? bodyS) + (#//.Let inputS register bodyS) (and (proper? inputS) (proper? bodyS)) @@ -100,16 +110,12 @@ (#//.Seq leftS rightS) (maybe/map (|>> (#//.Seq leftS)) (recur rightS)) - (#//.Exec bodyS) - (maybe/map (|>> #//.Exec) (synthesis-recursion bodyS)) + (#//.Then bodyS) + (maybe/map (|>> #//.Then) (synthesis-recursion bodyS)) _ #.None))) -(template: (recursive-apply args) - (#//.Apply (#//.Variable (#///analysis.Local +0)) - args)) - (def: #export (recursion arity) (-> Nat (Transform Synthesis)) (function (recur exprS) @@ -123,6 +129,9 @@ (path-recursion recur) (maybe/map (|>> (#//.Case inputS) #//.Branch #//.Control))) + (#//.Exec bodyS) + (maybe/map (|>> //.branch/exec) (recur bodyS)) + (#//.Let inputS register bodyS) (maybe/map (|>> (#//.Let inputS register) #//.Branch #//.Control) (recur bodyS)) @@ -174,8 +183,8 @@ (wrap (<tag> leftS' rightS')))) ([#//.Alt] [#//.Seq]) - (#//.Exec bodyS) - (|> bodyS adjust-synthesis (maybe/map (|>> #//.Exec))) + (#//.Then bodyS) + (|> bodyS adjust-synthesis (maybe/map (|>> #//.Then))) _ (#.Some pathS)))) @@ -199,15 +208,20 @@ (monad.map maybe.Monad<Maybe> recur) (maybe/map (|>> #//.Tuple #//.Structure)))) - (#//.Variable variable) - (case variable - (#///analysis.Local register) - (#.Some (#//.Variable (#///analysis.Local (n/+ offset register)))) + (#//.Reference reference) + (case reference + (#///analysis.Constant constant) + (#.Some exprS) - (#///analysis.Foreign register) - (|> scope-environment - (list.nth register) - (maybe/map (|>> #//.Variable)))) + (#///analysis.Variable variable) + (case variable + (#///analysis.Local register) + (#.Some (#//.Reference (#///analysis.Variable (#///analysis.Local (n/+ offset register))))) + + (#///analysis.Foreign register) + (|> scope-environment + (list.nth register) + (maybe/map (|>> #///analysis.Variable #//.Reference))))) (^ (//.branch/case [inputS pathS])) (do maybe.Monad<Maybe> diff --git a/stdlib/test/test/lux/lang/analysis/reference.lux b/stdlib/test/test/lux/lang/analysis/reference.lux index 00689f3e0..e67756d55 100644 --- a/stdlib/test/test/lux/lang/analysis/reference.lux +++ b/stdlib/test/test/lux/lang/analysis/reference.lux @@ -36,7 +36,7 @@ (typeA.with-inference (..analyse (code.symbol ["" var-name]))))) (macro.run (initL.compiler [])) - (case> (^ (#e.Success [inferredT (#analysisL.Variable (#analysisL.Local var))])) + (case> (^ (#e.Success [inferredT (analysisL.variable/local var)])) (and (type/= expectedT inferredT) (n/= +0 var)) @@ -49,7 +49,7 @@ (..analyse (code.symbol def-name)))) (moduleL.with-module +0 module-name) (macro.run (initL.compiler [])) - (case> (#e.Success [_ inferredT (#analysisL.Constant constant-name)]) + (case> (^ (#e.Success [_ inferredT (analysisL.reference/constant constant-name)])) (and (type/= expectedT inferredT) (ident/= def-name constant-name)) diff --git a/stdlib/test/test/lux/lang/synthesis/case.lux b/stdlib/test/test/lux/lang/synthesis/case.lux index 3ae62badc..23ed6726c 100644 --- a/stdlib/test/test/lux/lang/synthesis/case.lux +++ b/stdlib/test/test/lux/lang/synthesis/case.lux @@ -1,47 +1,50 @@ (.module: lux - (lux [io] - (control [monad #+ do] + (lux (control [monad #+ do] pipe) - (macro [code]) + (data [error "error/" Functor<Error>]) + (lang [".L" analysis #+ Branch Analysis] + ["//" synthesis #+ Synthesis] + (synthesis [".S" expression]) + [".L" extension]) ["r" math/random "r/" Monad<Random>] test) - (luxc (lang ["la" analysis] - ["//" synthesis #+ Synthesis] - (synthesis [".S" expression]) - [".L" extension] - [".L" variable #+ Variable])) - (/// common)) + [//primitive]) (context: "Dummy variables." (<| (times +100) (do @ - [maskedA gen-primitive + [maskedA //primitive.primitive temp (|> r.nat (:: @ map (n/% +100))) - #let [maskA (` ("lux case" (~ maskedA) - {("lux case bind" (~ (code.nat temp))) - (~ (la.var (variableL.local temp)))}))]] + #let [maskA (analysisL.control/case + [maskedA + [[(#analysisL.Bind temp) + (analysisL.variable/local temp)] + (list)]])]] (test "Dummy variables created to mask expressions get eliminated during synthesis." - (|> (//.run (expressionS.synthesizer extensionL.no-syntheses - maskA)) - (corresponds? maskedA)))))) + (|> maskA + (//.run (expressionS.synthesizer extensionL.empty)) + (error/map (//primitive.corresponds? maskedA)) + (error.default false)))))) (context: "Let expressions." (<| (times +100) (do @ [registerA r.nat - inputA gen-primitive - outputA gen-primitive - #let [letA (` ("lux case" (~ inputA) - {("lux case bind" (~ (code.nat registerA))) - (~ outputA)}))]] + inputA //primitive.primitive + outputA //primitive.primitive + #let [letA (analysisL.control/case + [inputA + [[(#analysisL.Bind registerA) + outputA] + (list)]])]] (test "Can detect and reify simple 'let' expressions." - (|> (//.run (expressionS.synthesizer extensionL.no-syntheses - letA)) - (case> (^ [_ (#.Form (list [_ (#.Text "lux let")] [_ (#.Nat registerS)] inputS outputS))]) + (|> letA + (//.run (expressionS.synthesizer extensionL.empty)) + (case> (^ (#error.Success (//.branch/let [inputS registerS outputS]))) (and (n/= registerA registerS) - (corresponds? inputA inputS) - (corresponds? outputA outputS)) + (//primitive.corresponds? inputA inputS) + (//primitive.corresponds? outputA outputS)) _ false)))))) @@ -50,23 +53,25 @@ (<| (times +100) (do @ [then|else r.bool - inputA gen-primitive - thenA gen-primitive - elseA gen-primitive - #let [ifA (if then|else - (` ("lux case" (~ inputA) - {true (~ thenA) - false (~ elseA)})) - (` ("lux case" (~ inputA) - {false (~ elseA) - true (~ thenA)})))]] + inputA //primitive.primitive + thenA //primitive.primitive + elseA //primitive.primitive + #let [thenB (: Branch + [(#analysisL.Simple (#analysisL.Bool true)) + thenA]) + elseB (: Branch + [(#analysisL.Simple (#analysisL.Bool false)) + elseA]) + ifA (if then|else + (analysisL.control/case [inputA [thenB (list elseB)]]) + (analysisL.control/case [inputA [elseB (list thenB)]]))]] (test "Can detect and reify simple 'if' expressions." - (|> (//.run (expressionS.synthesizer extensionL.no-syntheses - ifA)) - (case> (^ [_ (#.Form (list [_ (#.Text "lux if")] inputS thenS elseS))]) - (and (corresponds? inputA inputS) - (corresponds? thenA thenS) - (corresponds? elseA elseS)) + (|> ifA + (//.run (expressionS.synthesizer extensionL.empty)) + (case> (^ (#error.Success (//.branch/if [inputS thenS elseS]))) + (and (//primitive.corresponds? inputA inputS) + (//primitive.corresponds? thenA thenS) + (//primitive.corresponds? elseA elseS)) _ false)))))) diff --git a/stdlib/test/test/lux/lang/synthesis/function.lux b/stdlib/test/test/lux/lang/synthesis/function.lux index c469d8665..93ca5d40d 100644 --- a/stdlib/test/test/lux/lang/synthesis/function.lux +++ b/stdlib/test/test/lux/lang/synthesis/function.lux @@ -11,7 +11,7 @@ (coll [list "list/" Functor<List> Fold<List>] (dictionary ["dict" unordered #+ Dict]) (set ["set" unordered]))) - (lang [".L" analysis #+ Variable Analysis "variable/" Eq<Variable>] + (lang [".L" analysis #+ Variable Analysis "variable/" Equality<Variable>] ["//" synthesis #+ Arity Synthesis] (synthesis [".S" expression]) [".L" extension]) @@ -44,40 +44,39 @@ (do r.Monad<Random> [num-locals (|> r.nat (:: @ map (|>> (n/% +100) (n/max +10)))) #let [indices (list.n/range +0 (dec num-locals)) - absolute-env (list/map (|>> #analysisL.Local) indices) - relative-env (list/map (|>> #analysisL.Foreign) indices)] + local-env (list/map (|>> #analysisL.Local) indices) + foreign-env (list/map (|>> #analysisL.Foreign) indices)] [arity bodyA predictionA] (: (r.Random [Arity Analysis Variable]) (loop [arity +1 - global-env relative-env] - (let [env-size (list.size global-env) + current-env foreign-env] + (let [current-env/size (list.size current-env) resolver (list/fold (function (_ [idx var] resolver) (dict.put idx var resolver)) (: (Dict Nat Variable) (dict.new number.Hash<Nat>)) - (list.zip2 (list.n/range +0 (dec env-size)) - global-env))] + (list.enumerate current-env))] (do @ [nest? r.bool] (if nest? (do @ - [num-picks (:: @ map (n/max +1) (pick (inc env-size))) - picks (|> (r.set number.Hash<Nat> num-picks (pick env-size)) + [num-picks (:: @ map (n/max +1) (pick (inc current-env/size))) + picks (|> (r.set number.Hash<Nat> num-picks (pick current-env/size)) (:: @ map set.to-list)) [arity bodyA predictionA] (recur (inc arity) (list/map (function (_ pick) - (maybe.assume (list.nth pick global-env))) - picks))] + (maybe.assume (list.nth pick current-env))) + picks)) + #let [picked-env (list/map (|>> #analysisL.Foreign) picks)]] (wrap [arity - (#analysisL.Function (list/map (|>> #analysisL.Foreign) picks) - bodyA) + (#analysisL.Function picked-env bodyA) predictionA])) (do @ - [chosen (pick (list.size global-env))] + [chosen (pick (list.size current-env))] (wrap [arity - (#analysisL.Variable (#analysisL.Foreign chosen)) + (analysisL.variable/foreign chosen) (maybe.assume (dict.get chosen resolver))])))))))] (wrap [arity - (#analysisL.Function absolute-env bodyA) + (#analysisL.Function local-env bodyA) predictionA]))) (def: local-function @@ -94,7 +93,7 @@ (do r.Monad<Random> [chosen (|> r.nat (:: @ map (|>> (n/% +100) (n/max +2))))] (wrap [arity - (#analysisL.Variable (#analysisL.Local chosen)) + (analysisL.variable/local chosen) (|> chosen (n/+ (dec arity)) #analysisL.Local)]))))) (context: "Function definition." @@ -116,7 +115,7 @@ (test "Folded functions provide direct access to environment variables." (|> function//environment (//.run (expressionS.synthesizer extensionL.empty)) - (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Variable output)]))) + (case> (^ (#error.Success (//.function/abstraction [environment arity (analysisL.reference/variable output)]))) (and (n/= arity//environment arity) (variable/= prediction//environment output)) @@ -125,7 +124,7 @@ (test "Folded functions properly offset local variables." (|> function//local (//.run (expressionS.synthesizer extensionL.empty)) - (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Variable output)]))) + (case> (^ (#error.Success (//.function/abstraction [environment arity (analysisL.reference/variable output)]))) (and (n/= arity//local arity) (variable/= prediction//local output)) |