diff options
Diffstat (limited to 'new-luxc/test/test')
| -rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/case.lux | 196 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/common.lux | 31 |
2 files changed, 0 insertions, 227 deletions
diff --git a/new-luxc/test/test/luxc/lang/analysis/case.lux b/new-luxc/test/test/luxc/lang/analysis/case.lux deleted file mode 100644 index 63dd60e14..000000000 --- a/new-luxc/test/test/luxc/lang/analysis/case.lux +++ /dev/null @@ -1,196 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "B/" Eq<Bool>] - ["R" error] - [product] - [maybe] - [text "T/" Eq<Text>] - text/format - (coll [list "L/" Monad<List>] - (set ["set" unordered]))) - ["r" math/random "r/" Monad<Random>] - [macro #+ Monad<Meta>] - (macro [code]) - (lang [type "type/" Eq<Type>] - (type ["tc" check])) - test) - (luxc ["&" lang] - (lang ["@." module] - ["la" analysis] - (analysis [".A" expression] - ["@" case] - ["@." common]))) - (// common) - (test/luxc common)) - -(def: (exhaustive-weaving branchings) - (-> (List (List Code)) (List (List Code))) - (case branchings - #.Nil - #.Nil - - (#.Cons head+ #.Nil) - (L/map (|>> list) head+) - - (#.Cons head+ tail++) - (do list.Monad<List> - [tail+ (exhaustive-weaving tail++) - head head+] - (wrap (#.Cons head tail+))))) - -(def: #export (exhaustive-branches 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> _)] - (if allow-literals? - (do r.Monad<Random> - [?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] - [#.Deg r.deg code.deg] - [#.Frac r.frac code.frac] - [#.Text (r.text +5) code.text]) - - (^ [_ (#.Tuple (list))]) - (r/wrap (list (' []))) - - (^ [_ (#.Record (list))]) - (r/wrap (list (' {}))) - - [_ (#.Tuple members)] - (do r.Monad<Random> - [member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) members)] - (wrap (|> member-wise-patterns - exhaustive-weaving - (L/map code.tuple)))) - - [_ (#.Record kvs)] - (do r.Monad<Random> - [#let [ks (L/map product.left kvs) - vs (L/map product.right kvs)] - member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) vs)] - (wrap (|> member-wise-patterns - exhaustive-weaving - (L/map (|>> (list.zip2 ks) code.record))))) - - (^ [_ (#.Form (list [_ (#.Tag _)] _))]) - (do r.Monad<Random> - [bundles (monad.map @ - (function (_ [_tag _code]) - (do @ - [v-branches (exhaustive-branches allow-literals? variantTC _code)] - (wrap (L/map (function (_ pattern) (` ((~ _tag) (~ pattern)))) - v-branches)))) - variantTC)] - (wrap (L/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 gen-primitive) - (do r.Monad<Random> - [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<Random> - [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.text +5) - variant-name (r.text +5) - record-name (|> (r.text +5) (r.filter (|>> (T/= variant-name) not))) - size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - variant-tags (|> (r.set text.Hash<Text> size (r.text +5)) (:: @ map set.to-list)) - record-tags (|> (r.set text.Hash<Text> size (r.text +5)) (:: @ map set.to-list)) - primitivesTC (r.list size gen-primitive) - #let [primitivesT (L/map product.left primitivesTC) - primitivesC (L/map product.right primitivesTC) - code-tag (|>> [module-name] code.tag) - variant-tags+ (L/map code-tag variant-tags) - record-tags+ (L/map code-tag record-tags) - variantTC (list.zip2 variant-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 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) - exhaustive-patterns) - non-exhaustive-branchesC (list.take (n/dec (list.size exhaustive-branchesC)) - exhaustive-branchesC) - redundant-branchesC (<| (L/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 (n/inc heterogeneous-idx) exhaustive-branchesC))) - analyse-pm (|>> (@.analyse-case analyse inputC) - (&.with-type outputT) - &.with-scope - (do Monad<Meta> - [_ (@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)))]) - (@module.with-module +0 module-name))]] - ($_ seq - (test "Will reject empty pattern-matching (no branches)." - (|> (analyse-pm (list)) - check-failure)) - (test "Can analyse exhaustive pattern-matching." - (|> (analyse-pm exhaustive-branchesC) - check-success)) - (test "Will reject non-exhaustive pattern-matching." - (|> (analyse-pm non-exhaustive-branchesC) - check-failure)) - (test "Will reject redundant pattern-matching." - (|> (analyse-pm redundant-branchesC) - check-failure)) - (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." - (|> (analyse-pm heterogeneous-branchesC) - check-failure)) - )))) diff --git a/new-luxc/test/test/luxc/lang/analysis/common.lux b/new-luxc/test/test/luxc/lang/analysis/common.lux deleted file mode 100644 index 7e343cc88..000000000 --- a/new-luxc/test/test/luxc/lang/analysis/common.lux +++ /dev/null @@ -1,31 +0,0 @@ -(.module: - lux - (lux [io] - (control pipe) - ["r" math/random "r/" Monad<Random>] - (data ["e" error]) - [macro] - (macro [code])) - (luxc ["&" lang] - (lang (analysis [".A" expression]) - [eval])) - (test/luxc common)) - -(def: #export analyse - &.Analyser - (expressionA.analyser eval.eval)) - -(do-template [<name> <on-success> <on-failure>] - [(def: #export (<name> analysis) - (All [a] (-> (Meta a) Bool)) - (|> analysis - (macro.run (io.run init-jvm)) - (case> (#e.Success _) - <on-success> - - (#e.Error error) - <on-failure>)))] - - [check-success true false] - [check-failure false true] - ) |