aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/data/format/json.lux189
-rw-r--r--stdlib/source/lux/macro/poly.lux2
-rw-r--r--stdlib/test/test/lux/data/format/json.lux22
-rw-r--r--stdlib/test/test/lux/macro/poly/eq.lux2
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<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)
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>]
text/format
- [result]
+ ["R" result]
[bool]
[maybe]
[number "i/" Number<Int>]
@@ -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<Text> size (r;text size) gen-int)
+ gen-recursive
)))
(derived: (&;Codec<JSON,?> Record))
@@ -119,6 +134,7 @@
(r.= tL1 tR1)
(:: text;Eq<Text> = tL2 tR2)))
(:: (d;Eq<Dict> i.=) = (get@ #dict recL) (get@ #dict recR))
+ (:: Eq<Recursive> = (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<Random>
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 20:22:54 +0000