Refactoring & improvements to "lux/macro/poly".

5 files changed, 75 insertions, 54 deletions

diff --git a/stdlib/source/lux/language/compiler/default/repl/type.lux b/stdlib/source/lux/language/compiler/default/repl/type.lux
index 635624e67..2af590c4b 100644
--- a/stdlib/source/lux/language/compiler/default/repl/type.lux
+++ b/stdlib/source/lux/language/compiler/default/repl/type.lux
@@ -38,7 +38,7 @@
           
           (~~ (do-template [<type> <formatter>]
                 [(do p.Monad<Parser>
-                   [_ (poly.similar <type>)]
+                   [_ (poly.sub <type>)]
                    (wrap (|>> (:coerce <type>) <formatter>)))]
 
                 [Bit %b]
@@ -53,7 +53,7 @@
   (`` ($_ p.either
           (~~ (do-template [<type> <formatter>]
                 [(do p.Monad<Parser>
-                   [_ (poly.similar <type>)]
+                   [_ (poly.sub <type>)]
                    (wrap (|>> (:coerce <type>) <formatter>)))]
 
                 [Type %type]
diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux
index 964f857a1..f234980c6 100644
--- a/stdlib/source/lux/macro/poly.lux
+++ b/stdlib/source/lux/macro/poly.lux
@@ -10,10 +10,11 @@
     ["." product]
     ["." bit]
     ["." maybe]
-    [ident ("ident/." Equivalence<Ident> Codec<Text,Ident>)]
+    [ident ("ident/." Codec<Text,Ident>)]
     ["e" error]
     ["." number ("nat/." Codec<Text,Nat>)]
-    ["." text ("text/." Monoid<Text>)]
+    ["." text ("text/." Monoid<Text>)
+     format]
     [collection
      ["." list ("list/." Fold<List> Monad<List> Monoid<List>)]
      ["dict" dictionary (#+ Dictionary)]]]
@@ -28,6 +29,36 @@
    ["." type ("type/." Equivalence<Type>)
     ["." check]]])
 
+(do-template [<name>]
+  [(exception: #export (<name> {type Type})
+     (%type type))]
+
+  [not-existential]
+  [not-recursive]
+  [not-named]
+  [not-parameter]
+  [unknown-parameter]
+  [not-function]
+  [not-application]
+  [not-polymorphic]
+  [not-variant]
+  [not-tuple]
+  )
+
+(do-template [<name>]
+  [(exception: #export (<name> {expected Type} {actual Type})
+     (ex.report ["Expected" (%type expected)]
+                ["Actual" (%type actual)]))]
+
+  [types-do-not-match]
+  [wrong-parameter]
+  )
+
+(exception: #export (unconsumed {remaining (List Type)})
+  (ex.report ["Types" (|> remaining
+                          (list/map (|>> %type (format "\n* ")))
+                          (text.join-with ""))]))
+
 (type: #export Env (Dictionary Nat [Type Code]))
 
 (type: #export (Poly a)
@@ -47,10 +78,7 @@
       (#e.Success output)
 
       _
-      (#e.Error (|> remaining
-                    (list/map type.to-text)
-                    (text.join-with ", ")
-                    (text/compose "Unconsumed types: "))))))
+      (ex.throw unconsumed remaining))))
 
 (def: #export (run type poly)
   (All [a] (-> Type (Poly a) (e.Error a)))
@@ -119,7 +147,7 @@
         (#e.Success [[_ inputs'] output])
         (#e.Success [[env inputs'] [g!var output]])))))
 
-(do-template [<name> <flattener> <tag>]
+(do-template [<name> <flattener> <tag> <exception>]
   [(def: #export (<name> poly)
      (All [a] (-> (Poly a) (Poly a)))
      (do p.Monad<Parser>
@@ -127,10 +155,10 @@
        (let [members (<flattener> (type.un-name headT))]
          (if (n/> +1 (list.size members))
            (local members poly)
-           (p.fail ($_ text/compose "Not a " (ident/encode (ident-for <tag>)) " type: " (type.to-text headT)))))))]
+           (p.fail (ex.construct <exception> headT))))))]
 
-  [variant type.flatten-variant #.Sum]
-  [tuple   type.flatten-tuple   #.Product]
+  [variant type.flatten-variant #.Sum     not-variant]
+  [tuple   type.flatten-tuple   #.Product not-tuple]
   )
 
 (def: polymorphic'
@@ -139,7 +167,7 @@
     [headT any
      #let [[num-arg bodyT] (type.flatten-univ-q (type.un-name headT))]]
     (if (n/= +0 num-arg)
-      (p.fail ($_ text/compose "Non-polymorphic type: " (type.to-text headT)))
+      (p.fail (ex.construct not-polymorphic headT))
       (wrap [num-arg bodyT]))))
 
 (def: #export (polymorphic poly)
@@ -187,7 +215,7 @@
     (if (n/> +0 (list.size inputsT))
       (p.seq (local inputsT in-poly)
              (local (list outputT) out-poly))
-      (p.fail ($_ text/compose "Non-function type: " (type.to-text headT))))))
+      (p.fail (ex.construct not-function headT)))))
 
 (def: #export (apply poly)
   (All [a] (-> (Poly a) (Poly a)))
@@ -195,7 +223,7 @@
     [headT any
      #let [[funcT paramsT] (type.flatten-application (type.un-name headT))]]
     (if (n/= +0 (list.size paramsT))
-      (p.fail ($_ text/compose "Non-application type: " (type.to-text headT)))
+      (p.fail (ex.construct not-application headT))
       (local (#.Cons funcT paramsT) poly))))
 
 (do-template [<name> <test>]
@@ -205,13 +233,11 @@
        [actual any]
        (if (<test> expected actual)
          (wrap [])
-         (p.fail ($_ text/compose
-                     "Types do not match." "\n"
-                     "Expected: " (type.to-text expected) "\n"
-                     "  Actual: " (type.to-text actual))))))]
+         (p.fail (ex.construct types-do-not-match [expected actual])))))]
 
   [exactly type/=]
-  [similar check.checks?]
+  [sub     check.checks?]
+  [super   (function.flip check.checks?)]
   )
 
 (def: (adjusted-idx env idx)
@@ -233,12 +259,12 @@
         (wrap poly-code)
 
         #.None
-        (p.fail ($_ text/compose "Unknown parameter type: " (type.to-text headT))))
+        (p.fail (ex.construct unknown-parameter headT)))
 
       _
-      (p.fail ($_ text/compose "Not a parameter type: " (type.to-text headT))))))
+      (p.fail (ex.construct not-parameter headT)))))
 
-(def: #export (var id)
+(def: #export (parameter! id)
   (-> Nat (Poly Any))
   (do p.Monad<Parser>
     [env ..env
@@ -247,15 +273,10 @@
       (#.Parameter idx)
       (if (n/= id (adjusted-idx env idx))
         (wrap [])
-        (p.fail ($_ text/compose "Wrong parameter type.\n"
-                    "Expected: " (nat/encode id) "\n"
-                    "  Actual: " (nat/encode idx))))
+        (p.fail (ex.construct wrong-parameter [(#.Parameter id) headT])))
 
       _
-      (p.fail ($_ text/compose "Not a parameter type: " (type.to-text headT))))))
-
-(exception: #export (not-existential-type {type Type})
-  (type.to-text type))
+      (p.fail (ex.construct not-parameter headT)))))
 
 (def: #export existential
   (Poly Nat)
@@ -266,7 +287,7 @@
       (wrap ex-id)
 
       _
-      (p.fail (ex.construct not-existential-type headT)))))
+      (p.fail (ex.construct not-existential headT)))))
 
 (def: #export named
   (Poly [Ident Type])
@@ -277,7 +298,7 @@
       (wrap [name anonymousT])
 
       _
-      (p.fail ($_ text/compose "Not a named type: " (type.to-text inputT))))))
+      (p.fail (ex.construct not-named inputT)))))
 
 (def: #export (recursive poly)
   (All [a] (-> (Poly a) (Poly [Code a])))
@@ -293,7 +314,7 @@
         (wrap [recT output]))
 
       _
-      (p.fail ($_ text/compose "Not a recursive type: " (type.to-text headT))))))
+      (p.fail (ex.construct not-recursive headT)))))
 
 (def: #export recursive-self
   (Poly Code)
@@ -307,17 +328,17 @@
       (wrap self-call)
 
       _
-      (p.fail ($_ text/compose "Not a recursive type: " (type.to-text headT))))))
+      (p.fail (ex.construct not-recursive headT)))))
 
 (def: #export recursive-call
   (Poly Code)
   (do p.Monad<Parser>
     [env ..env
      [funcT argsT] (apply (p.seq any (p.many any)))
-     _ (local (list funcT) (var +0))
+     _ (local (list funcT) (..parameter! +0))
      allC (let [allT (list& funcT argsT)]
             (|> allT
-                (monad.map @ (function.constant parameter))
+                (monad.map @ (function.constant ..parameter))
                 (local allT)))]
     (wrap (` ((~+ allC))))))
 
@@ -327,7 +348,7 @@
     [current any
      #let [_ (log! ($_ text/compose
                        "{" (ident/encode (ident-for ..log)) "} "
-                       (type.to-text current)))]]
+                       (%type current)))]]
     (p.fail "LOGGING")))
 
 ## [Syntax]
diff --git a/stdlib/source/lux/macro/poly/equivalence.lux b/stdlib/source/lux/macro/poly/equivalence.lux
index ae910874c..8c2f8dd21 100644
--- a/stdlib/source/lux/macro/poly/equivalence.lux
+++ b/stdlib/source/lux/macro/poly/equivalence.lux
@@ -50,12 +50,12 @@
                                  <eq>))))]
 
                   [(poly.exactly Any) (function ((~ g!_) (~ g!_) (~ g!_)) #1)]
-                  [(poly.similar Bit)  bit.Equivalence<Bit>]
-                  [(poly.similar Nat)  number.Equivalence<Nat>]
-                  [(poly.similar Int)  number.Equivalence<Int>]
-                  [(poly.similar Rev)  number.Equivalence<Rev>]
-                  [(poly.similar Frac) number.Equivalence<Frac>]
-                  [(poly.similar Text) text.Equivalence<Text>]))
+                  [(poly.sub Bit)     bit.Equivalence<Bit>]
+                  [(poly.sub Nat)     number.Equivalence<Nat>]
+                  [(poly.sub Int)     number.Equivalence<Int>]
+                  [(poly.sub Rev)     number.Equivalence<Rev>]
+                  [(poly.sub Frac)    number.Equivalence<Frac>]
+                  [(poly.sub Text)    text.Equivalence<Text>]))
             ## Composite types
             (~~ (do-template [<name> <eq>]
                   [(do @
diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux
index 90a2ecde0..3b9e851a4 100644
--- a/stdlib/source/lux/macro/poly/functor.lux
+++ b/stdlib/source/lux/macro/poly/functor.lux
@@ -40,7 +40,7 @@
                            ## Type-var
                            (do p.Monad<Parser>
                              [#let [varI (|> num-vars (n/* +2) dec)]
-                              _ (poly.var varI)]
+                              _ (poly.parameter! varI)]
                              (wrap (` ((~ funcC) (~ valueC)))))
                            ## Variants
                            (do @
diff --git a/stdlib/source/lux/macro/poly/json.lux b/stdlib/source/lux/macro/poly/json.lux
index 596d24b18..7cd02657f 100644
--- a/stdlib/source/lux/macro/poly/json.lux
+++ b/stdlib/source/lux/macro/poly/json.lux
@@ -92,11 +92,11 @@
                               <encoder>))))]
 
                [(poly.exactly Any) (function ((~ g!_) (~ (code.symbol ["" "0"]))) #//.Null)]
-               [(poly.similar Bit) (|>> #//.Boolean)]
-               [(poly.similar Nat)  (:: (~! ..Codec<JSON,Nat>) (~' encode))]
-               [(poly.similar Int)  (:: (~! ..Codec<JSON,Int>) (~' encode))]
-               [(poly.similar Frac) (|>> #//.Number)]
-               [(poly.similar Text) (|>> #//.String)])
+               [(poly.sub Bit)     (|>> #//.Boolean)]
+               [(poly.sub Nat)     (:: (~! ..Codec<JSON,Nat>) (~' encode))]
+               [(poly.sub Int)     (:: (~! ..Codec<JSON,Int>) (~' encode))]
+               [(poly.sub Frac)    (|>> #//.Number)]
+               [(poly.sub Text)    (|>> #//.String)])
      <time> (do-template [<type> <codec>]
               [(do @
                  [_ (poly.exactly <type>)]
@@ -208,11 +208,11 @@
                               <decoder>))))]
 
                [(poly.exactly Any)  //.null]
-               [(poly.similar Bit)  //.boolean]
-               [(poly.similar Nat)  (p.codec (~! ..Codec<JSON,Nat>) //.any)]
-               [(poly.similar Int)  (p.codec (~! ..Codec<JSON,Int>) //.any)]
-               [(poly.similar Frac) //.number]
-               [(poly.similar Text) //.string])
+               [(poly.sub Bit)      //.boolean]
+               [(poly.sub Nat)      (p.codec (~! ..Codec<JSON,Nat>) //.any)]
+               [(poly.sub Int)      (p.codec (~! ..Codec<JSON,Int>) //.any)]
+               [(poly.sub Frac)     //.number]
+               [(poly.sub Text)     //.string])
      <time> (do-template [<type> <codec>]
               [(do @
                  [_ (poly.exactly <type>)]