diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/data/format/json/codec.lux | 16 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly.lux | 21 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly/eq.lux | 8 | ||||
| -rw-r--r-- | 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)) |