aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/test
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/test')
-rw-r--r--new-luxc/test/test/luxc/analyser/case.lux22
-rw-r--r--new-luxc/test/test/luxc/generator/case.lux102
-rw-r--r--new-luxc/test/tests.lux1
3 files changed, 114 insertions, 11 deletions
diff --git a/new-luxc/test/test/luxc/analyser/case.lux b/new-luxc/test/test/luxc/analyser/case.lux
index 3c05f5dad..983dff6f5 100644
--- a/new-luxc/test/test/luxc/analyser/case.lux
+++ b/new-luxc/test/test/luxc/analyser/case.lux
@@ -40,7 +40,7 @@
head head+]
(wrap (#;Cons head tail+)))))
-(def: (exhaustive-branches-for allow-literals? variantTC inputC)
+(def: #export (exhaustive-branches allow-literals? variantTC inputC)
(-> Bool (List [Code Code]) Code (r;Random (List Code)))
(case inputC
[_ (#;Bool _)]
@@ -54,7 +54,7 @@
(case ?sample
(#;Some sample)
(do @
- [else (exhaustive-branches-for allow-literals? variantTC inputC)]
+ [else (exhaustive-branches allow-literals? variantTC inputC)]
(wrap (list& (<wrapper> sample) else)))
#;None
@@ -74,7 +74,7 @@
[_ (#;Tuple members)]
(do r;Monad<Random>
- [member-wise-patterns (monad;map @ (exhaustive-branches-for allow-literals? variantTC) members)]
+ [member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) members)]
(wrap (|> member-wise-patterns
exhaustive-weaving
(L/map code;tuple))))
@@ -83,7 +83,7 @@
(do r;Monad<Random>
[#let [ks (L/map product;left kvs)
vs (L/map product;right kvs)]
- member-wise-patterns (monad;map @ (exhaustive-branches-for allow-literals? variantTC) vs)]
+ member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) vs)]
(wrap (|> member-wise-patterns
exhaustive-weaving
(L/map (|>. (list;zip2 ks) code;record)))))
@@ -93,7 +93,7 @@
[bundles (monad;map @
(function [[_tag _code]]
(do @
- [v-branches (exhaustive-branches-for allow-literals? variantTC _code)]
+ [v-branches (exhaustive-branches allow-literals? variantTC _code)]
(wrap (L/map (function [pattern] (` ((~ _tag) (~ pattern))))
v-branches))))
variantTC)]
@@ -103,10 +103,10 @@
(r/wrap (list))
))
-(def: (gen-input variant-tags record-tags primitivesC)
+(def: #export (input variant-tags record-tags primitivesC)
(-> (List Code) (List Code) (List Code) (r;Random Code))
(r;rec
- (function [gen-input]
+ (function [input]
($_ r;either
(r/map product;right gen-primitive)
(do r;Monad<Random>
@@ -116,7 +116,7 @@
(wrap (` ((~ choiceT) (~ choiceC)))))
(do r;Monad<Random>
[size (|> r;nat (:: @ map (n.% +3)))
- elems (r;list size gen-input)]
+ elems (r;list size input)]
(wrap (code;tuple elems)))
(r/wrap (code;record (list;zip2 record-tags primitivesC)))
))))
@@ -141,12 +141,12 @@
variant-tags+ (L/map (|>. [module-name] code;tag) variant-tags)
record-tags+ (L/map (|>. [module-name] code;tag) record-tags)
variantTC (list;zip2 variant-tags+ primitivesC)]
- inputC (gen-input variant-tags+ record-tags+ primitivesC)
+ inputC (input variant-tags+ record-tags+ primitivesC)
[outputT outputC] gen-primitive
[heterogeneousT heterogeneousC] (|> gen-primitive
(r;filter (|>. product;left (tc;checks? outputT) not)))
- exhaustive-patterns (exhaustive-branches-for true variantTC inputC)
- redundant-patterns (exhaustive-branches-for false variantTC inputC)
+ exhaustive-patterns (exhaustive-branches true variantTC inputC)
+ redundant-patterns (exhaustive-branches false variantTC inputC)
redundancy-idx (|> r;nat (:: @ map (n.% (list;size redundant-patterns))))
heterogeneous-idx (|> r;nat (:: @ map (n.% (list;size exhaustive-patterns))))
#let [exhaustive-branchesC (L/map (branch outputC)
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)))))
diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux
index 06f3e940e..d07822069 100644
--- a/new-luxc/test/tests.lux
+++ b/new-luxc/test/tests.lux
@@ -20,6 +20,7 @@
["_;S" loop])
(generator ["_;G" primitive]
["_;G" structure]
+ ["_;G" case]
(procedure ["_;G" common]))
))
## (luxc (generator ["_;G" function]))
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-23 02:43:48 +0000