Improvements to error messaging for extensions.

5 files changed, 56 insertions, 48 deletions

diff --git a/stdlib/source/lux/tool/compiler/phase/extension.lux b/stdlib/source/lux/tool/compiler/phase/extension.lux
index 43df97b9e..3b247eda9 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension.lux
@@ -4,7 +4,7 @@
     [monad (#+ do)]]
    [control
     ["." function]
-    ["ex" exception (#+ exception:)]]
+    ["." exception (#+ exception:)]]
    [data
     ["." error (#+ Error)]
     ["." text ("#@." order)
@@ -38,29 +38,35 @@
 (type: #export (Phase s i o)
   (//.Phase (State s i o) i o))
 
-(template [<name>]
-  [(exception: #export (<name> {name Name})
-     (ex.report ["Extension" (%t name)]))]
+(exception: #export (cannot-overwrite {name Name})
+  (exception.report
+   ["Extension" (%t name)]))
 
-  [cannot-overwrite]
-  [invalid-syntax]
-  )
+(exception: #export (invalid-syntax {name Name} {inputs (List Code)})
+  (exception.report
+   ["Extension" (%t name)]
+   ["Inputs" (|> inputs
+                 (list@map %code)
+                 (text.join-with text.new-line))]))
 
 (exception: #export [s i o] (unknown {name Name} {bundle (Bundle s i o)})
-  (ex.report ["Extension" (%t name)]
-             ["Available" (|> bundle
-                              dictionary.keys
-                              (list.sort text@<)
-                              (list@map (|>> %t (format text.new-line text.tab)))
-                              (text.join-with ""))]))
+  (exception.report
+   ["Extension" (%t name)]
+   ["Available" (|> bundle
+                    dictionary.keys
+                    (list.sort text@<)
+                    (list@map %t)
+                    (text.join-with text.new-line))]))
 
 (exception: #export (incorrect-arity {name Name} {arity Nat} {args Nat})
-  (ex.report ["Extension" (%t name)]
-             ["Expected" (%n arity)]
-             ["Actual" (%n args)]))
+  (exception.report
+   ["Extension" (%t name)]
+   ["Expected" (%n arity)]
+   ["Actual" (%n args)]))
 
 (exception: #export (incorrect-syntax {name Name})
-  (ex.report ["Extension" (%t name)]))
+  (exception.report
+   ["Extension" (%t name)]))
 
 (def: #export (install name handler)
   (All [s i o]
@@ -72,7 +78,7 @@
                        []])
 
       _
-      (ex.throw cannot-overwrite name))))
+      (exception.throw cannot-overwrite name))))
 
 (def: #export (apply phase [name parameters])
   (All [s i o]
@@ -84,7 +90,7 @@
        stateE)
 
       #.None
-      (ex.throw unknown [name bundle]))))
+      (exception.throw unknown [name bundle]))))
 
 (def: #export (localized get set transform)
   (All [s s' i o v]
diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux
index f62b1031b..4f11e47fb 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux
@@ -92,7 +92,7 @@
         (analyse exprC))
       
       _
-      (/////analysis.throw ///.invalid-syntax [extension-name]))))
+      (/////analysis.throw ///.invalid-syntax [extension-name argsC+]))))
 
 (template [<name> <type>]
   [(def: (<name> eval)
diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux
index f3b6552c0..13762272e 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux
@@ -533,7 +533,7 @@
           (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class)))))
 
         _
-        (/////analysis.throw ///.invalid-syntax extension-name))
+        (/////analysis.throw ///.invalid-syntax [extension-name args]))
 
       _
       (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)]))))
@@ -556,7 +556,7 @@
             (/////analysis.throw cannot-possibly-be-an-instance (format object-class " !<= "  class))))
 
         _
-        (/////analysis.throw ///.invalid-syntax extension-name))
+        (/////analysis.throw ///.invalid-syntax [extension-name args]))
 
       _
       (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))
@@ -756,7 +756,7 @@
                                                    "           For value: " (%code valueC) text.new-line))))
 
       _
-      (/////analysis.throw ///.invalid-syntax extension-name))))
+      (/////analysis.throw ///.invalid-syntax [extension-name args]))))
 
 (def: bundle::object
   Bundle
@@ -845,7 +845,7 @@
           (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field)))))
 
         _
-        (/////analysis.throw ///.invalid-syntax extension-name))
+        (/////analysis.throw ///.invalid-syntax [extension-name args]))
 
       _
       (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))
@@ -867,7 +867,7 @@
           (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) valueA))))
 
         _
-        (/////analysis.throw ///.invalid-syntax extension-name))
+        (/////analysis.throw ///.invalid-syntax [extension-name args]))
 
       _
       (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)]))))
@@ -886,7 +886,7 @@
           (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) objectA))))
 
         _
-        (/////analysis.throw ///.invalid-syntax extension-name))
+        (/////analysis.throw ///.invalid-syntax [extension-name args]))
 
       _
       (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)]))))
@@ -910,7 +910,7 @@
           (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) valueA objectA))))
 
         _
-        (/////analysis.throw ///.invalid-syntax extension-name))
+        (/////analysis.throw ///.invalid-syntax [extension-name args]))
 
       _
       (/////analysis.throw ///.incorrect-arity [extension-name 4 (list.size args)]))))
@@ -1185,7 +1185,7 @@
                                                               (/////analysis.text outputJC) (decorate-inputs argsT argsA)))))
 
       _
-      (/////analysis.throw ///.invalid-syntax extension-name))))
+      (/////analysis.throw ///.invalid-syntax [extension-name args]))))
 
 (def: invoke::virtual
   Handler
@@ -1208,7 +1208,7 @@
                                                               (/////analysis.text outputJC) objectA (decorate-inputs argsT argsA)))))
 
       _
-      (/////analysis.throw ///.invalid-syntax extension-name))))
+      (/////analysis.throw ///.invalid-syntax [extension-name args]))))
 
 (def: invoke::special
   Handler
@@ -1225,7 +1225,7 @@
                                                               (/////analysis.text outputJC) (decorate-inputs argsT argsA)))))
 
       _
-      (/////analysis.throw ///.invalid-syntax extension-name))))
+      (/////analysis.throw ///.invalid-syntax [extension-name args]))))
 
 (def: invoke::interface
   Handler
@@ -1246,7 +1246,7 @@
                                                (decorate-inputs argsT argsA)))))
 
       _
-      (/////analysis.throw ///.invalid-syntax extension-name))))
+      (/////analysis.throw ///.invalid-syntax [extension-name args]))))
 
 (def: invoke::constructor
   Handler
@@ -1261,7 +1261,7 @@
         (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (decorate-inputs argsT argsA)))))
 
       _
-      (/////analysis.throw ///.invalid-syntax extension-name))))
+      (/////analysis.throw ///.invalid-syntax [extension-name args]))))
 
 (def: bundle::member
   Bundle
diff --git a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux
index f5c52bfc4..030bc5a2b 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux
@@ -6,6 +6,7 @@
     [io (#+ IO)]
     ["p" parser]]
    [data
+    ["." maybe]
     ["." error]
     [text
      format]
@@ -145,15 +146,13 @@
         (wrap ////statement.no-requirements))
 
       _
-      (///.throw //.invalid-syntax [extension-name]))))
+      (///.throw //.invalid-syntax [extension-name inputsC+]))))
 
 (def: imports
   (Syntax (List Import))
   (|> (s.tuple (p.and s.text s.text))
       p.some
-      s.tuple
-      (p.after (s.this (' #.imports)))
-      s.record))
+      s.tuple))
 
 (def: def::module
   Handler
@@ -162,13 +161,16 @@
       (^ (list annotationsC))
       (do ///.monad
         [[_ annotationsT annotationsV] (evaluate! Code annotationsC)
-         imports (case (s.run (list (:coerce Code annotationsV))
+         #let [annotationsV (:coerce Code annotationsV)]
+         imports (case (s.run (list (|> annotationsV
+                                        (macro.get-ann (name-of #.imports))
+                                        (maybe.default (' []))))
                               ..imports)
                    (#error.Success imports)
                    (wrap imports)
                    
                    (#error.Failure error)
-                   (///.throw //.invalid-syntax [extension-name]))
+                   (///.throw //.invalid-syntax [extension-name (list annotationsV)]))
          _ (////statement.lift-analysis
             (do @
               [_ (monad.map @ (function (_ [module alias])
@@ -178,12 +180,12 @@
                                     "" (wrap [])
                                     _ (module.alias alias module))))
                             imports)]
-              (module.set-annotations (:coerce Code annotationsV))))]
+              (module.set-annotations annotationsV)))]
         (wrap {#////statement.imports imports
                #////statement.referrals (list)}))
 
       _
-      (///.throw //.invalid-syntax [extension-name]))))
+      (///.throw //.invalid-syntax [extension-name inputsC+]))))
 
 ## TODO: Reify aliasing as a feature of the compiler, instead of
 ## manifesting it implicitly through definition annotations.
@@ -213,7 +215,7 @@
         (wrap ////statement.no-requirements))
 
       _
-      (///.throw //.invalid-syntax [extension-name]))))
+      (///.throw //.invalid-syntax [extension-name inputsC+]))))
 
 (template [<mame> <type> <scope>]
   [(def: <mame>
@@ -238,7 +240,7 @@
            (wrap ////statement.no-requirements))
 
          _
-         (///.throw //.invalid-syntax [extension-name]))))]
+         (///.throw //.invalid-syntax [extension-name inputsC+]))))]
 
   [def::analysis   ////analysis.Handler                                ////statement.lift-analysis]
   [def::synthesis  ////synthesis.Handler                               ////statement.lift-synthesis]
@@ -291,7 +293,7 @@
         (wrap ////statement.no-requirements))
 
       _
-      (///.throw //.invalid-syntax [extension-name]))))
+      (///.throw //.invalid-syntax [extension-name inputsC+]))))
 
 (def: (bundle::def program)
   (All [anchor expression statement]
diff --git a/stdlib/source/test/lux/tool/compiler/phase/analysis/function.lux b/stdlib/source/test/lux/tool/compiler/phase/analysis/function.lux
index 8d345dae2..252344cb6 100644
--- a/stdlib/source/test/lux/tool/compiler/phase/analysis/function.lux
+++ b/stdlib/source/test/lux/tool/compiler/phase/analysis/function.lux
@@ -100,19 +100,19 @@
     (<| (_.context (%name (name-of /.apply)))
         ($_ _.and
             (_.test "Can analyse monomorphic type application."
-                    (|> (/.apply _primitive.phase funcT dummy-function inputsC)
+                    (|> (/.apply _primitive.phase funcT dummy-function (' []) inputsC)
                         (check-apply outputT full-args)))
             (_.test "Can partially apply functions."
-                    (|> (/.apply _primitive.phase funcT dummy-function (list.take partial-args inputsC))
+                    (|> (/.apply _primitive.phase funcT dummy-function (' []) (list.take partial-args inputsC))
                         (check-apply partialT partial-args)))
             (_.test "Can apply polymorphic functions."
-                    (|> (/.apply _primitive.phase polyT dummy-function inputsC)
+                    (|> (/.apply _primitive.phase polyT dummy-function (' []) inputsC)
                         (check-apply poly-inputT full-args)))
             (_.test "Polymorphic partial application propagates found type-vars."
-                    (|> (/.apply _primitive.phase polyT dummy-function (list.take (inc var-idx) inputsC))
+                    (|> (/.apply _primitive.phase polyT dummy-function (' []) (list.take (inc var-idx) inputsC))
                         (check-apply partial-polyT1 (inc var-idx))))
             (_.test "Polymorphic partial application preserves quantification for type-vars."
-                    (|> (/.apply _primitive.phase polyT dummy-function (list.take var-idx inputsC))
+                    (|> (/.apply _primitive.phase polyT dummy-function (' []) (list.take var-idx inputsC))
                         (check-apply partial-polyT2 var-idx)))
             ))))