- Migrated pattern-matching analysis to stdlib.

3 files changed, 199 insertions, 5 deletions

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<Bool>]
+             ["R" error]
+             [product]
+             [maybe]
+             [text "T/" Eq<Text>]
+             text/format
+             (coll [list "list/" Monad<List>]
+                   (set ["set" unordered])))
+       ["r" math/random "r/" Monad<Random>]
+       [macro #+ Monad<Meta>]
+       (macro [code])
+       [lang]
+       (lang [type "type/" Eq<Type>]
+             (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<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.unicode +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
+                (list/map code.tuple))))
+
+    [_ (#.Record kvs)]
+    (do r.Monad<Random>
+      [#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<Random>
+      [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<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.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<Text> size (r.unicode +5)) (:: @ map set.to-list))
+         record-tags (|> (r.set text.Hash<Text> 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<Meta>
+                                 [_ (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)