diff options
author | Eduardo Julian | 2017-09-17 00:38:24 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-09-17 00:38:24 -0400 |
commit | c95fa2cc7db042fdde7250479727650f43b087a1 (patch) | |
tree | cf4cc5a1829fa717b4dad17683251af56c54afa3 /new-luxc/test/test/luxc/generator/case.lux | |
parent | 18fa9ac1ded14e8e6b96609ff1fb6f98af47580f (diff) |
- Added pattern-matching compilation.
Diffstat (limited to '')
-rw-r--r-- | new-luxc/test/test/luxc/generator/case.lux | 102 |
1 files changed, 102 insertions, 0 deletions
diff --git a/new-luxc/test/test/luxc/generator/case.lux b/new-luxc/test/test/luxc/generator/case.lux new file mode 100644 index 000000000..9e6dbf928 --- /dev/null +++ b/new-luxc/test/test/luxc/generator/case.lux @@ -0,0 +1,102 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data text/format + [product] + ["R" result] + [bool "B/" Eq<Bool>] + [text "T/" Eq<Text>] + (coll ["a" array] + [list "L/" Functor<List>] + ["S" set])) + ["r" math/random "r/" Monad<Random>] + [macro #+ Monad<Lux>] + (macro [code]) + [host] + test) + (luxc (lang ["ls" synthesis]) + [analyser] + [synthesizer] + (generator ["@" case] + ["@;" 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]) + (with-expansions [<simple> (do-template [<gen> <synth> <path>] + [(do r;Monad<Random> + [value <gen>] + (wrap [(<synth> value) (<path> value)]))] + + [r;bool #ls;Bool #ls;BoolP] + [r;nat #ls;Nat #ls;NatP] + [r;int #ls;Int #ls;IntP] + [r;deg #ls;Deg #ls;DegP] + [r;frac #ls;Frac #ls;FracP] + [(r;text +5) #ls;Text #ls;TextP])] + ($_ r;either + (r/wrap [#ls;Unit #ls;UnitP]) + <simple> + (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 [dummyS (list;repeat (n.dec size) #ls;Unit) + caseS (#ls;Tuple (list;concat (list (list;take idx dummyS) + (list subS) + (list;drop idx dummyS)))) + caseP (#ls;TupleP (if (tail? idx idx) + (#;Right idx) + (#;Left 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 (#ls;Variant idx (tail? idx idx) subS) + caseP (#ls;VariantP (if (tail? idx idx) + (#;Right idx) + (#;Left idx)) + subP)]] + (wrap [caseS caseP])) + )))) + +(context: "Pattern-matching." + [[valueS path] gen-case + to-bind r;nat] + ($_ seq + (test "Can generate pattern-matching." + (|> (do Monad<Lux> + [runtime-bytecode @runtime;generate] + (@eval;eval (@;generate valueS + (#ls;AltP (#ls;SeqP path (#ls;ExecP (#ls;Bool true))) + (#ls;SeqP (#ls;BindP +0) (#ls;ExecP (#ls;Bool false))))))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (:! Bool valueG) + + _ + false))) + (test "Can bind values." + (|> (do Monad<Lux> + [runtime-bytecode @runtime;generate] + (@eval;eval (@;generate (#ls;Nat to-bind) + (#ls;SeqP (#ls;BindP +1) (#ls;ExecP (#ls;Variable 1)))))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (n.= to-bind (:! Nat valueG)) + + _ + false))))) |