diff options
Diffstat (limited to 'stdlib/source/lux/compiler/default/phase/synthesis/case.lux')
| -rw-r--r-- | stdlib/source/lux/compiler/default/phase/synthesis/case.lux | 181 |
1 files changed, 181 insertions, 0 deletions
diff --git a/stdlib/source/lux/compiler/default/phase/synthesis/case.lux b/stdlib/source/lux/compiler/default/phase/synthesis/case.lux new file mode 100644 index 000000000..eaa7621f6 --- /dev/null +++ b/stdlib/source/lux/compiler/default/phase/synthesis/case.lux @@ -0,0 +1,181 @@ +(.module: + [lux #* + [control + [equivalence (#+ Equivalence)] + pipe + ["." monad (#+ do)]] + [data + ["." product] + [bit ("bit/." Equivalence<Bit>)] + [text ("text/." Equivalence<Text>) + format] + [number ("frac/." Equivalence<Frac>)] + [collection + ["." list ("list/." Fold<List> Monoid<List>)]]]] + ["." // (#+ Path Synthesis Operation Phase) + ["." function] + ["/." // ("operation/." Monad<Operation>) + ["." analysis (#+ Pattern Match Analysis)] + [// + ["." reference]]]]) + +(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/map (|>> (#//.Seq (#//.Test (|> value <to>)))) + bodyC)) + ([#analysis.Bit #//.Bit] + [#analysis.Nat (<| #//.I64 .i64)] + [#analysis.Int (<| #//.I64 .i64)] + [#analysis.Rev (<| #//.I64 .i64)] + [#analysis.Frac #//.F64] + [#analysis.Text #//.Text])) + + (#analysis.Bind register) + (<| (do ///.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/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/map (|>> (#//.Seq #//.Pop)) thenC)) + (path' tuple/member) + (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) + (-> Phase Pattern Analysis (Operation Path)) + (path' pattern (operation/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>)) + ([#//.Bit bit/=] + [#//.I64 (:coerce (Equivalence 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+]) + (-> Phase Analysis Match (Operation Synthesis)) + (do ///.Monad<Operation> + [inputS (synthesize^ 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 @ + [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]))))) + + <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^ thenA) + elseS (synthesize^ 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 synthesize^ lastP lastA) + prevsSP+ (monad.map @ (product.uncurry (path synthesize^)) prevsPA)] + (wrap (//.branch/case [inputS (list/fold weave lastSP prevsSP+)])))))] + (case [headB tailB+] + <let> + <if> + <case>)))) |