- Re-named "Compiler" to "Phase".

- Re-structured the compiler infrastructure.

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>))))