aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/test
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/test/test/luxc/common.lux7
-rw-r--r--new-luxc/test/test/luxc/lang/translation/js/case.lux107
-rw-r--r--new-luxc/test/test/luxc/lang/translation/js/function.lux103
-rw-r--r--new-luxc/test/test/luxc/lang/translation/js/primitive.lux64
-rw-r--r--new-luxc/test/test/luxc/lang/translation/js/reference.lux82
-rw-r--r--new-luxc/test/test/luxc/lang/translation/js/structure.lux113
-rw-r--r--new-luxc/test/tests.lux22
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