- Added tests for JS procedure translation.

12 files changed, 227 insertions, 40 deletions

diff --git a/new-luxc/test/test/luxc/common.lux b/new-luxc/test/test/luxc/common.lux
index c2082dc81..20fb07e03 100644
--- a/new-luxc/test/test/luxc/common.lux
+++ b/new-luxc/test/test/luxc/common.lux
@@ -1,10 +1,20 @@
 (.module:
   lux
   (lux (control [monad #+ do])
-       [io #+ IO])
-  (luxc (lang ["&." host]
+       [io #+ IO]
+       (data ["e" error])
+       [macro])
+  (luxc [lang]
+        (lang ["&." host]
               [".L" init]
-              (translation [js]))))
+              [synthesis #+ Synthesis]
+              (translation (jvm [".T_jvm" expression]
+                                [".T_jvm" eval]
+                                [".T_jvm" runtime])
+                           [js]
+                           (js [".T_js" expression]
+                               [".T_js" eval]
+                               [".T_js" runtime])))))
 
 (do-template [<name> <host>]
   [(def: #export <name>
@@ -16,3 +26,18 @@
   [init-jvm &host.init-host]
   [init-js  js.init]
   )
+
+(def: (run-synthesis translate-runtime translate-expression eval init)
+  (All [a] (-> (Meta Top) (-> Synthesis (Meta a)) (-> a (Meta Top)) (IO Compiler)
+               (-> Synthesis (e.Error Top))))
+  (function [synthesis]
+    (|> (do macro.Monad<Meta>
+          [_ translate-runtime
+           sampleO (translate-expression synthesis)]
+          (eval sampleO))
+        (lang.with-current-module "")
+        (macro.run (io.run init)))))
+
+(def: #export run-jvm (run-synthesis runtimeT_jvm.translate expressionT_jvm.translate evalT_jvm.eval init-jvm))
+
+(def: #export run-js (run-synthesis runtimeT_js.translate expressionT_js.translate evalT_js.eval init-js))
diff --git a/new-luxc/test/test/luxc/lang/analysis/common.lux b/new-luxc/test/test/luxc/lang/analysis/common.lux
index 38c712972..cf213ccef 100644
--- a/new-luxc/test/test/luxc/lang/analysis/common.lux
+++ b/new-luxc/test/test/luxc/lang/analysis/common.lux
@@ -1,6 +1,7 @@
 (.module:
   lux
-  (lux (control pipe)
+  (lux [io]
+       (control pipe)
        ["r" math/random "r/" Monad<Random>]
        (data ["e" error])
        [macro]
@@ -40,7 +41,7 @@
   [(def: #export (<name> analysis)
      (All [a] (-> (Meta a) Bool))
      (|> analysis
-         (macro.run (init-compiler []))
+         (macro.run (io.run init-jvm))
          (case> (#e.Success _)
                 <on-success>
 
diff --git a/new-luxc/test/test/luxc/lang/analysis/function.lux b/new-luxc/test/test/luxc/lang/analysis/function.lux
index 62d5ad93c..968de53ef 100644
--- a/new-luxc/test/test/luxc/lang/analysis/function.lux
+++ b/new-luxc/test/test/luxc/lang/analysis/function.lux
@@ -55,7 +55,7 @@
   (-> Type Nat (Meta la.Analysis) Bool)
   (|> analysis
       (&.with-type expectedT)
-      (macro.run (init-compiler []))
+      (macro.run (io.run init-jvm))
       (case> (#e.Success applyA)
              (let [[funcA argsA] (flatten-apply applyA)]
                (n/= num-args (list.size argsA)))
@@ -75,25 +75,25 @@
             (test "Can analyse function."
                   (and (|> (&.with-type (All [a] (-> a outputT))
                              (@.analyse-function analyse func-name arg-name outputC))
-                           (macro.run (init-compiler []))
+                           (macro.run (io.run init-jvm))
                            succeeds?)
                        (|> (&.with-type (All [a] (-> a a))
                              (@.analyse-function analyse func-name arg-name g!arg))
-                           (macro.run (init-compiler []))
+                           (macro.run (io.run init-jvm))
                            succeeds?)))
             (test "Generic functions can always be specialized."
                   (and (|> (&.with-type (-> inputT outputT)
                              (@.analyse-function analyse func-name arg-name outputC))
-                           (macro.run (init-compiler []))
+                           (macro.run (io.run init-jvm))
                            succeeds?)
                        (|> (&.with-type (-> inputT inputT)
                              (@.analyse-function analyse func-name arg-name g!arg))
-                           (macro.run (init-compiler []))
+                           (macro.run (io.run init-jvm))
                            succeeds?)))
             (test "The function's name is bound to the function's type."
                   (|> (&.with-type (Rec self (-> inputT self))
                         (@.analyse-function analyse func-name arg-name (code.local-symbol func-name)))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       succeeds?))
             ))))
 
diff --git a/new-luxc/test/test/luxc/lang/analysis/primitive.lux b/new-luxc/test/test/luxc/lang/analysis/primitive.lux
index d8ba4561f..96e2c62f9 100644
--- a/new-luxc/test/test/luxc/lang/analysis/primitive.lux
+++ b/new-luxc/test/test/luxc/lang/analysis/primitive.lux
@@ -32,7 +32,7 @@
                 (test "Can analyse unit."
                       (|> (@common.with-unknown-type
                             @.analyse-unit)
-                          (macro.run (init-compiler []))
+                          (macro.run (io.run init-jvm))
                           (case> (^ (#e.Success [_type (^code [])]))
                                  (type/= Unit _type)
 
@@ -43,7 +43,7 @@
                       [(test (format "Can analyse " <desc> ".")
                              (|> (@common.with-unknown-type
                                    (<analyser> <value>))
-                                 (macro.run (init-compiler []))
+                                 (macro.run (io.run init-jvm))
                                  (case> (#e.Success [_type [_ (<tag> value)]])
                                         (and (type/= <type> _type)
                                              (is <value> value))
diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux b/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux
index 9701a04b6..f51938046 100644
--- a/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux
+++ b/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux
@@ -29,7 +29,7 @@
      (|> (&.with-scope
            (&.with-type output-type
              (analyse (` ((~ (code.text procedure)) (~+ params))))))
-         (macro.run (init-compiler []))
+         (macro.run (io.run init-jvm))
          (case> (#e.Success _)
                 <success>
 
@@ -261,7 +261,7 @@
                                        (&scope.with-local [var-name arrayT]
                                          (&.with-type output-type
                                            (analyse code))))
-                                     (macro.run (init-compiler []))
+                                     (macro.run (io.run init-jvm))
                                      (case> (#e.Success _)
                                             true
 
@@ -335,7 +335,7 @@
                         (&scope.with-local [var-name atomT]
                           (&.with-type elemT
                             (analyse (` ("lux atom read" (~ (code.symbol ["" var-name]))))))))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (#e.Success _)
                              true
 
@@ -349,7 +349,7 @@
                                          (~ (code.symbol ["" var-name]))
                                          (~ elemC)
                                          (~ elemC)))))))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (#e.Success _)
                              true
 
diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux
index 7b2b993d2..efc550ff5 100644
--- a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux
@@ -39,7 +39,7 @@
                ((expressionA.analyser evalL.eval)
                 (` ((~ (code.text procedure)) (~+ params)))))))
          (&.with-current-module "")
-         (macro.run (init-compiler []))
+         (macro.run (io.run init-jvm))
          (case> (#e.Success _)
                 <success>
 
@@ -59,7 +59,7 @@
              (&.with-type output-type
                (expressionA.analyser evalL.eval syntax))))
          (&.with-current-module "")
-         (macro.run (init-compiler []))
+         (macro.run (io.run init-jvm))
          (case> (#e.Success _)
                 <success>
 
diff --git a/new-luxc/test/test/luxc/lang/analysis/reference.lux b/new-luxc/test/test/luxc/lang/analysis/reference.lux
index 45e1eb0e8..0ab23600b 100644
--- a/new-luxc/test/test/luxc/lang/analysis/reference.lux
+++ b/new-luxc/test/test/luxc/lang/analysis/reference.lux
@@ -30,7 +30,7 @@
                         (&scope.with-local [var-name ref-type]
                           (@common.with-unknown-type
                             (@.analyse-reference ["" var-name]))))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (^ (#e.Success [_type (^code ((~ [_ (#.Int var)])))]))
                              (type/= ref-type _type)
 
@@ -43,7 +43,7 @@
                                            [ref-type (' {}) (:! Void [])])]
                         (@common.with-unknown-type
                           (@.analyse-reference [module-name var-name])))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (#e.Success [_type [_ (#.Symbol def-name)]])
                              (type/= ref-type _type)
 
diff --git a/new-luxc/test/test/luxc/lang/analysis/structure.lux b/new-luxc/test/test/luxc/lang/analysis/structure.lux
index 42177ebb4..cdef25448 100644
--- a/new-luxc/test/test/luxc/lang/analysis/structure.lux
+++ b/new-luxc/test/test/luxc/lang/analysis/structure.lux
@@ -47,7 +47,7 @@
                   (|> (&.with-scope
                         (&.with-type variantT
                           (@.analyse-sum analyse choice valueC)))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (^multi (#e.Success [_ sumA])
                                      [(la.unfold-variant sumA)
                                       (#.Some [tag last? valueA])])
@@ -64,7 +64,7 @@
                                (tc.check varT variantT))]
                           (&.with-type varT
                             (@.analyse-sum analyse choice valueC))))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (^multi (#e.Success [_ sumA])
                                      [(la.unfold-variant sumA)
                                       (#.Some [tag last? valueA])])
@@ -79,7 +79,7 @@
                           [[_ varT] (&.with-type-env tc.var)]
                           (&.with-type varT
                             (@.analyse-sum analyse choice valueC))))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (#e.Success _)
                              false
 
@@ -89,7 +89,7 @@
                   (|> (&.with-scope
                         (&.with-type (type.ex-q +1 +variantT)
                           (@.analyse-sum analyse +choice +valueC)))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (#e.Success _)
                              true
 
@@ -99,7 +99,7 @@
                   (|> (&.with-scope
                         (&.with-type (type.univ-q +1 +variantT)
                           (@.analyse-sum analyse +choice +valueC)))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (#e.Success _)
                              (not (n/= choice +choice))
 
@@ -123,7 +123,7 @@
             (test "Can analyse product."
                   (|> (&.with-type (type.tuple (list/map product.left primitives))
                         (@.analyse-product analyse (list/map product.right primitives)))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (#e.Success tupleA)
                              (n/= size (list.size (la.unfold-tuple tupleA)))
 
@@ -132,7 +132,7 @@
             (test "Can infer product."
                   (|> (@common.with-unknown-type
                         (@.analyse-product analyse (list/map product.right primitives)))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (#e.Success [_type tupleA])
                              (and (type/= (type.tuple (list/map product.left primitives))
                                           _type)
@@ -143,7 +143,7 @@
             (test "Can analyse pseudo-product (singleton tuple)"
                   (|> (&.with-type singletonT
                         (analyse (` [(~ singletonC)])))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (#e.Success singletonA)
                              true
 
@@ -157,7 +157,7 @@
                                (tc.check varT (type.tuple (list/map product.left primitives))))]
                           (&.with-type varT
                             (@.analyse-product analyse (list/map product.right primitives)))))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (#e.Success [_ tupleA])
                              (n/= size (list.size (la.unfold-tuple tupleA)))
 
@@ -167,7 +167,7 @@
                   (|> (&.with-scope
                         (&.with-type (type.ex-q +1 +tupleT)
                           (@.analyse-product analyse (list/map product.right +primitives))))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (#e.Success _)
                              true
 
@@ -177,7 +177,7 @@
                   (|> (&.with-scope
                         (&.with-type (type.univ-q +1 +tupleT)
                           (@.analyse-product analyse (list/map product.right +primitives))))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (#e.Success _)
                              false
 
@@ -189,7 +189,7 @@
   (-> Type Nat Nat (Meta [Module Scope la.Analysis]) Bool)
   (|> analysis
       (&.with-type variantT)
-      (macro.run (init-compiler []))
+      (macro.run (io.run init-jvm))
       (case> (^multi (#e.Success [_ _ sumA])
                      [(la.unfold-variant sumA)
                       (#.Some [tag last? valueA])])
@@ -202,7 +202,7 @@
 (def: (check-record-inference tupleT size analysis)
   (-> Type Nat (Meta [Module Scope Type la.Analysis]) Bool)
   (|> analysis
-      (macro.run (init-compiler []))
+      (macro.run (io.run init-jvm))
       (case> (^multi (#e.Success [_ _ productT productA])
                      [(la.unfold-tuple productA)
                       membersA])
@@ -264,7 +264,7 @@
                           (&.with-scope
                             (&.with-type variantT
                               (@.analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC)))))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (^multi (#e.Success [_ _ sumA])
                                      [(la.unfold-variant sumA)
                                       (#.Some [tag last? valueA])])
@@ -320,7 +320,7 @@
                           (&.with-scope
                             (&.with-type tupleT
                               (@.analyse-record analyse recordC)))))
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (^multi (#e.Success [_ _ productA])
                                      [(la.unfold-tuple productA)
                                       membersA])
diff --git a/new-luxc/test/test/luxc/lang/analysis/type.lux b/new-luxc/test/test/luxc/lang/analysis/type.lux
index 4de75b989..3826b1e5d 100644
--- a/new-luxc/test/test/luxc/lang/analysis/type.lux
+++ b/new-luxc/test/test/luxc/lang/analysis/type.lux
@@ -58,7 +58,7 @@
                           (@common.with-unknown-type
                             (@.analyse-check analyse eval.eval typeC exprC))))
                       (&.with-current-module "")
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (#e.Success [_ [analysisT analysisA]])
                              (and (type/= codeT analysisT)
                                   (case [exprC analysisA]
@@ -84,7 +84,7 @@
                           (@common.with-unknown-type
                             (@.analyse-coerce analyse eval.eval typeC exprC))))
                       (&.with-current-module "")
-                      (macro.run (init-compiler []))
+                      (macro.run (io.run init-jvm))
                       (case> (#e.Success [_ [analysisT analysisA]])
                              (type/= codeT analysisT)
 
diff --git a/new-luxc/test/test/luxc/lang/translation/common.lux b/new-luxc/test/test/luxc/lang/translation/common.lux
index 7b7445737..7e46abfda 100644
--- a/new-luxc/test/test/luxc/lang/translation/common.lux
+++ b/new-luxc/test/test/luxc/lang/translation/common.lux
@@ -328,7 +328,7 @@
       (frac-spec|1 translate-expression eval translate-runtime init)))
 
 (def: deg-threshold
-  {#.doc "1/(2^30)"}
+  {#.doc "~ 1/(2^30)"}
   Deg
   .000000001)
 
diff --git a/new-luxc/test/test/luxc/lang/translation/js.lux b/new-luxc/test/test/luxc/lang/translation/js.lux
new file mode 100644
index 000000000..68bc227f2
--- /dev/null
+++ b/new-luxc/test/test/luxc/lang/translation/js.lux
@@ -0,0 +1,160 @@
+(.module:
+  lux
+  (lux [io #+ IO]
+       (control [monad #+ do]
+                pipe)
+       (data ["e" error]
+             text/format
+             [number]
+             (coll [list "list/" Functor<List>]
+                   [set]))
+       [math]
+       ["r" math/random]
+       (macro [code])
+       test)
+  (luxc (lang [synthesis #+ Synthesis]))
+  (test/luxc common))
+
+(def: upper-alpha-ascii
+  (r.Random Nat)
+  (|> r.nat (:: r.Functor<Random> map (|>> (n/% +91) (n/max +65)))))
+
+(def: (test-primitive-identity synthesis)
+  (-> Synthesis Bool)
+  (|> (run-js (` ("lux is" (~ synthesis) (~ synthesis))))
+      (case> (#e.Success valueV)
+             (:! Bool valueV)
+
+             _
+             false)))
+
+(type: Check (-> (e.Error Top) Bool))
+
+(do-template [<name> <type> <pre> <=>]
+  [(def: (<name> angle)
+     (-> <type> Check)
+     (|>> (case> (#e.Success valueV)
+                 (<=> (<pre> angle) (:! <type> valueV))
+                 
+                 (#e.Error error)
+                 false)))]
+
+  [sin-check    Frac math.sin f/=]
+  [length-check Nat  id       n/=]
+  )
+
+(context: "[JS] Primitives."
+  ($_ seq
+      (test "Null is equal to itself."
+            (test-primitive-identity (` ("js null"))))
+      (test "Undefined is equal to itself."
+            (test-primitive-identity (` ("js undefined"))))
+      (test "Object comparison is by reference, not by value."
+            (not (test-primitive-identity (` ("js object")))))
+      (test "Values are equal to themselves."
+            (test-primitive-identity (` ("js global" "Math"))))
+      (<| (times +100)
+          (do @
+            [value r.int
+             #let [frac-value (int-to-frac value)]]
+            (test "Can call primitive functions."
+                  (|> (run-js (` ("js call" ("js global" "Math.sin") (~ (code.text (%f frac-value))))))
+                      (sin-check frac-value)))))
+      ))
+
+(context: "[JS] Objects."
+  (<| (times +100)
+      (do @
+        [field (:: @ map code.text (r.text' upper-alpha-ascii +5))
+         value r.int
+         #let [empty-object (` ("js object"))
+               object (` ("js object set" (~ field) (~ (code.int value)) (~ empty-object)))
+               frac-value (int-to-frac value)]]
+        ($_ seq
+            (test "Cannot get non-existing fields from objects."
+                  (|> (run-js (` ("js object get" (~ field) (~ empty-object))))
+                      (case> (^multi (#e.Success valueV)
+                                     [(:! (Maybe Int) valueV) #.None])
+                             true
+
+                             _
+                             false)))
+            (test "Can get fields from objects."
+                  (|> (run-js (` ("js object get" (~ field) (~ object))))
+                      (case> (^multi (#e.Success valueV)
+                                     [(:! (Maybe Int) valueV) (#.Some valueV)])
+                             (i/= value (:! Int valueV))
+
+                             _
+                             false)))
+            (test "Can delete fields from objects."
+                  (|> (run-js (let [post-delete (` ("js object delete" (~ field) (~ object)))]
+                                (` ("js object get" (~ field) (~ post-delete)))))
+                      (case> (^multi (#e.Success valueV)
+                                     [(:! (Maybe Int) valueV) #.None])
+                             true
+
+                             _
+                             false)))
+            (test "Can instance new objects."
+                  (let [base (` ("js object new" ("js global" "Number") (~ (code.text (%f frac-value)))))]
+                    (|> (run-js (` ("lux frac +" (~ base) 0.0)))
+                        (case> (#e.Success valueV)
+                               (f/= frac-value (:! Frac valueV))
+
+                               (#e.Error error)
+                               false))))
+            (test "Can call methods on objects."
+                  (|> (run-js (` ("js object call" ("js global" "Math") "sin" (~ (code.text (%f frac-value))))))
+                      (sin-check frac-value)))
+            ))))
+
+(context: "[JS] Arrays."
+  (<| (times +100)
+      (do @
+        [length (|> r.nat (:: @ map (|>> (n/% +10) (n/max +1))))
+         idx (|> r.nat (:: @ map (n/% length)))
+         overwrite r.nat
+         elems (|> (r.set number.Hash<Nat> length r.nat)
+                   (:: @ map set.to-list))
+         #let [arrayS (` ("js array literal" (~+ (list/map code.nat elems))))]]
+        ($_ seq
+            (test "Can get the length of an array."
+                  (|> (run-js (` ("js array length" (~ arrayS))))
+                      (length-check length)))
+            (test "Can get an element from an array."
+                  (|> (run-js (` ("js array read" (~ (code.nat idx)) (~ arrayS))))
+                      (case> (^multi (#e.Success elemV)
+                                     [[(list.nth idx elems) (:! (Maybe Nat) elemV)]
+                                      [(#.Some reference) (#.Some sample)]])
+                             (n/= reference sample)
+
+                             _
+                             false)))
+            (test "Can write an element into an array."
+                  (let [idxS (code.nat idx)
+                        overwriteS (code.nat overwrite)]
+                    (|> (run-js (` ("js array read" (~ idxS)
+                                    ("js array write" (~ idxS) (~ overwriteS) (~ arrayS)))))
+                        (case> (^multi (#e.Success elemV)
+                                       [(:! (Maybe Nat) elemV)
+                                        (#.Some sample)])
+                               (n/= overwrite sample)
+
+                               _
+                               false))))
+            (test "Can delete an element from an array."
+                  (let [idxS (code.nat idx)
+                        deleteS (` ("js array delete" (~ idxS) (~ arrayS)))]
+                    (and (|> (run-js (` ("js array length" (~ deleteS))))
+                             (length-check length))
+                         (|> (run-js (` ("js array read" (~ idxS) (~ deleteS))))
+                             (case> (^multi (#e.Success elemV)
+                                            [(:! (Maybe Nat) elemV)
+                                             #.None])
+                                    true
+
+                                    _
+                                    false))
+                         )))
+            ))))
diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux
index d33bcebd8..9268e492c 100644
--- a/new-luxc/test/tests.lux
+++ b/new-luxc/test/tests.lux
@@ -25,7 +25,8 @@
                                  ["_.T" case]
                                  ["_.T" function]
                                  ["_.T" common]
-                                 ["_.T" jvm]))
+                                 ["_.T" jvm]
+                                 ["_.T" js]))
               )))
 
 (program: args