From e97796bf4fd2217d3b9eaaf0b20a8f1b5f0f6b29 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 4 Sep 2017 20:29:51 -0400
Subject: - Simple types are no longer matched by their names, but by the types
 themselves.

---
 stdlib/source/lux/data/format/json/codec.lux | 16 +++++++-------
 stdlib/source/lux/macro/poly.lux             | 21 +++++++++---------
 stdlib/source/lux/macro/poly/eq.lux          |  8 +++----
 stdlib/source/lux/type/check.lux             | 33 ++++++++++++++--------------
 4 files changed, 39 insertions(+), 39 deletions(-)

diff --git a/stdlib/source/lux/data/format/json/codec.lux b/stdlib/source/lux/data/format/json/codec.lux
index d6d888c0e..6fa1d566c 100644
--- a/stdlib/source/lux/data/format/json/codec.lux
+++ b/stdlib/source/lux/data/format/json/codec.lux
@@ -233,7 +233,7 @@
                [Text poly;text ..;string])
      <time> (do-template [<type> <codec>]
               [(do @
-                 [_ (poly;named (ident-for <type>))]
+                 [_ (poly;this <type>)]
                  (wrap (` (: (~ (@JSON//encode inputT))
                              (|>. (:: <codec> (~' encode)) ..;string)))))]
 
@@ -255,7 +255,7 @@
             [#let [g!key (code;local-symbol "\u0000key")
                    g!val (code;local-symbol "\u0000val")]
              [_ _ .val.] (poly;apply ($_ p;seq
-                                         (poly;named (ident-for d;Dict))
+                                         (poly;this d;Dict)
                                          poly;text
                                          Codec<JSON,?>//encode))]
             (wrap (` (: (~ (@JSON//encode inputT))
@@ -266,13 +266,13 @@
                              #..;Object)))))
           (do @
             [[_ .sub.] (poly;apply ($_ p;seq
-                                       (poly;named (ident-for ;Maybe))
+                                       (poly;this ;Maybe)
                                        Codec<JSON,?>//encode))]
             (wrap (` (: (~ (@JSON//encode inputT))
                         (..;nullable (~ .sub.))))))
           (do @
             [[_ .sub.] (poly;apply ($_ p;seq
-                                       (poly;named (ident-for ;List))
+                                       (poly;this ;List)
                                        Codec<JSON,?>//encode))]
             (wrap (` (: (~ (@JSON//encode inputT))
                         (|>. (;;_map_ (~ .sub.)) vector;from-list ..;array)))))
@@ -340,7 +340,7 @@
                [Text poly;text ../reader;string])
      <time> (do-template [<type> <codec>]
               [(do @
-                 [_ (poly;named (ident-for <type>))]
+                 [_ (poly;this <type>)]
                  (wrap (` (: (~ (@JSON//decode inputT))
                              (p;codec <codec> ../reader;string)))))]
 
@@ -360,18 +360,18 @@
           <time>
           (do @
             [[_ _ valC] (poly;apply ($_ p;seq
-                                        (poly;named (ident-for d;Dict))
+                                        (poly;this d;Dict)
                                         poly;text
                                         Codec<JSON,?>//decode))]
             (wrap (` (: (~ (@JSON//decode inputT))
                         (../reader;object (~ valC))))))
           (do @
-            [[_ subC] (poly;apply (p;seq (poly;named (ident-for ;Maybe))
+            [[_ subC] (poly;apply (p;seq (poly;this ;Maybe)
                                          Codec<JSON,?>//decode))]
             (wrap (` (: (~ (@JSON//decode inputT))
                         (../reader;nullable (~ subC))))))
           (do @
-            [[_ subC] (poly;apply (p;seq (poly;named (ident-for ;List))
+            [[_ subC] (poly;apply (p;seq (poly;this ;List)
                                          Codec<JSON,?>//decode))]
             (wrap (` (: (~ (@JSON//decode inputT))
                         (../reader;array (p;some (~ subC)))))))
diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux
index bc8d5d375..58afcd1a3 100644
--- a/stdlib/source/lux/macro/poly.lux
+++ b/stdlib/source/lux/macro/poly.lux
@@ -20,6 +20,7 @@
                       (common ["csr" reader]
                               ["csw" writer])))
        [type]
+       (type [check])
        ))
 
 (type: #export Env (Dict Nat [Type Code]))
@@ -233,18 +234,16 @@
       (p;fail ($_ text/append "Non-application type: " (type;to-text headT)))
       (local (#;Cons funcT paramsT) poly))))
 
-(def: #export (named expected)
-  (-> Ident (Poly Unit))
+(def: #export (this expected)
+  (-> Type (Poly Unit))
   (do p;Monad<Parser>
-    [headT any]
-    (case (type;un-alias headT)
-      (#;Named actual _)
-      (if (Ident/= expected actual)
-        (wrap [])
-        (p;fail ($_ text/append "Not " (Ident/encode expected) " type: " (type;to-text headT))))
-
-      _
-      (p;fail ($_ text/append "Not a named type: " (type;to-text headT))))))
+    [actual any]
+    (if (check;checks? expected actual)
+      (wrap [])
+      (p;fail ($_ text/append
+                  "Types do not match." "\n"
+                  "Expected: " (type;to-text expected) "\n"
+                  "  Actual: " (type;to-text actual))))))
 
 (def: (adjusted-idx env idx)
   (-> Env Nat Nat)
diff --git a/stdlib/source/lux/macro/poly/eq.lux b/stdlib/source/lux/macro/poly/eq.lux
index 45013ebb8..d5b331642 100644
--- a/stdlib/source/lux/macro/poly/eq.lux
+++ b/stdlib/source/lux/macro/poly/eq.lux
@@ -47,7 +47,7 @@
                [poly;text text;Eq<Text>])
      <time> (do-template [<type> <eq>]
               [(do @
-                 [_ (poly;named (ident-for <type>))]
+                 [_ (poly;this <type>)]
                  (wrap (` (: (~ (@Eq inputT))
                              <eq>))))]
 
@@ -58,7 +58,7 @@
               [da;Month    da;Eq<Month>])
      <composites> (do-template [<name> <eq>]
                     [(do @
-                       [[_ argC] (poly;apply (p;seq (poly;named (ident-for <name>))
+                       [[_ argC] (poly;apply (p;seq (poly;this <name>)
                                                     Eq<?>))]
                        (wrap (` (: (~ (@Eq inputT))
                                    (<eq> (~ argC))))))]
@@ -86,7 +86,7 @@
           <composites>
           (do @
             [[_ _ valC] (poly;apply ($_ p;seq
-                                        (poly;named (ident-for dict;Dict))
+                                        (poly;this dict;Dict)
                                         poly;any
                                         Eq<?>))]
             (wrap (` (: (~ (@Eq inputT))
@@ -94,7 +94,7 @@
           ## Models
           <time>
           (do @
-            [_ (poly;apply (p;seq (poly;named (ident-for unit;Qty))
+            [_ (poly;apply (p;seq (poly;this unit;Qty)
                                   poly;any))]
             (wrap (` (: (~ (@Eq inputT))
                         unit;Eq<Qty>))))
diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux
index 0e77e6633..7d1bd0462 100644
--- a/stdlib/source/lux/type/check.lux
+++ b/stdlib/source/lux/type/check.lux
@@ -5,8 +5,8 @@
   (lux (control functor
                 applicative
                 ["M" monad #+ do Monad])
-       (data [text "Text/" Monoid<Text> Eq<Text>]
-             text/format
+       (data [text "text/" Monoid<Text> Eq<Text>]
+             [number "nat/" Codec<Text,Nat>]
              maybe
              [product]
              (coll [list])
@@ -134,7 +134,7 @@
   (function [context]
     (case (type;apply (list t-arg) t-func)
       #;None
-      (#R;Error (format "Invalid type application: " (%type t-func) " on " (%type t-arg)))
+      (#R;Error ($_ text/append "Invalid type application: " (type;to-text t-func) " on " (type;to-text t-arg)))
 
       (#;Some output)
       (#R;Success [context output]))))
@@ -158,7 +158,7 @@
       (#R;Success [context false])
       
       #;None
-      (#R;Error (format "Unknown type-var: " (%n id))))))
+      (#R;Error ($_ text/append "Unknown type-var: " (nat/encode id))))))
 
 (def: #export (read-var id)
   (-> Nat (Check Type))
@@ -168,24 +168,24 @@
       (#R;Success [context type])
 
       (#;Some #;None)
-      (#R;Error (format "Unbound type-var: " (%n id)))
+      (#R;Error ($_ text/append "Unbound type-var: " (nat/encode id)))
       
       #;None
-      (#R;Error (format "Unknown type-var: " (%n id))))))
+      (#R;Error ($_ text/append "Unknown type-var: " (nat/encode id))))))
 
 (def: #export (write-var id type)
   (-> Nat Type (Check Unit))
   (function [context]
     (case (|> context (get@ #;var-bindings) (var::get id))
       (#;Some (#;Some bound))
-      (#R;Error (format "Cannot rebind type-var: " (%n id) " | Current type: " (%type bound)))
+      (#R;Error ($_ text/append "Cannot rebind type-var: " (nat/encode id) " | Current type: " (type;to-text bound)))
       
       (#;Some #;None)
       (#R;Success [(update@ #;var-bindings (var::put id (#;Some type)) context)
                    []])
 
       #;None
-      (#R;Error (format "Unknown type-var: " (%n id))))))
+      (#R;Error ($_ text/append "Unknown type-var: " (nat/encode id))))))
 
 (def: (rewrite-var id type)
   (-> Nat Type (Check Unit))
@@ -196,7 +196,7 @@
                    []])
       
       #;None
-      (#R;Error (format "Unknown type-var: " (%n id))))))
+      (#R;Error ($_ text/append "Unknown type-var: " (nat/encode id))))))
 
 (def: #export (clear-var id)
   (-> Nat (Check Unit))
@@ -207,7 +207,7 @@
                    []])
       
       #;None
-      (#R;Error (format "Unknown type-var: " (%n id))))))
+      (#R;Error ($_ text/append "Unknown type-var: " (nat/encode id))))))
 
 (def: #export (clean t-id type)
   (-> Nat Type (Check Type))
@@ -329,8 +329,9 @@
 
 (def: (fail-check expected actual)
   (All [a] (-> Type Type (Check a)))
-  (fail (format "Expected: " (%type expected) "\n\n"
-                "Actual:   " (%type actual))))
+  (fail ($_ text/append
+            "Expected: " (type;to-text expected) "\n\n"
+            "Actual:   " (type;to-text actual))))
 
 (def: (either left right)
   (All [a] (-> (Check a) (Check a) (Check a)))
@@ -476,14 +477,14 @@
         (check' expected actual' assumptions))
 
       [(#;Host e-name e-params) (#;Host a-name a-params)]
-      (if (and (Text/= e-name a-name)
+      (if (and (text/= e-name a-name)
                (n.= (list;size e-params)
                     (list;size a-params)))
         (do Monad<Check>
           [assumptions (M;fold Monad<Check>
-                         (function [[e a] assumptions] (check' e a assumptions))
-                         assumptions
-                         (list;zip2 e-params a-params))]
+                               (function [[e a] assumptions] (check' e a assumptions))
+                               assumptions
+                               (list;zip2 e-params a-params))]
           (Check/wrap assumptions))
         (fail-check expected actual))
 
-- 
cgit v1.2.3