1 files changed, 170 insertions, 0 deletions
diff --git a/stdlib/source/lux/lang/translation/scheme/case.jvm.lux b/stdlib/source/lux/lang/translation/scheme/case.jvm.lux
new file mode 100644
index 000000000..e5d12a005
--- /dev/null
+++ b/stdlib/source/lux/lang/translation/scheme/case.jvm.lux
@@ -0,0 +1,170 @@
+(.module:
+  [lux #- case let if]
+  (lux (control [monad #+ do]
+                ["ex" exception #+ exception:])
+       (data [number]
+             [text]
+             text/format
+             (coll [list "list/" Functor<List> Fold<List>]
+                   (set ["set" unordered #+ Set]))))
+  (//// [reference #+ Register]
+        (host ["_" scheme #+ Expression Computation Var])
+        [compiler #+ "operation/" Monad<Operation>]
+        [synthesis #+ Synthesis Path])
+  [//runtime #+ Operation Translator]
+  [//reference])
+
+(def: #export (let translate [valueS register bodyS])
+  (-> Translator [Synthesis Register Synthesis]
+      (Operation Computation))
+  (do compiler.Monad<Operation>
+    [valueO (translate valueS)
+     bodyO (translate bodyS)]
+    (wrap (_.let (list [(//reference.local' register) valueO])
+            bodyO))))
+
+(def: #export (record-get translate valueS pathP)
+  (-> Translator Synthesis (List [Nat Bool])
+      (Operation Expression))
+  (do compiler.Monad<Operation>
+    [valueO (translate valueS)]
+    (wrap (list/fold (function (_ [idx tail?] source)
+                       (.let [method (.if tail?
+                                       //runtime.product//right
+                                       //runtime.product//left)]
+                         (method source (_.int (:! Int idx)))))
+                     valueO
+                     pathP))))
+
+(def: #export (if translate [testS thenS elseS])
+  (-> Translator [Synthesis Synthesis Synthesis]
+      (Operation Computation))
+  (do compiler.Monad<Operation>
+    [testO (translate testS)
+     thenO (translate thenS)
+     elseO (translate elseS)]
+    (wrap (_.if testO thenO elseO))))
+
+(def: @savepoint (_.var "lux_pm_cursor_savepoint"))
+
+(def: @cursor (_.var "lux_pm_cursor"))
+
+(def: top _.length/1)
+
+(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: save-cursor!
+  Computation
+  (push! @cursor @savepoint))
+
+(def: restore-cursor!
+  Computation
+  (_.set! @cursor (_.car/1 @savepoint)))
+
+(def: cursor-top
+  Computation
+  (_.car/1 @cursor))
+
+(def: pop-cursor!
+  Computation
+  (pop! @cursor))
+
+(def: pm-error (_.string "PM-ERROR"))
+
+(def: fail-pm! (_.raise/1 pm-error))
+
+(def: @temp (_.var "lux_pm_temp"))
+
+(exception: #export (unrecognized-path)
+  "")
+
+(def: $alt_error (_.var "alt_error"))
+
+(def: (pm-catch handler)
+  (-> Expression Computation)
+  (_.lambda [(list $alt_error) #.None]
+       (_.if (|> $alt_error (_.eqv?/2 pm-error))
+         handler
+         (_.raise/1 $alt_error))))
+
+(def: (pattern-matching' translate pathP)
+  (-> Translator Path (Operation Expression))
+  (.case pathP
+    (^ (synthesis.path/then bodyS))
+    (translate bodyS)
+
+    #synthesis.Pop
+    (operation/wrap pop-cursor!)
+
+    (#synthesis.Bind register)
+    (operation/wrap (_.define (//reference.local' register) [(list) #.None]
+                              cursor-top))
+
+    (^template [<tag> <format> <=>]
+      (^ (<tag> value))
+      (operation/wrap (_.when (|> value <format> (<=> cursor-top) _.not/1)
+                              fail-pm!)))
+    ([synthesis.path/bool _.bool   _.eqv?/2]
+     [synthesis.path/i64  _.int    _.=/2]
+     [synthesis.path/f64  _.float  _.=/2]
+     [synthesis.path/text _.string _.eqv?/2])
+
+    (^template [<pm> <flag> <prep>]
+      (^ (<pm> idx))
+      (operation/wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get cursor-top <flag>))])
+                        (_.if (_.null?/1 @temp)
+                          fail-pm!
+                          (push-cursor! @temp)))))
+    ([synthesis.side/left  _.nil         (<|)]
+     [synthesis.side/right (_.string "") inc])
+
+    (^template [<pm> <getter> <prep>]
+      (^ (<pm> idx))
+      (operation/wrap (|> idx <prep> .int _.int (<getter> cursor-top) push-cursor!)))
+    ([synthesis.member/left  //runtime.product//left  (<|)]
+     [synthesis.member/right //runtime.product//right inc])
+
+    (^template [<tag> <computation>]
+      (^ (<tag> [leftP rightP]))
+      (do compiler.Monad<Operation>
+        [leftO (pattern-matching' translate leftP)
+         rightO (pattern-matching' translate rightP)]
+        (wrap <computation>)))
+    ([synthesis.path/seq (_.begin (list leftO
+                                        rightO))]
+     [synthesis.path/alt (_.with-exception-handler
+                           (pm-catch (_.begin (list restore-cursor!
+                                                    rightO)))
+                           (_.lambda [(list) #.None]
+                                (_.begin (list save-cursor!
+                                               leftO))))])
+    
+    _
+    (compiler.throw unrecognized-path [])))
+
+(def: (pattern-matching translate pathP)
+  (-> Translator Path (Operation Computation))
+  (do compiler.Monad<Operation>
+    [pattern-matching! (pattern-matching' translate pathP)]
+    (wrap (_.with-exception-handler
+            (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching.")))
+            (_.lambda [(list) #.None]
+                 pattern-matching!)))))
+
+(def: #export (case translate [valueS pathP])
+  (-> Translator [Synthesis Path] (Operation Computation))
+  (do compiler.Monad<Operation>
+    [valueO (translate valueS)]
+    (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))]
+                               [@savepoint (_.list/* (list))])))
+        (pattern-matching translate pathP))))