From 899b1823b1b5cd5d2d9f29439238b92756d4e536 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 16 Jul 2017 19:30:41 -0400 Subject: - Polytypic JSON codec can now handle #rec-style recursive types. --- stdlib/source/lux/data/format/json.lux | 189 ++++++++++++++++++++---------- stdlib/source/lux/macro/poly.lux | 2 +- stdlib/test/test/lux/data/format/json.lux | 22 +++- stdlib/test/test/lux/macro/poly/eq.lux | 2 - 4 files changed, 150 insertions(+), 65 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//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//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//encode *env* :val:)] - (wrap (` (: (~ (->Codec//encode (type;to-ast :x:))) + .val. (Codec//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) #;;Object)) - ))) - )) + ))))) (do @ [:sub: (poly;apply-1 (ident-for ;Maybe) :x:) - .sub. (Codec//encode *env* :sub:)] - (wrap (` (: (~ (->Codec//encode (type;to-ast :x:))) + .sub. (Codec//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//encode *env* :sub:)] - (wrap (` (: (~ (->Codec//encode (type;to-ast :x:))) + .sub. (Codec//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//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//encode new-*env* :case:)] + encoder (Codec//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//encode new-*env* :slot:)] + [encoder (Codec//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//encode new-*env* :member:)] + encoder (Codec//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//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//encode *env* :func:) - .args. (mapM @ (Codec//encode *env*) :args:)] - (wrap (` (: (~ (->Codec//encode (type;to-ast :x:))) + .func. (Codec//encode env :func:) + .args. (mapM @ (Codec//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//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//decode env :x:) (let [->Codec//decode (: (-> Code Code) (function [.type.] (` (-> JSON (R;Result (~ .type.))))))] (with-expansions @@ -859,8 +901,8 @@ (do-template [ ] [(do @ [:sub: ( :x:) - .sub. (Codec//decode *env* :sub:)] - (wrap (` (: (~ (->Codec//decode (type;to-ast :x:))) + .sub. (Codec//decode env :sub:)] + (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:))) ( (~ .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//decode *env* :val:)] - (wrap (` (: (~ (->Codec//decode (type;to-ast :x:))) + .val. (Codec//decode env :val:)] + (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:))) (function [(~ g!input)] (do R;Monad [(~ g!key) (;;fields (~ g!input)) @@ -887,17 +929,32 @@ ))) )) + (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//decode env :case:)] + (wrap (list (` (do Monad + [(~ 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//decode new-*env* :case:)] + decoder (Codec//decode new-env :case:)] (wrap (list (` (do Monad [(~ 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//decode new-*env* :slot:)] + decoder (Codec//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 @@ -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//decode new-*env* :member:)] + decoder (Codec//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//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//decode *env* :func:) - .args. (mapM @ (Codec//decode *env*) :args:)] - (wrap (` (: (~ (->Codec//decode (type;to-ast :x:))) + .func. (Codec//decode env :func:) + .args. (mapM @ (Codec//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) diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux index fc533e4c1..eba3b4cf9 100644 --- a/stdlib/test/test/lux/data/format/json.lux +++ b/stdlib/test/test/lux/data/format/json.lux @@ -7,7 +7,7 @@ pipe) (data [text "Text/" Monoid] text/format - [result] + ["R" result] [bool] [maybe] [number "i/" Number] @@ -18,7 +18,8 @@ [macro #+ with-gensyms] (macro [code] [syntax #+ syntax:] - [poly #+ derived:]) + [poly #+ derived:] + [poly/eq]) ["r" math/random] test) ) @@ -59,6 +60,10 @@ (#Case1 Int) (#Case2 Real)) +(type: #rec Recursive + (#Number Real) + (#Addition Real Recursive)) + (type: Record {#unit Unit #bool Bool @@ -69,7 +74,16 @@ #list (List Int) #variant Variant #tuple [Int Real Text] - #dict (d;Dict Text Int)}) + #dict (d;Dict Text Int) + #recursive Recursive}) + +(def: gen-recursive + (r;Random Recursive) + (r;rec (function [gen-recursive] + (r;alt r;real + (r;seq r;real gen-recursive))))) + +(derived: (poly/eq;Eq Recursive)) (def: gen-record (r;Random Record) @@ -87,6 +101,7 @@ ($_ r;alt r;bool gen-int r;real) ($_ r;seq gen-int r;real (r;text size)) (r;dict text;Hash size (r;text size) gen-int) + gen-recursive ))) (derived: (&;Codec Record)) @@ -119,6 +134,7 @@ (r.= tL1 tR1) (:: text;Eq = tL2 tR2))) (:: (d;Eq i.=) = (get@ #dict recL) (get@ #dict recR)) + (:: Eq = (get@ #recursive recL) (get@ #recursive recR)) )))) (context: "Polytypism" diff --git a/stdlib/test/test/lux/macro/poly/eq.lux b/stdlib/test/test/lux/macro/poly/eq.lux index 9bd6fc5e6..8bd102823 100644 --- a/stdlib/test/test/lux/macro/poly/eq.lux +++ b/stdlib/test/test/lux/macro/poly/eq.lux @@ -41,8 +41,6 @@ (r;alt r;real (r;seq r;real gen-recursive))))) -(derived: (&;Eq Recursive)) - (def: gen-record (r;Random Record) (do r;Monad -- cgit v1.2.3