Moved pattern-matching machinery over.

8 files changed, 247 insertions, 70 deletions

diff --git a/stdlib/source/lux/tool/compiler/phase/translation/common/reference.lux b/stdlib/source/lux/tool/compiler/phase/translation/common/reference.lux
index 5d85bfd16..033effdfe 100644
--- a/stdlib/source/lux/tool/compiler/phase/translation/common/reference.lux
+++ b/stdlib/source/lux/tool/compiler/phase/translation/common/reference.lux
@@ -34,12 +34,24 @@
         (-> Register expression)))
   (|>> .int %i (format prefix) variable))
 
+(def: #export foreign
+  (All [expression]
+    (-> (-> Text expression)
+        (-> Register expression)))
+  (variable-maker "f"))
+
+(def: #export local
+  (All [expression]
+    (-> (-> Text expression)
+        (-> Register expression)))
+  (variable-maker "l"))
+
 (def: #export (system constant variable)
   (All [expression]
     (-> (-> Text expression) (-> Text expression)
         (System expression)))
-  (let [local (variable-maker "l" variable)
-        foreign (variable-maker "f" variable)
+  (let [local (..local variable)
+        foreign (..foreign variable)
         variable (:share [expression]
                          {(-> Text expression)
                           variable}
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/case.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/case.lux
new file mode 100644
index 000000000..91c7b4ace
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/js/case.lux
@@ -0,0 +1,175 @@
+(.module:
+  [lux (#- case let if)
+   [control
+    [monad (#+ do)]
+    ["ex" exception (#+ exception:)]]
+   [data
+    ["." number]
+    ["." text
+     format]
+    [collection
+     ["." list ("#/." functor fold)]]]
+   [host
+    ["_" js (#+ Expression Computation Var Statement)]]]
+  [//
+   ["//." runtime (#+ Operation Phase)]
+   ["//." reference]
+   ["//." primitive]
+   [//
+    [common
+     ["common-." reference]]
+    ["//." // ("#/." monad)
+     ["." synthesis (#+ Synthesis Path)]
+     [//
+      [reference (#+ Register)]]]]])
+
+(def: register
+  (common-reference.local _.var))
+
+(def: #export (let translate [valueS register bodyS])
+  (-> Phase [Synthesis Register Synthesis]
+      (Operation Computation))
+  (do ////.monad
+    [valueO (translate valueS)
+     bodyO (translate bodyS)]
+    (wrap (<| (_.closure (list))
+              ($_ _.then
+                  (_.define (..register register) valueO)
+                  (_.return bodyO))))))
+
+(def: #export (record-get translate valueS pathP)
+  (-> Phase Synthesis (List [Nat Bit])
+      (Operation Expression))
+  (do ////.monad
+    [valueO (translate valueS)]
+    (wrap (list/fold (function (_ [idx tail?] source)
+                       (.let [method (.if tail?
+                                       //runtime.product//right
+                                       //runtime.product//left)]
+                         (method source (_.i32 (.int idx)))))
+                     valueO
+                     pathP))))
+
+(def: #export (if translate [testS thenS elseS])
+  (-> Phase [Synthesis Synthesis Synthesis]
+      (Operation Computation))
+  (do ////.monad
+    [testO (translate testS)
+     thenO (translate thenS)
+     elseO (translate elseS)]
+    (wrap (_.? testO thenO elseO))))
+
+(def: @savepoint (_.var "lux_pm_cursor_savepoint"))
+(def: @cursor (_.var "lux_pm_cursor"))
+(def: @temp (_.var "lux_pm_temp"))
+(def: @alt-error (_.var "alt_error"))
+
+(def: (push-cursor! value)
+  (-> Expression Statement)
+  (_.statement (|> @cursor (_.do "push" (list value)))))
+
+(def: pop-cursor!
+  Statement
+  (_.statement (|> @cursor (_.do "pop" (list)))))
+
+(def: peek-cursor
+  Expression
+  (.let [idx (|> @cursor (_.the "length") (_.- (_.i32 -1)))]
+    (|> @cursor (_.at idx))))
+
+(def: save-cursor!
+  Statement
+  (.let [cursor (|> @cursor (_.do "slice" (list)))]
+    (_.statement (|> @savepoint (_.do "push" (list cursor))))))
+
+(def: restore-cursor!
+  Statement
+  (_.set @cursor (|> @savepoint (_.do "pop" (list)))))
+
+(def: pm-error (_.string "PM-ERROR"))
+(def: fail-pm! (_.throw pm-error))
+
+(exception: #export unrecognized-path)
+
+(def: (pm-catch on-catch!)
+  (-> Statement [Var Statement])
+  [@alt-error
+   (_.if (_.= ..pm-error @alt-error)
+     on-catch!
+     (_.throw @alt-error))])
+
+(def: (pattern-matching' translate pathP)
+  (-> Phase Path (Operation Statement))
+  (.case pathP
+    (^ (synthesis.path/then bodyS))
+    (do ////.monad
+      [body! (translate bodyS)]
+      (wrap (_.return body!)))
+
+    #synthesis.Pop
+    (/////wrap pop-cursor!)
+
+    (#synthesis.Bind register)
+    (/////wrap (_.define (..register register) ..peek-cursor))
+
+    (^template [<tag> <format> <=>]
+      (^ (<tag> value))
+      (/////wrap (_.when (|> value <format> (<=> ..peek-cursor) _.not)
+                         fail-pm!)))
+    ([synthesis.path/bit  //primitive.bit           _.=]
+     [synthesis.path/i64  (<| //primitive.i64 .int) //runtime.i64//=]
+     [synthesis.path/f64  //primitive.f64           _.=]
+     [synthesis.path/text //primitive.text          _.=])
+
+    (^template [<pm> <flag> <prep>]
+      (^ (<pm> idx))
+      (/////wrap ($_ _.then
+                     (_.set @temp (|> idx <prep> .int _.i32 (//runtime.sum//get ..peek-cursor <flag>)))
+                     (_.if (_.= _.null @temp)
+                       fail-pm!
+                       (push-cursor! @temp)))))
+    ([synthesis.side/left  _.null        (<|)]
+     [synthesis.side/right (_.string "") inc])
+
+    (^template [<pm> <getter> <prep>]
+      (^ (<pm> idx))
+      (/////wrap (|> idx <prep> .int _.i32 (<getter> ..peek-cursor) push-cursor!)))
+    ([synthesis.member/left  //runtime.product//left  (<|)]
+     [synthesis.member/right //runtime.product//right inc])
+
+    (^template [<tag> <computation>]
+      (^ (<tag> leftP rightP))
+      (do ////.monad
+        [left! (pattern-matching' translate leftP)
+         right! (pattern-matching' translate rightP)]
+        (wrap <computation>)))
+    ([synthesis.path/seq (_.then left! right!)]
+     [synthesis.path/alt (_.try ($_ _.then
+                                    ..save-cursor!
+                                    left!)
+                                (pm-catch ($_ _.then
+                                              ..restore-cursor!
+                                              right!)))])
+
+    _
+    (////.throw unrecognized-path [])))
+
+(def: (pattern-matching translate pathP)
+  (-> Phase Path (Operation Statement))
+  (do ////.monad
+    [pattern-matching! (pattern-matching' translate pathP)]
+    (wrap (_.try pattern-matching!
+                 (pm-catch (_.throw (_.string "Invalid expression for pattern-matching.")))))))
+
+(def: #export (case translate [valueS pathP])
+  (-> Phase [Synthesis Path] (Operation Computation))
+  (do ////.monad
+    [stack-init (translate valueS)
+     path! (pattern-matching translate pathP)
+     #let [closure (<| (_.closure (list))
+                       ($_ _.then
+                           (_.declare @temp)
+                           (_.define @cursor (_.array (list stack-init)))
+                           (_.define @savepoint (_.array (list)))
+                           path!))]]
+    (wrap (_.apply/* closure (list)))))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux
index d99eec0e9..7b475c2e7 100644
--- a/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux
+++ b/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux
@@ -1,23 +1,19 @@
 (.module:
-  [lux (#- int)
+  [lux (#- i64)
    [control
     [pipe (#+ cond> new>)]]
    [data
     [number
      ["." i64]
-     ["." frac]]
-    [text
-     format]]
+     ["." frac]]]
    [host
     ["_" js (#+ Expression)]]]
   [//
-   ["//." runtime (#+ Operation)]
-   [//
-    ["//." // ("#/." monad)]]])
+   ["//." runtime]])
 
 (def: #export bit
-  (-> Bit (Operation Expression))
-  (|>> _.boolean /////wrap))
+  (-> Bit Expression)
+  _.boolean)
 
 (def: high
   (-> Int Int)
@@ -28,13 +24,13 @@
   (let [mask (dec (i64.left-shift 32 1))]
     (|>> (i64.and mask))))
 
-(def: #export (int value)
-  (-> Int (Operation Expression))
-  (/////wrap (//runtime.i64//new (|> value ..high _.i32)
-                                 (|> value ..low _.i32))))
+(def: #export (i64 value)
+  (-> Int Expression)
+  (//runtime.i64//new (|> value ..high _.i32)
+                      (|> value ..low _.i32)))
 
-(def: #export frac
-  (-> Frac (Operation Expression))
+(def: #export f64
+  (-> Frac Expression)
   (|>> (cond> [(f/= frac.positive-infinity)]
               [(new> _.positive-infinity [])]
               
@@ -45,9 +41,8 @@
               [(new> _.not-a-number [])]
               
               ## else
-              [_.number])
-       /////wrap))
+              [_.number])))
 
 (def: #export text
-  (-> Text (Operation Expression))
-  (|>> _.string  /////wrap))
+  (-> Text Expression)
+  _.string)
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux
index 4949ddacf..bac907bea 100644
--- a/stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux
+++ b/stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux
@@ -5,28 +5,28 @@
    [host
     ["_" js (#+ Expression)]]]
   [//
-   ["//." runtime (#+ Generator)]
+   ["//." runtime (#+ Operation Phase)]
    ["//." primitive]
-   ["//." ///
+   ["/." ///
     [analysis (#+ Variant Tuple)]
     ["." synthesis (#+ Synthesis)]]])
 
-(def: #export (tuple elemsS+ translate)
-  (Generator (Tuple Synthesis))
+(def: #export (tuple translate elemsS+)
+  (-> Phase (Tuple Synthesis) (Operation Expression))
   (case elemsS+
     #.Nil
-    (//primitive.text synthesis.unit)
+    (:: ////.monad wrap (//primitive.text synthesis.unit))
 
     (#.Cons singletonS #.Nil)
     (translate singletonS)
 
     _
-    (do /////.monad
+    (do ////.monad
       [elemsT+ (monad.map @ translate elemsS+)]
       (wrap (_.array elemsT+)))))
 
-(def: #export (variant [lefts right? valueS] translate)
-  (Generator (Variant Synthesis))
-  (do /////.monad
+(def: #export (variant translate [lefts right? valueS])
+  (-> Phase (Variant Synthesis) (Operation Expression))
+  (do ////.monad
     [valueT (translate valueS)]
     (wrap (//runtime.variant (_.i32 (.int lefts)) (//runtime.flag right?) valueT))))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux
index 92b55cb80..0cb6a6c9d 100644
--- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux
@@ -8,18 +8,23 @@
     ["." text
      format]
     [collection
-     ["." list ("#/." functor fold)]
-     [set (#+ Set)]]]]
+     ["." list ("#/." functor fold)]]]
+   [host
+    ["_" scheme (#+ Expression Computation Var)]]]
   [//
    ["." runtime (#+ Operation Phase)]
+   ["//." primitive]
    ["." reference]
-   ["/." /// ("#/." monad)
-    ["." synthesis (#+ Synthesis Path)]
-    [//
-     [reference (#+ Register)]
+   [//
+    [common
+     ["common-." reference]]
+    ["//." // ("#/." monad)
+     ["." synthesis (#+ Synthesis Path)]
      [//
-      [host
-       ["_" scheme (#+ Expression Computation Var)]]]]]])
+      [reference (#+ Register)]]]]])
+
+(def: register
+  (common-reference.local _.var))
 
 (def: #export (let translate [valueS register bodyS])
   (-> Phase [Synthesis Register Synthesis]
@@ -27,7 +32,7 @@
   (do ////.monad
     [valueO (translate valueS)
      bodyO (translate bodyS)]
-    (wrap (_.let (list [(reference.local' register) valueO])
+    (wrap (_.let (list [(..register register) valueO])
             bodyO))))
 
 (def: #export (record-get translate valueS pathP)
@@ -39,7 +44,7 @@
                        (.let [method (.if tail?
                                        runtime.product//right
                                        runtime.product//left)]
-                         (method source (_.int (:coerce Int idx)))))
+                         (method source (_.int (.int idx)))))
                      valueO
                      pathP))))
 
@@ -53,23 +58,22 @@
     (wrap (_.if testO thenO elseO))))
 
 (def: @savepoint (_.var "lux_pm_cursor_savepoint"))
-
 (def: @cursor (_.var "lux_pm_cursor"))
-
-(def: top _.length/1)
+(def: @temp (_.var "lux_pm_temp"))
+(def: @alt-error (_.var "alt_error"))
 
 (def: (push! value var)
   (-> Expression Var Computation)
   (_.set! var (_.cons/2 value var)))
 
-(def: (pop! var)
-  (-> Var Computation)
-  (_.set! var var))
-
 (def: (push-cursor! value)
   (-> Expression Computation)
   (push! value @cursor))
 
+(def: (pop! var)
+  (-> Var Computation)
+  (_.set! var var))
+
 (def: save-cursor!
   Computation
   (push! @cursor @savepoint))
@@ -90,19 +94,14 @@
 
 (def: fail-pm! (_.raise/1 pm-error))
 
-(def: @temp (_.var "lux_pm_temp"))
-
-(exception: #export (unrecognized-path)
-  "")
-
-(def: $alt_error (_.var "alt_error"))
+(exception: #export unrecognized-path)
 
 (def: (pm-catch handler)
   (-> Expression Computation)
-  (_.lambda [(list $alt_error) #.None]
-       (_.if (|> $alt_error (_.eqv?/2 pm-error))
+  (_.lambda [(list @alt-error) #.None]
+       (_.if (|> @alt-error (_.eqv?/2 pm-error))
          handler
-         (_.raise/1 $alt_error))))
+         (_.raise/1 @alt-error))))
 
 (def: (pattern-matching' translate pathP)
   (-> Phase Path (Operation Expression))
@@ -114,17 +113,17 @@
     (/////wrap pop-cursor!)
 
     (#synthesis.Bind register)
-    (/////wrap (_.define (reference.local' register) [(list) #.None]
+    (/////wrap (_.define (..register register) [(list) #.None]
                          cursor-top))
 
     (^template [<tag> <format> <=>]
       (^ (<tag> value))
       (/////wrap (_.when (|> value <format> (<=> cursor-top) _.not/1)
                          fail-pm!)))
-    ([synthesis.path/bit  _.bool          _.eqv?/2]
-     [synthesis.path/i64  (<| _.int .int) _.=/2]
-     [synthesis.path/f64  _.float         _.=/2]
-     [synthesis.path/text _.string        _.eqv?/2])
+    ([synthesis.path/bit  //primitive.bit           _.eqv?/2]
+     [synthesis.path/i64  (<| //primitive.i64 .int) _.=/2]
+     [synthesis.path/f64  //primitive.f64           _.=/2]
+     [synthesis.path/text //primitive.text          _.eqv?/2])
 
     (^template [<pm> <flag> <prep>]
       (^ (<pm> idx))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux
index 53d7bbbcb..c54311da0 100644
--- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux
@@ -19,7 +19,7 @@
   (case synthesis
     (^template [<tag> <generator>]
       (^ (<tag> value))
-      (<generator> value))
+      (:: ///.monad wrap (<generator> value)))
     ([synthesis.bit  primitive.bit]
      [synthesis.i64  primitive.i64]
      [synthesis.f64  primitive.f64]
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux
index 86bf44c0f..dff6cd644 100644
--- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux
@@ -1,16 +1,12 @@
 (.module:
   [lux (#- i64)
    [host
-    ["_" scheme (#+ Expression)]]]
-  [//
-   [runtime (#+ Operation)]
-   [//
-    ["//." // ("#/." monad)]]])
+    ["_" scheme (#+ Expression)]]])
 
 (do-template [<name> <type> <code>]
   [(def: #export <name>
-     (-> <type> (Operation Expression))
-     (|>> <code> /////wrap))]
+     (-> <type> Expression)
+     <code>)]
 
   [bit  Bit  _.bool]
   [i64  Int  _.int]
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux
index aa4742fb1..d90569d9c 100644
--- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux
@@ -15,7 +15,7 @@
   (-> Phase (Tuple Synthesis) (Operation Expression))
   (case elemsS+
     #.Nil
-    (primitive.text synthesis.unit)
+    (:: ///.monad wrap (primitive.text synthesis.unit))
 
     (#.Cons singletonS #.Nil)
     (translate singletonS)