From c8cda71ba02ab0986e3d4d839088aabdd02b37fa Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 22 Feb 2018 19:40:55 -0400 Subject: - Added tests for JS procedure translation. --- new-luxc/test/test/luxc/common.lux | 31 +++- new-luxc/test/test/luxc/lang/analysis/common.lux | 5 +- new-luxc/test/test/luxc/lang/analysis/function.lux | 12 +- .../test/test/luxc/lang/analysis/primitive.lux | 4 +- .../test/luxc/lang/analysis/procedure/common.lux | 8 +- .../test/luxc/lang/analysis/procedure/host.jvm.lux | 4 +- .../test/test/luxc/lang/analysis/reference.lux | 4 +- .../test/test/luxc/lang/analysis/structure.lux | 30 ++-- new-luxc/test/test/luxc/lang/analysis/type.lux | 4 +- .../test/test/luxc/lang/translation/common.lux | 2 +- new-luxc/test/test/luxc/lang/translation/js.lux | 160 +++++++++++++++++++++ new-luxc/test/tests.lux | 3 +- 12 files changed, 227 insertions(+), 40 deletions(-) create mode 100644 new-luxc/test/test/luxc/lang/translation/js.lux (limited to 'new-luxc/test') 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 [ ] [(def: #export @@ -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 + [_ 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] (data ["e" error]) [macro] @@ -40,7 +41,7 @@ [(def: #export ( analysis) (All [a] (-> (Meta a) Bool)) (|> analysis - (macro.run (init-compiler [])) + (macro.run (io.run init-jvm)) (case> (#e.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 " ".") (|> (@common.with-unknown-type ( )) - (macro.run (init-compiler [])) + (macro.run (io.run init-jvm)) (case> (#e.Success [_type [_ ( value)]]) (and (type/= _type) (is 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 _) @@ -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 _) @@ -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 _) 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] + [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 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 [ 
 <=>]
+  [(def: ( angle)
+     (->  Check)
+     (|>> (case> (#e.Success valueV)
+                 (<=> (
 angle) (:!  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 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
-- 
cgit v1.2.3