- "with-stack" function for stacking exceptions.

5 files changed, 52 insertions, 51 deletions

diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux
index 066a81d65..2ca06defa 100644
--- a/stdlib/source/lux/control/exception.lux
+++ b/stdlib/source/lux/control/exception.lux
@@ -2,7 +2,7 @@
   lux
   (lux (control [monad #+ do]
                 ["p" parser])
-       (data ["e" error]
+       (data ["/" error #+ Error]
              [maybe]
              [product]
              [text "text/" Monoid<Text>]
@@ -30,36 +30,36 @@
 
           If no exception was detected, or a different one from the one being checked, then pass along the original value."}
   (All [e a]
-    (-> (Exception e) (-> Text a) (e.Error a)
-        (e.Error a)))
+    (-> (Exception e) (-> Text a) (Error a)
+        (Error a)))
   (case try
-    (#e.Success output)
-    (#e.Success output)
+    (#/.Success output)
+    (#/.Success output)
 
-    (#e.Error error)
+    (#/.Error error)
     (let [reference (get@ #label exception)]
       (if (text.starts-with? reference error)
-        (#e.Success (|> error
+        (#/.Success (|> error
                         (text.clip (text.size reference) (text.size error))
                         maybe.assume
                         then))
-        (#e.Error error)))))
+        (#/.Error error)))))
 
 (def: #export (otherwise to-do try)
   {#.doc "If no handler could be found to catch the exception, then run a function as a last-resort measure."}
   (All [a]
-    (-> (-> Text a) (e.Error a) a))
+    (-> (-> Text a) (Error a) a))
   (case try
-    (#e.Success output)
+    (#/.Success output)
     output
 
-    (#e.Error error)
+    (#/.Error error)
     (to-do error)))
 
 (def: #export (return value)
   {#.doc "A way to lift normal values into the error-handling context."}
-  (All [a] (-> a (e.Error a)))
-  (#e.Success value))
+  (All [a] (-> a (Error a)))
+  (#/.Success value))
 
 (def: #export (construct exception message)
   {#.doc "Constructs an exception."}
@@ -68,8 +68,8 @@
 
 (def: #export (throw exception message)
   {#.doc "Decorate an error message with an Exception and lift it into the error-handling context."}
-  (All [e] (-> (Exception e) e e.Error))
-  (#e.Error (construct exception message)))
+  (All [e] (-> (Exception e) e Error))
+  (#/.Error (construct exception message)))
 
 (syntax: #export (exception: {export csr.export}
                    {t-vars (p.default (list) csr.type-variables)}
@@ -119,3 +119,26 @@
   (wrap (list (` (report' (list (~+ (|> entries
                                         (list/map (function (_ [header message])
                                                     (` [(~ header) (~ message)])))))))))))
+
+(def: separator
+  ($_ "lux text concat"
+      "\n\n"
+      "-----------------------------------------"
+      "\n\n"))
+
+(def: #export (with-stack exception message computation)
+  (All [e a] (-> (Exception e) e (Error a) (Error a)))
+  (case computation
+    (#/.Error error)
+    (#/.Error (case error
+                ""
+                (..construct exception message)
+
+                _
+                ($_ "lux text concat"
+                    (..construct exception message)
+                    ..separator
+                    error)))
+
+    success
+    success))
diff --git a/stdlib/source/lux/lang/compiler.lux b/stdlib/source/lux/lang/compiler.lux
index 20278a6cd..2e88938de 100644
--- a/stdlib/source/lux/lang/compiler.lux
+++ b/stdlib/source/lux/lang/compiler.lux
@@ -57,22 +57,10 @@
   (All [s o] (-> s (-> (Operation s o) (Operation s o))))
   (localized (function.constant state)))
 
-(def: error-separator
-  (format "\n\n"
-          "-----------------------------------------"
-          "\n\n"))
-
-(def: #export (with-stacked-errors handler action)
-  (All [s o] (-> (-> [] Text) (Operation s o) (Operation s o)))
-  (function (_ state)
-    (case (action state)
-      (#error.Error error)
-      (#error.Error (if (text.empty? error)
-                      (handler [])
-                      (format (handler []) error-separator error)))
-
-      success
-      success)))
+(def: #export (with-stack exception message action)
+  (All [e s o] (-> (Exception e) e (Operation s o) (Operation s o)))
+  (<<| (ex.with-stack exception message)
+       action))
 
 (def: #export identity
   (All [s a] (Compiler s a a))
diff --git a/stdlib/source/lux/lang/compiler/analysis/function.lux b/stdlib/source/lux/lang/compiler/analysis/function.lux
index b6e09f11a..b16b18e59 100644
--- a/stdlib/source/lux/lang/compiler/analysis/function.lux
+++ b/stdlib/source/lux/lang/compiler/analysis/function.lux
@@ -35,9 +35,7 @@
   (do macro.Monad<Meta>
     [functionT macro.expected-type]
     (loop [expectedT functionT]
-      (///.with-stacked-errors
-        (.function (_ _)
-          (ex.construct cannot-analyse [expectedT function-name arg-name body]))
+      (///.with-stack cannot-analyse [expectedT function-name arg-name body]
         (case expectedT
           (#.Named name unnamedT)
           (recur unnamedT)
@@ -95,9 +93,7 @@
 
 (def: #export (apply analyse functionT functionA args)
   (-> Compiler Type Analysis (List Code) (Meta Analysis))
-  (///.with-stacked-errors
-    (.function (_ _)
-      (ex.construct cannot-apply [functionT args]))
-    (do macro.Monad<Meta>
-      [[applyT argsA] (//inference.general analyse functionT args)]
-      (wrap (//.apply [functionA argsA])))))
+  (<| (///.with-stack cannot-apply [functionT args])
+      (do macro.Monad<Meta>
+        [[applyT argsA] (//inference.general analyse functionT args)])
+      (wrap (//.apply [functionA argsA]))))
diff --git a/stdlib/source/lux/lang/compiler/analysis/inference.lux b/stdlib/source/lux/lang/compiler/analysis/inference.lux
index abf1529d6..5e3fb0cfe 100644
--- a/stdlib/source/lux/lang/compiler/analysis/inference.lux
+++ b/stdlib/source/lux/lang/compiler/analysis/inference.lux
@@ -143,11 +143,9 @@
       (#.Function inputT outputT)
       (do ///.Monad<Operation>
         [[outputT' args'A] (general analyse outputT args')
-         argA (///.with-stacked-errors
-                (function (_ _)
-                  (ex.construct cannot-infer-argument [inputT argC]))
-                (//type.with-type inputT
-                  (analyse argC)))]
+         argA (<| (///.with-stack cannot-infer-argument [inputT argC])
+                  (//type.with-type inputT)
+                  (analyse argC))]
         (wrap [outputT' (list& argA args'A)]))
 
       (#.Var infer-id)
diff --git a/stdlib/source/lux/lang/compiler/analysis/structure.lux b/stdlib/source/lux/lang/compiler/analysis/structure.lux
index 78b36bc32..ed809135a 100644
--- a/stdlib/source/lux/lang/compiler/analysis/structure.lux
+++ b/stdlib/source/lux/lang/compiler/analysis/structure.lux
@@ -77,9 +77,7 @@
   (-> Compiler Nat Code (Operation Analysis))
   (do ///.Monad<Operation>
     [expectedT macro.expected-type]
-    (///.with-stacked-errors
-      (function (_ _)
-        (ex.construct cannot-analyse-variant [expectedT tag valueC]))
+    (///.with-stack cannot-analyse-variant [expectedT tag valueC]
       (case expectedT
         (#.Sum _)
         (let [flat (type.flatten-variant expectedT)
@@ -191,9 +189,7 @@
   (-> Compiler (List Code) (Operation Analysis))
   (do ///.Monad<Operation>
     [expectedT macro.expected-type]
-    (///.with-stacked-errors
-      (function (_ _)
-        (ex.construct cannot-analyse-tuple [expectedT membersC]))
+    (///.with-stack cannot-analyse-tuple [expectedT membersC]
       (case expectedT
         (#.Product _)
         (..typed-product analyse membersC)