diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/test/test/luxc/synthesizer/case.lux | 213 | ||||
| -rw-r--r-- | new-luxc/test/tests.lux | 4 |
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] |