From 19d38211c33faf6d5fe01665982d696643f60051 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 20 May 2018 20:12:22 -0400 Subject: - Migrated pattern-matching analysis to stdlib. --- stdlib/test/test/lux/lang/analysis/case.lux | 194 +++++++++++++++++++++++ stdlib/test/test/lux/lang/analysis/primitive.lux | 2 +- stdlib/test/test/lux/lang/analysis/structure.lux | 8 +- 3 files changed, 199 insertions(+), 5 deletions(-) create mode 100644 stdlib/test/test/lux/lang/analysis/case.lux (limited to 'stdlib/test') diff --git a/stdlib/test/test/lux/lang/analysis/case.lux b/stdlib/test/test/lux/lang/analysis/case.lux new file mode 100644 index 000000000..9e775f8a3 --- /dev/null +++ b/stdlib/test/test/lux/lang/analysis/case.lux @@ -0,0 +1,194 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "B/" Eq] + ["R" error] + [product] + [maybe] + [text "T/" Eq] + text/format + (coll [list "list/" Monad] + (set ["set" unordered]))) + ["r" math/random "r/" Monad] + [macro #+ Monad] + (macro [code]) + [lang] + (lang [type "type/" Eq] + (type ["tc" check]) + [".L" module] + (analysis [".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) + (-> Bool (List [Code Code]) Code (r.Random (List Code))) + (case inputC + [_ (#.Bool _)] + (r/wrap (list (' true) (' false))) + + (^template [ ] + [_ ( _)] + (if allow-literals? + (do r.Monad + [?sample (r.maybe )] + (case ?sample + (#.Some sample) + (do @ + [else (exhaustive-branches allow-literals? variantTC inputC)] + (wrap (list& ( 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.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 (|>> (T/= 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] (|> _primitive.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 (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.analyse inputC) + (typeA.with-type outputT) + lang.with-scope + (do Monad + [_ (moduleL.declare-tags variant-tags false + (#.Named [module-name variant-name] + (type.variant primitivesT))) + _ (moduleL.declare-tags record-tags false + (#.Named [module-name record-name] + (type.tuple primitivesT)))]) + (moduleL.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)) + )))) diff --git a/stdlib/test/test/lux/lang/analysis/primitive.lux b/stdlib/test/test/lux/lang/analysis/primitive.lux index ed9d8bfc6..8e4ca6dde 100644 --- a/stdlib/test/test/lux/lang/analysis/primitive.lux +++ b/stdlib/test/test/lux/lang/analysis/primitive.lux @@ -17,7 +17,7 @@ [".A" expression])) test)) -(def: analyse (expressionA.analyser (:! lang.Eval []))) +(def: #export analyse (expressionA.analyser (:! lang.Eval []))) (def: unit (r.Random Code) diff --git a/stdlib/test/test/lux/lang/analysis/structure.lux b/stdlib/test/test/lux/lang/analysis/structure.lux index ad6691287..20b911714 100644 --- a/stdlib/test/test/lux/lang/analysis/structure.lux +++ b/stdlib/test/test/lux/lang/analysis/structure.lux @@ -19,7 +19,7 @@ (type ["tc" check]) [".L" module] [".L" init] - [".L" analysis #+ Analysis] + [".L" analysis #+ Analysis Variant Tag] (analysis [".A" type] ["/" structure] [".A" expression])) @@ -43,7 +43,7 @@ ) (def: (check-sum' size tag variant) - (-> Nat analysisL.Tag analysisL.Variant Bool) + (-> Nat Tag (Variant Analysis) Bool) (let [variant-tag (if (get@ #analysisL.right? variant) (inc (get@ #analysisL.lefts variant)) (get@ #analysisL.lefts variant))] @@ -52,7 +52,7 @@ (and (n/= tag variant-tag))))) (def: (check-sum type size tag analysis) - (-> Type Nat analysisL.Tag (Meta Analysis) Bool) + (-> Type Nat Tag (Meta Analysis) Bool) (|> analysis (typeA.with-type type) (macro.run (initL.compiler [])) @@ -71,7 +71,7 @@ (moduleL.with-module +0 module))) (def: (check-variant module tags type size tag analysis) - (-> Text (List moduleL.Tag) Type Nat analysisL.Tag (Meta Analysis) Bool) + (-> Text (List moduleL.Tag) Type Nat Tag (Meta Analysis) Bool) (|> analysis (tagged module tags type) (typeA.with-type type) -- cgit v1.2.3