diff options
| -rw-r--r-- | stdlib/source/lux/language/compiler/default/repl/type.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly.lux | 91 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly/equivalence.lux | 12 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly/functor.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly/json.lux | 20 |
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>)] |