diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/data/format/json.lux | 189 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly.lux | 2 |
2 files changed, 131 insertions, 60 deletions
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index 865e92b8c..61a104555 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -710,7 +710,14 @@ (All [a b] (-> (-> a b) (List a) (List b))) L/map) -(poly: #hidden (Codec<JSON,?>//encode *env* :x:) +(def: #hidden (rec-encode non-rec) + (All [a] (-> (-> (-> a JSON) + (-> a JSON)) + (-> a JSON))) + (function [input] + (non-rec (rec-encode non-rec) input))) + +(poly: #hidden (Codec<JSON,?>//encode env :x:) (let [->Codec//encode (: (-> Code Code) (function [.type.] (` (-> (~ .type.) JSON))))] (with-expansions @@ -728,53 +735,67 @@ (do @ [[:key: :val:] (poly;apply-2 (ident-for d;Dict) :x:) _ (poly;text :key:) - .val. (Codec<JSON,?>//encode *env* :val:)] - (wrap (` (: (~ (->Codec//encode (type;to-ast :x:))) + .val. (Codec<JSON,?>//encode env :val:)] + (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:))) (function [(~ g!input)] (|> (~ g!input) d;entries - (;;_map_ (: (-> [Text (~ (type;to-ast :val:))] + (;;_map_ (: (-> [Text (~ (poly;to-ast env :val:))] [Text JSON]) (function [[(~ g!key) (~ g!val)]] [(~ g!key) ((~ .val.) (~ g!val))]))) (d;from-list text;Hash<Text>) #;;Object)) - ))) - )) + ))))) (do @ [:sub: (poly;apply-1 (ident-for ;Maybe) :x:) - .sub. (Codec<JSON,?>//encode *env* :sub:)] - (wrap (` (: (~ (->Codec//encode (type;to-ast :x:))) + .sub. (Codec<JSON,?>//encode env :sub:)] + (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:))) (;;gen-nullable (~ .sub.)))))) (do @ [:sub: (poly;apply-1 (ident-for ;List) :x:) - .sub. (Codec<JSON,?>//encode *env* :sub:)] - (wrap (` (: (~ (->Codec//encode (type;to-ast :x:))) + .sub. (Codec<JSON,?>//encode env :sub:)] + (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:))) (|>. (;;_map_ (~ .sub.)) vector;from-list ;;gen-array))))) (with-gensyms [g!type-fun g!case g!input] (do @ + [members (poly;sum+ :x:) + pattern-matching (mapM @ + (function [[tag :case:]] + (do @ + [g!encode (Codec<JSON,?>//encode env :case:)] + (wrap (list (` ((~ (code;nat tag)) (~ g!case))) + (` (;;json [(~ (code;int (nat-to-int tag))) + ((~ g!encode) (~ g!case))])))))) + (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*)] + #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 @ (function [[name :case:]] (do @ [#let [tag (code;tag name)] - encoder (Codec<JSON,?>//encode new-*env* :case:)] + 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 (type;to-ast :x:)) + (->Codec//encode (poly;to-ast env :x:)) _ (` (All (~ g!type-fun) [(~@ g!vars)] (-> (~@ (L/map ->Codec//encode g!vars)) - (~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]] + (~ (->Codec//encode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))]] (wrap (` (: (~ :x:+) (function [(~@ g!vars) (~ g!input)] (case (~ g!input) @@ -783,24 +804,24 @@ (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*)] + #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 @ (function [[name :slot:]] (do @ - [encoder (Codec<JSON,?>//encode new-*env* :slot:)] + [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 (type;to-ast :x:)) + (->Codec//encode (poly;to-ast env :x:)) _ (` (All (~ g!type-fun) [(~@ g!vars)] (-> (~@ (L/map ->Codec//encode g!vars)) - (~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]] + (~ (->Codec//encode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))]] (wrap (` (: (~ :x:+) (function [(~@ g!vars) (~ g!input)] (;;json (~ (code;record synthesis)))) @@ -808,24 +829,24 @@ (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*)] + #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 @ (function [:member:] (do @ [g!member (macro;gensym "g!member") - encoder (Codec<JSON,?>//encode new-*env* :member:)] + encoder (Codec<JSON,?>//encode new-env :member:)] (wrap [g!member encoder]))) members) #let [:x:+ (case g!vars #;Nil - (->Codec//encode (type;to-ast :x:)) + (->Codec//encode (poly;to-ast env :x:)) _ (` (All (~ g!type-fun) [(~@ g!vars)] (-> (~@ (L/map ->Codec//encode g!vars)) - (~ (->Codec//encode (` ((~ (type;to-ast :x:)) (~@ 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.)] @@ -834,17 +855,38 @@ pattern-matching))])) ))) )) + ## 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)] + .non-rec. (Codec<JSON,?>//encode new-env :non-rec:)] + (wrap (` (: (~ (poly;gen-type new-env ->Codec//encode g!rec (list) :x:)) + (rec-encode (;function [(~ g!rec)] + (~ .non-rec.)))))))) + (poly;self env :x:) + (poly;recursion env :x:) + ## Type applications (do @ [[:func: :args:] (poly;apply :x:) - .func. (Codec<JSON,?>//encode *env* :func:) - .args. (mapM @ (Codec<JSON,?>//encode *env*) :args:)] - (wrap (` (: (~ (->Codec//encode (type;to-ast :x:))) + .func. (Codec<JSON,?>//encode env :func:) + .args. (mapM @ (Codec<JSON,?>//encode env) :args:)] + (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:))) ((~ .func.) (~@ .args.)))))) - (poly;bound *env* :x:) + ## Bound type-vars + (poly;bound env :x:) + ## If all else fails... (macro;fail (format "Cannot create JSON encoder for: " (%type :x:))) )))) -(poly: #hidden (Codec<JSON,?>//decode *env* :x:) +(def: #hidden (rec-decode non-rec) + (All [a] (-> (-> (-> JSON (R;Result a)) + (-> JSON (R;Result a))) + (-> JSON (R;Result a)))) + (function [input] + (non-rec (rec-decode non-rec) input))) + +(poly: #hidden (Codec<JSON,?>//decode env :x:) (let [->Codec//decode (: (-> Code Code) (function [.type.] (` (-> JSON (R;Result (~ .type.))))))] (with-expansions @@ -859,8 +901,8 @@ <complex> (do-template [<type> <matcher> <decoder>] [(do @ [:sub: (<matcher> :x:) - .sub. (Codec<JSON,?>//decode *env* :sub:)] - (wrap (` (: (~ (->Codec//decode (type;to-ast :x:))) + .sub. (Codec<JSON,?>//decode env :sub:)] + (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:))) (<decoder> (~ .sub.))))))] [Maybe (poly;apply-1 (ident-for ;Maybe)) ;;nullable] @@ -871,8 +913,8 @@ (do @ [[:key: :val:] (poly;apply-2 (ident-for d;Dict) :x:) _ (poly;text :key:) - .val. (Codec<JSON,?>//decode *env* :val:)] - (wrap (` (: (~ (->Codec//decode (type;to-ast :x:))) + .val. (Codec<JSON,?>//decode env :val:)] + (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:))) (function [(~ g!input)] (do R;Monad<Result> [(~ g!key) (;;fields (~ g!input)) @@ -887,17 +929,32 @@ ))) )) <complex> + (with-gensyms [g!type-fun g!case g!input g!_] + (do @ + [members (poly;sum+ :x:) + pattern-matching (mapM @ + (function [[tag :case:]] + (do @ + [g!decode (Codec<JSON,?>//decode env :case:)] + (wrap (list (` (do Monad<Parser> + [(~ g!_) (;;nth +0 (;;int! (~ (code;int (nat-to-int tag))))) + (~ g!_) (;;nth +1 (~ g!decode))] + ((~' wrap) ((~ (code;nat tag)) (~ g!_))))))))) + (list;enumerate members))] + (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:))) + ($_ ;;either + (~@ (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*)] + #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 @ (function [[name :case:]] (do @ [#let [tag (code;tag name)] - decoder (Codec<JSON,?>//decode new-*env* :case:)] + decoder (Codec<JSON,?>//decode new-env :case:)] (wrap (list (` (do Monad<Parser> [(~ g!_) (;;nth +0 (;;text! (~ (code;text (product;right name))))) (~ g!_) (;;nth +1 (~ decoder))] @@ -905,12 +962,12 @@ members) #let [:x:+ (case g!vars #;Nil - (->Codec//decode (type;to-ast :x:)) + (->Codec//decode (poly;to-ast env :x:)) _ (` (All (~ g!type-fun) [(~@ g!vars)] (-> (~@ (L/map ->Codec//decode g!vars)) - (~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars))))))))) + (~ (->Codec//decode (` ((~ (poly;to-ast env :x:)) (~@ g!vars))))))))) base-parser (` ($_ ;;either (~@ (L/join pattern-matching)))) parser (case g!vars @@ -924,14 +981,14 @@ (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*)] + #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 @ (function [[name :slot:]] (do @ [#let [g!member (code;symbol ["" (product;right name)])] - decoder (Codec<JSON,?>//decode new-*env* :slot:)] + decoder (Codec<JSON,?>//decode new-env :slot:)] (wrap (list g!member (` (;;get (~ (code;text (product;right name))) (~ g!input))) g!member @@ -939,12 +996,12 @@ members) #let [:x:+ (case g!vars #;Nil - (->Codec//decode (type;to-ast :x:)) + (->Codec//decode (poly;to-ast env :x:)) _ (` (All (~ g!type-fun) [(~@ g!vars)] (-> (~@ (L/map ->Codec//decode g!vars)) - (~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]] + (~ (->Codec//decode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))]] (wrap (` (: (~ :x:+) (function [(~@ g!vars) (~ g!input)] (do R;Monad<Result> @@ -956,24 +1013,24 @@ (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*)] + #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 @ (function [:member:] (do @ [g!member (macro;gensym "g!member") - decoder (Codec<JSON,?>//decode new-*env* :member:)] + decoder (Codec<JSON,?>//decode new-env :member:)] (wrap [g!member decoder]))) members) #let [:x:+ (case g!vars #;Nil - (->Codec//decode (type;to-ast :x:)) + (->Codec//decode (poly;to-ast env :x:)) _ (` (All (~ g!type-fun) [(~@ g!vars)] (-> (~@ (L/map ->Codec//decode g!vars)) - (~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))] + (~ (->Codec//decode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))))] #let [.decoder. (case g!vars #;Nil (` (;;shape [(~@ (L/map product;right pattern-matching))])) @@ -983,15 +1040,29 @@ (;;shape [(~@ (L/map product;right pattern-matching))]))))]] (wrap (` (: (~ :x:+) (~ .decoder.)))) )) + ## 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)] + .non-rec. (Codec<JSON,?>//decode new-env :non-rec:)] + (wrap (` (: (~ (poly;gen-type new-env ->Codec//decode g!rec (list) :x:)) + (rec-decode (;function [(~ g!rec)] + (~ .non-rec.)))))))) + (poly;self env :x:) + (poly;recursion env :x:) + ## Type applications (do @ [[:func: :args:] (poly;apply :x:) - .func. (Codec<JSON,?>//decode *env* :func:) - .args. (mapM @ (Codec<JSON,?>//decode *env*) :args:)] - (wrap (` (: (~ (->Codec//decode (type;to-ast :x:))) + .func. (Codec<JSON,?>//decode env :func:) + .args. (mapM @ (Codec<JSON,?>//decode env) :args:)] + (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:))) ((~ .func.) (~@ .args.)))))) + ## Bound type-vars (do @ - [g!bound (poly;bound *env* :x:)] + [g!bound (poly;bound env :x:)] (wrap g!bound)) + ## If all else fails... (macro;fail (format "Cannot create JSON decoder for: " (%type :x:))) )))) diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux index 4ff1b3012..e2a438b00 100644 --- a/stdlib/source/lux/macro/poly.lux +++ b/stdlib/source/lux/macro/poly.lux @@ -377,7 +377,7 @@ (~ impl))))))) ## [Derivers] -(def: (to-ast env type) +(def: #export (to-ast env type) (-> Env Type Code) (case type (#;Host name params) |