- Migrated the format of analysis nodes from a custom data-type, to just Code nodes.

2 files changed, 67 insertions, 54 deletions

diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux
index b17dbcbfd..29256865a 100644
--- a/new-luxc/source/luxc/analyser/case.lux
+++ b/new-luxc/source/luxc/analyser/case.lux
@@ -25,6 +25,7 @@
 (exception: #export Cannot-Match-Type-With-Pattern)
 (exception: #export Sum-Type-Has-No-Case)
 (exception: #export Unrecognized-Pattern-Syntax)
+(exception: #export Cannot-Simplify-Type-For-Pattern-Matching)
 
 (def: (pattern-error type pattern)
   (-> Type Code Text)
@@ -51,7 +52,7 @@
           [type' (&;with-type-env
                    (tc;read id))]
           (simplify-case-type type'))
-        (&;fail (format "Cannot simplify type for pattern-matching: " (%type type)))))
+        (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type type))))
 
     (#;Named name unnamedT)
     (simplify-case-type unnamedT)
@@ -98,26 +99,26 @@
         [outputA (&scope;with-local [name inputT]
                    next)
          idx &scope;next-local]
-        (wrap [(#la;BindP idx) outputA])))
+        (wrap [(` ("lux case bind" (~ (code;nat idx)))) outputA])))
 
     [cursor (#;Symbol ident)]
     (&;with-cursor cursor
       (&;fail (format "Symbols must be unqualified inside patterns: " (%ident ident))))
 
-    (^template [<type> <code-tag> <pattern-tag>]
+    (^template [<type> <code-tag>]
       [cursor (<code-tag> test)]
       (&;with-cursor cursor
         (do meta;Monad<Meta>
           [_ (&;with-type-env
                (tc;check inputT <type>))
            outputA next]
-          (wrap [(<pattern-tag> test) outputA]))))
-    ([Bool #;Bool #la;BoolP]
-     [Nat  #;Nat  #la;NatP]
-     [Int  #;Int  #la;IntP]
-     [Deg  #;Deg  #la;DegP]
-     [Frac #;Frac #la;FracP]
-     [Text #;Text #la;TextP])
+          (wrap [pattern outputA]))))
+    ([Bool #;Bool]
+     [Nat  #;Nat]
+     [Int  #;Int]
+     [Deg  #;Deg]
+     [Frac #;Frac]
+     [Text #;Text])
 
     (^ [cursor (#;Tuple (list))])
     (&;with-cursor cursor
@@ -125,7 +126,7 @@
         [_ (&;with-type-env
              (tc;check inputT Unit))
          outputA next]
-        (wrap [(#la;TupleP (list)) outputA])))
+        (wrap [(` ("lux case tuple" [])) outputA])))
 
     (^ [cursor (#;Tuple (list singleton))])
     (analyse-pattern #;None inputT singleton next)
@@ -165,7 +166,8 @@
                                              [nextA next]
                                              (wrap [(list) nextA]))
                                            matches)]
-              (wrap [(#la;TupleP memberP+) thenA])))
+              (wrap [(` ("lux case tuple" [(~@ memberP+)]))
+                     thenA])))
 
           _
           (&;fail (pattern-error inputT pattern))
@@ -202,11 +204,11 @@
                                                   (type;variant (list;drop (n.dec num-cases) flat-sum))
                                                   (` [(~@ values)])
                                                   next)]
-                  (wrap [(#la;VariantP idx num-cases testP)
+                  (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP)))
                          nextA]))
                 (do meta;Monad<Meta>
                   [[testP nextA] (analyse-pattern #;None case-type (` [(~@ values)]) next)]
-                  (wrap [(#la;VariantP idx num-cases testP)
+                  (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP)))
                          nextA])))
 
               _
@@ -245,10 +247,9 @@
                           (function [[patternT bodyT]]
                             (analyse-pattern #;None inputT patternT (analyse bodyT)))
                           branchesT)
-       _ (case (monad;fold e;Monad<Error>
-                           &&coverage;merge
-                           (|> outputH product;left &&coverage;determine)
-                           (list/map (|>. product;left &&coverage;determine) outputT))
+       outputHC (|> outputH product;left &&coverage;determine)
+       outputTC (monad;map @ (|>. product;left &&coverage;determine) outputT)
+       _ (case (monad;fold e;Monad<Error> &&coverage;merge outputHC outputTC)
            (#e;Success coverage)
            (if (&&coverage;exhaustive? coverage)
              (wrap [])
@@ -256,4 +257,4 @@
 
            (#e;Error error)
            (&;fail error))]
-      (wrap (#la;Case inputA (#;Cons outputH outputT))))))
+      (wrap (` ("lux case" (~ inputA) (~ (code;record (list& outputH outputT)))))))))
diff --git a/new-luxc/source/luxc/analyser/case/coverage.lux b/new-luxc/source/luxc/analyser/case/coverage.lux
index cb066a2bf..554aea1a8 100644
--- a/new-luxc/source/luxc/analyser/case/coverage.lux
+++ b/new-luxc/source/luxc/analyser/case/coverage.lux
@@ -1,13 +1,17 @@
 (;module:
   lux
   (lux (control [monad #+ do]
+                ["ex" exception #+ exception:]
                 eq)
-       (data [bool "B/" Eq<Bool>]
+       (data [bool "bool/" Eq<Bool>]
              [number]
              ["e" error "error/" Monad<Error>]
-             (coll [list "L/" Fold<List>]
-                   ["D" dict])))
-  (luxc (lang ["la" analysis])))
+             text/format
+             (coll [list "list/" Fold<List>]
+                   [dict #+ Dict]))
+       [meta "meta/" Monad<Meta>])
+  (luxc ["&" base]
+        (lang ["la" analysis])))
 
 ## The coverage of a pattern-matching expression summarizes how well
 ## all the possible values of an input are being covered by the
@@ -24,7 +28,7 @@
 (type: #export #rec Coverage
   #Partial
   (#Bool Bool)
-  (#Variant Nat (D;Dict Nat Coverage))
+  (#Variant Nat (Dict Nat Coverage))
   (#Seq Coverage Coverage)
   (#Alt Coverage Coverage)
   #Exhaustive)
@@ -38,52 +42,60 @@
     _
     false))
 
+(exception: #export Unknown-Pattern)
+
 (def: #export (determine pattern)
-  (-> la;Pattern Coverage)
+  (-> la;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 (#la;BindP _) (^ (#la;TupleP (list))))
-    #Exhaustive
+    (^or (^code ("lux case bind" (~ _))) (^code ("lux case tuple" [])))
+    (meta/wrap #Exhaustive)
 
-    (^ (#la;TupleP (list singleton)))
+    (^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 (#la;NatP _)  (#la;IntP _)  (#la;DegP _)
-         (#la;FracP _) (#la;TextP _))
-    #Partial
+    (^or [_ (#;Nat _)]  [_ (#;Int _)]  [_ (#;Deg _)]
+         [_ (#;Frac _)] [_ (#;Text _)])
+    (meta/wrap #Partial)
 
     ## 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.
-    (#la;BoolP value)
-    (#Bool value)
+    [_ (#;Bool value)]
+    (meta/wrap (#Bool value))
 
     ## Tuple patterns can be exhaustive if there is exhaustiveness for all of
     ## their sub-patterns.
-    (#la;TupleP subs)
+    (^code ("lux case tuple" [(~@ subs)]))
     (loop [subs subs]
       (case subs
         #;Nil
-        #Exhaustive
+        (meta/wrap #Exhaustive)
 
         (#;Cons sub subs')
-        (let [post (recur subs')]
+        (do meta;Monad<Meta>
+          [pre (determine sub)
+           post (recur subs')]
           (if (exhaustive? post)
-            (determine sub)
-            (#Seq (determine sub)
-                  post)))))
+            (wrap pre)
+            (wrap (#Seq pre post))))))
 
     ## Variant patterns can be shown to be exhaustive if all the possible
     ## cases are handled exhaustively.
-    (#la;VariantP tag-id num-tags sub)
-    (#Variant num-tags
-              (|> (D;new number;Hash<Nat>)
-                  (D;put tag-id (determine sub))))))
+    (^code ("lux case variant" (~ [_ (#;Nat tag-id)]) (~ [_ (#;Nat num-tags)]) (~ sub)))
+    (do meta;Monad<Meta>
+      [=sub (determine sub)]
+      (wrap (#Variant num-tags
+                      (|> (dict;new number;Hash<Nat>)
+                          (dict;put tag-id =sub)))))
+
+    _
+    (&;throw Unknown-Pattern (%code pattern))))
 
 (def: (xor left right)
   (-> Bool Bool Bool)
@@ -116,11 +128,11 @@
       true
 
       [(#Bool sideR) (#Bool sideS)]
-      (B/= sideR sideS)
+      (bool/= sideR sideS)
 
       [(#Variant allR casesR) (#Variant allS casesS)]
       (and (n.= allR allS)
-           (:: (D;Eq<Dict> =) = casesR casesS))
+           (:: (dict;Eq<Dict> =) = casesR casesS))
 
       [(#Seq leftR rightR) (#Seq leftS rightS)]
       (and (= leftR leftS)
@@ -166,23 +178,23 @@
     (cond (not (n.= allSF allA))
           (e;fail "Variants do not match.")
 
-          (:: (D;Eq<Dict> Eq<Coverage>) = casesSF casesA)
+          (:: (dict;Eq<Dict> Eq<Coverage>) = casesSF casesA)
           redundant-pattern
 
           ## else
           (do e;Monad<Error>
             [casesM (monad;fold @
                                 (function [[tagA coverageA] casesSF']
-                                  (case (D;get tagA casesSF')
+                                  (case (dict;get tagA casesSF')
                                     (#;Some coverageSF)
                                     (do @
                                       [coverageM (merge coverageA coverageSF)]
-                                      (wrap (D;put tagA coverageM casesSF')))
+                                      (wrap (dict;put tagA coverageM casesSF')))
 
                                     #;None
-                                    (wrap (D;put tagA coverageA casesSF'))))
-                                casesSF (D;entries casesA))]
-            (wrap (if (let [case-coverages (D;values casesM)]
+                                    (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))
                              (list;every? exhaustive? case-coverages)))
                     #Exhaustive
@@ -272,9 +284,9 @@
           #;None
           (case (list;reverse possibilities)
             (#;Cons last prevs)
-            (wrap (L/fold (function [left right] (#Alt left right))
-                          last
-                          prevs))
+            (wrap (list/fold (function [left right] (#Alt left right))
+                             last
+                             prevs))
 
             #;Nil
             (undefined)))))