diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/data/format/json/codec.lux | 250 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly.lux | 78 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly/eq.lux | 118 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly/functor.lux | 50 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly/text-encoder.lux | 140 | ||||
| -rw-r--r-- | stdlib/test/test/lux/macro/poly/text-encoder.lux | 54 | ||||
| -rw-r--r-- | stdlib/test/tests.lux | 3 |
7 files changed, 147 insertions, 546 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:))) - )))) diff --git a/stdlib/test/test/lux/macro/poly/text-encoder.lux b/stdlib/test/test/lux/macro/poly/text-encoder.lux deleted file mode 100644 index d5a871e5c..000000000 --- a/stdlib/test/test/lux/macro/poly/text-encoder.lux +++ /dev/null @@ -1,54 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do Monad] - [eq #+ Eq]) - (data text/format - [bool] - [number "i/" Number<Int>] - [text]) - ["r" math/random] - [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 - #text Text - #maybe (Maybe Int) - #list (List Int) - #variant Variant - #tuple [Int Real Text]}) - -(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;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;text size)) - ))) - -(derived: (&;Codec<Text,?>::encode Record)) - -## [Tests] -(context: "Text-encoding polytypism" - (test "" true)) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index b6dbdfcd2..39ac02d5e 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -63,7 +63,6 @@ (macro ["_;" code] ["_;" syntax] (poly ["poly_;" eq] - ["poly_;" text-encoder] ["poly_;" functor])) ["_;" type] (type ["_;" check] @@ -71,7 +70,7 @@ ["_;" object]) )) (lux (control [contract] - ["_;" concatenative]) + [concatenative]) (data [env] [trace] [store] |