diff options
Diffstat (limited to 'new-luxc/source/luxc/synthesizer')
-rw-r--r-- | new-luxc/source/luxc/synthesizer/case.lux | 96 | ||||
-rw-r--r-- | new-luxc/source/luxc/synthesizer/loop.lux | 224 |
2 files changed, 164 insertions, 156 deletions
diff --git a/new-luxc/source/luxc/synthesizer/case.lux b/new-luxc/source/luxc/synthesizer/case.lux index 02b1bfba5..91f339bdf 100644 --- a/new-luxc/source/luxc/synthesizer/case.lux +++ b/new-luxc/source/luxc/synthesizer/case.lux @@ -1,10 +1,10 @@ (;module: lux - (lux (data [bool "B/" Eq<Bool>] - [text "T/" Eq<Text>] + (lux (data [bool "bool/" Eq<Bool>] + [text "text/" Eq<Text>] [number] - (coll [list "L/" Functor<List> Fold<List> Monoid<List>] - ["s" set]))) + (coll [list "list/" Fold<List>])) + (meta [code "code/" Eq<Code>])) (luxc (lang ["la" analysis] ["ls" synthesis]) (synthesizer ["&;" function]))) @@ -12,21 +12,23 @@ (def: #export (path pattern) (-> la;Pattern ls;Path) (case pattern + (#la;BindP register) + (` ("lux case bind" (~ (code;nat register)))) + (^template [<from> <to>] - (<from> register) - (<to> register)) - ([#la;BindP #ls;BindP] - [#la;BoolP #ls;BoolP] - [#la;NatP #ls;NatP] - [#la;IntP #ls;IntP] - [#la;DegP #ls;DegP] - [#la;FracP #ls;FracP] - [#la;TextP #ls;TextP]) + (<from> value) + (<to> value)) + ([#la;BoolP code;bool] + [#la;NatP code;nat] + [#la;IntP code;int] + [#la;DegP code;deg] + [#la;FracP code;frac] + [#la;TextP code;text]) (#la;TupleP membersP) (case (list;reverse membersP) #;Nil - #ls;UnitP + (' ("lux case pop")) (#;Cons singletonP #;Nil) (path singletonP) @@ -34,58 +36,46 @@ (#;Cons lastP prevsP) (let [length (list;size membersP) last-idx (n.dec length) - last-path (#ls;TupleP (#;Right last-idx) (path lastP)) - [_ tuple-path] (L/fold (function [current-pattern [current-idx next-path]] - [(n.dec current-idx) - (#ls;SeqP (#ls;TupleP (#;Left current-idx) - (path current-pattern)) - next-path)]) - [(n.dec last-idx) last-path] - prevsP)] + [_ tuple-path] (list/fold (function [current-pattern [current-idx next-path]] + [(n.dec current-idx) + (` ("lux case seq" + ("lux case tuple left" (~ (code;nat current-idx)) (~ (path current-pattern))) + (~ next-path)))]) + [(n.dec last-idx) + (` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path lastP))))] + prevsP)] tuple-path)) (#la;VariantP tag num-tags memberP) - (let [last? (n.= (n.dec num-tags) tag)] - (#ls;VariantP (if last? (#;Right tag) (#;Left tag)) - (path memberP))))) + (if (n.= (n.dec num-tags) tag) + (` ("lux case variant right" (~ (code;nat tag)) (~ (path memberP)))) + (` ("lux case variant left" (~ (code;nat tag)) (~ (path memberP))))))) (def: #export (weave leftP rightP) (-> ls;Path ls;Path ls;Path) - (with-expansions [<default> (as-is (#ls;AltP leftP rightP))] + (with-expansions [<default> (as-is (` ("lux case alt" (~ leftP) (~ rightP))))] (case [leftP rightP] - [#ls;UnitP #ls;UnitP] - #ls;UnitP - - (^template [<tag> <test>] - [(<tag> left) (<tag> right)] - (if (<test> left right) - leftP - <default>)) - ([#ls;BindP n.=] - [#ls;BoolP B/=] - [#ls;NatP n.=] - [#ls;IntP i.=] - [#ls;DegP d.=] - [#ls;FracP f.=] - [#ls;TextP T/=]) - - (^template [<tag> <side>] - [(<tag> (<side> left-idx) left-then) (<tag> (<side> right-idx) right-then)] + (^template [<special>] + (^ [[_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat left-idx)] left-then))] + [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat right-idx)] right-then))]]) (if (n.= left-idx right-idx) - (weave left-then right-then) + (` (<special> (~ (code;nat left-idx)) (~ (weave left-then right-then)))) <default>)) - ([#ls;TupleP #;Left] - [#ls;TupleP #;Right] - [#ls;VariantP #;Left] - [#ls;VariantP #;Right]) + (["lux case tuple left"] + ["lux case tuple right"] + ["lux case variant left"] + ["lux case variant right"]) - [(#ls;SeqP left-pre left-post) (#ls;SeqP right-pre right-post)] + (^ [[_ (#;Form (list [_ (#;Text "lux case seq")] left-pre left-post))] + [_ (#;Form (list [_ (#;Text "lux case seq")] right-pre right-post))]]) (case (weave left-pre right-pre) - (#ls;AltP _ _) + (^ [_ (#;Form (list [_ (#;Text "lux case alt")] _ _))]) <default> weavedP - (#ls;SeqP weavedP (weave left-post right-post))) + (` ("lux case seq" (~ weavedP) (~ (weave left-post right-post))))) _ - <default>))) + (if (code/= leftP rightP) + leftP + <default>)))) diff --git a/new-luxc/source/luxc/synthesizer/loop.lux b/new-luxc/source/luxc/synthesizer/loop.lux index ad4504f41..8599db981 100644 --- a/new-luxc/source/luxc/synthesizer/loop.lux +++ b/new-luxc/source/luxc/synthesizer/loop.lux @@ -1,61 +1,71 @@ (;module: lux - (lux (data [maybe] - text/format - (coll [list "L/" Functor<List>]))) + (lux (control [monad #+ do] + ["p" parser]) + (data [maybe] + (coll [list "list/" Functor<List>])) + (meta [code] + [syntax])) (luxc (lang ["ls" synthesis]) (synthesizer ["&&;" function]))) (def: #export (contains-self-reference? exprS) (-> ls;Synthesis Bool) (case exprS - (#ls;Variant tag last? memberS) + (^ [_ (#;Form (list [_ (#;Nat tag)] [_ (#;Bool last?)] memberS))]) (contains-self-reference? memberS) - (#ls;Tuple membersS) + [_ (#;Tuple membersS)] (list;any? contains-self-reference? membersS) - (#ls;Case inputS pathS) + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (&&function;self? var) + + (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))]) (or (contains-self-reference? inputS) (loop [pathS pathS] (case pathS - (^or (#ls;AltP leftS rightS) - (#ls;SeqP leftS rightS)) + (^or (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftS rightS))]) + (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftS rightS))])) (or (recur leftS) (recur rightS)) - - (#ls;ExecP bodyS) + + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) (contains-self-reference? bodyS) _ false))) - (#ls;Function arity environment bodyS) - (list;any? &&function;self? environment) - - (#ls;Call argsS funcS) + (^ [_ (#;Form (list [_ (#;Text "lux function")] arity [_ (#;Tuple environment)] bodyS))]) + (list;any? (function [captured] + (case captured + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (&&function;self? var) + + _ + false)) + environment) + + (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS argsS))]) (or (contains-self-reference? funcS) (list;any? contains-self-reference? argsS)) - - (^or (#ls;Recur argsS) - (#ls;Procedure name argsS)) - (list;any? contains-self-reference? argsS) - - (#ls;Variable idx) - (&&function;self? idx) - (#ls;Let register inputS bodyS) + (^ [_ (#;Form (list [_ (#;Text "lux let")] register inputS bodyS))]) (or (contains-self-reference? inputS) (contains-self-reference? bodyS)) - (#ls;If inputS thenS elseS) + (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))]) (or (contains-self-reference? inputS) (contains-self-reference? thenS) (contains-self-reference? elseS)) - (#ls;Loop offset argsS bodyS) - (or (list;any? contains-self-reference? argsS) + (^ [_ (#;Form (list [_ (#;Text "lux loop")] offset [_ (#;Tuple initsS)] bodyS))]) + (or (list;any? contains-self-reference? initsS) (contains-self-reference? bodyS)) + + (^or (^ [_ (#;Form (list& [_ (#;Text "lux recur")] argsS))]) + (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))])) + (list;any? contains-self-reference? argsS) _ false @@ -65,37 +75,34 @@ (-> Nat ls;Synthesis ls;Synthesis) (loop [exprS exprS] (case exprS - (#ls;Case inputS pathS) - (#ls;Case inputS - (let [reify-recursion' recur] - (loop [pathS pathS] - (case pathS - (#ls;AltP leftS rightS) - (#ls;AltP (recur leftS) (recur rightS)) - - (#ls;SeqP leftS rightS) - (#ls;SeqP leftS (recur rightS)) - - (#ls;ExecP bodyS) - (#ls;ExecP (reify-recursion' bodyS)) - - _ - pathS)))) - - (^multi (#ls;Call argsS (#ls;Variable 0)) + (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))]) + (` ("lux case" (~ inputS) + (~ (let [reify-recursion' recur] + (loop [pathS pathS] + (case pathS + (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftS rightS))]) + (` ("lux case alt" (~ (recur leftS)) (~ (recur rightS)))) + + (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftS rightS))]) + (` ("lux case seq" (~ leftS) (~ (recur rightS)))) + + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) + (` ("lux case exec" (~ (reify-recursion' bodyS)))) + + _ + pathS)))))) + + (^multi (^ [_ (#;Form (list& [_ (#;Text "lux call")] + [_ (#;Form (list [_ (#;Int 0)]))] + argsS))]) (n.= arity (list;size argsS))) - (#ls;Recur argsS) + (` ("lux recur" (~@ argsS))) - (#ls;Call argsS (#ls;Variable var)) - exprS + (^ [_ (#;Form (list [_ (#;Text "lux let")] register inputS bodyS))]) + (` ("lux let" (~ register) (~ inputS) (~ (recur bodyS)))) - (#ls;Let register inputS bodyS) - (#ls;Let register inputS (recur bodyS)) - - (#ls;If inputS thenS elseS) - (#ls;If inputS - (recur thenS) - (recur elseS)) + (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))]) + (` ("lux if" (~ inputS) (~ (recur thenS)) (~ (recur elseS)))) _ exprS @@ -109,58 +116,69 @@ (|> env (list;nth idx) maybe;assume))))] (loop [exprS exprS] (case exprS - (#ls;Variant tag last? valueS) - (#ls;Variant tag last? (recur valueS)) + (^ [_ (#;Form (list [_ (#;Nat tag)] last? valueS))]) + (` ((~ (code;nat tag)) (~ last?) (~ (recur valueS)))) - (#ls;Tuple members) - (#ls;Tuple (L/map recur members)) - - (#ls;Case inputS pathS) - (#ls;Case (recur inputS) - (let [adjust' recur] - (loop [pathS pathS] - (case pathS - (^template [<tag>] - (<tag> leftS rightS) - (<tag> (recur leftS) (recur rightS))) - ([#ls;AltP] - [#ls;SeqP]) - - (#ls;ExecP bodyS) - (#ls;ExecP (adjust' bodyS)) - - _ - pathS)))) - - (#ls;Function arity scope bodyS) - (#ls;Function arity - (L/map resolve-captured scope) - (recur bodyS)) - - (#ls;Call argsS funcS) - (#ls;Call (L/map recur argsS) (recur funcS)) - - (#ls;Recur argsS) - (#ls;Recur (L/map recur argsS)) - - (#ls;Procedure name argsS) - (#ls;Procedure name (L/map recur argsS)) - - (#ls;Variable var) - (if (&&function;captured? var) - (#ls;Variable (resolve-captured var)) - (#ls;Variable (|> outer-offset nat-to-int (i.+ var)))) - - (#ls;Let register inputS bodyS) - (#ls;Let (n.+ outer-offset register) (recur inputS) (recur bodyS)) - - (#ls;If inputS thenS elseS) - (#ls;If (recur inputS) (recur thenS) (recur elseS)) + [_ (#;Tuple members)] + [_ (#;Tuple (list/map recur members))] + + (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))]) + (` ("lux case" (~ (recur inputS)) + (~ (let [adjust' recur] + (loop [pathS pathS] + (case pathS + (^template [<pattern>] + (^ [_ (#;Form (list [_ (#;Text <pattern>)] leftS rightS))]) + (` (<pattern> (~ (recur leftS)) (~ (recur rightS))))) + (["lux case alt"] + ["lux case seq"]) + + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) + (` ("lux case exec" (~ (adjust' bodyS)))) + + _ + pathS)))))) + + (^ [_ (#;Form (list [_ (#;Text "lux function")] arity [_ (#;Tuple environment)] bodyS))]) + (` ("lux function" (~ arity) + (~ [_ (#;Tuple (list/map (function [_var] + (case _var + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (` ((~ (code;int (resolve-captured var))))) + + _ + _var)) + environment))]) + (~ (recur bodyS)))) + + (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS argsS))]) + (` ("lux call" (~ (recur funcS)) (~@ (list/map recur argsS)))) + + (^ [_ (#;Form (list& [_ (#;Text "lux recur")] argsS))]) + (` ("lux recur" (~@ (list/map recur argsS)))) + + (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))]) + (` ((~ (code;text procedure)) (~@ (list/map recur argsS)))) - (#ls;Loop inner-offset argsS bodyS) - (#ls;Loop (n.+ outer-offset inner-offset) - (L/map recur argsS) - (recur bodyS)) + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (if (&&function;captured? var) + (` ((~ (code;int (resolve-captured var))))) + (` ((~ (code;int (|> outer-offset nat-to-int (i.+ var))))))) + + (^ [_ (#;Form (list [_ (#;Text "lux let")] [_ (#;Nat register)] inputS bodyS))]) + (` ("lux let" (~ (code;nat (n.+ outer-offset register))) + (~ (recur inputS)) + (~ (recur bodyS)))) + + (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))]) + (` ("lux if" (~ (recur inputS)) + (~ (recur thenS)) + (~ (recur elseS)))) + + (^ [_ (#;Form (list [_ (#;Text "lux loop")] [_ (#;Nat inner-offset)] [_ (#;Tuple initsS)] bodyS))]) + (` ("lux loop" (~ (code;nat (n.+ outer-offset inner-offset))) + [(~@ (list/map recur initsS))] + (~ (recur bodyS)))) _ exprS |