More improvements to error messages.

4 files changed, 39 insertions, 50 deletions

diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux
index c893d2af6..5d241b0c6 100644
--- a/stdlib/source/lux/control/exception.lux
+++ b/stdlib/source/lux/control/exception.lux
@@ -120,8 +120,8 @@
                                       (list.repeat (n/- (text.size header)
                                                         largest-header-size))
                                       (text.join-with ""))]
-                      ($_ text@compose padding header ": " message text.new-line))))
-        (text.join-with ""))))
+                      ($_ text@compose padding header ": " message))))
+        (text.join-with text.new-line))))
 
 (syntax: #export (report {entries (p.many (s.tuple (p.and s.any s.any)))})
   (wrap (list (` (report' (list (~+ (|> entries
diff --git a/stdlib/source/lux/tool/compiler/phase/analysis.lux b/stdlib/source/lux/tool/compiler/phase/analysis.lux
index d21effc00..dd21c8a1e 100644
--- a/stdlib/source/lux/tool/compiler/phase/analysis.lux
+++ b/stdlib/source/lux/tool/compiler/phase/analysis.lux
@@ -113,10 +113,10 @@
               (compile expansion))
 
             _
-            (/function.apply compile functionT functionA argsC+)))
+            (/function.apply compile functionT functionA functionC argsC+)))
 
         _
-        (/function.apply compile functionT functionA argsC+)))
+        (/function.apply compile functionT functionA functionC argsC+)))
 
     _
     (//.throw unrecognized-syntax [.dummy-cursor code'])))
diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/function.lux b/stdlib/source/lux/tool/compiler/phase/analysis/function.lux
index e63a3b8ee..fbaaf2fc5 100644
--- a/stdlib/source/lux/tool/compiler/phase/analysis/function.lux
+++ b/stdlib/source/lux/tool/compiler/phase/analysis/function.lux
@@ -28,8 +28,9 @@
              ["Argument" argument]
              ["Body" (%code body)]))
 
-(exception: #export (cannot-apply {function Type} {arguments (List Code)})
-  (ex.report ["Function" (%type function)]
+(exception: #export (cannot-apply {functionT Type} {functionC Code} {arguments (List Code)})
+  (ex.report ["Function type" (%type functionT)]
+             ["Function" (%code functionC)]
              ["Arguments" (|> arguments
                               list.enumerate
                               (list@map (.function (_ [idx argC])
@@ -97,9 +98,9 @@
           (/.fail "")
           )))))
 
-(def: #export (apply analyse functionT functionA argsC+)
-  (-> Phase Type Analysis (List Code) (Operation Analysis))
-  (<| (/.with-stack cannot-apply [functionT argsC+])
+(def: #export (apply analyse functionT functionA functionC argsC+)
+  (-> Phase Type Analysis Code (List Code) (Operation Analysis))
+  (<| (/.with-stack cannot-apply [functionT functionC argsC+])
       (do ///.monad
         [[applyT argsA+] (//inference.general analyse functionT argsC+)])
       (wrap (/.apply [functionA argsA+]))))
diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux
index 359a0e3b0..c9383696e 100644
--- a/stdlib/source/lux/type/check.lux
+++ b/stdlib/source/lux/type/check.lux
@@ -5,7 +5,7 @@
     [apply (#+ Apply)]
     ["." monad (#+ Monad do)]]
    [control
-    ["ex" exception (#+ exception:)]]
+    ["." exception (#+ Exception exception:)]]
    [data
     ["." maybe]
     ["." product]
@@ -25,23 +25,28 @@
   ("lux text =" reference subject))
 
 (exception: #export (unknown-type-var {id Nat})
-  (ex.report ["ID" (nat@encode id)]))
+  (exception.report
+   ["ID" (nat@encode id)]))
 
 (exception: #export (unbound-type-var {id Nat})
-  (ex.report ["ID" (nat@encode id)]))
+  (exception.report
+   ["ID" (nat@encode id)]))
 
 (exception: #export (invalid-type-application {funcT Type} {argT Type})
-  (ex.report ["Type function" (//.to-text funcT)]
-             ["Type argument" (//.to-text argT)]))
+  (exception.report
+   ["Type function" (//.to-text funcT)]
+   ["Type argument" (//.to-text argT)]))
 
 (exception: #export (cannot-rebind-var {id Nat} {type Type} {bound Type})
-  (ex.report ["Var" (nat@encode id)]
-             ["Wanted Type" (//.to-text type)]
-             ["Current Type" (//.to-text bound)]))
+  (exception.report
+   ["Var" (nat@encode id)]
+   ["Wanted Type" (//.to-text type)]
+   ["Current Type" (//.to-text bound)]))
 
 (exception: #export (type-check-failed {expected Type} {actual Type})
-  (ex.report ["Expected" (//.to-text expected)]
-             ["Actual" (//.to-text actual)]))
+  (exception.report
+   ["Expected" (//.to-text expected)]
+   ["Actual" (//.to-text actual)]))
 
 (type: #export Var Nat)
 
@@ -160,9 +165,9 @@
     (#error.Failure error)))
 
 (def: #export (throw exception message)
-  (All [e a] (-> (ex.Exception e) e (Check a)))
+  (All [e a] (-> (Exception e) e (Check a)))
   (function (_ context)
-    (ex.throw exception message)))
+    (exception.throw exception message)))
 
 (def: #export existential
   {#.doc "A producer of existential types."}
@@ -185,7 +190,7 @@
          (#error.Success [context <succeed>])
 
          #.None
-         (ex.throw unknown-type-var id))))]
+         (exception.throw unknown-type-var id))))]
 
   [bound? Bit          #0     #1]
   [read   (Maybe Type) #.None (#.Some bound)]
@@ -199,10 +204,10 @@
       (#error.Success [context bound])
 
       (#.Some _)
-      (ex.throw unbound-type-var id)
+      (exception.throw unbound-type-var id)
 
       _
-      (ex.throw unknown-type-var id))))
+      (exception.throw unknown-type-var id))))
 
 (def: #export (bind type id)
   (-> Type Var (Check Any))
@@ -213,10 +218,10 @@
                        []])
 
       (#.Some (#.Some bound))
-      (ex.throw cannot-rebind-var [id type bound])
+      (exception.throw cannot-rebind-var [id type bound])
       
       _
-      (ex.throw unknown-type-var id))))
+      (exception.throw unknown-type-var id))))
 
 (def: (update type id)
   (-> Type Var (Check Any))
@@ -227,7 +232,7 @@
                        []])
       
       _
-      (ex.throw unknown-type-var id))))
+      (exception.throw unknown-type-var id))))
 
 (def: #export var
   (Check [Var Type])
@@ -284,7 +289,7 @@
         (#error.Success [context output])
         
         #.None
-        (ex.throw unknown-type-var current)))))
+        (exception.throw unknown-type-var current)))))
 
 (def: #export fresh-context
   Type-Context
@@ -438,26 +443,6 @@
           _
           (check' assumptions etype atype))))))
 
-(def: (with-error-stack on-error check)
-  (All [a] (-> (-> Any Text) (Check a) (Check a)))
-  (function (_ context)
-    (case (check context)
-      (#error.Failure error)
-      (#error.Failure (case error
-                        ""
-                        (on-error [])
-
-                        _
-                        ($_ text@compose
-                            (on-error [])
-                            text.new-line text.new-line
-                            "-----------------------------------------"
-                            text.new-line text.new-line
-                            error)))
-
-      output
-      output)))
-
 ## TODO: "check-apply" can be optimized...
 (def: (check-apply check' assumptions [eAT eFT] [aAT aFT])
   (-> (-> (List Assumption) Type Type (Check (List Assumption))) (List Assumption)
@@ -510,14 +495,17 @@
     _
     (fail "")))
 
+(def: (with-stack exception parameter check)
+  (All [e a] (-> (Exception e) e (Check a) (Check a)))
+  (|>> check (exception.with-stack exception parameter)))
+
 ## TODO: "check'" can be optimized...
 (def: #export (check' assumptions expected actual)
   {#.doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."}
   (-> (List Assumption) Type Type (Check (List Assumption)))
   (if (is? expected actual)
     (check@wrap assumptions)
-    (with-error-stack
-      (function (_ _) (ex.construct type-check-failed [expected actual]))
+    (with-stack type-check-failed [expected actual]
       (case [expected actual]
         [(#.Var idE) (#.Var idA)]
         (check-vars check' assumptions idE idA)