aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2017-09-04 20:29:51 -0400
committerEduardo Julian2017-09-04 20:29:51 -0400
commite97796bf4fd2217d3b9eaaf0b20a8f1b5f0f6b29 (patch)
tree6e38770631ca33221a52f3b7821f42e9a105377c
parent4808ec4dd27afc06fb949166ce2ba7c52657feff (diff)
- Simple types are no longer matched by their names, but by the types themselves.
-rw-r--r--stdlib/source/lux/data/format/json/codec.lux16
-rw-r--r--stdlib/source/lux/macro/poly.lux21
-rw-r--r--stdlib/source/lux/macro/poly/eq.lux8
-rw-r--r--stdlib/source/lux/type/check.lux33
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))