- Migrated pattern-matching analysis to stdlib.

2 files changed, 175 insertions, 170 deletions

diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/stdlib/source/lux/lang/analysis/case.lux
index d9efa2bf4..3140a9d7e 100644
--- a/new-luxc/source/luxc/lang/analysis/case.lux
+++ b/stdlib/source/lux/lang/analysis/case.lux
@@ -1,8 +1,8 @@
 (.module:
-  lux
+  [lux #- case]
   (lux (control [monad #+ do]
                 ["ex" exception #+ exception:]
-                eq)
+                [equality #+ Eq])
        (data [bool]
              [number]
              [product]
@@ -11,38 +11,43 @@
              [text]
              text/format
              (coll [list "list/" Fold<List> Monoid<List> Functor<List>]))
+       [function]
        [macro]
        (macro [code])
+       [lang]
        (lang [type]
-             (type ["tc" check])))
-  (luxc ["&" lang]
-        (lang ["&." scope]
-              ["la" analysis]
-              (analysis [".A" common]
-                        [".A" structure]
-                        (case [".A" coverage])))))
+             (type ["tc" check])
+             [".L" scope]
+             [".L" analysis #+ Pattern Analysis Analyser]
+             (analysis [".A" type]
+                       [".A" structure]
+                       (case [".A" coverage])))))
+
+(exception: #export (cannot-match-type-with-pattern {type Type} {pattern Code})
+  (ex.report ["Type" (%type type)]
+             ["Pattern" (%code pattern)]))
+
+(exception: #export (sum-type-has-no-case {case Nat} {type Type})
+  (ex.report ["Case" (%n case)]
+             ["Type" (%type type)]))
+
+(exception: #export (unrecognized-pattern-syntax {pattern Code})
+  (%code pattern))
+
+(exception: #export (cannot-simplify-type-for-pattern-matching {type Type})
+  (%type type))
 
 (do-template [<name>]
   [(exception: #export (<name> {message Text})
      message)]
 
-  [Cannot-Match-Type-With-Pattern]
-  [Sum-Type-Has-No-Case]
-  [Unrecognized-Pattern-Syntax]
-  [Cannot-Simplify-Type-For-Pattern-Matching]
-  [Cannot-Have-Empty-Branches]
-  [Non-Exhaustive-Pattern-Matching]
-  [Symbols-Must-Be-Unqualified-Inside-Patterns]
+  [cannot-have-empty-branches]
+  [non-exhaustive-pattern-matching]
   )
 
-(def: (pattern-error type pattern)
-  (-> Type Code Text)
-  (format "   Type: " (%type type) "\n"
-          "Pattern: " (%code pattern)))
-
 (def: (re-quantify envs baseT)
   (-> (List (List Type)) Type Type)
-  (case envs
+  (.case envs
     #.Nil
     baseT
 
@@ -61,17 +66,17 @@
   (loop [envs (: (List (List Type))
                  (list))
          caseT caseT]
-    (case caseT
+    (.case caseT
       (#.Var id)
       (do macro.Monad<Meta>
-        [?caseT' (&.with-type-env
+        [?caseT' (typeA.with-env
                    (tc.read id))]
-        (case ?caseT'
+        (.case ?caseT'
           (#.Some caseT')
           (recur envs caseT')
 
           _
-          (&.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
+          (lang.throw cannot-simplify-type-for-pattern-matching caseT)))
 
       (#.Named name unnamedT)
       (recur envs unnamedT)
@@ -79,43 +84,34 @@
       (#.UnivQ env unquantifiedT)
       (recur (#.Cons env envs) unquantifiedT)
 
-      ## (^template [<tag> <instancer>]
-      ##   (<tag> _)
-      ##   (do macro.Monad<Meta>
-      ##     [[_ instanceT] (&.with-type-env
-      ##                      <instancer>)]
-      ##     (recur (maybe.assume (type.apply (list instanceT) caseT)))))
-      ## ([#.UnivQ tc.var]
-      ##  [#.ExQ tc.existential])
-      
       (#.ExQ _)
       (do macro.Monad<Meta>
-        [[ex-id exT] (&.with-type-env
+        [[ex-id exT] (typeA.with-env
                        tc.existential)]
         (recur envs (maybe.assume (type.apply (list exT) caseT))))
 
       (#.Apply inputT funcT)
-      (case funcT
+      (.case funcT
         (#.Var funcT-id)
         (do macro.Monad<Meta>
-          [funcT' (&.with-type-env
+          [funcT' (typeA.with-env
                     (do tc.Monad<Check>
                       [?funct' (tc.read funcT-id)]
-                      (case ?funct'
+                      (.case ?funct'
                         (#.Some funct')
                         (wrap funct')
 
                         _
-                        (tc.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))]
+                        (tc.throw cannot-simplify-type-for-pattern-matching caseT))))]
           (recur envs (#.Apply inputT funcT')))
 
         _
-        (case (type.apply (list inputT) funcT)
+        (.case (type.apply (list inputT) funcT)
           (#.Some outputT)
           (recur envs outputT)
 
           #.None
-          (&.throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
+          (lang.throw cannot-simplify-type-for-pattern-matching caseT)))
 
       (#.Product _)
       (|> caseT
@@ -127,6 +123,15 @@
       _
       (:: macro.Monad<Meta> wrap (re-quantify envs caseT)))))
 
+(def: (analyse-primitive type inputT cursor output next)
+  (All [a] (-> Type Type Cursor Pattern (Meta a) (Meta [Pattern a])))
+  (lang.with-cursor cursor
+    (do macro.Monad<Meta>
+      [_ (typeA.with-env
+           (tc.check inputT type))
+       outputA next]
+      (wrap [output outputA]))))
+
 ## This function handles several concerns at once, but it must be that
 ## way because those concerns are interleaved when doing
 ## pattern-matching and they cannot be separated.
@@ -144,74 +149,57 @@
 ## That is why the body must be analysed in the context of the
 ## pattern, and not separately.
 (def: (analyse-pattern num-tags inputT pattern next)
-  (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la.Pattern a])))
-  (case pattern
+  (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [Pattern a])))
+  (.case pattern
     [cursor (#.Symbol ["" name])]
-    (&.with-cursor cursor
+    (lang.with-cursor cursor
       (do macro.Monad<Meta>
-        [outputA (&scope.with-local [name inputT]
+        [outputA (scopeL.with-local [name inputT]
                    next)
-         idx &scope.next-local]
-        (wrap [(` ("lux case bind" (~ (code.nat idx)))) outputA])))
-
-    [cursor (#.Symbol ident)]
-    (&.with-cursor cursor
-      (&.throw Symbols-Must-Be-Unqualified-Inside-Patterns (%ident ident)))
-
-    (^template [<type> <code-tag>]
-      [cursor (<code-tag> test)]
-      (&.with-cursor cursor
-        (do macro.Monad<Meta>
-          [_ (&.with-type-env
-               (tc.check inputT <type>))
-           outputA next]
-          (wrap [pattern outputA]))))
-    ([Bool #.Bool]
-     [Nat  #.Nat]
-     [Int  #.Int]
-     [Deg  #.Deg]
-     [Frac #.Frac]
-     [Text #.Text])
-
-    (^ [cursor (#.Tuple (list))])
-    (&.with-cursor cursor
-      (do macro.Monad<Meta>
-        [_ (&.with-type-env
-             (tc.check inputT Top))
-         outputA next]
-        (wrap [(` ("lux case tuple" [])) outputA])))
-
+         idx scopeL.next-local]
+        (wrap [(#analysisL.Bind idx) outputA])))
+
+    (^template [<type> <input> <output>]
+      [cursor <input>]
+      (analyse-primitive <type> inputT cursor (#analysisL.Simple <output>) next))
+    ([Bool (#.Bool pattern-value) (#analysisL.Bool pattern-value)]
+     [Nat  (#.Nat pattern-value)  (#analysisL.Nat pattern-value)]
+     [Int  (#.Int pattern-value)  (#analysisL.Int pattern-value)]
+     [Deg  (#.Deg pattern-value)  (#analysisL.Deg pattern-value)]
+     [Frac (#.Frac pattern-value) (#analysisL.Frac pattern-value)]
+     [Text (#.Text pattern-value) (#analysisL.Text pattern-value)]
+     [Top  (#.Tuple #.Nil)        #analysisL.Unit])
+    
     (^ [cursor (#.Tuple (list singleton))])
     (analyse-pattern #.None inputT singleton next)
     
     [cursor (#.Tuple sub-patterns)]
-    (&.with-cursor cursor
+    (lang.with-cursor cursor
       (do macro.Monad<Meta>
         [inputT' (simplify-case-type inputT)]
-        (case inputT'
+        (.case inputT'
           (#.Product _)
           (let [sub-types (type.flatten-tuple inputT')
                 num-sub-types (maybe.default (list.size sub-types)
                                              num-tags)
                 num-sub-patterns (list.size sub-patterns)
                 matches (cond (n/< num-sub-types num-sub-patterns)
-                              (let [[prefix suffix] (list.split (n/dec num-sub-patterns) sub-types)]
+                              (let [[prefix suffix] (list.split (dec num-sub-patterns) sub-types)]
                                 (list.zip2 (list/compose prefix (list (type.tuple suffix))) sub-patterns))
 
                               (n/> num-sub-types num-sub-patterns)
-                              (let [[prefix suffix] (list.split (n/dec num-sub-types) sub-patterns)]
+                              (let [[prefix suffix] (list.split (dec num-sub-types) sub-patterns)]
                                 (list.zip2 sub-types (list/compose prefix (list (code.tuple suffix)))))
                               
                               ## (n/= num-sub-types num-sub-patterns)
-                              (list.zip2 sub-types sub-patterns)
-                              )]
+                              (list.zip2 sub-types sub-patterns))]
             (do @
               [[memberP+ thenA] (list/fold (: (All [a]
-                                                (-> [Type Code] (Meta [(List la.Pattern) a])
-                                                    (Meta [(List la.Pattern) a])))
+                                                (-> [Type Code] (Meta [(List Pattern) a])
+                                                    (Meta [(List Pattern) a])))
                                               (function (_ [memberT memberC] then)
                                                 (do @
-                                                  [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [la.Pattern a])))
+                                                  [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [Pattern a])))
                                                                                    analyse-pattern)
                                                                                #.None memberT memberC then)]
                                                   (wrap [(list& memberP memberP+) thenA]))))
@@ -219,81 +207,76 @@
                                              [nextA next]
                                              (wrap [(list) nextA]))
                                            (list.reverse matches))]
-              (wrap [(` ("lux case tuple" [(~+ memberP+)]))
+              (wrap [(analysisL.product-pattern memberP+)
                      thenA])))
 
           _
-          (&.throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern))
+          (lang.throw cannot-match-type-with-pattern [inputT pattern])
           )))
 
     [cursor (#.Record record)]
     (do macro.Monad<Meta>
       [record (structureA.normalize record)
        [members recordT] (structureA.order record)
-       _ (&.with-type-env
+       _ (typeA.with-env
            (tc.check inputT recordT))]
       (analyse-pattern (#.Some (list.size members)) inputT [cursor (#.Tuple members)] next))
 
     [cursor (#.Tag tag)]
-    (&.with-cursor cursor
+    (lang.with-cursor cursor
       (analyse-pattern #.None inputT (` ((~ pattern))) next))
 
     (^ [cursor (#.Form (list& [_ (#.Nat idx)] values))])
-    (&.with-cursor cursor
+    (lang.with-cursor cursor
       (do macro.Monad<Meta>
         [inputT' (simplify-case-type inputT)]
-        (case inputT'
+        (.case inputT'
           (#.Sum _)
           (let [flat-sum (type.flatten-variant inputT')
                 size-sum (list.size flat-sum)
                 num-cases (maybe.default size-sum num-tags)]
-            (case (list.nth idx flat-sum)
+            (.case (list.nth idx flat-sum)
               (^multi (#.Some case-type)
                       (n/< num-cases idx))
-              (if (and (n/> num-cases size-sum)
-                       (n/= (n/dec num-cases) idx))
-                (do macro.Monad<Meta>
-                  [[testP nextA] (analyse-pattern #.None
-                                                  (type.variant (list.drop (n/dec num-cases) flat-sum))
+              (do macro.Monad<Meta>
+                [[testP nextA] (if (and (n/> num-cases size-sum)
+                                        (n/= (dec num-cases) idx))
+                                 (analyse-pattern #.None
+                                                  (type.variant (list.drop (dec num-cases) flat-sum))
                                                   (` [(~+ values)])
-                                                  next)]
-                  (wrap [(` ("lux case variant" (~ (code.nat idx)) (~ (code.nat num-cases)) (~ testP)))
-                         nextA]))
-                (do macro.Monad<Meta>
-                  [[testP nextA] (analyse-pattern #.None case-type (` [(~+ values)]) next)]
-                  (wrap [(` ("lux case variant" (~ (code.nat idx)) (~ (code.nat num-cases)) (~ testP)))
-                         nextA])))
+                                                  next)
+                                 (analyse-pattern #.None case-type (` [(~+ values)]) next))]
+                (wrap [(analysisL.sum-pattern num-cases idx testP)
+                       nextA]))
 
               _
-              (&.throw Sum-Type-Has-No-Case
-                       (format "Case: " (%n idx) "\n"
-                               "Type: " (%type inputT)))))
+              (lang.throw sum-type-has-no-case [idx inputT])))
 
           _
-          (&.throw Cannot-Match-Type-With-Pattern (pattern-error inputT pattern)))))
+          (lang.throw cannot-match-type-with-pattern [inputT pattern]))))
 
     (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))])
-    (&.with-cursor cursor
+    (lang.with-cursor cursor
       (do macro.Monad<Meta>
         [tag (macro.normalize tag)
          [idx group variantT] (macro.resolve-tag tag)
-         _ (&.with-type-env
+         _ (typeA.with-env
              (tc.check inputT variantT))]
         (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next)))
 
     _
-    (&.throw Unrecognized-Pattern-Syntax (%code pattern))
+    (lang.throw unrecognized-pattern-syntax pattern)
     ))
 
-(def: #export (analyse-case analyse inputC branches)
-  (-> &.Analyser Code (List [Code Code]) (Meta la.Analysis))
-  (case branches
+(def: #export (case analyse inputC branches)
+  (-> Analyser Code (List [Code Code]) (Meta Analysis))
+  (.case branches
     #.Nil
-    (&.throw Cannot-Have-Empty-Branches "")
+    (lang.throw cannot-have-empty-branches "")
 
     (#.Cons [patternH bodyH] branchesT)
     (do macro.Monad<Meta>
-      [[inputT inputA] (commonA.with-unknown-type
+      [[inputT inputA] (typeA.with-inference
                          (analyse inputC))
        outputH (analyse-pattern #.None inputT patternH (analyse bodyH))
        outputT (monad.map @
@@ -302,11 +285,11 @@
                           branchesT)
        outputHC (|> outputH product.left coverageA.determine)
        outputTC (monad.map @ (|>> product.left coverageA.determine) outputT)
-       _ (case (monad.fold e.Monad<Error> coverageA.merge outputHC outputTC)
+       _ (.case (monad.fold e.Monad<Error> coverageA.merge outputHC outputTC)
            (#e.Success coverage)
-           (&.assert Non-Exhaustive-Pattern-Matching ""
-                     (coverageA.exhaustive? coverage))
+           (lang.assert non-exhaustive-pattern-matching ""
+                        (coverageA.exhaustive? coverage))
 
            (#e.Error error)
-           (&.fail error))]
-      (wrap (` ("lux case" (~ inputA) (~ (code.record (list& outputH outputT)))))))))
+           (lang.fail error))]
+      (wrap (#analysisL.Case inputA [outputH outputT])))))
diff --git a/new-luxc/source/luxc/lang/analysis/case/coverage.lux b/stdlib/source/lux/lang/analysis/case/coverage.lux
index 38f977011..da256206f 100644
--- a/new-luxc/source/luxc/lang/analysis/case/coverage.lux
+++ b/stdlib/source/lux/lang/analysis/case/coverage.lux
@@ -2,19 +2,41 @@
   lux
   (lux (control [monad #+ do]
                 ["ex" exception #+ exception:]
-                eq)
+                equality)
        (data [bool "bool/" Eq<Bool>]
              [number]
              ["e" error "error/" Monad<Error>]
+             [maybe]
              text/format
              (coll [list "list/" Fold<List>]
                    (dictionary ["dict" unordered #+ Dict])))
-       [macro "macro/" Monad<Meta>])
-  (luxc ["&" lang]
-        (lang ["la" analysis])))
-
-(exception: #export (Unknown-Pattern {message Text})
-  message)
+       [macro "macro/" Monad<Meta>]
+       [lang]
+       (lang [".L" analysis #+ Pattern Variant])))
+
+(def: cases
+  (-> (Maybe Nat) Nat)
+  (|>> (maybe.default +0)))
+
+(def: (variant sum-side)
+  (-> (Either Pattern Pattern) (Variant Pattern))
+  (loop [lefts +0
+         variantP sum-side]
+    (case variantP
+      (#.Left valueP)
+      (case valueP
+        (#analysisL.Complex (#analysisL.Sum value-side))
+        (recur (inc lefts) value-side)
+
+        _
+        {#analysisL.lefts lefts
+         #analysisL.right? false
+         #analysisL.value valueP})
+      
+      (#.Right valueP)
+      {#analysisL.lefts lefts
+       #analysisL.right? true
+       #analysisL.value valueP})))
 
 ## The coverage of a pattern-matching expression summarizes how well
 ## all the possible values of an input are being covered by the
@@ -31,7 +53,7 @@
 (type: #export #rec Coverage
   #Partial
   (#Bool Bool)
-  (#Variant Nat (Dict Nat Coverage))
+  (#Variant (Maybe Nat) (Dict Nat Coverage))
   (#Seq Coverage Coverage)
   (#Alt Coverage Coverage)
   #Exhaustive)
@@ -46,57 +68,56 @@
     false))
 
 (def: #export (determine pattern)
-  (-> la.Pattern (Meta Coverage))
+  (-> Pattern (Meta Coverage))
   (case pattern
-    ## Binding amounts to exhaustive coverage because any value can be
-    ## matched that way.
-    ## Unit [] amounts to exhaustive coverage because there is only one
-    ## possible value, so matching against it covers all cases.
-    (^or (^code ("lux case bind" (~ _))) (^code ("lux case tuple" [])))
+    (^or (#analysisL.Simple #analysisL.Unit)
+         (#analysisL.Bind _))
     (macro/wrap #Exhaustive)
 
-    (^code ("lux case tuple" [(~ singleton)]))
-    (determine singleton)
-
     ## Primitive patterns always have partial coverage because there
     ## are too many possibilities as far as values go.
-    (^or [_ (#.Nat _)]  [_ (#.Int _)]  [_ (#.Deg _)]
-         [_ (#.Frac _)] [_ (#.Text _)])
-    (macro/wrap #Partial)
+    (^template [<tag>]
+      (#analysisL.Simple (<tag> _))
+      (macro/wrap #Partial))
+    ([#analysisL.Nat]
+     [#analysisL.Int]
+     [#analysisL.Deg]
+     [#analysisL.Frac]
+     [#analysisL.Text])
 
     ## Bools are the exception, since there is only "true" and
     ## "false", which means it is possible for boolean
     ## pattern-matching to become exhaustive if complementary parts meet.
-    [_ (#.Bool value)]
+    (#analysisL.Simple (#analysisL.Bool value))
     (macro/wrap (#Bool value))
 
     ## Tuple patterns can be exhaustive if there is exhaustiveness for all of
     ## their sub-patterns.
-    (^code ("lux case tuple" [(~+ subs)]))
-    (loop [subs subs]
-      (case subs
-        #.Nil
-        (macro/wrap #Exhaustive)
-
-        (#.Cons sub subs')
-        (do macro.Monad<Meta>
-          [pre (determine sub)
-           post (recur subs')]
-          (if (exhaustive? post)
-            (wrap pre)
-            (wrap (#Seq pre post))))))
-
-    ## Variant patterns can be shown to be exhaustive if all the possible
-    ## cases are handled exhaustively.
-    (^code ("lux case variant" (~ [_ (#.Nat tag-id)]) (~ [_ (#.Nat num-tags)]) (~ sub)))
+    (#analysisL.Complex (#analysisL.Product [left right]))
     (do macro.Monad<Meta>
-      [=sub (determine sub)]
-      (wrap (#Variant num-tags
-                      (|> (dict.new number.Hash<Nat>)
-                          (dict.put tag-id =sub)))))
-
-    _
-    (&.throw Unknown-Pattern (%code pattern))))
+      [left (determine left)
+       right (determine right)]
+      (case right
+        (#Exhaustive _)
+        (wrap left)
+
+        _
+        (wrap (#Seq left right))))
+
+    (#analysisL.Complex (#analysisL.Sum sum-side))
+    (let [[variant-lefts variant-right? variant-value] (variant sum-side)]
+      ## Variant patterns can be shown to be exhaustive if all the possible
+      ## cases are handled exhaustively.
+      (do macro.Monad<Meta>
+        [value-coverage (determine variant-value)
+         #let [variant-idx (if variant-right?
+                             (inc variant-lefts)
+                             variant-lefts)]]
+        (wrap (#Variant (if variant-right?
+                          (#.Some variant-idx)
+                          #.None)
+                        (|> (dict.new number.Hash<Nat>)
+                            (dict.put variant-idx value-coverage))))))))
 
 (def: (xor left right)
   (-> Bool Bool Bool)
@@ -132,9 +153,10 @@
       (bool/= sideR sideS)
 
       [(#Variant allR casesR) (#Variant allS casesS)]
-      (and (n/= allR allS)
+      (and (n/= (cases allR)
+                (cases allS))
            (:: (dict.Eq<Dict> =) = casesR casesS))
-
+      
       [(#Seq leftR rightR) (#Seq leftS rightS)]
       (and (= leftR leftS)
            (= rightR rightS))
@@ -176,7 +198,7 @@
     (error/wrap #Exhaustive)
 
     [(#Variant allA casesA) (#Variant allSF casesSF)]
-    (cond (not (n/= allSF allA))
+    (cond (not (n/= (cases allSF) (cases allA)))
           (e.fail "Variants do not match.")
 
           (:: (dict.Eq<Dict> Eq<Coverage>) = casesSF casesA)
@@ -196,7 +218,7 @@
                                     (wrap (dict.put tagA coverageA casesSF'))))
                                 casesSF (dict.entries casesA))]
             (wrap (if (let [case-coverages (dict.values casesM)]
-                        (and (n/= allSF (list.size case-coverages))
+                        (and (n/= (cases allSF) (list.size case-coverages))
                              (list.every? exhaustive? case-coverages)))
                     #Exhaustive
                     (#Variant allSF casesM)))))