diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/test/test/luxc/common.lux | 7 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/lang/translation/js/case.lux | 107 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/lang/translation/js/function.lux | 103 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/lang/translation/js/primitive.lux | 64 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/lang/translation/js/reference.lux | 82 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/lang/translation/js/structure.lux | 113 | ||||
| -rw-r--r-- | new-luxc/test/tests.lux | 22 |
7 files changed, 490 insertions, 8 deletions
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 |