aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2018-07-21 01:16:07 -0400
committerEduardo Julian2018-07-21 01:16:07 -0400
commit76e97634aaab09c89a895a6f6e863d10479821d1 (patch)
treefa7a2aed9ab5f2f4f93db565db4165ac349dbeff
parente550029ac3ca8eecade4705020b9cf24312227f5 (diff)
Refactoring & improvements to "lux/macro/poly".
-rw-r--r--stdlib/source/lux/language/compiler/default/repl/type.lux4
-rw-r--r--stdlib/source/lux/macro/poly.lux91
-rw-r--r--stdlib/source/lux/macro/poly/equivalence.lux12
-rw-r--r--stdlib/source/lux/macro/poly/functor.lux2
-rw-r--r--stdlib/source/lux/macro/poly/json.lux20
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>)]