From 76e97634aaab09c89a895a6f6e863d10479821d1 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 21 Jul 2018 01:16:07 -0400 Subject: Refactoring & improvements to "lux/macro/poly". --- .../lux/language/compiler/default/repl/type.lux | 4 +- stdlib/source/lux/macro/poly.lux | 91 +++++++++++++--------- stdlib/source/lux/macro/poly/equivalence.lux | 12 +-- stdlib/source/lux/macro/poly/functor.lux | 2 +- stdlib/source/lux/macro/poly/json.lux | 20 ++--- 5 files changed, 75 insertions(+), 54 deletions(-) (limited to 'stdlib') 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 [ ] [(do p.Monad - [_ (poly.similar )] + [_ (poly.sub )] (wrap (|>> (:coerce ) )))] [Bit %b] @@ -53,7 +53,7 @@ (`` ($_ p.either (~~ (do-template [ ] [(do p.Monad - [_ (poly.similar )] + [_ (poly.sub )] (wrap (|>> (:coerce ) )))] [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 Codec)] + [ident ("ident/." Codec)] ["e" error] ["." number ("nat/." Codec)] - ["." text ("text/." Monoid)] + ["." text ("text/." Monoid) + format] [collection ["." list ("list/." Fold Monad Monoid)] ["dict" dictionary (#+ Dictionary)]]] @@ -28,6 +29,36 @@ ["." type ("type/." Equivalence) ["." check]]]) +(do-template [] + [(exception: #export ( {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 [] + [(exception: #export ( {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 [ ] +(do-template [ ] [(def: #export ( poly) (All [a] (-> (Poly a) (Poly a))) (do p.Monad @@ -127,10 +155,10 @@ (let [members ( (type.un-name headT))] (if (n/> +1 (list.size members)) (local members poly) - (p.fail ($_ text/compose "Not a " (ident/encode (ident-for )) " type: " (type.to-text headT)))))))] + (p.fail (ex.construct 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 [ ] @@ -205,13 +233,11 @@ [actual any] (if ( 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 [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 [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 @@ ))))] [(poly.exactly Any) (function ((~ g!_) (~ g!_) (~ g!_)) #1)] - [(poly.similar Bit) bit.Equivalence] - [(poly.similar Nat) number.Equivalence] - [(poly.similar Int) number.Equivalence] - [(poly.similar Rev) number.Equivalence] - [(poly.similar Frac) number.Equivalence] - [(poly.similar Text) text.Equivalence])) + [(poly.sub Bit) bit.Equivalence] + [(poly.sub Nat) number.Equivalence] + [(poly.sub Int) number.Equivalence] + [(poly.sub Rev) number.Equivalence] + [(poly.sub Frac) number.Equivalence] + [(poly.sub Text) text.Equivalence])) ## Composite types (~~ (do-template [ ] [(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 [#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 @@ ))))] [(poly.exactly Any) (function ((~ g!_) (~ (code.symbol ["" "0"]))) #//.Null)] - [(poly.similar Bit) (|>> #//.Boolean)] - [(poly.similar Nat) (:: (~! ..Codec) (~' encode))] - [(poly.similar Int) (:: (~! ..Codec) (~' encode))] - [(poly.similar Frac) (|>> #//.Number)] - [(poly.similar Text) (|>> #//.String)]) + [(poly.sub Bit) (|>> #//.Boolean)] + [(poly.sub Nat) (:: (~! ..Codec) (~' encode))] + [(poly.sub Int) (:: (~! ..Codec) (~' encode))] + [(poly.sub Frac) (|>> #//.Number)] + [(poly.sub Text) (|>> #//.String)])