diff options
author | Eduardo Julian | 2018-02-17 11:40:12 -0400 |
---|---|---|
committer | Eduardo Julian | 2018-02-17 11:40:12 -0400 |
commit | d01f75d220539efd7d58ee9534d3ef3a7bbc3cdc (patch) | |
tree | b0b4f7d06b3e57b3ec304a1323feaa1c44f605c9 | |
parent | 24b5c3a973dbfea7bd3de102c909af5483ade0f7 (diff) |
- Added tests for normal JS (non-procedure) behavior.
- Fixed a few bugs.
Diffstat (limited to '')
14 files changed, 525 insertions, 52 deletions
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<Meta> [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<Meta> [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 [<register> <translation> <prefix>] [(def: #export (<register> register) (-> Register //.Expression) - (format <prefix> (%n register))) + (format <prefix> (%i (nat-to-int register)))) (def: #export (<translation> 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<Meta> - [_ (//.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<Random>] + [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 [<gen> <synth>] + [(do r.Monad<Random> + [value <gen>] + (wrap [(<synth> value) (<synth> 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<Random> + [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<Random> + [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<Meta> + [_ 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<Meta> + [_ 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<List>])) + ["r" math/random "r/" Monad<Random>] + [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<Random> + [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<Meta> + [_ 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<Meta> + [#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<Meta> + [#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<Bool>] + [text "text/" Eq<Text>]) + ["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<Meta> + [_ 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 [<desc> <type> <synthesis> <sample> <test>] + [(test (format "Can translate " <desc> ".") + (|> (do macro.Monad<Meta> + [_ runtimeT.translate + sampleI (expressionT.translate (<synthesis> <sample>))] + (evalT.eval sampleI)) + (lang.with-current-module "") + (macro.run (init-js [])) + (case> (#e.Success valueT) + (<test> <sample> (:! <type> 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<Random> 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<Meta> + [_ 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<Meta> + [_ 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<Bool>] + [text "text/" Eq<Text>] + text/format + (coll [array] + [list])) + ["r" math/random "r/" Monad<Random>] + [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 [<tag> <type> <test>] + [_ (<tag> prediction')] + (case (host.try (<test> prediction' (:! <type> 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<Meta> + [_ 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<Meta> + [_ 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 |