aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/test
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/test/test/luxc/synthesizer/case.lux213
-rw-r--r--new-luxc/test/tests.lux4
2 files changed, 1 insertions, 216 deletions
diff --git a/new-luxc/test/test/luxc/synthesizer/case.lux b/new-luxc/test/test/luxc/synthesizer/case.lux
deleted file mode 100644
index ff60deedb..000000000
--- a/new-luxc/test/test/luxc/synthesizer/case.lux
+++ /dev/null
@@ -1,213 +0,0 @@
-(;module:
- lux
- (lux [io]
- (control [monad #+ do]
- pipe
- eq)
- (data [bool "B/" Eq<Bool>]
- [text "T/" Eq<Text>]
- [product]
- [number]
- text/format
- (coll [list "L/" Functor<List> Fold<List> Monoid<List>]
- ["s" set]))
- ["r" math/random "r/" Monad<Random>]
- test)
- (luxc (lang ["la" analysis]
- ["ls" synthesis])
- [synthesizer]
- (synthesizer ["@" case]))
- (.. common))
-
-(struct: _ (Eq ls;Synthesis)
- (def: (= reference sample)
- (case [reference sample]
- (^template [<tag> <test>]
- [(<tag> reference') (<tag> sample')]
- (<test> reference' sample'))
- ([#ls;Unit is]
- [#ls;Bool B/=]
- [#ls;Nat n.=]
- [#ls;Int i.=]
- [#ls;Deg d.=]
- [#ls;Frac f.=]
- [#ls;Text T/=])
-
- _
- false)))
-
-(struct: _ (Eq ls;Path)
- (def: (= reference sample)
- (case [reference sample]
- (^or [#ls;UnitP #ls;UnitP]
- [(#ls;ExecP _) (#ls;ExecP _)])
- true
-
- (^template [<tag> <eq>]
- [(<tag> reference') (<tag> sample')]
- (<eq> reference' sample'))
- ([#ls;BindP n.=]
- [#ls;BoolP B/=]
- [#ls;NatP n.=]
- [#ls;IntP i.=]
- [#ls;DegP d.=]
- [#ls;FracP f.=]
- [#ls;TextP T/=])
-
- (^template [<outer> <inner>]
- [(<outer> (<inner> reference') reference-then)
- (<outer> (<inner> sample') sample-then)]
- (and (n.= reference' sample')
- (= reference-then sample-then)))
- ([#ls;VariantP #;Left]
- [#ls;VariantP #;Right]
- [#ls;TupleP #;Left]
- [#ls;TupleP #;Right])
-
- (^template [<tag>]
- [(<tag> referenceL referenceR) (<tag> sampleL sampleR)]
- (and (= referenceL sampleL)
- (= referenceR sampleR)))
- ([#ls;AltP]
- [#ls;SeqP])
-
- _
- false)))
-
-(do-template [<name> <path> <sampler> <hash> <max>]
- [(def: <name>
- (r;Random ls;Path)
- (do r;Monad<Random>
- [num-alts (|> r;nat (:: @ map (|>. (n.% <max>) (n.max +1))))
- samples (|> (r;set <hash> num-alts <sampler>)
- (:: @ map s;to-list))]
- (case (|> samples
- (L/map (|>. <path>))
- list;reverse)
- (#;Cons last prevs)
- (wrap (L/fold (function [left right]
- (#ls;AltP left right))
- last
- prevs))
-
- #;Nil
- (undefined))))]
-
- [gen-bool #ls;BoolP r;bool bool;Hash<Bool> +2]
- [gen-nat #ls;NatP r;nat number;Hash<Nat> +5]
- [gen-int #ls;IntP r;int number;Hash<Int> +5]
- [gen-deg #ls;DegP r;deg number;Hash<Deg> +5]
- [gen-frac #ls;FracP r;frac number;Hash<Frac> +5]
- [gen-text #ls;TextP (r;text +5) text;Hash<Text> +5]
- )
-
-(def: gen-primitive-path
- (r;Random ls;Path)
- (r;either (r;either (r;either (r/wrap #ls;UnitP)
- gen-bool)
- (r;either gen-nat
- gen-int))
- (r;either (r;either gen-deg
- gen-frac)
- gen-text)))
-
-(do-template [<name> <tag> <join>]
- [(def: (<name> gen-path)
- (-> (-> (Maybe ls;Synthesis) (r;Random ls;Path))
- (r;Random ls;Path))
- (do r;Monad<Random>
- [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2))))
- members (r;list size (gen-path #;None))]
- (case (list;reverse (list;enumerate members))
- (#;Cons [last-idx last-path] prevs)
- (wrap (L/fold (function [[left-idx left-path] right-path]
- (<join> (<tag> (#;Right left-idx) left-path)
- right-path))
- (<tag> (#;Right last-idx) last-path)
- prevs))
-
- #;Nil
- (undefined))))]
-
- [gen-tuple-path #ls;TupleP #ls;SeqP]
- [gen-variant-path #ls;VariantP #ls;AltP]
- )
-
-(def: (gen-path ?body)
- (-> (Maybe ls;Synthesis) (r;Random ls;Path))
- (do r;Monad<Random>
- [pattern (r;either (r;either (r/wrap (#ls;BindP +0))
- gen-primitive-path)
- (r;either (gen-tuple-path gen-path)
- (gen-variant-path gen-path)))]
- (case ?body
- #;None
- (wrap pattern)
-
- (#;Some body)
- (wrap (#ls;SeqP pattern (#ls;ExecP body))))))
-
-(def: (to-branches path)
- (-> ls;Path (List la;Pattern))
- (case path
- (^template [<from> <to>]
- (<from> value)
- (list (<to> value)))
- ([#ls;UnitP #la;UnitP]
- [#ls;BoolP #la;BoolP]
- [#ls;NatP #la;NatP]
- [#ls;IntP #la;IntP]
- [#ls;DegP #la;DegP]
- [#ls;FracP #la;FracP]
- [#ls;TextP #la;TextP]
- [#ls;BindP #la;BindP])
-
- (#ls;AltP left right)
- (L/append (to-branches left)
- (to-branches right))
-
- (#ls;SeqP (#ls;TupleP (#;Left +0) head)
- tail)
- (loop [head head
- tail tail]
- (case [(path-to-pattern head) tail]
- [(#;Some =head) (#ls;SeqP (#ls;TupleP (#;Left idx) head')
- tail')]
- (list& =head (recur head' tail'))
-
- [(#;Some =head) (#ls;SeqP (#ls;TupleP (#;Left idx) head')
- tail')]
- (list& =head (recur head' tail'))
-
- [(#;Some =head) (#ls;SeqP (#ls;TupleP (#;Right last-idx))
- tail')]
- (do list;Monad<List>
- [=tail' (to-branches tail')
- =right (to-branches right)]
- )))
-
- (#ls;SeqP left right)
- (do list;Monad<List>
- [=left (to-branches left)
- =right (to-branches right)]
- )
-
- #PopP
- (#VariantP (Either Nat Nat))
- (#TupleP (Either Nat Nat))
-
-
- (#ExecP s)
- ))
-
-(context: "Pattern-matching."
- [outputA gen-primitive
- prediction (gen-path (#;Some (synthesizer;synthesize outputA)))
- #let [branches (to-branches outputA prediction)]]
- (test "Can efficiently synthesize pattern-matching trees."
- (|> (synthesizer;synthesize (#la;Case #la;Unit branches))
- (case> (#la;Case #ls;Unit pathS)
- (:: Eq<Path> prediction pathS)
-
- _
- false))))
diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux
index 695c72174..06f3e940e 100644
--- a/new-luxc/test/tests.lux
+++ b/new-luxc/test/tests.lux
@@ -14,7 +14,6 @@
(procedure ["_;A" common]))
(synthesizer ["_;S" primitive]
["_;S" structure]
- ## ["_;S" case]
(case ["_;S" special])
["_;S" function]
["_;S" procedure]
@@ -23,8 +22,7 @@
["_;G" structure]
(procedure ["_;G" common]))
))
- ## (luxc (generator ["_;G" function])
- ## )
+ ## (luxc (generator ["_;G" function]))
)
## [Program]