diff options
Diffstat (limited to 'new-luxc/test')
| -rw-r--r-- | new-luxc/test/test/luxc/analyser/case.lux | 87 |
1 files changed, 68 insertions, 19 deletions
diff --git a/new-luxc/test/test/luxc/analyser/case.lux b/new-luxc/test/test/luxc/analyser/case.lux index 98777b5d6..69ab4cd99 100644 --- a/new-luxc/test/test/luxc/analyser/case.lux +++ b/new-luxc/test/test/luxc/analyser/case.lux @@ -12,7 +12,7 @@ ["S" set])) ["r" math/random "r/" Monad<Random>] [type "Type/" Eq<Type>] - (type ["TC" check]) + (type ["tc" check]) [macro #+ Monad<Lux>] (macro [code]) test) @@ -40,24 +40,26 @@ head head+] (wrap (#;Cons head tail+))))) -(def: (total-branches-for variantTC inputC) - (-> (List [Code Code]) Code (r;Random (List Code))) +(def: (total-branches-for allow-literals? variantTC inputC) + (-> Bool (List [Code Code]) Code (r;Random (List Code))) (case inputC [_ (#;Bool _)] (r/wrap (list (' true) (' false))) (^template [<tag> <gen> <wrapper>] [_ (<tag> _)] - (do r;Monad<Random> - [?sample (r;maybe <gen>)] - (case ?sample - (#;Some sample) - (do @ - [else (total-branches-for variantTC inputC)] - (wrap (list& (<wrapper> sample) else))) + (if allow-literals? + (do r;Monad<Random> + [?sample (r;maybe <gen>)] + (case ?sample + (#;Some sample) + (do @ + [else (total-branches-for allow-literals? variantTC inputC)] + (wrap (list& (<wrapper> sample) else))) - #;None - (wrap (list (' _)))))) + #;None + (wrap (list (' _))))) + (r/wrap (list (' _))))) ([#;Nat r;nat code;nat] [#;Int r;int code;int] [#;Deg r;deg code;deg] @@ -72,7 +74,7 @@ [_ (#;Tuple members)] (do r;Monad<Random> - [member-wise-patterns (monad;map @ (total-branches-for variantTC) members)] + [member-wise-patterns (monad;map @ (total-branches-for allow-literals? variantTC) members)] (wrap (|> member-wise-patterns total-weaving (L/map code;tuple)))) @@ -81,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 @ (total-branches-for variantTC) vs)] + member-wise-patterns (monad;map @ (total-branches-for allow-literals? variantTC) vs)] (wrap (|> member-wise-patterns total-weaving (L/map (|>. (list;zip2 ks) code;record))))) @@ -91,7 +93,7 @@ [bundles (monad;map @ (function [[_tag _code]] (do @ - [v-branches (total-branches-for variantTC _code)] + [v-branches (total-branches-for allow-literals? variantTC _code)] (wrap (L/map (function [pattern] (` ((~ _tag) (~ pattern)))) v-branches)))) variantTC)] @@ -119,8 +121,14 @@ (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 +9253409297339902486 + ## #seed +3793366152923578600 + #seed +5004137551292836565 [module-name (r;text +5) variant-name (r;text +5) record-name (|> (r;text +5) (r;filter (|>. (T/= variant-name) not))) @@ -135,11 +143,26 @@ variantTC (list;zip2 variant-tags+ primitivesC)] inputC (gen-input variant-tags+ record-tags+ primitivesC) [outputT outputC] gen-primitive - total-patterns (total-branches-for variantTC inputC) - #let [total-branchesC (L/map (function [pattern] [pattern outputC]) + [heterogeneousT heterogeneousC] (|> gen-primitive + (r;filter (|>. product;left (tc;checks? outputT) not))) + total-patterns (total-branches-for true variantTC inputC) + redundant-patterns (total-branches-for false variantTC inputC) + redundancy-idx (|> r;nat (:: @ map (n.% (list;size redundant-patterns)))) + heterogeneous-idx (|> r;nat (:: @ map (n.% (list;size total-patterns)))) + #let [total-branchesC (L/map (branch outputC) total-patterns) non-total-branchesC (list;take (n.dec (list;size total-branchesC)) - total-branchesC)]] + total-branchesC) + redundant-branchesC (<| (L/map (branch outputC)) + list;concat + (list (list;take redundancy-idx redundant-patterns) + (list (assume (list;nth redundancy-idx redundant-patterns))) + (list;drop redundancy-idx redundant-patterns))) + heterogeneous-branchesC (list;concat (list (list;take heterogeneous-idx total-branchesC) + (list (let [[_pattern _body] (assume (list;nth heterogeneous-idx total-branchesC))] + [_pattern heterogeneousC])) + (list;drop (n.inc heterogeneous-idx) total-branchesC))) + ]] ($_ seq (test "Will reject empty pattern-matching (no branches)." (|> (&;with-scope @@ -172,4 +195,30 @@ (&;with-expected-type outputT (@;analyse-case analyse inputC non-total-branchesC))))) check-failure)) + (test "Will reject redundant pattern-matching." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC redundant-branchesC))))) + check-failure)) + (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC heterogeneous-branchesC))))) + check-failure)) )) |