aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--stdlib/source/lux/compiler.lux4
-rw-r--r--stdlib/source/lux/data/format/json.lux51
-rw-r--r--stdlib/source/lux/macro/poly.lux93
-rw-r--r--stdlib/source/lux/macro/poly/eq.lux24
-rw-r--r--stdlib/source/lux/macro/poly/functor.lux52
-rw-r--r--stdlib/source/lux/macro/poly/text-encoder.lux85
-rw-r--r--stdlib/test/test/lux/macro/poly/eq.lux66
-rw-r--r--stdlib/test/test/lux/macro/poly/functor.lux44
-rw-r--r--stdlib/test/test/lux/macro/poly/text-encoder.lux63
-rw-r--r--stdlib/test/tests.lux13
10 files changed, 376 insertions, 119 deletions
diff --git a/stdlib/source/lux/compiler.lux b/stdlib/source/lux/compiler.lux
index fd438b1a3..437389717 100644
--- a/stdlib/source/lux/compiler.lux
+++ b/stdlib/source/lux/compiler.lux
@@ -98,8 +98,8 @@
(#;Right [compiler' output])
(#;Right [compiler' output]))))
-(def: #export (assert test message)
- (-> Bool Text (Lux Unit))
+(def: #export (assert message test)
+ (-> Text Bool (Lux Unit))
(lambda [compiler]
(if test
(#;Right [compiler []])
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
index e8189a594..1b2c65f97 100644
--- a/stdlib/source/lux/data/format/json.lux
+++ b/stdlib/source/lux/data/format/json.lux
@@ -744,7 +744,10 @@
_
(compiler;fail ""))
- #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ #let [new-*env* (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices)
+ g!vars)
+ *env*)]
.val. (Codec<JSON,?>//encode new-*env* :val:)
#let [:x:+ (case g!vars
#;Nil
@@ -777,8 +780,10 @@
(|>. (_map_ (~ .sub.)) vector;from-list ;;gen-array)))))
(with-gensyms [g!type-fun g!case g!input]
(do @
- [[g!vars cases] (poly;variant :x:)
- #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ [[g!vars members] (poly;variant :x:)
+ #let [new-*env* (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
+ *env*)]
pattern-matching (mapM @
(lambda [[name :case:]]
(do @
@@ -787,7 +792,7 @@
(wrap (list (` ((~ tag) (~ g!case)))
(` (;;json [(~ (ast;text (product;right name)))
((~ encoder) (~ g!case))]))))))
- cases)
+ members)
#let [:x:+ (case g!vars
#;Nil
(->Codec//encode (type;to-ast :x:))
@@ -803,15 +808,17 @@
)))))
(with-gensyms [g!type-fun g!case g!input]
(do @
- [[g!vars slots] (poly;record :x:)
- #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ [[g!vars members] (poly;record :x:)
+ #let [new-*env* (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
+ *env*)]
synthesis (mapM @
(lambda [[name :slot:]]
(do @
[encoder (Codec<JSON,?>//encode new-*env* :slot:)]
(wrap [(` (~ (ast;text (product;right name))))
(` ((~ encoder) (get@ (~ (ast;tag name)) (~ g!input))))])))
- slots)
+ members)
#let [:x:+ (case g!vars
#;Nil
(->Codec//encode (type;to-ast :x:))
@@ -827,7 +834,9 @@
(with-gensyms [g!type-fun g!case]
(do @
[[g!vars members] (poly;tuple :x:)
- #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ #let [new-*env* (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
+ *env*)]
pattern-matching (mapM @
(lambda [:member:]
(do @
@@ -895,7 +904,9 @@
_
(compiler;fail ""))
- #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ #let [new-*env* (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
+ *env*)]
.val. (Codec<JSON,?>//decode new-*env* :val:)
#let [:x:+ (case g!vars
#;Nil
@@ -921,8 +932,10 @@
<complex>
(with-gensyms [g!type-fun g!_]
(do @
- [[g!vars cases] (poly;variant :x:)
- #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ [[g!vars members] (poly;variant :x:)
+ #let [new-*env* (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
+ *env*)]
pattern-matching (mapM @
(lambda [[name :case:]]
(do @
@@ -932,7 +945,7 @@
[(~ g!_) (;;at +0 (;;text! (~ (ast;text (product;right name)))))
(~ g!_) (;;at +1 (~ decoder))]
((~ (' wrap)) ((~ tag) (~ g!_)))))))))
- cases)
+ members)
#let [:x:+ (case g!vars
#;Nil
(->Codec//decode (type;to-ast :x:))
@@ -953,8 +966,10 @@
))
(with-gensyms [g!type-fun g!case g!input]
(do @
- [[g!vars slots] (poly;record :x:)
- #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ [[g!vars members] (poly;record :x:)
+ #let [new-*env* (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
+ *env*)]
extraction (mapM @
(lambda [[name :slot:]]
(do @
@@ -964,7 +979,7 @@
(` (;;get (~ (ast;text (product;right name))) (~ g!input)))
g!member
(` ((~ decoder) (~ g!member)))))))
- slots)
+ members)
#let [:x:+ (case g!vars
#;Nil
(->Codec//decode (type;to-ast :x:))
@@ -979,12 +994,14 @@
[(~@ (List/join extraction))]
((~ (' wrap)) (~ (ast;record (List/map (lambda [[name :slot:]]
[(ast;tag name) (ast;symbol ["" (product;right name)])])
- slots))))))
+ members))))))
)))))
(with-gensyms [g!type-fun g!case g!input]
(do @
[[g!vars members] (poly;tuple :x:)
- #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ #let [new-*env* (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
+ *env*)]
pattern-matching (mapM @
(lambda [:member:]
(do @
diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux
index 0cf0e64f1..ea2d722ae 100644
--- a/stdlib/source/lux/macro/poly.lux
+++ b/stdlib/source/lux/macro/poly.lux
@@ -27,7 +27,7 @@
(type: #export (Matcher a)
(-> Type (Lux a)))
-(type: #export Env (Dict Nat AST))
+(type: #export Env (Dict Nat [Type AST]))
## [Combinators]
(do-template [<combinator> <name> <type>]
@@ -73,6 +73,8 @@
[_ (<parser> :type:)]
(wrap <type>))]
+ [void Void]
+ [unit Unit]
[bool Bool]
[nat Nat]
[int Int]
@@ -160,7 +162,8 @@
(lambda [:type:]
(do compiler;Monad<Lux>
[[tags :type:] (tagged :type:)
- _ (compiler;assert (n.> +0 (list;size tags)) "Records and variants must have tags.")
+ _ (compiler;assert "Records and variants must have tags."
+ (n.> +0 (list;size tags)))
[vars :type:] (polymorphic :type:)
members (<sub-comb> :type:)
#let [num-tags (list;size tags)
@@ -239,8 +242,8 @@
(case :type:
(#;BoundT idx)
(case (dict;get (adjusted-idx env idx) env)
- (#;Some poly-val)
- (:: compiler;Monad<Lux> wrap poly-val)
+ (#;Some [poly-type poly-ast])
+ (:: compiler;Monad<Lux> wrap poly-ast)
#;None
(compiler;fail (format "Unknown bound type: " (%type :type:))))
@@ -266,7 +269,7 @@
_
#;None))
t-args)]
- (wrap (` ((~ =func) (~@ =args)))))
+ (wrap (` ((~ (product;right =func)) (~@ (List/map product;right =args))))))
(#;Some call)])
(wrap call)
@@ -274,19 +277,32 @@
(compiler;fail (format "Type is not a recursive instance: " (%type :type:))))
)))
+(def: #export (var env var-id)
+ (-> Env Nat (Matcher Unit))
+ (lambda [:type:]
+ (case :type:
+ (^=> (#;BoundT idx)
+ (exec (log! (format "poly;var " (%n idx) " => " (%n (adjusted-idx env idx))))
+ (n.= var-id (adjusted-idx env idx))))
+ (:: compiler;Monad<Lux> wrap [])
+
+ _
+ (compiler;fail (format "Not a bound type: " (%type :type:))))))
+
## [Syntax]
-(def: #export (extend-env type-func type-vars env)
- (-> AST (List AST) Env Env)
+(def: #export (extend-env [funcT funcA] type-vars env)
+ (-> [Type AST] (List [Type AST]) Env Env)
(case type-vars
#;Nil
env
- (#;Cons tvar type-vars')
+ (#;Cons [varT varA] type-vars')
(let [current-size (dict;size env)]
(|> env
- (dict;put current-size type-func)
- (dict;put (n.inc current-size) tvar)
- (extend-env (` (#;AppT (~ type-func) (~ tvar))) type-vars')
+ (dict;put current-size [funcT funcA])
+ (dict;put (n.inc current-size) [varT varA])
+ (extend-env [(#;AppT funcT varT) (` (#;AppT (~ funcA) (~ varA)))]
+ type-vars')
))))
(syntax: #export (poly: [_ex-lev common;export-level]
@@ -351,35 +367,54 @@
(~ impl)))))))
## [Derivers]
-(def: #export (contains-bound-types? type)
- (-> Type Bool)
+(def: (to-ast env type)
+ (-> Env Type AST)
(case type
(#;HostT name params)
- (list;any? contains-bound-types? params)
+ (` (#;HostT (~ (ast;text name))
+ (list (~@ (List/map (to-ast env) params)))))
(^template [<tag>]
- (<tag> _)
- false)
- ([#;VoidT] [#;UnitT]
- [#;VarT] [#;ExT]
- [#;UnivQ] [#;ExQ])
+ <tag>
+ (` <tag>))
+ ([#;VoidT] [#;UnitT])
+
+ (^template [<tag>]
+ (<tag> idx)
+ (` (<tag> (~ (ast;nat idx)))))
+ ([#;VarT] [#;ExT])
(#;BoundT idx)
- true
+ (let [idx (adjusted-idx env idx)]
+ (if (n.= +0 idx)
+ (|> (dict;get idx env) (default (undefined)) product;left (to-ast env))
+ (` (;$ (~ (ast;nat (n.dec idx)))))))
(^template [<tag>]
(<tag> left right)
- (or (contains-bound-types? left)
- (contains-bound-types? right)))
- ([#;LambdaT] [#;AppT] [#;SumT] [#;ProdT])
+ (` (<tag> (~ (to-ast env left))
+ (~ (to-ast env right)))))
+ ([#;LambdaT] [#;AppT])
+
+ (^template [<tag> <macro> <flattener>]
+ (<tag> left right)
+ (` (<macro> (~@ (List/map (to-ast env) (<flattener> type))))))
+ ([#;SumT | type;flatten-variant]
+ [#;ProdT & type;flatten-tuple])
(#;NamedT name sub-type)
- (contains-bound-types? sub-type)
+ (ast;symbol name)
+
+ (^template [<tag>]
+ (<tag> scope body)
+ (` (<tag> (list (~@ (List/map (to-ast env) scope)))
+ (~ (to-ast env body)))))
+ ([#;UnivQ] [#;ExQ])
))
-(def: #export (gen-type converter type-fun tvars type)
- (-> (-> AST AST) AST (List AST) Type AST)
- (let [type' (type;to-ast type)]
+(def: #export (gen-type env converter type-fun tvars type)
+ (-> Env (-> AST AST) AST (List AST) Type AST)
+ (let [type' (to-ast env type)]
(case tvars
#;Nil
(converter type')
@@ -388,3 +423,7 @@
(` (All (~ type-fun) [(~@ tvars)]
(-> (~@ (List/map converter tvars))
(~ (converter (` ((~ type') (~@ tvars)))))))))))
+
+(def: #export (type-var-indices num-vars)
+ (-> Nat (List Type))
+ (|> num-vars list;indices (List/map (|>. #;BoundT))))
diff --git a/stdlib/source/lux/macro/poly/eq.lux b/stdlib/source/lux/macro/poly/eq.lux
index ce42c2eab..dc37e0c9f 100644
--- a/stdlib/source/lux/macro/poly/eq.lux
+++ b/stdlib/source/lux/macro/poly/eq.lux
@@ -60,8 +60,10 @@
## Variants
(with-gensyms [g!type-fun g!left g!right]
(do @
- [[g!vars cases] (poly;variant :x:)
- #let [new-env (poly;extend-env g!type-fun g!vars env)]
+ [[g!vars members] (poly;variant :x:)
+ #let [new-env (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
+ env)]
pattern-matching (mapM @
(lambda [[name :case:]]
(do @
@@ -69,20 +71,20 @@
(wrap (list (` [((~ (ast;tag name)) (~ g!left))
((~ (ast;tag name)) (~ g!right))])
(` ((~ g!eq) (~ g!left) (~ g!right)))))))
- cases)
+ members)
#let [base (function$ g!type-fun g!vars
(` (lambda [(~ g!left) (~ g!right)]
(case [(~ g!left) (~ g!right)]
(~@ (List/join pattern-matching))))))]]
- (wrap (if (and false (poly;contains-bound-types? :x:))
- base
- (` (: (~ (poly;gen-type ->Eq g!type-fun g!vars :x:))
- (~ base)))))))
+ (wrap (` (: (~ (poly;gen-type new-env ->Eq g!type-fun g!vars :x:))
+ (~ base))))))
## Tuples
(with-gensyms [g!type-fun]
(do @
[[g!vars members] (poly;tuple :x:)
- #let [new-env (poly;extend-env g!type-fun g!vars env)]
+ #let [new-env (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
+ env)]
pattern-matching (mapM @
(lambda [:member:]
(do @
@@ -98,10 +100,8 @@
(and (~@ (List/map (lambda [[g!left g!right g!eq]]
(` ((~ g!eq) (~ g!left) (~ g!right))))
pattern-matching))))))]]
- (wrap (if (and false (poly;contains-bound-types? :x:))
- base
- (` (: (~ (poly;gen-type ->Eq g!type-fun g!vars :x:))
- (~ base)))))))
+ (wrap (` (: (~ (poly;gen-type new-env ->Eq g!type-fun g!vars :x:))
+ (~ base))))))
## Type recursion
(poly;recur env :x:)
## Type applications
diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux
index 17fd7808f..e659bb41d 100644
--- a/stdlib/source/lux/macro/poly/functor.lux
+++ b/stdlib/source/lux/macro/poly/functor.lux
@@ -27,19 +27,25 @@
))
## [Derivers]
-(poly: #export (|Functor| env :x:)
+(poly: #export (Functor<?> env :x:)
(with-gensyms [g!type-fun g!func g!input]
(do @
[#let [g!map (' map)]
[g!vars _] (poly;polymorphic :x:)
#let [num-vars (list;size g!vars)
- new-env (poly;extend-env g!type-fun g!vars env)]
- _ (compiler;assert (n.> +0 num-vars)
- "Functors must have at least 1 type-variable.")]
+ new-env (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
+ env)]
+ _ (compiler;assert "Functors must have at least 1 type-variable."
+ (n.> +0 num-vars))]
(let [->Functor (: (-> AST AST)
- (lambda [.type.] (` (functor;Functor (~ .type.)))))
- |elem| (: (-> AST (poly;Matcher AST))
- (lambda |elem| [value :type:]
+ (lambda [.type.]
+ (if (n.= +1 num-vars)
+ (` (functor;Functor (~ .type.)))
+ (let [type-params (|> num-vars n.dec list;indices (List/map (|>. %n ast;local-symbol)))]
+ (` (All [(~@ type-params)] (functor;Functor ((~ .type.) (~@ type-params)))))))))
+ Arg<?> (: (-> AST (poly;Matcher AST))
+ (lambda Arg<?> [value :type:]
($_ compiler;either
## Nothing to do.
(do @
@@ -47,19 +53,23 @@
(wrap value))
## Type-var
(do @
- [_ (poly;var new-env (n.dec num-vars) :type:)]
+ [_ (poly;var new-env (|> num-vars (n.* +2) n.dec) :type:)]
(wrap (` ((~ g!func) (~ value)))))
+ ## Bound type-variables
+ (do @
+ [_ (poly;bound new-env :type:)]
+ (wrap value))
## Tuples/records
(do @
- [[g!vars members] (poly;tuple :x:)
+ [[g!vars members] (poly;tuple :type:)
pm (mapM @
(lambda [:slot:]
(do @
[g!slot (compiler;gensym "g!slot")
- body (|elem| g!slot :slot:)]
+ body (Arg<?> g!slot :slot:)]
(wrap [g!slot body])))
members)]
- (wrap (` (case (~ g!input)
+ (wrap (` (case (~ value)
[(~@ (List/map product;left pm))]
[(~@ (List/map product;right pm))])
)))
@@ -76,9 +86,9 @@
(lambda [[name :case:]]
(do @
[#let [analysis (` ((~ (ast;tag name)) (~ g!input)))]
- synthesis (|elem| g!input :case:)]
+ synthesis (Arg<?> g!input :case:)]
(wrap (list analysis
- synthesis))))
+ (` ((~ (ast;tag name)) (~ synthesis)))))))
cases)]
(wrap (` (: (~ (->Functor (type;to-ast :x:)))
(struct (def: ((~ g!map) (~ g!func) (~ g!input))
@@ -92,7 +102,7 @@
(lambda [:slot:]
(do @
[g!slot (compiler;gensym "g!slot")
- body (|elem| g!slot :slot:)]
+ body (Arg<?> g!slot :slot:)]
(wrap [g!slot body])))
members)]
(wrap (` (: (~ (->Functor (type;to-ast :x:)))
@@ -105,18 +115,18 @@
(with-gensyms [g!out]
(do @
[[g!vars [:ins: :out:]] (poly;function :x:)
- .out. (|elem| g!out :out:)
- g!ins (seqM @
- (list;repeat (list;size :ins:)
- (compiler;gensym "g!arg")))]
+ .out. (Arg<?> g!out :out:)
+ g!envs (seqM @
+ (list;repeat (list;size :ins:)
+ (compiler;gensym "g!envs")))]
(wrap (` (: (~ (->Functor (type;to-ast :x:)))
(struct (def: ((~ g!map) (~ g!func) (~ g!input))
- (lambda [(~@ g!ins)]
- (let [(~ g!out) ((~ g!input) (~@ g!ins))]
+ (lambda [(~@ g!envs)]
+ (let [(~ g!out) ((~ g!input) (~@ g!envs))]
(~ .out.))))))))))
## No structure (as you'd expect from Identity)
(do @
- [_ (poly;var new-env (n.dec num-vars) :x:)]
+ [_ (poly;var new-env num-vars :x:)]
(wrap (` (: (~ (->Functor (type;to-ast :x:)))
(struct (def: ((~ g!map) (~ g!func) (~ g!input))
((~ g!func) (~ g!input))))))))
diff --git a/stdlib/source/lux/macro/poly/text-encoder.lux b/stdlib/source/lux/macro/poly/text-encoder.lux
index c2ab30d7f..858abc208 100644
--- a/stdlib/source/lux/macro/poly/text-encoder.lux
+++ b/stdlib/source/lux/macro/poly/text-encoder.lux
@@ -26,14 +26,25 @@
[type]
))
+(def: (function$ func inputs output)
+ (-> AST (List AST) AST AST)
+ (case inputs
+ #;Nil
+ output
+
+ _
+ (` (lambda (~@ (if (list;empty? inputs) (list) (list func)))
+ [(~@ inputs)]
+ (~ output)))))
+
## [Derivers]
-(poly: #export (|Codec@Text//encode| env :x:)
- (let [->Codec//encode (: (-> AST AST)
+(poly: #export (Codec<Text,?>::encode env :x:)
+ (let [->Codec::encode (: (-> AST AST)
(lambda [.type.] (` (-> (~ .type.) Text))))]
(let% [<basic> (do-template [<type> <matcher> <encoder>]
[(do @
[_ (<matcher> :x:)]
- (wrap (` (: (~ (->Codec//encode (` <type>)))
+ (wrap (` (: (~ (->Codec::encode (` <type>)))
(~' <encoder>)))))]
[Unit poly;unit (lambda [_0] "[]")]
@@ -51,73 +62,83 @@
(with-gensyms [g!type-fun g!case g!input]
(do @
[[g!vars cases] (poly;variant :x:)
- #let [new-env (poly;extend-env g!type-fun g!vars env)]
+ #let [new-env (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
+ env)]
pattern-matching (mapM @
(lambda [[name :case:]]
(do @
- [encoder (|Codec@Text//encode| new-env :case:)]
+ [encoder (Codec<Text,?>::encode new-env :case:)]
(wrap (list (` ((~ (ast;tag name)) (~ g!case)))
(` (format "(#"
(~ (ast;text (Ident/encode name)))
" "
((~ encoder) (~ g!case))
")"))))))
- cases)]
- (wrap (` (: (~ (poly;gen-type ->Codec//encode g!type-fun g!vars :x:))
- (lambda [(~@ g!vars)]
- (lambda [(~ g!input)]
- (case (~ g!input)
- (~@ (List/join pattern-matching)))))
+ cases)
+ #let [base (function$ g!type-fun g!vars
+ (` (lambda [(~ g!input)]
+ (case (~ g!input)
+ (~@ (List/join pattern-matching))))))]]
+ (wrap (` (: (~ (poly;gen-type env ->Codec::encode g!type-fun g!vars :x:))
+ (~ base)
)))))
## Records
(with-gensyms [g!type-fun g!case g!input]
(do @
[[g!vars slots] (poly;record :x:)
- #let [new-env (poly;extend-env g!type-fun g!vars env)]
+ #let [new-env (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
+ env)]
synthesis (mapM @
(lambda [[name :slot:]]
(do @
- [encoder (|Codec@Text//encode| new-env :slot:)]
+ [encoder (Codec<Text,?>::encode new-env :slot:)]
(wrap (` (format "#"
(~ (ast;text (Ident/encode name)))
" "
((~ encoder) (get@ (~ (ast;tag name)) (~ g!input))))))))
- slots)]
- (wrap (` (: (~ (poly;gen-type ->Codec//encode g!type-fun g!vars :x:))
- (lambda [(~@ g!vars)]
- (lambda [(~ g!input)]
- (format "{" (~@ (list;interpose (' " ") synthesis)) "}")))
+ slots)
+ #let [base (function$ g!type-fun g!vars
+ (` (lambda [(~ g!input)]
+ (format "{" (~@ (list;interpose (' " ") synthesis)) "}"))))]]
+ (wrap (` (: (~ (poly;gen-type env ->Codec::encode g!type-fun g!vars :x:))
+ (~ base)
)))))
## Tuples
(with-gensyms [g!type-fun g!case g!input]
(do @
[[g!vars members] (poly;tuple :x:)
- #let [new-env (poly;extend-env g!type-fun g!vars env)]
+ #let [new-env (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
+ env)]
parts (mapM @
(lambda [:member:]
(do @
[g!member (compiler;gensym "g!member")
- encoder (|Codec@Text//encode| new-env :member:)]
+ encoder (Codec<Text,?>::encode new-env :member:)]
(wrap [g!member encoder])))
members)
#let [analysis (` [(~@ (List/map product;left parts))])
synthesis (List/map (lambda [[g!member g!encoder]]
(` ((~ g!encoder) (~ g!member))))
- parts)]]
- (wrap (` (: (~ (poly;gen-type ->Codec//encode g!type-fun g!vars :x:))
- (lambda [(~@ g!vars)]
- (lambda [(~ g!input)]
- (case (~ g!input)
- (~ analysis)
- (format "[" (~@ (list;interpose (' " ") synthesis)) "]"))))
- )))
- ))
+ parts)
+ base (function$ g!type-fun g!vars
+ (` (lambda [(~ g!input)]
+ (case (~ g!input)
+ (~ analysis)
+ (format "[" (~@ (list;interpose (' " ") synthesis)) "]")))))]]
+ (wrap (` (: (~ (poly;gen-type env ->Codec::encode g!type-fun g!vars :x:))
+ (~ base)
+ )))))
+ ## Type recursion
+ (poly;recur env :x:)
## Type applications
(do @
[[:func: :args:] (poly;apply :x:)
- .func. (|Codec@Text//encode| env :func:)
- .args. (mapM @ (|Codec@Text//encode| env) :args:)]
- (wrap (` (: (~ (->Codec//encode (type;to-ast :x:)))
+ .func. (Codec<Text,?>::encode env :func:)
+ .args. (mapM @ (Codec<Text,?>::encode env) :args:)]
+ (wrap (` (: (~ (->Codec::encode (type;to-ast :x:)))
((~ .func.) (~@ .args.))))))
## Bound type-variables
(poly;bound env :x:)
diff --git a/stdlib/test/test/lux/macro/poly/eq.lux b/stdlib/test/test/lux/macro/poly/eq.lux
new file mode 100644
index 000000000..983d2da69
--- /dev/null
+++ b/stdlib/test/test/lux/macro/poly/eq.lux
@@ -0,0 +1,66 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad
+ eq)
+ (data text/format
+ [bool]
+ [number "i/" Number<Int>]
+ [char]
+ [text])
+ (math ["R" random])
+ pipe
+ [macro]
+ (macro [poly #+ derived:]
+ ["&" poly/eq]))
+ lux/test)
+
+## [Utils]
+(type: Variant
+ (#Case0 Bool)
+ (#Case1 Int)
+ (#Case2 Real))
+
+(type: Record
+ {#unit Unit
+ #bool Bool
+ #int Int
+ #real Real
+ #char Char
+ #text Text
+ #maybe (Maybe Int)
+ #list (List Int)
+ #variant Variant
+ #tuple [Int Real Char]})
+
+(def: gen-record
+ (R;Random Record)
+ (do R;Monad<Random>
+ [size (:: @ map (n.% +2) R;nat)
+ #let [gen-int (|> R;int (:: @ map (|>. i/abs (i.% 1_000_000))))]]
+ ($_ R;seq
+ (:: @ wrap [])
+ R;bool
+ gen-int
+ R;real
+ R;char
+ (R;text size)
+ (R;maybe gen-int)
+ (R;list size gen-int)
+ ($_ R;alt R;bool gen-int R;real)
+ ($_ R;seq gen-int R;real R;char)
+ )))
+
+(derived: (&;Eq<?> Record))
+
+## [Tests]
+(test: "Eq polytypism"
+ [sample gen-record
+ #let [(^open "&/") Eq<Record>]]
+ (assert "Every instance equals itself."
+ (&/= sample sample)))
diff --git a/stdlib/test/test/lux/macro/poly/functor.lux b/stdlib/test/test/lux/macro/poly/functor.lux
new file mode 100644
index 000000000..c25f536e9
--- /dev/null
+++ b/stdlib/test/test/lux/macro/poly/functor.lux
@@ -0,0 +1,44 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad
+ [functor]
+ eq)
+ (data text/format
+ [bool]
+ [number "i/" Number<Int>]
+ [char]
+ [text])
+ (math ["R" random])
+ pipe
+ [macro]
+ (macro [poly #+ derived:]
+ ["&" poly/functor]))
+ lux/test)
+
+## [Utils]
+(type: (My-Maybe a)
+ #My-None
+ (#My-Some a))
+
+(type: (My-List a)
+ #My-Nil
+ (#My-Cons [a (My-List a)]))
+
+(type: (My-State s a)
+ (-> s [s a]))
+
+(derived: (&;Functor<?> My-Maybe))
+
+(derived: (&;Functor<?> My-List))
+
+(derived: (&;Functor<?> My-State))
+
+## [Tests]
+(test: "Functor polytypism"
+ (assert "" true))
diff --git a/stdlib/test/test/lux/macro/poly/text-encoder.lux b/stdlib/test/test/lux/macro/poly/text-encoder.lux
new file mode 100644
index 000000000..e106162a3
--- /dev/null
+++ b/stdlib/test/test/lux/macro/poly/text-encoder.lux
@@ -0,0 +1,63 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+ lux
+ (lux (codata [io])
+ (control monad
+ eq)
+ (data text/format
+ [bool]
+ [number "i/" Number<Int>]
+ [char]
+ [text])
+ (math ["R" random])
+ pipe
+ [macro]
+ (macro [poly #+ derived:]
+ ["&" poly/text-encoder]))
+ lux/test)
+
+## [Utils]
+(type: Variant
+ (#Case0 Bool)
+ (#Case1 Int)
+ (#Case2 Real))
+
+(type: Record
+ {#unit Unit
+ #bool Bool
+ #int Int
+ #real Real
+ #char Char
+ #text Text
+ #maybe (Maybe Int)
+ #list (List Int)
+ #variant Variant
+ #tuple [Int Real Char]})
+
+(def: gen-record
+ (R;Random Record)
+ (do R;Monad<Random>
+ [size (:: @ map (n.% +2) R;nat)
+ #let [gen-int (|> R;int (:: @ map (|>. i/abs (i.% 1_000_000))))]]
+ ($_ R;seq
+ (:: @ wrap [])
+ R;bool
+ gen-int
+ R;real
+ R;char
+ (R;text size)
+ (R;maybe gen-int)
+ (R;list size gen-int)
+ ($_ R;alt R;bool gen-int R;real)
+ ($_ R;seq gen-int R;real R;char)
+ )))
+
+(derived: (&;Codec<Text,?>::encode Record))
+
+## [Tests]
+(test: "Text-encoding polytypism"
+ (assert "" true))
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
index 85cce3d9f..ebb6c6999 100644
--- a/stdlib/test/tests.lux
+++ b/stdlib/test/tests.lux
@@ -26,7 +26,6 @@
[frp]
["_;" promise]
[stm])
-
(data [bit]
[bool]
[char]
@@ -60,18 +59,16 @@
## [macro]
(macro ["_;" ast]
["_;" syntax]
- ["_;" template])
+ ["_;" template]
+ (poly ["poly_;" eq]
+ ["poly_;" text-encoder]
+ ["poly_;" functor]))
["_;" type]
(type ["_;" check]
["_;" auto])
## (control [effect])
)
- )
- ## (lux (macro [poly]
- ## (poly ["poly_;" eq]
- ## ["poly_;" text-encoder]
- ## ["poly_;" functor])))
- )
+ ))
## [Program]
(program: args
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-22 10:11:02 +0000