diff options
Diffstat (limited to 'new-luxc/test/test/luxc/lang/translation/jvm/case.lux')
-rw-r--r-- | new-luxc/test/test/luxc/lang/translation/jvm/case.lux | 105 |
1 files changed, 105 insertions, 0 deletions
diff --git a/new-luxc/test/test/luxc/lang/translation/jvm/case.lux b/new-luxc/test/test/luxc/lang/translation/jvm/case.lux new file mode 100644 index 000000000..91071be6c --- /dev/null +++ b/new-luxc/test/test/luxc/lang/translation/jvm/case.lux @@ -0,0 +1,105 @@ +(.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 (jvm ["@" case] + [".T" expression] + ["@." eval] + ["@." runtime] + ["@." common])))) + (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 (if (tail? size idx) + (` ("lux case tuple right" (~ (code.nat idx)) (~ subP))) + (` ("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 (if (tail? size idx) + (` ("lux case variant right" (~ (code.nat idx)) (~ subP))) + (` ("lux case variant left" (~ (code.nat idx)) (~ subP))))]] + (wrap [caseS caseP])) + )))) + +(context: "Pattern-matching." + (<| (seed +517905247826) + ## (times +100) + (do @ + [[valueS pathS] gen-case + to-bind r.nat] + ($_ seq + (test "Can translate pattern-matching." + (|> (do macro.Monad<Meta> + [runtime-bytecode @runtime.translate + sampleI (@.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)))))] + (@eval.eval sampleI)) + (lang.with-current-module "") + (macro.run (init-compiler [])) + (case> (#e.Success valueT) + (:! Bool valueT) + + (#e.Error error) + false))) + (test "Can bind values." + (|> (do macro.Monad<Meta> + [runtime-bytecode @runtime.translate + sampleI (@.translate-case expressionT.translate + (code.nat to-bind) + (` ("lux case seq" ("lux case bind" +0) + ("lux case exec" (0)))))] + (@eval.eval sampleI)) + (lang.with-current-module "") + (macro.run (init-compiler [])) + (case> (#e.Success valueT) + (n/= to-bind (:! Nat valueT)) + + _ + false))))))) |