From d01f75d220539efd7d58ee9534d3ef3a7bbc3cdc Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sat, 17 Feb 2018 11:40:12 -0400
Subject: - Added tests for normal JS (non-procedure) behavior. - Fixed a few
bugs.
---
new-luxc/source/luxc/lang/translation/js.lux | 22 ++--
.../source/luxc/lang/translation/js/case.jvm.lux | 4 +-
.../source/luxc/lang/translation/js/eval.jvm.lux | 29 ++----
.../luxc/lang/translation/js/expression.jvm.lux | 2 +-
.../luxc/lang/translation/js/reference.jvm.lux | 4 +-
.../luxc/lang/translation/js/runtime.jvm.lux | 9 +-
.../luxc/lang/translation/js/statement.jvm.lux | 9 +-
new-luxc/test/test/luxc/common.lux | 7 +-
.../test/test/luxc/lang/translation/js/case.lux | 107 +++++++++++++++++++
.../test/luxc/lang/translation/js/function.lux | 103 +++++++++++++++++++
.../test/luxc/lang/translation/js/primitive.lux | 64 ++++++++++++
.../test/luxc/lang/translation/js/reference.lux | 82 +++++++++++++++
.../test/luxc/lang/translation/js/structure.lux | 113 +++++++++++++++++++++
new-luxc/test/tests.lux | 22 ++--
14 files changed, 525 insertions(+), 52 deletions(-)
create mode 100644 new-luxc/test/test/luxc/lang/translation/js/case.lux
create mode 100644 new-luxc/test/test/luxc/lang/translation/js/function.lux
create mode 100644 new-luxc/test/test/luxc/lang/translation/js/primitive.lux
create mode 100644 new-luxc/test/test/luxc/lang/translation/js/reference.lux
create mode 100644 new-luxc/test/test/luxc/lang/translation/js/structure.lux
diff --git a/new-luxc/source/luxc/lang/translation/js.lux b/new-luxc/source/luxc/lang/translation/js.lux
index 9b1b2b503..680439355 100644
--- a/new-luxc/source/luxc/lang/translation/js.lux
+++ b/new-luxc/source/luxc/lang/translation/js.lux
@@ -35,8 +35,10 @@
(host.import java/lang/Long
(intValue [] Integer))
-(host.import java/lang/AbstractStringBuilder
- (append [String] AbstractStringBuilder))
+(host.import java/lang/CharSequence)
+
+(host.import java/lang/Appendable
+ (append [CharSequence] Appendable))
(host.import java/lang/StringBuilder
(new [])
@@ -80,8 +82,8 @@
(def: #export module-js-name Text "module.js")
-(def: #export (init-module-buffer _)
- (-> Top (Meta Unit))
+(def: #export init-module-buffer
+ (Meta Unit)
(function [compiler]
(#e.Success [(update@ #.host
(|>> (:! Host)
@@ -297,12 +299,6 @@
(:! Object)))
))
-## (def: (wrap-lux-object object)
-## (-> Top JSObject)
-## (if (host.instance? JSObject object)
-## (lux-obj object)
-## obj))
-
(def: #export unit Text "\u0000")
(def: (module-name module)
@@ -319,7 +315,8 @@
(-> JS (Meta Unit))
(do macro.Monad
[module-buffer module-buffer
- #let [_ (AbstractStringBuilder::append [code] module-buffer)]]
+ #let [_ (Appendable::append [(:! CharSequence code)]
+ module-buffer)]]
(execute code)))
(def: #export (save-definition name code)
@@ -333,7 +330,8 @@
module-buffer module-buffer
program-buffer program-buffer
#let [module-code (StringBuilder::toString [] module-buffer)
- _ (AbstractStringBuilder::append [(format module-code "\n")] program-buffer)]]
+ _ (Appendable::append [(:! CharSequence (format module-code "\n"))]
+ program-buffer)]]
(wrap (ioC.write target
(format module "/" module-js-name)
(|> module-code
diff --git a/new-luxc/source/luxc/lang/translation/js/case.jvm.lux b/new-luxc/source/luxc/lang/translation/js/case.jvm.lux
index 626181984..cbb0e6c77 100644
--- a/new-luxc/source/luxc/lang/translation/js/case.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/case.jvm.lux
@@ -12,8 +12,8 @@
[".T" primitive]
[".T" reference]))
-(def: #export (translate-let translate valueS register bodyS)
- (-> (-> ls.Synthesis (Meta //.Expression)) ls.Synthesis Nat ls.Synthesis
+(def: #export (translate-let translate register valueS bodyS)
+ (-> (-> ls.Synthesis (Meta //.Expression)) Nat ls.Synthesis ls.Synthesis
(Meta //.Expression))
(do macro.Monad
[valueJS (translate valueS)
diff --git a/new-luxc/source/luxc/lang/translation/js/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/js/eval.jvm.lux
index bcf70bcae..fada5a70c 100644
--- a/new-luxc/source/luxc/lang/translation/js/eval.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/eval.jvm.lux
@@ -12,13 +12,14 @@
(host.import java/lang/Object
(toString [] String))
-(host.import java/lang/Number
- (doubleValue [] double)
- (longValue [] Long))
-
(host.import java/lang/Integer
(longValue [] Long))
+(host.import java/lang/Number
+ (doubleValue [] double)
+ (longValue [] Long)
+ (intValue [] Integer))
+
(host.import javax/script/ScriptEngine
(eval [String] #try #? Object))
@@ -51,18 +52,14 @@
[[(Number::longValue [] (:! Number high))
(Number::longValue [] (:! Number low))]
[high low]])
- (#.Some (nat-to-int (n/+ (|> high (:! Int) int-to-nat (bit.shift-left +32))
- (|> low (:! Int) int-to-nat))))
+ (#.Some (nat-to-int (n/+ (|> high (:! Nat) (bit.shift-left +32))
+ (if (i/< 0 (:! Int low))
+ (|> low (:! Nat) (bit.shift-left +32) (bit.shift-right +32))
+ (|> low (:! Nat))))))
_
#.None))
-(def: (extend-array by input)
- (All [a] (-> Nat (Array a) (Array a)))
- (let [size (array.size input)]
- (|> (array.new (n/+ by size))
- (array.copy size +0 input +0))))
-
(def: (array element-parser js-object)
(-> (-> Object (Error Top)) ScriptObjectMirror (Maybe (Array Object)))
(if (JSObject::isArray [] js-object)
@@ -77,17 +74,13 @@
(#.Some member)
(case (element-parser member)
(#e.Success parsed-member)
- (recur num-keys
- (n/inc idx)
- (array.write idx (:! Object parsed-member) output))
+ (recur num-keys (n/inc idx) (array.write idx (:! Object parsed-member) output))
(#e.Error error)
#.None)
#.None
- (recur (n/inc num-keys)
- (n/inc idx)
- (extend-array +1 output))))
+ (recur num-keys (n/inc idx) output)))
(#.Some output))))
#.None))
diff --git a/new-luxc/source/luxc/lang/translation/js/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/js/expression.jvm.lux
index 4634497a1..1bde82766 100644
--- a/new-luxc/source/luxc/lang/translation/js/expression.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/expression.jvm.lux
@@ -56,7 +56,7 @@
(referenceT.translate-definition definition)
(^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS)))
- (caseT.translate-let translate inputS register exprS)
+ (caseT.translate-let translate register inputS exprS)
(^code ("lux case" (~ inputS) (~ pathPS)))
(caseT.translate-case translate inputS pathPS)
diff --git a/new-luxc/source/luxc/lang/translation/js/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/js/reference.jvm.lux
index 66d340949..d9e508193 100644
--- a/new-luxc/source/luxc/lang/translation/js/reference.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/reference.jvm.lux
@@ -11,7 +11,7 @@
(do-template [ ]
[(def: #export ( register)
(-> Register //.Expression)
- (format (%n register)))
+ (format (%i (nat-to-int register))))
(def: #export ( register)
(-> Register (Meta //.Expression))
@@ -23,7 +23,7 @@
(def: #export (translate-variable var)
(-> Variable (Meta //.Expression))
(if (variableL.captured? var)
- (translate-captured (int-to-nat var))
+ (translate-captured (variableL.captured-register var))
(translate-local (int-to-nat var))))
(def: #export global
diff --git a/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux
index e9653547d..aceac4089 100644
--- a/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux
@@ -1059,9 +1059,9 @@
(def: #export atom-field Text "V")
(runtime: atom//compare-and-swap "atomCompareAndSwap"
- (format "(function " @ "(atom,old,new) {"
- "if(atom." atom-field " === old) {"
- "atom." atom-field " = new;"
+ (format "(function " @ "(atom,oldV,newV) {"
+ "if(atom." atom-field " === oldV) {"
+ "atom." atom-field " = newV;"
"return true;"
"}"
"else {"
@@ -1127,5 +1127,6 @@
(def: #export translate
(Meta (Process Unit))
(do macro.Monad
- [_ (//.save-js runtime)]
+ [_ //.init-module-buffer
+ _ (//.save-js runtime)]
(//.save-module! artifact)))
diff --git a/new-luxc/source/luxc/lang/translation/js/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/js/statement.jvm.lux
index e430d22ae..a2c0c6510 100644
--- a/new-luxc/source/luxc/lang/translation/js/statement.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/statement.jvm.lux
@@ -6,7 +6,8 @@
(luxc (lang [".L" module]))
[//]
(// [".T" runtime]
- [".T" reference]))
+ [".T" reference]
+ [".T" eval]))
(def: #export (translate-def name expressionT expressionJS metaV)
(-> Text Type //.Expression Code (Meta Unit))
@@ -22,10 +23,8 @@
_
(do @
- [#let [def-name (referenceT.global def-ident)]
- ## _ (hostT.save (format "var " def-name " = " expressionJS ";"))
- #let [expressionV (: Top [])]
- ## expressionV (hostT.eval def-name)
+ [_ (//.save-definition def-ident expressionJS)
+ expressionV (evalT.eval (referenceT.global def-ident))
_ (moduleL.define def-ident [expressionT metaV expressionV])
_ (if (macro.type? metaV)
(case (macro.declared-tags metaV)
diff --git a/new-luxc/test/test/luxc/common.lux b/new-luxc/test/test/luxc/common.lux
index 5ec4b1259..b9f5af6bd 100644
--- a/new-luxc/test/test/luxc/common.lux
+++ b/new-luxc/test/test/luxc/common.lux
@@ -2,8 +2,13 @@
lux
(lux [io])
(luxc (lang ["&." host]
- [".L" init])))
+ [".L" init]
+ (translation [js]))))
(def: #export (init-compiler _)
(-> Top Compiler)
(initL.compiler (io.run &host.init-host)))
+
+(def: #export (init-js _)
+ (-> Top Compiler)
+ (initL.compiler (io.run js.init)))
diff --git a/new-luxc/test/test/luxc/lang/translation/js/case.lux b/new-luxc/test/test/luxc/lang/translation/js/case.lux
new file mode 100644
index 000000000..ea527b86b
--- /dev/null
+++ b/new-luxc/test/test/luxc/lang/translation/js/case.lux
@@ -0,0 +1,107 @@
+(.module:
+ lux
+ (lux [io]
+ (control [monad #+ do]
+ pipe)
+ (data ["e" error]
+ text/format
+ (coll [list]))
+ ["r" math/random "r/" Monad]
+ [macro]
+ (macro [code])
+ test)
+ (luxc [lang]
+ (lang ["ls" synthesis]
+ (translation (js ["/" case]
+ [".T" expression]
+ [".T" eval]
+ [".T" runtime]))))
+ (test/luxc common))
+
+(def: struct-limit Nat +10)
+
+(def: (tail? size idx)
+ (-> Nat Nat Bool)
+ (n/= (n/dec size) idx))
+
+(def: gen-case
+ (r.Random [ls.Synthesis ls.Path])
+ (<| r.rec (function [gen-case])
+ (`` ($_ r.either
+ (r/wrap [(' []) (' ("lux case pop"))])
+ (~~ (do-template [ ]
+ [(do r.Monad
+ [value ]
+ (wrap [( value) ( value)]))]
+
+ [r.bool code.bool]
+ [r.nat code.nat]
+ [r.int code.int]
+ [r.deg code.deg]
+ [r.frac code.frac]
+ [(r.text +5) code.text]))
+ (do r.Monad
+ [size (|> r.nat (:: @ map (|>> (n/% struct-limit) (n/max +2))))
+ idx (|> r.nat (:: @ map (n/% size)))
+ [subS subP] gen-case
+ #let [caseS (` [(~+ (list.concat (list (list.repeat idx (' []))
+ (list subS)
+ (list.repeat (|> size n/dec (n/- idx)) (' [])))))])
+ caseP (` ("lux case seq"
+ (~ (if (tail? size idx)
+ (` ("lux case tuple right" (~ (code.nat idx))))
+ (` ("lux case tuple left" (~ (code.nat idx))))))
+ (~ subP)))]]
+ (wrap [caseS caseP]))
+ (do r.Monad
+ [size (|> r.nat (:: @ map (|>> (n/% struct-limit) (n/max +2))))
+ idx (|> r.nat (:: @ map (n/% size)))
+ [subS subP] gen-case
+ #let [caseS (` ((~ (code.nat idx)) (~ (code.bool (tail? size idx))) (~ subS)))
+ caseP (` ("lux case seq"
+ (~ (if (tail? size idx)
+ (` ("lux case variant right" (~ (code.nat idx))))
+ (` ("lux case variant left" (~ (code.nat idx))))))
+ (~ subP)))]]
+ (wrap [caseS caseP]))
+ ))))
+
+(context: "Pattern-matching."
+ (<| (times +100)
+ (do @
+ [[valueS pathS] gen-case
+ to-bind r.nat]
+ ($_ seq
+ (test "Can translate pattern-matching."
+ (|> (do macro.Monad
+ [_ runtimeT.translate
+ sampleJS (/.translate-case expressionT.translate
+ valueS
+ (` ("lux case alt"
+ ("lux case seq" (~ pathS)
+ ("lux case exec" true))
+ ("lux case seq" ("lux case bind" +0)
+ ("lux case exec" false)))))]
+ (evalT.eval sampleJS))
+ (lang.with-current-module "")
+ (macro.run (init-js []))
+ (case> (#e.Success valueT)
+ (:! Bool valueT)
+
+ (#e.Error error)
+ false)))
+ (test "Can bind values."
+ (|> (do macro.Monad
+ [_ runtimeT.translate
+ sampleJS (/.translate-case expressionT.translate
+ (code.nat to-bind)
+ (` ("lux case seq" ("lux case bind" +0)
+ ("lux case exec" (0)))))]
+ (evalT.eval sampleJS))
+ (lang.with-current-module "")
+ (macro.run (init-js []))
+ (case> (#e.Success valueT)
+ (n/= to-bind (:! Nat valueT))
+
+ _
+ false)))))))
diff --git a/new-luxc/test/test/luxc/lang/translation/js/function.lux b/new-luxc/test/test/luxc/lang/translation/js/function.lux
new file mode 100644
index 000000000..6cb1e64cc
--- /dev/null
+++ b/new-luxc/test/test/luxc/lang/translation/js/function.lux
@@ -0,0 +1,103 @@
+(.module:
+ lux
+ (lux [io]
+ (control [monad #+ do]
+ pipe)
+ (data [product]
+ [maybe]
+ ["e" error]
+ (coll ["a" array]
+ [list "list/" Functor]))
+ ["r" math/random "r/" Monad]
+ [macro]
+ (macro [code])
+ [host]
+ test)
+ (luxc [lang]
+ (lang ["ls" synthesis]
+ (translation (js [".T" expression]
+ [".T" eval]
+ [".T" runtime]))))
+ (test/luxc common))
+
+(def: arity-limit Nat +10)
+
+(def: arity
+ (r.Random ls.Arity)
+ (|> r.nat (r/map (|>> (n/% arity-limit) (n/max +1)))))
+
+(def: gen-function
+ (r.Random [ls.Arity Nat ls.Synthesis])
+ (do r.Monad
+ [arity arity
+ arg (|> r.nat (:: @ map (n/% arity)))
+ #let [functionS (` ("lux function" (~ (code.nat arity)) []
+ ((~ (code.int (nat-to-int (n/inc arg)))))))]]
+ (wrap [arity arg functionS])))
+
+(context: "Function."
+ (<| (times +100)
+ (do @
+ [[arity arg functionS] gen-function
+ cut-off (|> r.nat (:: @ map (n/% arity)))
+ args (r.list arity r.nat)
+ #let [arg-value (maybe.assume (list.nth arg args))
+ argsS (list/map code.nat args)
+ last-arg (n/dec arity)
+ cut-off (|> cut-off (n/min (n/dec last-arg)))]]
+ ($_ seq
+ (test "Can read arguments."
+ (|> (do macro.Monad
+ [_ runtimeT.translate
+ sampleJS (expressionT.translate (` ("lux call" (~ functionS) (~+ argsS))))]
+ (evalT.eval sampleJS))
+ (lang.with-current-module "")
+ (macro.run (init-js []))
+ (case> (#e.Success valueT)
+ (n/= arg-value (:! Nat valueT))
+
+ (#e.Error error)
+ false)))
+ (test "Can partially apply functions."
+ (or (n/= +1 arity)
+ (|> (do macro.Monad
+ [#let [partial-arity (n/inc cut-off)
+ preS (list.take partial-arity argsS)
+ postS (list.drop partial-arity argsS)]
+ _ runtimeT.translate
+ sampleJS (expressionT.translate (` ("lux call"
+ ("lux call" (~ functionS) (~+ preS))
+ (~+ postS))))]
+ (evalT.eval sampleJS))
+ (lang.with-current-module "")
+ (macro.run (init-js []))
+ (case> (#e.Success valueT)
+ (n/= arg-value (:! Nat valueT))
+
+ (#e.Error error)
+ false))))
+ (test "Can read environment."
+ (or (n/= +1 arity)
+ (|> (do macro.Monad
+ [#let [env (|> (list.n/range +0 cut-off)
+ (list/map (|>> n/inc nat-to-int)))
+ super-arity (n/inc cut-off)
+ arg-var (if (n/<= cut-off arg)
+ (|> arg n/inc nat-to-int (i/* -1))
+ (|> arg n/inc (n/- super-arity) nat-to-int))
+ sub-arity (|> arity (n/- super-arity))
+ functionS (` ("lux function" (~ (code.nat super-arity)) []
+ ("lux function" (~ (code.nat sub-arity)) [(~+ (list/map code.int env))]
+ ((~ (code.int arg-var))))))]
+ _ runtimeT.translate
+ sampleJS (expressionT.translate (` ("lux call" (~ functionS) (~+ argsS))))]
+ (evalT.eval sampleJS))
+ (lang.with-current-module "")
+ (macro.run (init-js []))
+ (case> (#e.Success valueT)
+ (n/= arg-value (:! Nat valueT))
+
+ (#e.Error error)
+ (exec (log! error)
+ false)))))
+ ))))
diff --git a/new-luxc/test/test/luxc/lang/translation/js/primitive.lux b/new-luxc/test/test/luxc/lang/translation/js/primitive.lux
new file mode 100644
index 000000000..91828eb3b
--- /dev/null
+++ b/new-luxc/test/test/luxc/lang/translation/js/primitive.lux
@@ -0,0 +1,64 @@
+(.module:
+ lux
+ (lux [io]
+ (control [monad #+ do]
+ pipe)
+ (data text/format
+ ["e" error]
+ [bool "bool/" Eq]
+ [text "text/" Eq])
+ ["r" math/random]
+ [macro]
+ (macro [code])
+ test)
+ (luxc [lang]
+ (lang [".L" host]
+ ["ls" synthesis]
+ (translation (js [".T" expression]
+ [".T" runtime]
+ [".T" eval]))))
+ (test/luxc common))
+
+(context: "Primitives."
+ (<| (times +100)
+ (do @
+ [%bool% r.bool
+ %nat% r.nat
+ %int% r.int
+ %deg% r.deg
+ %frac% r.frac
+ %text% (r.text +5)]
+ (`` ($_ seq
+ (test "Can translate unit."
+ (|> (do macro.Monad
+ [_ runtimeT.translate
+ sampleI (expressionT.translate (' []))]
+ (evalT.eval sampleI))
+ (lang.with-current-module "")
+ (macro.run (init-js []))
+ (case> (#e.Success valueT)
+ (is hostL.unit (:! Text valueT))
+
+ _
+ false)))
+ (~~ (do-template [ ]
+ [(test (format "Can translate " ".")
+ (|> (do macro.Monad
+ [_ runtimeT.translate
+ sampleI (expressionT.translate ( ))]
+ (evalT.eval sampleI))
+ (lang.with-current-module "")
+ (macro.run (init-js []))
+ (case> (#e.Success valueT)
+ ( (:! valueT))
+
+ (#e.Error error)
+ false)))]
+
+ ["bool" Bool code.bool %bool% bool/=]
+ ["nat" Nat code.nat %nat% n/=]
+ ["int" Int code.int %int% i/=]
+ ["deg" Deg code.deg %deg% d/=]
+ ["frac" Frac code.frac %frac% f/=]
+ ["text" Text code.text %text% text/=]))
+ )))))
diff --git a/new-luxc/test/test/luxc/lang/translation/js/reference.lux b/new-luxc/test/test/luxc/lang/translation/js/reference.lux
new file mode 100644
index 000000000..80ccd3123
--- /dev/null
+++ b/new-luxc/test/test/luxc/lang/translation/js/reference.lux
@@ -0,0 +1,82 @@
+(.module:
+ lux
+ (lux [io]
+ (control [monad #+ do]
+ pipe)
+ (data ["e" error]
+ [text])
+ ["r" math/random]
+ [macro]
+ (macro [code])
+ test)
+ (luxc [lang]
+ (lang ["_." module]
+ ["ls" synthesis]
+ (translation (js [".T" statement]
+ [".T" eval]
+ [".T" expression]
+ [".T" case]
+ [".T" runtime]))))
+ (test/luxc common))
+
+(def: upper-alpha-ascii
+ (r.Random Nat)
+ (|> r.nat (:: r.Functor map (|>> (n/% +91) (n/max +65)))))
+
+(def: ident-part
+ (r.Random Text)
+ (|> (r.text' upper-alpha-ascii +5)
+ (r.filter (function [sample]
+ (not (or (text.contains? "/" sample)
+ (text.contains? "[" sample)
+ (text.contains? "]" sample)))))))
+
+(context: "Definitions."
+ (<| (times +100)
+ (do @
+ [module-name ident-part
+ def-name ident-part
+ def-value r.int]
+ ($_ seq
+ (test "Can refer to definitions."
+ (|> (do macro.Monad
+ [_ runtimeT.translate
+ valueJS (expressionT.translate (code.int def-value))
+ _ (_module.with-module +0 module-name
+ (statementT.translate-def def-name Int valueJS (' {})))
+ sampleJS (expressionT.translate (code.symbol [module-name def-name]))]
+ (evalT.eval sampleJS))
+ (lang.with-current-module "")
+ (macro.run (init-js []))
+ (case> (#e.Success valueT)
+ (i/= def-value (:! Int valueT))
+
+ (#e.Error error)
+ (exec (log! error)
+ false))))
+ ))))
+
+(context: "Variables."
+ (<| (times +100)
+ (do @
+ [module-name (|> (r.text +5) (r.filter (|>> (text.contains? "/") not)))
+ register (|> r.nat (:: @ map (n/% +100)))
+ value r.int]
+ ($_ seq
+ (test "Can refer to local variables/registers."
+ (|> (do macro.Monad
+ [_ runtimeT.translate
+ sampleJS (caseT.translate-let expressionT.translate
+ register
+ (code.int value)
+ (` ((~ (code.int (nat-to-int register))))))]
+ (evalT.eval sampleJS))
+ (lang.with-current-module "")
+ (macro.run (init-js []))
+ (case> (#e.Success outputT)
+ (i/= value (:! Int outputT))
+
+ (#e.Error error)
+ (exec (log! error)
+ false))))
+ ))))
diff --git a/new-luxc/test/test/luxc/lang/translation/js/structure.lux b/new-luxc/test/test/luxc/lang/translation/js/structure.lux
new file mode 100644
index 000000000..fde45c1cb
--- /dev/null
+++ b/new-luxc/test/test/luxc/lang/translation/js/structure.lux
@@ -0,0 +1,113 @@
+(.module:
+ lux
+ (lux [io]
+ (control [monad #+ do]
+ pipe)
+ (data ["e" error]
+ [maybe]
+ [bool "bool/" Eq]
+ [text "text/" Eq]
+ text/format
+ (coll [array]
+ [list]))
+ ["r" math/random "r/" Monad]
+ [macro]
+ (macro [code])
+ [host]
+ test)
+ (luxc [lang]
+ (lang [".L" host]
+ ["ls" synthesis]
+ (translation (js [".T" expression]
+ [".T" runtime]
+ [".T" eval]))))
+ (test/luxc common))
+
+(host.import java/lang/Long)
+
+(def: gen-primitive
+ (r.Random ls.Synthesis)
+ (r.either (r.either (r.either (r/wrap (' []))
+ (r/map code.bool r.bool))
+ (r.either (r/map code.nat r.nat)
+ (r/map code.int r.int)))
+ (r.either (r.either (r/map code.deg r.deg)
+ (r/map code.frac r.frac))
+ (r/map code.text (r.text +5)))))
+
+(def: (corresponds? [prediction sample])
+ (-> [ls.Synthesis Top] Bool)
+ (case prediction
+ [_ (#.Tuple #.Nil)]
+ (text/= hostL.unit (:! Text sample))
+
+ (^template [ ]
+ [_ ( prediction')]
+ (case (host.try ( prediction' (:! sample)))
+ (#e.Success result)
+ result
+
+ (#e.Error error)
+ false))
+ ([#.Bool Bool bool/=]
+ [#.Nat Nat n/=]
+ [#.Int Int i/=]
+ [#.Deg Deg d/=]
+ [#.Frac Frac f/=]
+ [#.Text Text text/=])
+
+ _
+ false
+ ))
+
+(context: "Tuples."
+ (<| (times +100)
+ (do @
+ [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2))))
+ members (r.list size gen-primitive)]
+ (test "Can translate tuple."
+ (|> (do macro.Monad
+ [_ runtimeT.translate
+ sampleI (expressionT.translate (code.tuple members))]
+ (evalT.eval sampleI))
+ (lang.with-current-module "")
+ (macro.run (init-js []))
+ (case> (#e.Success valueT)
+ (let [valueT (:! (Array Top) valueT)]
+ (and (n/= size (array.size valueT))
+ (list.every? corresponds? (list.zip2 members (array.to-list valueT)))))
+
+ (#e.Error error)
+ false))))))
+
+(context: "Variants."
+ (<| (times +100)
+ (do @
+ [num-tags (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2))))
+ tag (|> r.nat (:: @ map (n/% num-tags)))
+ #let [last? (n/= (n/dec num-tags) tag)]
+ member gen-primitive]
+ (test "Can translate variant."
+ (|> (do macro.Monad
+ [_ runtimeT.translate
+ sampleI (expressionT.translate (` ((~ (code.nat tag)) (~ (code.bool last?)) (~ member))))]
+ (evalT.eval sampleI))
+ (lang.with-current-module "")
+ (macro.run (init-js []))
+ (case> (#e.Success valueT)
+ (let [valueT (:! (Array Top) valueT)]
+ (and (n/= +3 (array.size valueT))
+ (let [_tag (:! Long (maybe.assume (array.read +0 valueT)))
+ _last? (array.read +1 valueT)
+ _value (:! Top (maybe.assume (array.read +2 valueT)))]
+ (and (n/= tag (|> _tag (:! Nat)))
+ (case _last?
+ (#.Some _last?')
+ (and last? (text/= "" (:! Text _last?')))
+
+ #.None
+ (not last?))
+ (corresponds? [member _value])))))
+
+ (#e.Error error)
+ false))))))
diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux
index ce15be88f..2404dde73 100644
--- a/new-luxc/test/tests.lux
+++ b/new-luxc/test/tests.lux
@@ -19,13 +19,21 @@
["_.S" function]
["_.S" procedure]
["_.S" loop])
- (translation (jvm ["_.T" primitive]
- ["_.T" structure]
- ["_.T" case]
- ["_.T" function]
- ["_.T" reference]
- (procedure ["_.T" common]
- ["_.T" host]))))
+ (translation (jvm ["_.T_jvm" primitive]
+ ["_.T_jvm" structure]
+ ["_.T_jvm" case]
+ ["_.T_jvm" function]
+ ["_.T_jvm" reference]
+ (procedure ["_.T_jvm" common]
+ ["_.T_jvm" host]))
+ (js ["_.T_js" primitive]
+ ["_.T_js" structure]
+ ["_.T_js" case]
+ ["_.T_js" function]
+ ["_.T_js" reference]
+ ## (procedure ["_.T_js" common]
+ ## ["_.T_js" host])
+ )))
)))
(program: args
--
cgit v1.2.3