diff options
Diffstat (limited to 'stdlib/source/test/lux/compiler/default/phase/analysis/case.lux')
-rw-r--r-- | stdlib/source/test/lux/compiler/default/phase/analysis/case.lux | 198 |
1 files changed, 0 insertions, 198 deletions
diff --git a/stdlib/source/test/lux/compiler/default/phase/analysis/case.lux b/stdlib/source/test/lux/compiler/default/phase/analysis/case.lux deleted file mode 100644 index 5c47960c1..000000000 --- a/stdlib/source/test/lux/compiler/default/phase/analysis/case.lux +++ /dev/null @@ -1,198 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)] - pipe] - [data - ["." product] - ["." maybe] - ["." text ("#;." equivalence)] - [collection - ["." list ("#;." monad)] - ["." set]]] - [math - ["r" random ("#;." monad)]] - ["." type - ["." check]] - [macro - ["." code]] - [compiler - [default - ["." phase - ["." analysis - ["." module] - [".A" type] - ["/" case]]]]] - test] - [// - ["_." primitive] - ["_." structure]]) - -(def: (exhaustive-weaving branchings) - (-> (List (List Code)) (List (List Code))) - (case branchings - #.Nil - #.Nil - - (#.Cons head+ #.Nil) - (list;map (|>> list) head+) - - (#.Cons head+ tail++) - (do list.monad - [tail+ (exhaustive-weaving tail++) - head head+] - (wrap (#.Cons head tail+))))) - -(def: #export (exhaustive-branches allow-literals? variantTC inputC) - (-> Bit (List [Code Code]) Code (r.Random (List Code))) - (case inputC - [_ (#.Bit _)] - (r;wrap (list (' #1) (' #0))) - - (^template [<tag> <gen> <wrapper>] - [_ (<tag> _)] - (if allow-literals? - (do r.monad - [?sample (r.maybe <gen>)] - (case ?sample - (#.Some sample) - (do @ - [else (exhaustive-branches allow-literals? variantTC inputC)] - (wrap (list& (<wrapper> sample) else))) - - #.None - (wrap (list (' _))))) - (r;wrap (list (' _))))) - ([#.Nat r.nat code.nat] - [#.Int r.int code.int] - [#.Rev r.rev code.rev] - [#.Frac r.frac code.frac] - [#.Text (r.unicode 5) code.text]) - - (^ [_ (#.Tuple (list))]) - (r;wrap (list (' []))) - - (^ [_ (#.Record (list))]) - (r;wrap (list (' {}))) - - [_ (#.Tuple members)] - (do r.monad - [member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) members)] - (wrap (|> member-wise-patterns - exhaustive-weaving - (list;map code.tuple)))) - - [_ (#.Record kvs)] - (do r.monad - [#let [ks (list;map product.left kvs) - vs (list;map product.right kvs)] - member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) vs)] - (wrap (|> member-wise-patterns - exhaustive-weaving - (list;map (|>> (list.zip2 ks) code.record))))) - - (^ [_ (#.Form (list [_ (#.Tag _)] _))]) - (do r.monad - [bundles (monad.map @ - (function (_ [_tag _code]) - (do @ - [v-branches (exhaustive-branches allow-literals? variantTC _code)] - (wrap (list;map (function (_ pattern) (` ((~ _tag) (~ pattern)))) - v-branches)))) - variantTC)] - (wrap (list;join bundles))) - - _ - (r;wrap (list)) - )) - -(def: #export (input variant-tags record-tags primitivesC) - (-> (List Code) (List Code) (List Code) (r.Random Code)) - (r.rec - (function (_ input) - ($_ r.either - (r;map product.right _primitive.primitive) - (do r.monad - [choice (|> r.nat (:: @ map (n/% (list.size variant-tags)))) - #let [choiceT (maybe.assume (list.nth choice variant-tags)) - choiceC (maybe.assume (list.nth choice primitivesC))]] - (wrap (` ((~ choiceT) (~ choiceC))))) - (do r.monad - [size (|> r.nat (:: @ map (n/% 3))) - elems (r.list size input)] - (wrap (code.tuple elems))) - (r;wrap (code.record (list.zip2 record-tags primitivesC))) - )))) - -(def: (branch body pattern) - (-> Code Code [Code Code]) - [pattern body]) - -(context: "Pattern-matching." - ## #seed 9253409297339902486 - ## #seed 3793366152923578600 - (<| (seed 5004137551292836565) - ## (times 100) - (do @ - [module-name (r.unicode 5) - variant-name (r.unicode 5) - record-name (|> (r.unicode 5) (r.filter (|>> (text;= variant-name) not))) - size (|> r.nat (:: @ map (|>> (n/% 10) (n/max 2)))) - variant-tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list)) - record-tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list)) - primitivesTC (r.list size _primitive.primitive) - #let [primitivesT (list;map product.left primitivesTC) - primitivesC (list;map product.right primitivesTC) - code-tag (|>> [module-name] code.tag) - variant-tags+ (list;map code-tag variant-tags) - record-tags+ (list;map code-tag record-tags) - variantTC (list.zip2 variant-tags+ primitivesC)] - inputC (input variant-tags+ record-tags+ primitivesC) - [outputT outputC] _primitive.primitive - [heterogeneousT heterogeneousC] (r.filter (|>> product.left (check.checks? outputT) not) - _primitive.primitive) - exhaustive-patterns (exhaustive-branches #1 variantTC inputC) - redundant-patterns (exhaustive-branches #0 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 (list;map (branch outputC) - exhaustive-patterns) - non-exhaustive-branchesC (list.take (dec (list.size exhaustive-branchesC)) - exhaustive-branchesC) - redundant-branchesC (<| (list;map (branch outputC)) - list.concat - (list (list.take redundancy-idx redundant-patterns) - (list (maybe.assume (list.nth redundancy-idx redundant-patterns))) - (list.drop redundancy-idx redundant-patterns))) - heterogeneous-branchesC (list.concat (list (list.take heterogeneous-idx exhaustive-branchesC) - (list (let [[_pattern _body] (maybe.assume (list.nth heterogeneous-idx exhaustive-branchesC))] - [_pattern heterogeneousC])) - (list.drop (inc heterogeneous-idx) exhaustive-branchesC))) - analyse-pm (|>> (/.case _primitive.phase inputC) - (typeA.with-type outputT) - analysis.with-scope - (do phase.monad - [_ (module.declare-tags variant-tags #0 - (#.Named [module-name variant-name] - (type.variant primitivesT))) - _ (module.declare-tags record-tags #0 - (#.Named [module-name record-name] - (type.tuple primitivesT)))]) - (module.with-module 0 module-name))]] - ($_ seq - (test "Will reject empty pattern-matching (no branches)." - (|> (analyse-pm (list)) - _structure.check-fails)) - (test "Can analyse exhaustive pattern-matching." - (|> (analyse-pm exhaustive-branchesC) - _structure.check-succeeds)) - (test "Will reject non-exhaustive pattern-matching." - (|> (analyse-pm non-exhaustive-branchesC) - _structure.check-fails)) - (test "Will reject redundant pattern-matching." - (|> (analyse-pm redundant-branchesC) - _structure.check-fails)) - (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." - (|> (analyse-pm heterogeneous-branchesC) - _structure.check-fails))) - ))) |