- WIP: Host procedures for JS.

1 files changed, 185 insertions, 0 deletions

diff --git a/new-luxc/source/luxc/lang/translation/js/case.jvm.lux b/new-luxc/source/luxc/lang/translation/js/case.jvm.lux
new file mode 100644
index 000000000..a005a45a1
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/js/case.jvm.lux
@@ -0,0 +1,185 @@
+(.module:
+  lux
+  (lux (control [monad #+ do])
+       (data text/format
+             (coll [list "list/" Fold<List>])))
+  (luxc (lang ["ls" synthesis]))
+  [//]
+  (// [".T" runtime]
+      [".T" primitive]
+      [".T" reference]))
+
+(def: #export (translate-let translate valueS register bodyS)
+  (-> (-> ls.Synthesis (Meta //.Expression)) ls.Synthesis Nat ls.Synthesis
+      (Meta //.Expression))
+  (do macro.Monad<Meta>
+    [valueJS (translate valueS)
+     bodyJS (translate bodyS)]
+    (wrap (format "(function() {"
+                  "var " (referenceT.variable register) " = " valueJS ";"
+                  "return " bodyJS ";"
+                  "})()"))))
+
+(def: #export (translate-record-get translate valueS path)
+  (-> (-> ls.Synthesis (Meta //.Expression)) ls.Synthesis (List [Nat Bool])
+      (Meta //.Expression))
+  (do macro.Monad<Meta>
+    [valueJS (translate valueS)]
+    (wrap (list/fold (function [source [idx tail?]]
+                       (let [method (if tail? runtimeT.product//right runtimeT.product//left)]
+                         (format method "(" source "," idx ")")))
+                     (format "(" valueJS ")")
+                     path))))
+
+(def: #export (translate-if translate testS thenS elseS)
+  (-> (-> ls.Synthesis (Meta //.Expression)) ls.Synthesis ls.Synthesis ls.Synthesis
+      (Meta //.Expression))
+  (do macro.Monad<Meta>
+    [testJS (translate testS)
+     thenJS (translate thenS)
+     elseJS (translate elseS)]
+    (wrap (format "(" testJS " ? " thenJS " : " elseJS ")"))))
+
+(def: savepoint
+  //.Expression
+  "pm_cursor_savepoint")
+
+(def: cursor
+  //.Expression
+  "pm_cursor")
+
+(def: (push-cursor value)
+  (-> //.Expression //.Expression)
+  (format cursor ".push(" value ");"))
+
+(def: save-cursor
+  //.Statement
+  (format savepoint ".push(" cursor ".slice());"))
+
+(def: restore-cursor
+  //.Statement
+  (format cursor " = " savepoint ".pop();"))
+
+(def: peek-cursor
+  //.Expression
+  (format cursor "[" cursor ".length - 1]"))
+
+(def: pop-cursor
+  //.Statement
+  (format cursor ".pop();"))
+
+(def: pm-error
+  //.Expression
+  (%t "PM-ERROR"))
+
+(def: fail-pattern-matching
+  //.Statement
+  (format "throw " pm-error ";"))
+
+(def: (translate-pattern-matching' translate path)
+  (-> (-> ls.Synthesis (Meta //.Expression)) Code (Meta //.Expression))
+  (case path
+    (^code ("lux case exec" (~ bodyS)))
+    (do macro.Monad<Meta>
+      [bodyJS (translate bodyS)]
+      (wrap (format "return " bodyJS ";")))
+
+    (^code ("lux case pop"))
+    (wrap pop-cursor)
+
+    (^code ("lux case bind" (~ [_ (#.Nat register)])))
+    (wrap (format "var " (referenceT.variable register) " = " peek-cursor ";"))
+
+    (^template [<tag> <translate>]
+      [_ (<tag> value)]
+      (do macro.Monad<Meta>
+        [valueJS (<translate> value)]
+        (wrap (format "if(!" (format runtimeT.int//= "(" peek-cursor "," valueJS ")") ") { " fail-pattern-matching " }"))))
+    ([#.Nat primitiveT.translate-nat]
+     [#.Int primitiveT.translate-int]
+     [#.Deg primitiveT.translate-deg])
+
+    (^template [<tag> <format>]
+      (<tag> value)
+      (wrap (format "if(" peek-cursor " !== " (<format> value) ") { " fail-pattern-matching " }")))
+    ([#.Bool %b]
+     [#.Frac %f]
+     [#.Text %t])
+
+    (^template [<pm> <getter>]
+      (^code (<pm> (~ [_ (#.Nat idx)])))
+      (wrap (push-cursor (format <getter> "(" peek-cursor "," (|> idx nat-to-int %i) ")"))))
+    (["lux case tuple left" runtimeT.product//left]
+     ["lux case tuple right" runtimeT.product//right])
+
+    (^template [<pm> <flag>]
+      (^code (<pm> (~ [_ (#.Nat idx)])))
+      (wrap (format "temp = " runtimeT.sum//get "(" peek-cursor "," (|> idx nat-to-int %i) "," <flag> ");"
+                    "if(temp !== null) {"
+                    (push-cursor "temp")
+                    "}"
+                    "else {"
+                    fail-pattern-matching
+                    "}")))
+    (["lux case variant left" "null"]
+     ["lux case variant right" "\"\""])
+
+    (^code ("lux case seq" (~ leftP) (~ rightP)))
+    (do macro.Monad<Meta>
+      [leftJS (translate-pattern-matching' translate leftP)
+       rightJS (translate-pattern-matching' translate rightP)]
+      (wrap (format leftJS rightJS)))
+
+    (^code ("lux case alt" (~ leftP) (~ rightP)))
+    (do macro.Monad<Meta>
+      [leftJS (translate-pattern-matching' translate leftP)
+       rightJS (translate-pattern-matching' translate rightP)]
+      (wrap (format "try {"
+                    save-cursor
+                    leftJS
+                    "}"
+                    "catch(ex) {"
+                    "if(ex === " pm-error ") {"
+                    restore-cursor
+                    rightJS
+                    "}"
+                    "else {"
+                    "throw ex;"
+                    "}"
+                    "}")))
+    ))
+
+(def: report-pattern-matching-error
+  //.Statement
+  (format "if(ex === " pm-error ") {"
+          "throw \"Invalid expression for pattern-matching.\";"
+          "}"
+          "else {"
+          "throw ex;"
+          "}"))
+
+(def: (translate-pattern-matching translate path)
+  (-> (-> ls.Synthesis (Meta //.Expression)) Code (Meta //.Expression))
+  (do macro.Monad<Meta>
+    [pmJS (translate-pattern-matching' translate path)]
+    (wrap (format "try {" pmJS "}"
+                  "catch(ex) {"
+                  report-pattern-matching-error
+                  "}"))))
+
+(def: (initialize-pattern-matching stack-init)
+  (-> //.Expression //.Statement)
+  (format "var temp;"
+          "var " cursor " = [" stack-init "];"
+          "var " savepoint " = [];"))
+
+(def: #export (translate-case translate valueS path)
+  (-> (-> ls.Synthesis (Meta //.Expression)) ls.Synthesis Code (Meta //.Expression))
+  (do macro.Monad<Meta>
+    [valueJS (translate valueS)
+     pmJS (translate-pattern-matching translate path)]
+    (wrap (format "(function() {"
+                  "\"use strict\";"
+                  (initialize-pattern-matching valueJS)
+                  pmJS
+                  "})()"))))