aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/data/format/json/codec.lux250
-rw-r--r--stdlib/source/lux/macro/poly.lux78
-rw-r--r--stdlib/source/lux/macro/poly/eq.lux118
-rw-r--r--stdlib/source/lux/macro/poly/functor.lux50
-rw-r--r--stdlib/source/lux/macro/poly/text-encoder.lux140
5 files changed, 146 insertions, 490 deletions
diff --git a/stdlib/source/lux/data/format/json/codec.lux b/stdlib/source/lux/data/format/json/codec.lux
index 2bd298419..98e3874fd 100644
--- a/stdlib/source/lux/data/format/json/codec.lux
+++ b/stdlib/source/lux/data/format/json/codec.lux
@@ -231,103 +231,33 @@
.sub. (Codec<JSON,?>//encode env :sub:)]
(wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
(|>. (;;_map_ (~ .sub.)) vector;from-list ..;array)))))
- (with-gensyms [g!type-fun g!case g!input]
+ (with-gensyms [g!input]
(do @
[members (poly;sum+ :x:)
pattern-matching (M;map @
(function [[tag :case:]]
(do @
[g!encode (Codec<JSON,?>//encode env :case:)]
- (wrap (list (` ((~ (code;nat tag)) (~ g!case)))
+ (wrap (list (` ((~ (code;nat tag)) (~ g!input)))
(` (..;json [(~ (code;real (;;tag tag)))
- ((~ g!encode) (~ g!case))]))))))
+ ((~ g!encode) (~ g!input))]))))))
(list;enumerate members))]
(wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
(function [(~ g!input)]
(case (~ g!input)
(~@ (L/join pattern-matching)))))))))
- (with-gensyms [g!type-fun g!case g!input]
- (do @
- [[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 (M;map @
- (function [[name :case:]]
- (do @
- [#let [tag (code;tag name)]
- encoder (Codec<JSON,?>//encode new-env :case:)]
- (wrap (list (` ((~ tag) (~ g!case)))
- (` (..;json [(~ (code;text (product;right name)))
- ((~ encoder) (~ g!case))]))))))
- members)
- #let [:x:+ (case g!vars
- #;Nil
- (->Codec//encode (poly;to-ast env :x:))
-
- _
- (` (All (~ g!type-fun) [(~@ g!vars)]
- (-> (~@ (L/map ->Codec//encode g!vars))
- (~ (->Codec//encode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))]]
- (wrap (` (: (~ :x:+)
- (function [(~@ g!vars) (~ g!input)]
- (case (~ g!input)
- (~@ (L/join pattern-matching))))
- )))))
- (with-gensyms [g!type-fun g!case g!input]
- (do @
- [[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 (M;map @
- (function [[name :slot:]]
- (do @
- [encoder (Codec<JSON,?>//encode new-env :slot:)]
- (wrap [(` (~ (code;text (product;right name))))
- (` ((~ encoder) (get@ (~ (code;tag name)) (~ g!input))))])))
- members)
- #let [:x:+ (case g!vars
- #;Nil
- (->Codec//encode (poly;to-ast env :x:))
-
- _
- (` (All (~ g!type-fun) [(~@ g!vars)]
- (-> (~@ (L/map ->Codec//encode g!vars))
- (~ (->Codec//encode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))]]
- (wrap (` (: (~ :x:+)
- (function [(~@ g!vars) (~ g!input)]
- (..;json (~ (code;record synthesis))))
- )))))
- (with-gensyms [g!type-fun g!case]
- (do @
- [[g!vars members] (poly;tuple :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 (M;map @
- (function [:member:]
- (do @
- [g!member (macro;gensym "g!member")
- encoder (Codec<JSON,?>//encode new-env :member:)]
- (wrap [g!member encoder])))
- members)
- #let [:x:+ (case g!vars
- #;Nil
- (->Codec//encode (poly;to-ast env :x:))
-
- _
- (` (All (~ g!type-fun) [(~@ g!vars)]
- (-> (~@ (L/map ->Codec//encode g!vars))
- (~ (->Codec//encode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))]
- #let [.tuple. (` [(~@ (L/map product;left pattern-matching))])]]
- (wrap (` (: (~ :x:+)
- (function [(~@ g!vars) (~ .tuple.)]
- (..;json [(~@ (L/map (function [[g!member g!encoder]]
- (` ((~ g!encoder) (~ g!member))))
- pattern-matching))]))
- )))
- ))
+ (do @
+ [members (poly;prod+ :x:)
+ #let [g!members (|> (list;size members) n.dec
+ (list;n.range +0)
+ (L/map (|>. nat/encode code;local-symbol)))]
+ g!encoders (M;map @ (Codec<JSON,?>//encode env) members)]
+ (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
+ (function [[(~@ g!members)]]
+ (..;json [(~@ (L/map (function [[g!member g!encode]]
+ (` ((~ g!encode) (~ g!member))))
+ (list;zip2 g!members g!encoders)))]))
+ ))))
## Type recursion
(with-gensyms [g!rec]
(do @
@@ -348,6 +278,19 @@
((~ .func.) (~@ .args.))))))
## Bound type-vars
(poly;bound env :x:)
+ ## Polymorphism
+ (with-gensyms [g!type-fun]
+ (do @
+ [[g!vars :non-poly:] (poly;polymorphic :x:)
+ #let [new-env (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
+ env)]
+ .non-poly. (Codec<JSON,?>//encode new-env :non-poly:)]
+ (wrap (` (: (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (L/map ->Codec//encode g!vars))
+ (~ (->Codec//encode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))
+ (function (~ g!type-fun) [(~@ g!vars)]
+ (~ .non-poly.)))))))
## If all else fails...
(macro;fail ($_ text/append "Cannot create JSON encoder for: " (type;to-text :x:)))
))))
@@ -381,109 +324,27 @@
.sub. (Codec<JSON,?>//decode env :sub:)]
(wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
(../reader;array (p;some (~ .sub.)))))))
- (with-gensyms [g!type-fun g!case g!_]
- (do @
- [members (poly;sum+ :x:)
- pattern-matching (M;map @
- (function [[tag :case:]]
- (do @
- [g!decode (Codec<JSON,?>//decode env :case:)]
- (wrap (list (` (|> (~ g!decode)
- (p;after (../reader;number! (~ (code;real (;;tag tag)))))
- ../reader;array))))))
- (list;enumerate members))]
- (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
- ($_ p;alt
- (~@ (L/join pattern-matching))))))))
- (with-gensyms [g!type-fun g!_]
- (do @
- [[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 (M;map @
- (function [[name :case:]]
- (do @
- [g!decode (Codec<JSON,?>//decode new-env :case:)]
- (wrap (list (` (|> (~ g!decode)
- (:: p;Monad<Parser> (~' map) (|>. (~ (code;tag name))))
- (p;after (../reader;string! (~ (code;text (product;right name)))))
- ../reader;array))))))
- members)
- #let [:x:+ (case g!vars
- #;Nil
- (->Codec//decode (poly;to-ast env :x:))
-
- _
- (` (All (~ g!type-fun) [(~@ g!vars)]
- (-> (~@ (L/map ->Codec//decode g!vars))
- (~ (->Codec//decode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))
- base-parser (` ($_ p;either
- (~@ (L/join pattern-matching))))
- parser (case g!vars
- #;Nil
- base-parser
-
- _
- (` (function [(~@ g!vars)] (~ base-parser))))]]
- (wrap (` (: (~ :x:+) (~ parser))))
- ))
- (with-gensyms [g!type-fun g!case]
- (do @
- [[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 (M;map @
- (function [[name :slot:]]
- (do @
- [g!decoder (Codec<JSON,?>//decode new-env :slot:)]
- (wrap (` (../reader;field (~ (code;text (product;right name)))
- (~ g!decoder))))))
- members)
- #let [:x:+ (case g!vars
- #;Nil
- (->Codec//decode (poly;to-ast env :x:))
-
- _
- (` (All (~ g!type-fun) [(~@ g!vars)]
- (-> (~@ (L/map ->Codec//decode g!vars))
- (~ (->Codec//decode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))]]
- (case g!vars
- #;Nil
- (wrap (` (: (~ :x:+)
- (|> ($_ p;seq (~@ extraction))
- (p;before ../reader;any)))))
-
- _
- (wrap (` (: (~ :x:+)
- (function [(~@ g!vars)]
- (|> ($_ p;seq (~@ extraction))
- (p;before ../reader;any)))))))))
- (with-gensyms [g!type-fun g!case]
- (do @
- [[g!vars members] (poly;tuple :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 (M;map @ (Codec<JSON,?>//decode new-env) members)
- #let [:x:+ (case g!vars
- #;Nil
- (->Codec//decode (poly;to-ast env :x:))
-
- _
- (` (All (~ g!type-fun) [(~@ g!vars)]
- (-> (~@ (L/map ->Codec//decode g!vars))
- (~ (->Codec//decode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))]
- #let [.decoder. (case g!vars
- #;Nil
- (` (../reader;array ($_ p;seq (~@ pattern-matching))))
-
- _
- (` (function [(~@ g!vars)]
- (../reader;array ($_ p;seq (~@ pattern-matching))))))]]
- (wrap (` (: (~ :x:+) (~ .decoder.))))
- ))
+ (do @
+ [members (poly;sum+ :x:)
+ pattern-matching (M;map @
+ (function [[tag :case:]]
+ (do @
+ [g!decode (Codec<JSON,?>//decode env :case:)]
+ (wrap (list (` (|> (~ g!decode)
+ (p;after (../reader;number! (~ (code;real (;;tag tag)))))
+ ../reader;array))))))
+ (list;enumerate members))]
+ (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
+ ($_ p;alt
+ (~@ (L/join pattern-matching)))))))
+ (do @
+ [members (poly;prod+ :x:)
+ #let [g!members (|> (list;size members) n.dec
+ (list;n.range +0)
+ (L/map (|>. nat/encode code;local-symbol)))]
+ g!decoders (M;map @ (Codec<JSON,?>//decode env) members)]
+ (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
+ (../reader;array ($_ p;seq (~@ g!decoders)))))))
## Type recursion
(with-gensyms [g!rec]
(do @
@@ -506,6 +367,19 @@
(do @
[g!bound (poly;bound env :x:)]
(wrap g!bound))
+ ## Polymorphism
+ (with-gensyms [g!type-fun]
+ (do @
+ [[g!vars :non-poly:] (poly;polymorphic :x:)
+ #let [new-env (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
+ env)]
+ .non-poly. (Codec<JSON,?>//decode new-env :non-poly:)]
+ (wrap (` (: (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (L/map ->Codec//decode g!vars))
+ (~ (->Codec//decode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))
+ (function (~ g!type-fun) [(~@ g!vars)]
+ (~ .non-poly.)))))))
## If all else fails...
(macro;fail ($_ text/append "Cannot create JSON decoder for: " (type;to-text :x:)))
))))
diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux
index 560847afd..7af9eefc1 100644
--- a/stdlib/source/lux/macro/poly.lux
+++ b/stdlib/source/lux/macro/poly.lux
@@ -81,9 +81,6 @@
($_ macro;either
<primitives>))))
-(syntax: ($Code$ ast)
- (wrap (;list (code;text (code;to-text ast)))))
-
(do-template [<single> <multi> <flattener> <tag>]
[(def: #export <single>
(Matcher [Type Type])
@@ -93,7 +90,7 @@
(Lux/wrap [:left: :right:])
_
- (macro;fail ($_ text/append "Not a " ($Code$ <tag>) " type: " (type;to-text :type:))))))
+ (macro;fail ($_ text/append "Not a " (Ident/encode (ident-for <tag>)) " type: " (type;to-text :type:))))))
(def: #export <multi>
(Matcher (List Type))
@@ -101,76 +98,37 @@
(let [members (<flattener> (type;un-name :type:))]
(if (n.> +1 (list;size members))
(Lux/wrap members)
- (macro;fail ($_ text/append "Not a " ($Code$ <tag>) " type: " (type;to-text :type:)))))))]
+ (macro;fail ($_ text/append "Not a " (Ident/encode (ident-for <tag>)) " type: " (type;to-text :type:)))))))]
[sum sum+ type;flatten-variant #;Sum]
[prod prod+ type;flatten-tuple #;Product]
)
-(def: #export tagged
- (Matcher [(List Ident) Type])
- (;function [:type:]
- (case (type;un-alias :type:)
- (#;Named type-name :def:)
- (do macro;Monad<Lux>
- [tags (macro;tags-of type-name)]
- (wrap [tags :def:]))
-
- _
- (macro;fail ($_ text/append "Unnamed types cannot have tags: " (type;to-text :type:))))))
-
(def: #export polymorphic
(Matcher [(List Code) Type])
(;function [:type:]
- (loop [:type: (type;un-name :type:)]
+ (let [:type: (type;un-name :type:)]
(case :type:
- (#;UnivQ _ :type:')
- (do macro;Monad<Lux>
- [[g!tail :type:''] (recur :type:')
- g!head (macro;gensym "type-var")]
- (wrap [(list& g!head g!tail)
- :type:'']))
-
- _
- (Lux/wrap [(;list) :type:])))))
+ (#;UnivQ _)
+ (loop [:type: :type:]
+ (case :type:
+ (#;UnivQ _ :type:')
+ (do macro;Monad<Lux>
+ [[g!tail :type:''] (recur :type:')
+ g!head (macro;gensym "type-var")]
+ (wrap [(list& g!head g!tail)
+ :type:'']))
-(do-template [<combinator> <sub-comb> <build>]
- [(def: #export <combinator>
- (Matcher [(List Code) (List [Ident Type])])
- (;function [:type:]
- (do macro;Monad<Lux>
- [[tags :type:] (tagged :type:)
- _ (macro;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)
- [init-tags last-tag] (list;split (n.dec num-tags) tags)
- [init-types last-types] (list;split (n.dec num-tags) members)]]
- (wrap [vars (list;concat (;list (list;zip2 init-tags init-types)
- (;list [(default (undefined)
- (list;head last-tag))
- (<build> last-types)])))]))))]
-
- [variant sum+ type;variant]
- [record prod+ type;tuple]
- )
+ _
+ (Lux/wrap [(;list) :type:])))
-(def: #export tuple
- (Matcher [(List Code) (List Type)])
- (;function [:type:]
- (do macro;Monad<Lux>
- [[vars :type:] (polymorphic :type:)
- members (prod+ :type:)]
- (wrap [vars members]))))
+ _
+ (macro;fail ($_ text/append "Non-polymorphic type: " (type;to-text :type:)))))))
(def: #export function
- (Matcher [(List Code) (List Type) Type])
+ (Matcher [(List Type) Type])
(;function [:type:]
- (do macro;Monad<Lux>
- [[vars :type:] (polymorphic :type:)
- #let [[ins out] (type;flatten-function (type;un-name :type:))]]
- (wrap [vars ins out]))))
+ (:: macro;Monad<Lux> wrap (type;flatten-function (type;un-name :type:)))))
(def: #export apply
(Matcher [Type (List Type)])
diff --git a/stdlib/source/lux/macro/poly/eq.lux b/stdlib/source/lux/macro/poly/eq.lux
index 0c36d307e..9de2a8784 100644
--- a/stdlib/source/lux/macro/poly/eq.lux
+++ b/stdlib/source/lux/macro/poly/eq.lux
@@ -1,10 +1,10 @@
(;module:
lux
- (lux (control ["M" monad #+ do Monad]
+ (lux (control [monad #+ do Monad]
[eq])
- (data [text]
+ (data [text "text/" Monoid<Text>]
text/format
- (coll [list "List/" Monad<List>]
+ (coll [list "L/" Monad<List>]
[vector]
[array]
[queue]
@@ -12,7 +12,7 @@
[seq]
[dict #+ Dict]
(tree [rose]))
- [number]
+ [number "nat/" Codec<Text,Nat>]
[product]
[bool]
[maybe])
@@ -24,18 +24,6 @@
[type]
))
-## [Utils]
-(def: (function$ func inputs output)
- (-> Code (List Code) Code Code)
- (case inputs
- #;Nil
- output
-
- _
- (` (function (~@ (if (list;empty? inputs) (list) (list func)))
- [(~@ inputs)]
- (~ output)))))
-
## [Derivers]
(poly: #export (Eq<?> env :x:)
(let [->Eq (: (-> Code Code)
@@ -80,71 +68,38 @@
(wrap (` (: (~ (->Eq (type;to-ast :x:)))
(dict;Eq<Dict> (~ g!val))))))
## Variants
- (with-gensyms [g!type-fun g!left g!right]
+ (with-gensyms [g!left g!right]
(do @
[members (poly;sum+ :x:)
- pattern-matching (M;map @
- (function [[tag :case:]]
- (do @
- [g!eq (Eq<?> env :case:)]
- (wrap (list (` [((~ (code;nat tag)) (~ g!left))
- ((~ (code;nat tag)) (~ g!right))])
- (` ((~ g!eq) (~ g!left) (~ g!right)))))))
- (list;enumerate members))
- #let [base (` (function [(~ g!left) (~ g!right)]
- (case [(~ g!left) (~ g!right)]
- (~@ (List/join pattern-matching)))))]]
- (wrap (` (: (~ (poly;gen-type env ->Eq g!type-fun (list) :x:))
- (~ base))))))
- (with-gensyms [g!type-fun g!left g!right]
- (do @
- [[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 (M;map @
- (function [[name :case:]]
- (do @
- [g!eq (Eq<?> new-env :case:)]
- (wrap (list (` [((~ (code;tag name)) (~ g!left))
- ((~ (code;tag name)) (~ g!right))])
- (` ((~ g!eq) (~ g!left) (~ g!right)))))))
- members)
- #let [base (function$ g!type-fun g!vars
- (` (function [(~ g!left) (~ g!right)]
- (case [(~ g!left) (~ g!right)]
- (~@ (List/join pattern-matching))))))]]
- (wrap (` (: (~ (poly;gen-type new-env ->Eq g!type-fun g!vars :x:))
- (~ base))))))
+ pattern-matching (monad;map @
+ (function [[tag :case:]]
+ (do @
+ [g!eq (Eq<?> env :case:)]
+ (wrap (list (` [((~ (code;nat tag)) (~ g!left))
+ ((~ (code;nat tag)) (~ g!right))])
+ (` ((~ g!eq) (~ g!left) (~ g!right)))))))
+ (list;enumerate members))]
+ (wrap (` (: (~ (->Eq (poly;to-ast env :x:)))
+ (function [(~ g!left) (~ g!right)]
+ (case [(~ g!left) (~ g!right)]
+ (~@ (L/join pattern-matching)))))))))
## Tuples
- (with-gensyms [g!type-fun]
- (do @
- [[g!vars members] (poly;tuple :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 (M;map @
- (function [:member:]
- (do @
- [g!left (macro;gensym "g!left")
- g!right (macro;gensym "g!right")
- g!eq (Eq<?> new-env :member:)]
- (wrap [g!left g!right g!eq])))
- members)
- #let [.left. (` [(~@ (List/map product;left pattern-matching))])
- .right. (` [(~@ (List/map (|>. product;right product;left) pattern-matching))])
- base (function$ g!type-fun g!vars
- (` (function [(~ .left.) (~ .right.)]
- (and (~@ (List/map (function [[g!left g!right g!eq]]
- (` ((~ g!eq) (~ g!left) (~ g!right))))
- pattern-matching))))))]]
- (wrap (` (: (~ (poly;gen-type new-env ->Eq g!type-fun g!vars :x:))
- (~ base))))))
+ (do @
+ [:members: (poly;prod+ :x:)
+ #let [indices (|> (list;size :members:) n.dec (list;n.range +0))
+ g!lefts (L/map (|>. nat/encode (text/append "left") code;local-symbol) indices)
+ g!rights (L/map (|>. nat/encode (text/append "right") code;local-symbol) indices)]
+ g!eqs (monad;map @ (Eq<?> env) :members:)]
+ (wrap (` (: (~ (->Eq (poly;to-ast env :x:)))
+ (function [[(~@ g!lefts)] [(~@ g!rights)]]
+ (and (~@ (|> (list;zip3 g!eqs g!lefts g!rights)
+ (L/map (function [[g!eq g!left g!right]]
+ (` ((~ g!eq) (~ g!left) (~ g!right)))))))))))))
## Type recursion
(with-gensyms [g!rec]
(do @
[:non-rec: (poly;recursive :x:)
- #let [new-env (poly;extend-env [:x: g!rec] (list [:x: (` (;undefined))]) env)]
+ #let [new-env (poly;extend-env [:x: g!rec] (list [Bottom (` (;undefined))]) env)]
.non-rec. (Eq<?> new-env :non-rec:)]
(wrap (` (: (~ (poly;gen-type new-env ->Eq g!rec (list) :x:))
(eq;rec (;function [(~ g!rec)]
@@ -155,11 +110,24 @@
(do @
[[:func: :args:] (poly;apply :x:)
.func. (Eq<?> env :func:)
- .args. (M;map @ (Eq<?> env) :args:)]
+ .args. (monad;map @ (Eq<?> env) :args:)]
(wrap (` (: (~ (->Eq (type;to-ast :x:)))
((~ .func.) (~@ .args.))))))
## Bound type-vars
(poly;bound env :x:)
+ ## Polymorphism
+ (with-gensyms [g!type-fun]
+ (do @
+ [[g!vars :non-poly:] (poly;polymorphic :x:)
+ #let [new-env (poly;extend-env [:x: g!type-fun]
+ (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
+ env)]
+ .non-poly. (Eq<?> new-env :non-poly:)]
+ (wrap (` (: (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (L/map ->Eq g!vars))
+ (~ (->Eq (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))
+ (function (~ g!type-fun) [(~@ g!vars)]
+ (~ .non-poly.)))))))
## If all else fails...
(macro;fail (format "Cannot create Eq for: " (%type :x:)))
))))
diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux
index 5212ad150..0acd49a8e 100644
--- a/stdlib/source/lux/macro/poly/functor.lux
+++ b/stdlib/source/lux/macro/poly/functor.lux
@@ -20,17 +20,14 @@
))
## [Derivers]
-(poly: #export (Functor<?> env :x:)
+(poly: #export (Functor<?> env :input:)
(with-gensyms [g!type-fun g!func g!input]
(do @
- [#let [g!map (' map)]
- [g!vars _] (poly;polymorphic :x:)
+ [[g!vars :x:] (poly;polymorphic :input:)
#let [num-vars (list;size g!vars)
- new-env (poly;extend-env [:x: g!type-fun]
- (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
- env)]
- _ (macro;assert "Functors must have at least 1 type-variable."
- (n.> +0 num-vars))]
+ new-env (poly;extend-env [:input: g!type-fun]
+ (list;zip2 (poly;type-var-indices num-vars) g!vars)
+ env)]]
(let [->Functor (: (-> Code Code)
(function [.type.]
(if (n.= +1 num-vars)
@@ -54,7 +51,7 @@
(wrap value))
## Tuples/records
(do @
- [[g!vars members] (poly;tuple :type:)
+ [members (poly;prod+ :type:)
pm (M;map @
(function [:slot:]
(do @
@@ -69,28 +66,27 @@
## Recursion
(do @
[_ (poly;recursion new-env :type:)]
- (wrap (` ((~ g!map) (~ g!func) (~ value)))))
+ (wrap (` ((~' map) (~ g!func) (~ value)))))
)))]
($_ macro;either
## Variants
(do @
- [[g!vars cases] (poly;variant :x:)
+ [cases (poly;sum+ :x:)
pattern-matching (M;map @
- (function [[name :case:]]
+ (function [[tag :case:]]
(do @
- [#let [analysis (` ((~ (code;tag name)) (~ g!input)))]
- synthesis (Arg<?> g!input :case:)]
- (wrap (list analysis
- (` ((~ (code;tag name)) (~ synthesis)))))))
- cases)]
- (wrap (` (: (~ (->Functor (type;to-ast :x:)))
- (struct (def: ((~ g!map) (~ g!func) (~ g!input))
+ [synthesis (Arg<?> g!input :case:)]
+ (wrap (list (` ((~ (code;nat tag)) (~ g!input)))
+ (` ((~ (code;nat tag)) (~ synthesis)))))))
+ (list;enumerate cases))]
+ (wrap (` (: (~ (->Functor (type;to-ast :input:)))
+ (struct (def: ((~' map) (~ g!func) (~ g!input))
(case (~ g!input)
(~@ (List/join pattern-matching)))))
))))
## Tuples/Records
(do @
- [[g!vars members] (poly;tuple :x:)
+ [members (poly;prod+ :x:)
pm (M;map @
(function [:slot:]
(do @
@@ -98,8 +94,8 @@
body (Arg<?> g!slot :slot:)]
(wrap [g!slot body])))
members)]
- (wrap (` (: (~ (->Functor (type;to-ast :x:)))
- (struct (def: ((~ g!map) (~ g!func) (~ g!input))
+ (wrap (` (: (~ (->Functor (type;to-ast :input:)))
+ (struct (def: ((~' map) (~ g!func) (~ g!input))
(case (~ g!input)
[(~@ (List/map product;left pm))]
[(~@ (List/map product;right pm))])))
@@ -107,21 +103,21 @@
## Functions
(with-gensyms [g!out]
(do @
- [[g!vars [:ins: :out:]] (poly;function :x:)
+ [[:ins: :out:] (poly;function :x:)
.out. (Arg<?> g!out :out:)
g!envs (M;seq @
(list;repeat (list;size :ins:)
(macro;gensym "g!envs")))]
- (wrap (` (: (~ (->Functor (type;to-ast :x:)))
- (struct (def: ((~ g!map) (~ g!func) (~ g!input))
+ (wrap (` (: (~ (->Functor (type;to-ast :input:)))
+ (struct (def: ((~' map) (~ g!func) (~ g!input))
(function [(~@ g!envs)]
(let [(~ g!out) ((~ g!input) (~@ g!envs))]
(~ .out.))))))))))
## No structure (as you'd expect from Identity)
(do @
[_ (poly;var new-env num-vars :x:)]
- (wrap (` (: (~ (->Functor (type;to-ast :x:)))
- (struct (def: ((~ g!map) (~ g!func) (~ g!input))
+ (wrap (` (: (~ (->Functor (type;to-ast :input:)))
+ (struct (def: ((~' map) (~ g!func) (~ g!input))
((~ g!func) (~ g!input))))))))
## Failure...
(macro;fail (format "Cannot create Functor for: " (%type :x:)))
diff --git a/stdlib/source/lux/macro/poly/text-encoder.lux b/stdlib/source/lux/macro/poly/text-encoder.lux
deleted file mode 100644
index e66bfc680..000000000
--- a/stdlib/source/lux/macro/poly/text-encoder.lux
+++ /dev/null
@@ -1,140 +0,0 @@
-(;module:
- lux
- (lux (control ["M" monad #+ do Monad]
- [codec])
- (data [text]
- text/format
- (coll [list "List/" Monad<List>]
- [dict #+ Dict])
- [number]
- [product]
- [bool]
- [maybe]
- [ident "Ident/" Codec<Text,Ident>])
- [macro #+ Monad<Lux> with-gensyms]
- (macro [code]
- [syntax #+ syntax: Syntax]
- (syntax [common])
- [poly #+ poly:])
- [type]
- ))
-
-(def: (function$ func inputs output)
- (-> Code (List Code) Code Code)
- (case inputs
- #;Nil
- output
-
- _
- (` (function (~@ (if (list;empty? inputs) (list) (list func)))
- [(~@ inputs)]
- (~ output)))))
-
-## [Derivers]
-(poly: #export (Codec<Text,?>::encode env :x:)
- (let [->Codec::encode (: (-> Code Code)
- (function [.type.] (` (-> (~ .type.) Text))))]
- (with-expansions
- [<basic> (do-template [<type> <matcher> <encoder>]
- [(do @
- [_ (<matcher> :x:)]
- (wrap (` (: (~ (->Codec::encode (` <type>)))
- (~' <encoder>)))))]
-
- [Unit poly;unit (function [_0] "[]")]
- [Bool poly;bool (:: bool;Codec<Text,Bool> encode)]
- [Nat poly;nat (:: number;Codec<Text,Nat> encode)]
- [Int poly;int (:: number;Codec<Text,Int> encode)]
- [Deg poly;deg (:: number;Codec<Text,Deg> encode)]
- [Real poly;real (:: number;Codec<Text,Real> encode)]
- [Text poly;text text;encode])]
- ($_ macro;either
- ## Primitives
- <basic>
- ## Variants
- (with-gensyms [g!type-fun g!case g!input]
- (do @
- [[g!vars cases] (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 (M;map @
- (function [[name :case:]]
- (do @
- [encoder (Codec<Text,?>::encode new-env :case:)]
- (wrap (list (` ((~ (code;tag name)) (~ g!case)))
- (` (format "(#"
- (~ (code;text (Ident/encode name)))
- " "
- ((~ encoder) (~ g!case))
- ")"))))))
- cases)
- #let [base (function$ g!type-fun g!vars
- (` (function [(~ 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 [:x: g!type-fun]
- (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
- env)]
- synthesis (M;map @
- (function [[name :slot:]]
- (do @
- [encoder (Codec<Text,?>::encode new-env :slot:)]
- (wrap (` (format "#"
- (~ (code;text (Ident/encode name)))
- " "
- ((~ encoder) (get@ (~ (code;tag name)) (~ g!input))))))))
- slots)
- #let [base (function$ g!type-fun g!vars
- (` (function [(~ 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 [:x: g!type-fun]
- (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
- env)]
- parts (M;map @
- (function [:member:]
- (do @
- [g!member (macro;gensym "g!member")
- encoder (Codec<Text,?>::encode new-env :member:)]
- (wrap [g!member encoder])))
- members)
- #let [analysis (` [(~@ (List/map product;left parts))])
- synthesis (List/map (function [[g!member g!encoder]]
- (` ((~ g!encoder) (~ g!member))))
- parts)
- base (function$ g!type-fun g!vars
- (` (function [(~ 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;recursion env :x:)
- ## Type applications
- (do @
- [[:func: :args:] (poly;apply :x:)
- .func. (Codec<Text,?>::encode env :func:)
- .args. (M;map @ (Codec<Text,?>::encode env) :args:)]
- (wrap (` (: (~ (->Codec::encode (type;to-ast :x:)))
- ((~ .func.) (~@ .args.))))))
- ## Bound type-variables
- (poly;bound env :x:)
- ## Failure...
- (macro;fail (format "Cannot create Text encoder for: " (%type :x:)))
- ))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 02:29:48 +0000