Fixes for pattern-matching and macro-expansions.

7 files changed, 191 insertions, 97 deletions

diff --git a/stdlib/source/lux/compiler/default/phase/analysis.lux b/stdlib/source/lux/compiler/default/phase/analysis.lux
index dde9f4e9a..8ef8324ae 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis.lux
@@ -132,6 +132,16 @@
 
 (do-template [<name> <tag>]
   [(template: #export (<name> content)
+     (.<| #..Reference
+          <tag>
+          content))]
+
+  [variable #reference.Variable]
+  [constant #reference.Constant]
+  )
+
+(do-template [<name> <tag>]
+  [(template: #export (<name> content)
      (.<| #Complex
           <tag>
           content))]
diff --git a/stdlib/source/lux/compiler/default/phase/analysis/case.lux b/stdlib/source/lux/compiler/default/phase/analysis/case.lux
index 0d3536db3..2081ceb61 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis/case.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis/case.lux
@@ -22,7 +22,7 @@
    ["/." //
     ["." extension]]]
   [/
-   ["." coverage]])
+   ["." coverage (#+ Coverage)]])
 
 (exception: #export (cannot-match-with-pattern {type Type} {pattern Code})
   (ex.report ["Type" (%type type)]
@@ -32,19 +32,19 @@
   (ex.report ["Case" (%n case)]
              ["Type" (%type type)]))
 
-(exception: #export (unrecognized-pattern-syntax {pattern Code})
-  (%code pattern))
+(exception: #export (not-a-pattern {code Code})
+  (ex.report ["Code" (%code code)]))
 
 (exception: #export (cannot-simplify-for-pattern-matching {type Type})
-  (%type type))
+  (ex.report ["Type" (%type type)]))
 
-(do-template [<name>]
-  [(exception: #export (<name> {message Text})
-     message)]
+(exception: #export (non-exhaustive-pattern-matching {input Code} {branches (List [Code Code])} {coverage Coverage})
+  (ex.report ["Input" (%code input)]
+             ["Branches" (%code (code.record branches))]
+             ["Coverage" (coverage.%coverage coverage)]))
 
-  [cannot-have-empty-branches]
-  [non-exhaustive-pattern-matching]
-  )
+(exception: #export (cannot-have-empty-branches {message Text})
+  message)
 
 (def: (re-quantify envs baseT)
   (-> (List (List Type)) Type Type)
@@ -270,7 +270,7 @@
         (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next)))
 
     _
-    (///.throw unrecognized-pattern-syntax pattern)
+    (///.throw not-a-pattern pattern)
     ))
 
 (def: #export (case analyse inputC branches)
@@ -292,7 +292,7 @@
        outputTC (monad.map @ (|>> product.left coverage.determine) outputT)
        _ (.case (monad.fold error.Monad<Error> coverage.merge outputHC outputTC)
            (#error.Success coverage)
-           (///.assert non-exhaustive-pattern-matching ""
+           (///.assert non-exhaustive-pattern-matching [inputC branches coverage]
                        (coverage.exhaustive? coverage))
 
            (#error.Error error)
diff --git a/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux b/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux
index 6b2f307ac..1f90bdcff 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux
@@ -7,13 +7,13 @@
    [data
     [bit ("bit/." Equivalence<Bit>)]
     ["." number]
-    ["e" error ("error/." Monad<Error>)]
+    ["." error (#+ Error) ("error/." Monad<Error>)]
     ["." maybe]
-    [text
+    ["." text
      format]
     [collection
-     ["." list ("list/." Fold<List>)]
-     ["dict" dictionary (#+ Dictionary)]]]]
+     ["." list ("list/." Functor<List> Fold<List>)]
+     ["." dictionary (#+ Dictionary)]]]]
   ["." //// ("operation/." Monad<Operation>)]
   ["." /// (#+ Pattern Variant Operation)])
 
@@ -24,6 +24,10 @@
   (-> (Maybe Nat) Nat)
   (|>> (maybe.default 0)))
 
+(def: known-cases?
+  (-> Nat Bit)
+  (n/> 0))
+
 ## The coverage of a pattern-matching expression summarizes how well
 ## all the possible values of an input are being covered by the
 ## different patterns involved.
@@ -53,6 +57,36 @@
     _
     #0))
 
+(def: #export (%coverage value)
+  (Format Coverage)
+  (case value
+    #Partial
+    "#Partial"
+    
+    (#Bit value')
+    (|> value'
+        %b
+        (text.enclose ["(#Bit " ")"]))
+    
+    (#Variant ?max-cases cases)
+    (|> cases
+        dictionary.entries
+        (list/map (function (_ [idx coverage])
+                    (format (%n idx) " " (%coverage coverage))))
+        (text.join-with " ")
+        (text.enclose ["{" "}"])
+        (format (%n (..cases ?max-cases)) " ")
+        (text.enclose ["(#Variant " ")"]))
+
+    (#Seq left right)
+    (format "(#Seq " (%coverage left) " " (%coverage right) ")")
+    
+    (#Alt left right)
+    (format "(#Alt " (%coverage left) " " (%coverage right) ")")
+
+    #Exhaustive
+    "#Exhaustive"))
+
 (def: #export (determine pattern)
   (-> Pattern (Operation Coverage))
   (case pattern
@@ -110,8 +144,8 @@
       (wrap (#Variant (if right?
                         (#.Some idx)
                         #.None)
-                      (|> (dict.new number.Hash<Nat>)
-                          (dict.put idx value-coverage)))))))
+                      (|> (dictionary.new number.Hash<Nat>)
+                          (dictionary.put idx value-coverage)))))))
 
 (def: (xor left right)
   (-> Bit Bit Bit)
@@ -124,9 +158,8 @@
 ## always be a pattern prior to them that would match the input.
 ## Because of that, the presence of redundant patterns is assumed to
 ## be a bug, likely due to programmer carelessness.
-(def: redundant-pattern
-  (e.Error Coverage)
-  (e.fail "Redundant pattern."))
+(exception: #export (redundant-pattern)
+  "")
 
 (def: (flatten-alt coverage)
   (-> Coverage (List Coverage))
@@ -149,7 +182,7 @@
       [(#Variant allR casesR) (#Variant allS casesS)]
       (and (n/= (cases allR)
                 (cases allS))
-           (:: (dict.Equivalence<Dictionary> =) = casesR casesS))
+           (:: (dictionary.Equivalence<Dictionary> =) = casesR casesS))
       
       [(#Seq leftR rightR) (#Seq leftS rightS)]
       (and (= leftR leftS)
@@ -168,16 +201,20 @@
 
 (open: "coverage/." Equivalence<Coverage>)
 
+(exception: #export (variants-do-not-match {addition-cases Nat} {so-far-cases Nat})
+  (ex.report ["So-far Cases" (%n so-far-cases)]
+             ["Addition Cases" (%n addition-cases)]))
+
 ## After determining the coverage of each individual pattern, it is
 ## necessary to merge them all to figure out if the entire
 ## pattern-matching expression is exhaustive and whether it contains
 ## redundant patterns.
 (def: #export (merge addition so-far)
-  (-> Coverage Coverage (e.Error Coverage))
+  (-> Coverage Coverage (Error Coverage))
   (case [addition so-far]
     ## The addition cannot possibly improve the coverage.
     [_ #Exhaustive]
-    redundant-pattern
+    (ex.throw redundant-pattern [])
 
     ## The addition completes the coverage.
     [#Exhaustive _]
@@ -192,36 +229,46 @@
     (error/wrap #Exhaustive)
 
     [(#Variant allA casesA) (#Variant allSF casesSF)]
-    (cond (not (n/= (cases allSF) (cases allA)))
-          (e.fail "Variants do not match.")
-
-          (:: (dict.Equivalence<Dictionary> Equivalence<Coverage>) = casesSF casesA)
-          redundant-pattern
-
-          ## else
-          (do e.Monad<Error>
-            [casesM (monad.fold @
-                                (function (_ [tagA coverageA] casesSF')
-                                  (case (dict.get tagA casesSF')
-                                    (#.Some coverageSF)
-                                    (do @
-                                      [coverageM (merge coverageA coverageSF)]
-                                      (wrap (dict.put tagA coverageM casesSF')))
-
-                                    #.None
-                                    (wrap (dict.put tagA coverageA casesSF'))))
-                                casesSF (dict.entries casesA))]
-            (wrap (if (let [case-coverages (dict.values casesM)]
-                        (and (n/= (cases allSF) (list.size case-coverages))
-                             (list.every? exhaustive? case-coverages)))
-                    #Exhaustive
-                    (#Variant allSF casesM)))))
+    (let [addition-cases (cases allSF)
+          so-far-cases (cases allA)]
+      (cond (and (known-cases? addition-cases)
+                 (known-cases? so-far-cases)
+                 (not (n/= addition-cases so-far-cases)))
+            (ex.throw variants-do-not-match [addition-cases so-far-cases])
+
+            (:: (dictionary.Equivalence<Dictionary> Equivalence<Coverage>) = casesSF casesA)
+            (ex.throw redundant-pattern [])
+
+            ## else
+            (do error.Monad<Error>
+              [casesM (monad.fold @
+                                  (function (_ [tagA coverageA] casesSF')
+                                    (case (dictionary.get tagA casesSF')
+                                      (#.Some coverageSF)
+                                      (do @
+                                        [coverageM (merge coverageA coverageSF)]
+                                        (wrap (dictionary.put tagA coverageM casesSF')))
+
+                                      #.None
+                                      (wrap (dictionary.put tagA coverageA casesSF'))))
+                                  casesSF (dictionary.entries casesA))]
+              (wrap (if (and (n/= (inc (n/max addition-cases so-far-cases))
+                                  (dictionary.size casesM))
+                             (list.every? exhaustive? (dictionary.values casesM)))
+                      #Exhaustive
+                      (#Variant (case allSF
+                                  (#.Some _)
+                                  allSF
+
+                                  _
+                                  allA)
+                                casesM))))))
 
     [(#Seq leftA rightA) (#Seq leftSF rightSF)]
     (case [(coverage/= leftSF leftA) (coverage/= rightSF rightA)]
       ## There is nothing the addition adds to the coverage.
       [#1 #1]
-      redundant-pattern
+      (ex.throw redundant-pattern [])
 
       ## The 2 sequences cannot possibly be merged.
       [#0 #0]
@@ -229,7 +276,7 @@
 
       ## Same prefix
       [#1 #0]
-      (do e.Monad<Error>
+      (do error.Monad<Error>
         [rightM (merge rightA rightSF)]
         (if (exhaustive? rightM)
           ## If all that follows is exhaustive, then it can be safely dropped
@@ -240,14 +287,14 @@
 
       ## Same suffix
       [#0 #1]
-      (do e.Monad<Error>
+      (do error.Monad<Error>
         [leftM (merge leftA leftSF)]
         (wrap (#Seq leftM rightA))))
     
     ## The left part will always match, so the addition is redundant.
     (^multi [(#Seq left right) single]
             (coverage/= left single))
-    redundant-pattern
+    (ex.throw redundant-pattern [])
 
     ## The right part is not necessary, since it can always match the left.
     (^multi [single (#Seq left right)]
@@ -264,10 +311,10 @@
     ## This process must be repeated until no further productive
     ## merges can be done.
     [_ (#Alt leftS rightS)]
-    (do e.Monad<Error>
+    (do error.Monad<Error>
       [#let [fuse-once (: (-> Coverage (List Coverage)
-                              (e.Error [(Maybe Coverage)
-                                        (List Coverage)]))
+                              (Error [(Maybe Coverage)
+                                      (List Coverage)]))
                           (function (_ coverage possibilities)
                             (loop [alts possibilities]
                               (case alts
@@ -276,7 +323,7 @@
                                 
                                 (#.Cons alt alts')
                                 (case (merge coverage alt)
-                                  (#e.Success altM)
+                                  (#error.Success altM)
                                   (case altM
                                     (#Alt _)
                                     (do @
@@ -286,8 +333,8 @@
                                     _
                                     (wrap [(#.Some altM) alts']))
                                   
-                                  (#e.Error error)
-                                  (e.fail error))
+                                  (#error.Error error)
+                                  (error.fail error))
                                 ))))]
        [success possibilities] (fuse-once addition (flatten-alt so-far))]
       (loop [success success
@@ -311,6 +358,6 @@
     _
     (if (coverage/= so-far addition)
       ## The addition cannot possibly improve the coverage.
-      redundant-pattern
+      (ex.throw redundant-pattern [])
       ## There are now 2 alternative paths.
       (error/wrap (#Alt so-far addition)))))
diff --git a/stdlib/source/lux/compiler/default/phase/analysis/expression.lux b/stdlib/source/lux/compiler/default/phase/analysis/expression.lux
index c3c3ee619..0f01b48da 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis/expression.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis/expression.lux
@@ -5,8 +5,10 @@
     ["ex" exception (#+ exception:)]]
    [data
     ["." error]
-    [text
-     format]]
+    ["." text
+     format]
+    [collection
+     [list ("list/." Functor<List>)]]]
    ["." macro]]
   ["." // (#+ Analysis Operation Phase)
    ["." type]
@@ -21,16 +23,32 @@
     [//
      ["." reference]]]])
 
-(exception: #export (macro-expansion-failed {message Text})
-  message)
-
-(do-template [<name>]
-  [(exception: #export (<name> {code Code})
-     (%code code))]
-
-  [macro-call-must-have-single-expansion]
-  [unrecognized-syntax]
-  )
+(exception: #export (macro-expansion-failed {macro Name} {inputs (List Code)} {error Text})
+  (ex.report ["Macro" (%name macro)]
+             ["Inputs" (|> inputs
+                           (list/map (|>> %code (format "\n\t")))
+                           (text.join-with ""))]
+             ["Error" error]))
+
+(exception: #export (macro-call-must-have-single-expansion {macro Name} {inputs (List Code)})
+  (ex.report ["Macro" (%name macro)]
+             ["Inputs" (|> inputs
+                           (list/map (|>> %code (format "\n\t")))
+                           (text.join-with ""))]))
+
+(exception: #export (unrecognized-syntax {code Code})
+  (ex.report ["Code" (%code code)]))
+
+(def: #export (expand-macro name macro inputs)
+  (-> Name Macro (List Code) (Operation (List Code)))
+  (extension.lift
+   (function (_ state)
+     (case (//macro.expand macro inputs state)
+       (#error.Error error)
+       ((///.throw macro-expansion-failed [name inputs error]) state)
+
+       output
+       output))))
 
 (def: #export (compile code)
   Phase
@@ -103,23 +121,13 @@
                 (case ?macro
                   (#.Some macro)
                   (do @
-                    [#let [_ (log! (format (%name def-name) " @@@ "
-                                           (%list %code argsC+)))]
-                     expansion (: (Operation (List Code))
-                                  (extension.lift
-                                   (function (_ state)
-                                     (case (//macro.expand macro argsC+ state)
-                                       (#error.Error error)
-                                       ((///.throw macro-expansion-failed error) state)
-
-                                       output
-                                       output))))]
+                    [expansion (expand-macro def-name macro argsC+)]
                     (case expansion
                       (^ (list single))
                       (compile single)
 
                       _
-                      (///.throw macro-call-must-have-single-expansion code)))
+                      (///.throw macro-call-must-have-single-expansion [def-name argsC+])))
 
                   _
                   (function.apply compile functionT functionA argsC+)))
diff --git a/stdlib/source/lux/compiler/default/phase/analysis/macro.lux b/stdlib/source/lux/compiler/default/phase/analysis/macro.lux
index c37375805..a674dde07 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis/macro.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis/macro.lux
@@ -5,7 +5,7 @@
    [data
     ["." error (#+ Error)]
     [collection
-     ["." array (#+ Array)]]]
+     [array (#+ Array)]]]
    ["." host (#+ import:)]])
 
 (import: java/lang/reflect/Method
@@ -29,7 +29,7 @@
 
 (def: #export (expand macro inputs)
   (-> Macro (List Code) (Meta (List Code)))
-  (function (_ compiler)
+  (function (_ state)
     (do error.Monad<Error>
       [apply-method (|> macro
                         (:coerce Object)
@@ -38,7 +38,7 @@
        output (Method::invoke [(:coerce Object macro)
                                (|> (host.array Object 2)
                                    (host.array-write 0 (:coerce Object inputs))
-                                   (host.array-write 1 (:coerce Object compiler)))]
+                                   (host.array-write 1 (:coerce Object state)))]
                               apply-method)]
       (:coerce (Error [Lux (List Code)])
                output))))
diff --git a/stdlib/source/lux/compiler/default/phase/statement/total.lux b/stdlib/source/lux/compiler/default/phase/statement/total.lux
index d2b046f5f..967f07294 100644
--- a/stdlib/source/lux/compiler/default/phase/statement/total.lux
+++ b/stdlib/source/lux/compiler/default/phase/statement/total.lux
@@ -1,27 +1,56 @@
 (.module:
   [lux #*
    [control
-    [monad (#+ do)]
+    ["." monad (#+ do)]
     ["ex" exception (#+ exception:)]]
    [data
     [text
-     format]]]
+     format]]
+   ["." macro]]
   ["." // (#+ Phase)
    ["/." //
+    ["." analysis
+     ["." expression]
+     ["." type]
+     [macro (#+ expand)]]
     ["." extension]]])
 
-(do-template [<name>]
-  [(exception: #export (<name> {code Code})
-     (ex.report ["Statement" (%code code)]))]
+(exception: #export (not-a-statement {code Code})
+  (ex.report ["Statement" (%code code)]))
 
-  [unrecognized-statement]
-  )
+(exception: #export (not-a-macro {code Code})
+  (ex.report ["Code" (%code code)]))
+
+(exception: #export (macro-was-not-found {name Name})
+  (ex.report ["Name" (%name name)]))
 
 (def: #export (phase code)
   Phase
   (case code
-    (^ [_ (#.Form (list& [_ (#.Text extension-name)] extension-args))])
-    (extension.apply phase [extension-name extension-args])
+    (^ [_ (#.Form (list& [_ (#.Text name)] inputs))])
+    (extension.apply phase [name inputs])
+
+    (^ [_ (#.Form (list& macro inputs))])
+    (do ///.Monad<Operation>
+      [expansion (//.lift-analysis
+                  (do @
+                    [macroA (type.with-type Macro
+                              (expression.compile macro))]
+                    (case macroA
+                      (^ (analysis.constant macro-name))
+                      (do @
+                        [?macro (extension.lift (macro.find-macro macro-name))
+                         macro (case ?macro
+                                 (#.Some macro)
+                                 (wrap macro)
+                                 
+                                 #.None
+                                 (///.throw macro-was-not-found macro-name))]
+                        (expression.expand-macro macro-name macro inputs))
+                      
+                      _
+                      (///.throw not-a-macro code))))]
+      (monad.map @ phase expansion))
 
     _
-    (///.throw unrecognized-statement code)))
+    (///.throw not-a-statement code)))
diff --git a/stdlib/source/lux/interpreter.lux b/stdlib/source/lux/interpreter.lux
index 2feb4b81c..36cef324d 100644
--- a/stdlib/source/lux/interpreter.lux
+++ b/stdlib/source/lux/interpreter.lux
@@ -131,7 +131,7 @@
         (#error.Success [state' output])
 
         (#error.Error error)
-        (if (ex.match? total.unrecognized-statement error)
+        (if (ex.match? total.not-a-statement error)
           (<| (phase.run' state)
               (:share [anchor expression statement]
                       {(State+ anchor expression statement)