aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/data/format/json.lux
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/data/format/json.lux1031
1 files changed, 1031 insertions, 0 deletions
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
new file mode 100644
index 000000000..c51e4b04c
--- /dev/null
+++ b/stdlib/source/lux/data/format/json.lux
@@ -0,0 +1,1031 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
+## If a copy of the MPL was not distributed with this file,
+## You can obtain one at http://mozilla.org/MPL/2.0/.
+
+(;module:
+ lux
+ (lux (control functor
+ applicative
+ monad
+ eq
+ codec)
+ (data [bool]
+ [text "Text/" Eq<Text> Monoid<Text>]
+ text/format
+ [number #* "Real/" Codec<Text,Real>]
+ maybe
+ [char "Char/" Eq<Char> Codec<Text,Char>]
+ error
+ [sum]
+ [product]
+ (struct [list "" Fold<List> "List/" Monad<List>]
+ [vector #+ Vector vector "Vector/" Monad<Vector>]
+ [dict #+ Dict]))
+ (codata [function])
+ [compiler #+ Monad<Lux> with-gensyms]
+ (macro [syntax #+ syntax:]
+ [ast]
+ [poly #+ poly:])
+ [type]
+ [lexer #+ Lexer Monad<Lexer>]))
+
+## [Types]
+(do-template [<name> <type>]
+ [(type: #export <name> <type>)]
+
+ [Null Unit]
+ [Boolean Bool]
+ [Number Real]
+ [String Text]
+ )
+
+(type: #export #rec JSON
+ (#Null Null)
+ (#Boolean Boolean)
+ (#Number Number)
+ (#String String)
+ (#Array (Vector JSON))
+ (#Object (Dict String JSON)))
+
+(do-template [<name> <type>]
+ [(type: #export <name> <type>)]
+
+ [Array (Vector JSON)]
+ [Object (Dict String JSON)]
+ )
+
+(type: #export (Parser a)
+ (-> JSON (Error a)))
+
+(type: #export (Gen a)
+ (-> a JSON))
+
+## [Syntax]
+(syntax: #export (json token)
+ (let [(^open) Monad<Lux>
+ wrapper (lambda [x] (` (;;json (~ x))))]
+ (case token
+ (^template [<ast-tag> <ctor> <json-tag>]
+ [_ (<ast-tag> value)]
+ (wrap (list (` (: JSON (<json-tag> (~ (<ctor> value))))))))
+ ([#;BoolS ast;bool #Boolean]
+ [#;IntS (|>. int-to-real ast;real) #Number]
+ [#;RealS ast;real #Number]
+ [#;TextS ast;text #String])
+
+ [_ (#;TagS ["" "null"])]
+ (wrap (list (` (: JSON #Null))))
+
+ [_ (#;TupleS members)]
+ (wrap (list (` (: JSON (#Array (vector (~@ (List/map wrapper members))))))))
+
+ [_ (#;RecordS pairs)]
+ (do Monad<Lux>
+ [pairs' (mapM @
+ (lambda [[slot value]]
+ (case slot
+ [_ (#;TextS key-name)]
+ (wrap (` [(~ (ast;text key-name)) (~ (wrapper value))]))
+
+ _
+ (compiler;fail "Wrong syntax for JSON object.")))
+ pairs)]
+ (wrap (list (` (: JSON (#Object (dict;from-list text;Hash<Text> (list (~@ pairs')))))))))
+
+ _
+ (wrap (list token))
+ )))
+
+## [Values]
+(def: #hidden (show-null _) (-> Null Text) "null")
+(do-template [<name> <type> <codec>]
+ [(def: <name> (-> <type> Text) (:: <codec> encode))]
+
+ [show-boolean Boolean bool;Codec<Text,Bool>]
+ [show-number Number number;Codec<Text,Real>]
+ [show-string String text;Codec<Text,Text>])
+
+(def: (show-array show-json elems)
+ (-> (-> JSON Text) (-> Array Text))
+ (format "["
+ (|> elems (Vector/map show-json) vector;vector-to-list (text;join-with ","))
+ "]"))
+
+(def: (show-object show-json object)
+ (-> (-> JSON Text) (-> Object Text))
+ (format "{"
+ (|> object
+ dict;entries
+ (List/map (lambda [[key value]] (format (:: text;Codec<Text,Text> encode key) ":" (show-json value))))
+ (text;join-with ","))
+ "}"))
+
+(def: (show-json json)
+ (-> JSON Text)
+ (case json
+ (^template [<tag> <show>]
+ (<tag> value)
+ (<show> value))
+ ([#Null show-null]
+ [#Boolean show-boolean]
+ [#Number show-number]
+ [#String show-string]
+ [#Array (show-array show-json)]
+ [#Object (show-object show-json)])
+ ))
+
+(def: #export null
+ JSON
+ #Null)
+
+(def: #export (keys json)
+ (-> JSON (Error (List String)))
+ (case json
+ (#Object obj)
+ (#;Right (dict;keys obj))
+
+ _
+ (#;Left (format "Can't get keys of a non-object."))))
+
+(def: #export (get key json)
+ (-> String JSON (Error JSON))
+ (case json
+ (#Object obj)
+ (case (dict;get key obj)
+ (#;Some value)
+ (#;Right value)
+
+ #;None
+ (#;Left (format "Missing field " (show-string key) " on object.")))
+
+ _
+ (#;Left (format "Can't get field " (show-string key) " of a non-object."))))
+
+(def: #export (set key value json)
+ (-> String JSON JSON (Error JSON))
+ (case json
+ (#Object obj)
+ (#;Right (#Object (dict;put key value obj)))
+
+ _
+ (#;Left (format "Can't set field " (show-string key) " of a non-object."))))
+
+(do-template [<name> <tag> <type>]
+ [(def: #export (<name> key json)
+ (-> Text JSON (Error <type>))
+ (case (get key json)
+ (#;Right (<tag> value))
+ (#;Right value)
+
+ (#;Right _)
+ (#;Left (format "Wrong value type at key " (show-string key)))
+
+ (#;Left error)
+ (#;Left error)))]
+
+ [get-boolean #Boolean Boolean]
+ [get-number #Number Number]
+ [get-string #String String]
+ [get-array #Array Array]
+ [get-object #Object Object]
+ )
+
+(do-template [<name> <type> <tag>]
+ [(def: #export (<name> value)
+ (Gen <type>)
+ (<tag> value))]
+
+ [gen-boolean Boolean #Boolean]
+ [gen-number Number #Number]
+ [gen-string String #String]
+ [gen-array Array #Array]
+ [gen-object Object #Object]
+ )
+
+(def: #export (gen-nullable gen)
+ (All [a] (-> (Gen a) (Gen (Maybe a))))
+ (lambda [elem]
+ (case elem
+ #;None #Null
+ (#;Some value) (gen value))))
+
+## Lexers
+(def: space~
+ (Lexer Text)
+ (lexer;some' lexer;space))
+
+(def: data-sep
+ (Lexer [Text Char Text])
+ ($_ lexer;seq space~ (lexer;this-char #",") space~))
+
+(def: null~
+ (Lexer Null)
+ (do Monad<Lexer>
+ [_ (lexer;this "null")]
+ (wrap [])))
+
+(do-template [<name> <token> <value>]
+ [(def: <name>
+ (Lexer Boolean)
+ (do Monad<Lexer>
+ [_ (lexer;this <token>)]
+ (wrap <value>)))]
+
+ [t~ "true" true]
+ [f~ "false" false]
+ )
+
+(def: boolean~
+ (Lexer Boolean)
+ (lexer;either t~ f~))
+
+(def: number~
+ (Lexer Number)
+ (do Monad<Lexer>
+ [?sign (: (Lexer (Maybe Text))
+ (lexer;opt (lexer;this "-")))
+ digits (: (Lexer Text)
+ (lexer;many' lexer;digit))
+ ?decimals (: (Lexer (Maybe Text))
+ (lexer;opt (do @
+ [_ (lexer;this ".")]
+ (lexer;many' lexer;digit))))]
+ (case (: (Error Real)
+ (Real/decode (format (default "" ?sign)
+ digits "."
+ (default "0" ?decimals))))
+ (#;Left message)
+ (lexer;fail message)
+
+ (#;Right value)
+ (wrap value))))
+
+(def: (un-escape escaped)
+ (-> Char Text)
+ (case escaped
+ #"t" "\t"
+ #"b" "\b"
+ #"n" "\n"
+ #"r" "\r"
+ #"f" "\f"
+ #"\"" "\""
+ #"\\" "\\"
+ _ ""))
+
+(def: string-body~
+ (Lexer Text)
+ (loop [_ []]
+ (do Monad<Lexer>
+ [chars (lexer;some' (lexer;none-of "\\\""))
+ stop-char lexer;peek]
+ (if (Char/= #"\\" stop-char)
+ (do @
+ [_ lexer;any
+ escaped lexer;any
+ next-chars (recur [])]
+ (wrap (format chars (un-escape escaped) next-chars)))
+ (wrap chars)))))
+
+(def: string~
+ (Lexer String)
+ (do Monad<Lexer>
+ [_ (lexer;this "\"")
+ string-body string-body~
+ _ (lexer;this "\"")]
+ (wrap string-body)))
+
+(def: (kv~ json~)
+ (-> (-> Unit (Lexer JSON)) (Lexer [String JSON]))
+ (do Monad<Lexer>
+ [key string~
+ _ space~
+ _ (lexer;this-char #":")
+ _ space~
+ value (json~ [])]
+ (wrap [key value])))
+
+(do-template [<name> <type> <open> <close> <elem-parser> <prep>]
+ [(def: (<name> json~)
+ (-> (-> Unit (Lexer JSON)) (Lexer <type>))
+ (do Monad<Lexer>
+ [_ (lexer;this-char <open>)
+ _ space~
+ elems (lexer;sep-by data-sep <elem-parser>)
+ _ space~
+ _ (lexer;this-char <close>)]
+ (wrap (<prep> elems))))]
+
+ [array~ Array #"[" #"]" (json~ []) vector;list-to-vector]
+ [object~ Object #"{" #"}" (kv~ json~) (dict;from-list text;Hash<Text>)]
+ )
+
+(def: (json~' _)
+ (-> Unit (Lexer JSON))
+ ($_ lexer;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~')))
+
+## [Structures]
+(struct: #export _ (Functor Parser)
+ (def: (map f ma)
+ (lambda [json]
+ (case (ma json)
+ (#;Left msg)
+ (#;Left msg)
+
+ (#;Right a)
+ (#;Right (f a))))))
+
+(struct: #export _ (Applicative Parser)
+ (def: functor Functor<Parser>)
+
+ (def: (wrap x json)
+ (#;Right x))
+
+ (def: (apply ff fa)
+ (lambda [json]
+ (case (ff json)
+ (#;Right f)
+ (case (fa json)
+ (#;Right a)
+ (#;Right (f a))
+
+ (#;Left msg)
+ (#;Left msg))
+
+ (#;Left msg)
+ (#;Left msg)))))
+
+(struct: #export _ (Monad Parser)
+ (def: applicative Applicative<Parser>)
+
+ (def: (join mma)
+ (lambda [json]
+ (case (mma json)
+ (#;Left msg)
+ (#;Left msg)
+
+ (#;Right ma)
+ (ma json)))))
+
+## [Values]
+## Syntax
+(do-template [<name> <type> <tag> <desc> <pre>]
+ [(def: #export (<name> json)
+ (Parser <type>)
+ (case json
+ (<tag> value)
+ (#;Right (<pre> value))
+
+ _
+ (#;Left (format "JSON value is not a " <desc> ": " (show-json json)))))]
+
+ [unit Unit #Null "null" id]
+ [bool Bool #Boolean "boolean" id]
+ [int Int #Number "number" real-to-int]
+ [real Real #Number "number" id]
+ [text Text #String "string" id]
+ )
+
+(do-template [<test> <check> <type> <eq> <codec> <tag> <desc> <pre>]
+ [(def: #export (<test> test json)
+ (-> <type> (Parser Bool))
+ (case json
+ (<tag> value)
+ (#;Right (:: <eq> = test (<pre> value)))
+
+ _
+ (#;Left (format "JSON value is not a " <desc> ": " (show-json json)))))
+
+ (def: #export (<check> test json)
+ (-> <type> (Parser Unit))
+ (case json
+ (<tag> value)
+ (let [value (<pre> value)]
+ (if (:: <eq> = test value)
+ (#;Right [])
+ (#;Left (format "Value mismatch: "
+ (:: <codec> encode test) "=/=" (:: <codec> encode value)))))
+
+ _
+ (#;Left (format "JSON value is not a " <desc> ": " (show-json json)))))]
+
+ [bool? bool! Bool bool;Eq<Bool> bool;Codec<Text,Bool> #Boolean "boolean" id]
+ [int? int! Int number;Eq<Int> number;Codec<Text,Int> #Number "number" real-to-int]
+ [real? real! Real number;Eq<Real> number;Codec<Text,Real> #Number "number" id]
+ [text? text! Text text;Eq<Text> text;Codec<Text,Text> #String "string" id]
+ )
+
+(def: #export (char json)
+ (Parser Char)
+ (case json
+ (#String input)
+ (case (Char/decode (format "#\"" input "\""))
+ (#;Right value)
+ (#;Right value)
+
+ (#;Left _)
+ (#;Left (format "Invalid format for char: " input)))
+
+ _
+ (#;Left (format "JSON value is not a " "string" ": " (show-json json)))))
+
+(def: #export (char? test json)
+ (-> Char (Parser Bool))
+ (case json
+ (#String input)
+ (case (Char/decode (format "#\"" input "\""))
+ (#;Right value)
+ (if (:: char;Eq<Char> = test value)
+ (#;Right true)
+ (#;Left (format "Value mismatch: "
+ (:: char;Codec<Text,Char> encode test) "=/=" (:: char;Codec<Text,Char> encode value))))
+
+ (#;Left _)
+ (#;Left (format "Invalid format for char: " input)))
+
+ _
+ (#;Left (format "JSON value is not a " "string" ": " (show-json json)))))
+
+(def: #export (char! test json)
+ (-> Char (Parser Unit))
+ (case json
+ (#String input)
+ (case (Char/decode (format "#\"" input "\""))
+ (#;Right value)
+ (if (:: char;Eq<Char> = test value)
+ (#;Right [])
+ (#;Left (format "Value mismatch: "
+ (:: char;Codec<Text,Char> encode test) "=/=" (:: char;Codec<Text,Char> encode value))))
+
+ (#;Left _)
+ (#;Left (format "Invalid format for char: " input)))
+
+ _
+ (#;Left (format "JSON value is not a " "string" ": " (show-json json)))))
+
+(def: #export (nullable parser)
+ (All [a] (-> (Parser a) (Parser (Maybe a))))
+ (lambda [json]
+ (case json
+ #Null
+ (#;Right #;None)
+
+ _
+ (case (parser json)
+ (#;Left error)
+ (#;Left error)
+
+ (#;Right value)
+ (#;Right (#;Some value)))
+ )))
+
+(def: #export (array parser)
+ (All [a] (-> (Parser a) (Parser (List a))))
+ (lambda [json]
+ (case json
+ (#Array values)
+ (do Monad<Error>
+ [elems (mapM @ parser (vector;vector-to-list values))]
+ (wrap elems))
+
+ _
+ (#;Left (format "JSON value is not an array: " (show-json json))))))
+
+(def: #export (object parser)
+ (All [a] (-> (Parser a) (Parser (Dict String a))))
+ (lambda [json]
+ (case json
+ (#Object fields)
+ (do Monad<Error>
+ [kvs (mapM @
+ (lambda [[key val']]
+ (do @
+ [val (parser val')]
+ (wrap [key val])))
+ (dict;entries fields))]
+ (wrap (dict;from-list text;Hash<Text> kvs)))
+
+ _
+ (#;Left (format "JSON value is not an object: " (show-json json))))))
+
+(def: #export (at idx parser)
+ (All [a] (-> Nat (Parser a) (Parser a)))
+ (lambda [json]
+ (case json
+ (#Array values)
+ (case (vector;at idx values)
+ (#;Some value)
+ (case (parser value)
+ (#;Right output)
+ (#;Right output)
+
+ (#;Left error)
+ (#;Left (format "JSON array index [" (%n idx) "]: (" error ") @ " (show-json json))))
+
+ #;None
+ (#;Left (format "JSON array does not have index " (%n idx) " @ " (show-json json))))
+
+ _
+ (#;Left (format "JSON value is not an array: " (show-json json))))))
+
+(def: #export (field field-name parser)
+ (All [a] (-> Text (Parser a) (Parser a)))
+ (lambda [json]
+ (case (get field-name json)
+ (#;Some value)
+ (case (parser value)
+ (#;Right output)
+ (#;Right output)
+
+ (#;Left error)
+ (#;Left (format "Failed to get JSON object field " (show-string field-name) ": (" error ") @ " (show-json json))))
+
+ (#;Left _)
+ (#;Left (format "JSON object does not have field " (show-string field-name) " @ " (show-json json))))))
+
+(def: #export any
+ (Parser JSON)
+ (lambda [json]
+ (#;Right json)))
+
+(def: #export (seq pa pb)
+ (All [a b] (-> (Parser a) (Parser b) (Parser [a b])))
+ (do Monad<Parser>
+ [=a pa
+ =b pb]
+ (wrap [=a =b])))
+
+(def: #export (alt pa pb json)
+ (All [a b] (-> (Parser a) (Parser b) (Parser (| a b))))
+ (case (pa json)
+ (#;Right a)
+ (sum;right (sum;left a))
+
+ (#;Left message0)
+ (case (pb json)
+ (#;Right b)
+ (sum;right (sum;right b))
+
+ (#;Left message1)
+ (#;Left message0))))
+
+(def: #export (either pl pr json)
+ (All [a] (-> (Parser a) (Parser a) (Parser a)))
+ (case (pl json)
+ (#;Right x)
+ (#;Right x)
+
+ _
+ (pr json)))
+
+(def: #export (opt p json)
+ (All [a]
+ (-> (Parser a) (Parser (Maybe a))))
+ (case (p json)
+ (#;Left _) (#;Right #;None)
+ (#;Right x) (#;Right (#;Some x))))
+
+(def: #export (run parser json)
+ (All [a] (-> (Parser a) JSON (Error a)))
+ (parser json))
+
+(def: #export (ensure test parser json)
+ (All [a] (-> (Parser Unit) (Parser a) (Parser a)))
+ (case (test json)
+ (#;Right _)
+ (parser json)
+
+ (#;Left error)
+ (#;Left error)))
+
+(def: #export (array-size! array-size json)
+ (-> Nat (Parser Unit))
+ (case json
+ (#Array parts)
+ (if (=+ array-size (vector;size parts))
+ (#;Right [])
+ (#;Left (format "JSON array does no have size " (%n array-size) " " (show-json json))))
+
+ _
+ (#;Left (format "JSON value is not an array: " (show-json json)))))
+
+(def: #export (object-fields! wanted-fields json)
+ (-> (List String) (Parser Unit))
+ (case json
+ (#Object kvs)
+ (let [actual-fields (dict;keys kvs)]
+ (if (and (=+ (list;size wanted-fields) (list;size actual-fields))
+ (list;every? (list;member? text;Eq<Text> wanted-fields)
+ actual-fields))
+ (#;Right [])
+ (#;Left (format "JSON object has wrong field-set. Expected: [" (text;join-with ", " wanted-fields) "]. Actual: [" (text;join-with ", " actual-fields) "]"))))
+
+ _
+ (#;Left (format "JSON value is not an object: " (show-json json)))))
+
+## [Structures]
+(struct: #export _ (Eq JSON)
+ (def: (= x y)
+ (case [x y]
+ [#Null #Null]
+ true
+
+ (^template [<tag> <struct>]
+ [(<tag> x') (<tag> y')]
+ (:: <struct> = x' y'))
+ ([#Boolean bool;Eq<Bool>]
+ [#Number number;Eq<Real>]
+ [#String text;Eq<Text>])
+
+ [(#Array xs) (#Array ys)]
+ (and (=+ (vector;size xs) (vector;size ys))
+ (fold (lambda [idx prev]
+ (and prev
+ (default false
+ (do Monad<Maybe>
+ [x' (vector;at idx xs)
+ y' (vector;at idx ys)]
+ (wrap (= x' y'))))))
+ true
+ (list;indices (vector;size xs))))
+
+ [(#Object xs) (#Object ys)]
+ (and (=+ (dict;size xs) (dict;size ys))
+ (fold (lambda [[xk xv] prev]
+ (and prev
+ (case (dict;get xk ys)
+ #;None false
+ (#;Some yv) (= xv yv))))
+ true
+ (dict;entries xs)))
+
+ _
+ false)))
+
+(struct: #export _ (Codec Text JSON)
+ (def: encode show-json)
+ (def: decode (lexer;run (json~' []))))
+
+## [Syntax]
+(type: Shape
+ (#ArrayShape (List AST))
+ (#ObjectShape (List [Text AST])))
+
+(def: _shape^
+ (syntax;Syntax Shape)
+ (syntax;alt (syntax;tuple (syntax;some syntax;any))
+ (syntax;record (syntax;some (syntax;seq syntax;text syntax;any)))))
+
+(syntax: #export (shape^ {shape _shape^})
+ (case shape
+ (#ArrayShape parts)
+ (let [array-size (list;size parts)
+ parsers (|> parts
+ (list;zip2 (list;indices array-size))
+ (List/map (lambda [[idx parser]]
+ (` (at (~ (ast;nat idx)) (~ parser))))))]
+ (wrap (list (` ($_ seq (~@ parsers))))))
+
+ (#ObjectShape kvs)
+ (let [fields (List/map product;left kvs)
+ parsers (List/map (lambda [[field-name parser]]
+ (` (field (~ (ast;text field-name)) (~ parser))))
+ kvs)]
+ (wrap (list (` ($_ seq (~@ parsers))))))
+ ))
+
+(syntax: #export (shape!^ {shape _shape^})
+ (case shape
+ (#ArrayShape parts)
+ (let [array-size (list;size parts)
+ parsers (|> parts
+ (list;zip2 (list;indices array-size))
+ (List/map (lambda [[idx parser]]
+ (` (at (~ (ast;nat idx)) (~ parser))))))]
+ (wrap (list (` (ensure (array-size! (~ (ast;nat array-size)))
+ ($_ seq (~@ parsers)))))))
+
+ (#ObjectShape kvs)
+ (let [fields (List/map product;left kvs)
+ parsers (List/map (lambda [[field-name parser]]
+ (` (field (~ (ast;text field-name)) (~ parser))))
+ kvs)]
+ (wrap (list (` (ensure (object-fields! (list (~@ (List/map ast;text fields))))
+ ($_ seq (~@ parsers)))))))
+ ))
+
+## [Polytypism]
+(def: #hidden _map_
+ (All [a b] (-> (-> a b) (List a) (List b)))
+ List/map)
+
+(poly: #export (|Codec@JSON//encode| *env* :x:)
+ (let [->Codec//encode (: (-> AST AST)
+ (lambda [.type.] (` (-> (~ .type.) JSON))))]
+ (let% [<basic> (do-template [<type> <matcher> <encoder>]
+ [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//encode (` <type>))) <encoder>))))]
+
+ [Unit poly;unit (lambda [(~ (ast;symbol ["" "0"]))] #Null)]
+ [Bool poly;bool ;;boolean]
+ [Int poly;int (|>. int-to-real ;;number)]
+ [Real poly;real ;;number]
+ [Char poly;char (|>. char;->Text ;;string)]
+ [Text poly;text ;;string])]
+ ($_ compiler;either
+ <basic>
+ (with-gensyms [g!type-fun g!case g!input g!key g!val]
+ (do @
+ [:sub: (poly;list :x:)
+ [g!vars members] (poly;tuple :sub:)
+ :val: (case members
+ (^ (list :key: :val:))
+ (do @ [_ (poly;text :key:)]
+ (wrap :val:))
+
+ _
+ (compiler;fail ""))
+ #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ .val. (|Codec@JSON//encode| new-*env* :val:)
+ #let [:x:+ (case g!vars
+ #;Nil
+ (->Codec//encode (type;type-to-ast :x:))
+
+ _
+ (` (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (List/map ->Codec//encode g!vars))
+ (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+ (wrap (` (: (~ :x:+)
+ (lambda [(~@ g!vars) (~ g!input)]
+ (|> (~ g!input)
+ (_map_ (: (-> [Text (~ (type;type-to-ast :val:))]
+ [Text JSON])
+ (lambda [[(~ g!key) (~ g!val)]]
+ [(~ g!key)
+ ((~ .val.) (~ g!val))])))
+ ;;object))
+ )))
+ ))
+ (do @
+ [:sub: (poly;maybe :x:)
+ .sub. (|Codec@JSON//encode| *env* :sub:)]
+ (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:)))
+ (;;nullable (~ .sub.))))))
+ (do @
+ [:sub: (poly;list :x:)
+ .sub. (|Codec@JSON//encode| *env* :sub:)]
+ (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:)))
+ (|>. (_map_ (~ .sub.)) vector;list-to-vector ;;array)))))
+ (with-gensyms [g!type-fun g!case g!input]
+ (do @
+ [[g!vars cases] (poly;variant :x:)
+ #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ pattern-matching (mapM @
+ (lambda [[name :case:]]
+ (do @
+ [#let [tag (ast;tag name)]
+ encoder (|Codec@JSON//encode| new-*env* :case:)]
+ (wrap (list (` ((~ tag) (~ g!case)))
+ (` (;;json [(~ (ast;text (product;right name)))
+ ((~ encoder) (~ g!case))]))))))
+ cases)
+ #let [:x:+ (case g!vars
+ #;Nil
+ (->Codec//encode (type;type-to-ast :x:))
+
+ _
+ (` (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (List/map ->Codec//encode g!vars))
+ (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+ (wrap (` (: (~ :x:+)
+ (lambda [(~@ g!vars) (~ g!input)]
+ (case (~ g!input)
+ (~@ (List/join pattern-matching))))
+ )))))
+ (with-gensyms [g!type-fun g!case g!input]
+ (do @
+ [[g!vars slots] (poly;record :x:)
+ #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ synthesis (mapM @
+ (lambda [[name :slot:]]
+ (do @
+ [encoder (|Codec@JSON//encode| new-*env* :slot:)]
+ (wrap [(` (~ (ast;text (product;right name))))
+ (` ((~ encoder) (get@ (~ (ast;tag name)) (~ g!input))))])))
+ slots)
+ #let [:x:+ (case g!vars
+ #;Nil
+ (->Codec//encode (type;type-to-ast :x:))
+
+ _
+ (` (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (List/map ->Codec//encode g!vars))
+ (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+ (wrap (` (: (~ :x:+)
+ (lambda [(~@ g!vars) (~ g!input)]
+ (;;json (~ (ast;record synthesis))))
+ )))))
+ (with-gensyms [g!type-fun g!case g!input]
+ (do @
+ [[g!vars members] (poly;tuple :x:)
+ #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ pattern-matching (mapM @
+ (lambda [:member:]
+ (do @
+ [g!member (compiler;gensym "g!member")
+ encoder (|Codec@JSON//encode| new-*env* :member:)]
+ (wrap [g!member encoder])))
+ members)
+ #let [:x:+ (case g!vars
+ #;Nil
+ (->Codec//encode (type;type-to-ast :x:))
+
+ _
+ (` (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (List/map ->Codec//encode g!vars))
+ (~ (->Codec//encode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]
+ #let [.tuple. (` [(~@ (List/map product;left pattern-matching))])]]
+ (wrap (` (: (~ :x:+)
+ (lambda [(~@ g!vars) (~ g!input)]
+ (case (~ g!input)
+ (~ .tuple.)
+ (;;array (list (~@ (List/map (lambda [[g!member g!encoder]]
+ (` ((~ g!encoder) (~ g!member))))
+ pattern-matching))))))
+ )))
+ ))
+ (do @
+ [[:func: :args:] (poly;apply :x:)
+ .func. (|Codec@JSON//encode| *env* :func:)
+ .args. (mapM @ (|Codec@JSON//encode| *env*) :args:)]
+ (wrap (` (: (~ (->Codec//encode (type;type-to-ast :x:)))
+ ((~ .func.) (~@ .args.))))))
+ (poly;bound *env* :x:)
+ (compiler;fail (format "Can't create JSON encoder for: " (type;type-to-text :x:)))
+ ))))
+
+(poly: #export (Codec<JSON,?>//decode *env* :x:)
+ (let [->Codec//decode (: (-> AST AST)
+ (lambda [.type.] (` (-> JSON (Error (~ .type.))))))]
+ (let% [<basic> (do-template [<type> <matcher> <decoder>]
+ [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//decode (` <type>))) <decoder>))))]
+
+ [Unit poly;unit ;;null]
+ [Bool poly;bool ;;bool]
+ [Int poly;int ;;int]
+ [Real poly;real ;;real]
+ [Char poly;char ;;char]
+ [Text poly;text ;;text])
+ <complex> (do-template [<type> <matcher> <decoder>]
+ [(do @
+ [:sub: (<matcher> :x:)
+ .sub. (Codec<JSON,?>//decode *env* :sub:)]
+ (wrap (` (: (~ (->Codec//decode (type;type-to-ast :x:)))
+ (<decoder> (~ .sub.))))))]
+
+ [Maybe poly;maybe ;;nullable]
+ [List poly;list ;;array])]
+ ($_ compiler;either
+ <basic>
+ (with-gensyms [g!type-fun g!case g!input g!key g!val]
+ (do @
+ [:sub: (poly;list :x:)
+ [g!vars members] (poly;tuple :sub:)
+ :val: (case members
+ (^ (list :key: :val:))
+ (do @ [_ (poly;text :key:)]
+ (wrap :val:))
+
+ _
+ (compiler;fail ""))
+ #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ .val. (Codec<JSON,?>//decode new-*env* :val:)
+ #let [:x:+ (case g!vars
+ #;Nil
+ (->Codec//decode (type;type-to-ast :x:))
+
+ _
+ (` (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (List/map ->Codec//decode g!vars))
+ (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+ (wrap (` (: (~ :x:+)
+ (lambda [(~@ g!vars) (~ g!input)]
+ (do Monad<Error>
+ [(~ g!key) (;;keys (~ g!input))]
+ (mapM (~ (' %))
+ (lambda [(~ g!key)]
+ (do Monad<Error>
+ [(~ g!val) (;;get (~ g!key) (~ g!input))
+ (~ g!val) (;;run (~ .val.) (~ g!val))]
+ ((~ (' wrap)) [(~ g!key) (~ g!val)])))
+ (~ g!key))))
+ )))
+ ))
+ <complex>
+ (with-gensyms [g!type-fun g!_]
+ (do @
+ [[g!vars cases] (poly;variant :x:)
+ #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ pattern-matching (mapM @
+ (lambda [[name :case:]]
+ (do @
+ [#let [tag (ast;tag name)]
+ decoder (Codec<JSON,?>//decode new-*env* :case:)]
+ (wrap (list (` (do Monad<Parser>
+ [(~ g!_) (;;at 0 (;;text! (~ (ast;text (product;right name)))))
+ (~ g!_) (;;at 1 (~ decoder))]
+ ((~ (' wrap)) ((~ tag) (~ g!_)))))))))
+ cases)
+ #let [:x:+ (case g!vars
+ #;Nil
+ (->Codec//decode (type;type-to-ast :x:))
+
+ _
+ (` (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (List/map ->Codec//decode g!vars))
+ (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))
+ base-parser (` ($_ ;;either
+ (~@ (List/join pattern-matching))))
+ parser (case g!vars
+ #;Nil
+ base-parser
+
+ _
+ (` (lambda [(~@ g!vars)] (~ base-parser))))]]
+ (wrap (` (: (~ :x:+) (~ parser))))
+ ))
+ (with-gensyms [g!type-fun g!case g!input]
+ (do @
+ [[g!vars slots] (poly;record :x:)
+ #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ extraction (mapM @
+ (lambda [[name :slot:]]
+ (do @
+ [#let [g!member (ast;symbol ["" (product;right name)])]
+ decoder (Codec<JSON,?>//decode new-*env* :slot:)]
+ (wrap (list g!member
+ (` (;;get (~ (ast;text (product;right name))) (~ g!input)))
+ g!member
+ (` ((~ decoder) (~ g!member)))))))
+ slots)
+ #let [:x:+ (case g!vars
+ #;Nil
+ (->Codec//decode (type;type-to-ast :x:))
+
+ _
+ (` (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (List/map ->Codec//decode g!vars))
+ (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]]
+ (wrap (` (: (~ :x:+)
+ (lambda [(~@ g!vars) (~ g!input)]
+ (do Monad<Error>
+ [(~@ (List/join extraction))]
+ ((~ (' wrap)) (~ (ast;record (List/map (lambda [[name :slot:]]
+ [(ast;tag name) (ast;symbol ["" (product;right name)])])
+ slots))))))
+ )))))
+ (with-gensyms [g!type-fun g!case g!input]
+ (do @
+ [[g!vars members] (poly;tuple :x:)
+ #let [new-*env* (poly;extend-env g!type-fun g!vars *env*)]
+ pattern-matching (mapM @
+ (lambda [:member:]
+ (do @
+ [g!member (compiler;gensym "g!member")
+ decoder (Codec<JSON,?>//decode new-*env* :member:)]
+ (wrap [g!member decoder])))
+ members)
+ #let [:x:+ (case g!vars
+ #;Nil
+ (->Codec//decode (type;type-to-ast :x:))
+
+ _
+ (` (All (~ g!type-fun) [(~@ g!vars)]
+ (-> (~@ (List/map ->Codec//decode g!vars))
+ (~ (->Codec//decode (` ((~ (type;type-to-ast :x:)) (~@ g!vars)))))))))]
+ #let [.decoder. (case g!vars
+ #;Nil
+ (` (;;shape^ [(~@ (List/map product;right pattern-matching))]))
+
+ _
+ (` (lambda [(~@ g!vars)]
+ (;;shape^ [(~@ (List/map product;right pattern-matching))]))))]]
+ (wrap (` (: (~ :x:+) (~ .decoder.))))
+ ))
+ (do @
+ [[:func: :args:] (poly;apply :x:)
+ .func. (Codec<JSON,?>//decode *env* :func:)
+ .args. (mapM @ (Codec<JSON,?>//decode *env*) :args:)]
+ (wrap (` (: (~ (->Codec//decode (type;type-to-ast :x:)))
+ ((~ .func.) (~@ .args.))))))
+ (do @
+ [g!bound (poly;bound *env* :x:)]
+ (wrap g!bound))
+ (compiler;fail (format "Can't create JSON decoder for: " (type;type-to-text :x:)))
+ ))))
+
+(syntax: #export (Codec<JSON,?> :x:)
+ (wrap (list (` (: (Codec JSON (~ :x:))
+ (struct
+ (def: (~ (' encode)) (|Codec@JSON//encode| (~ :x:)))
+ (def: (~ (' decode)) (Codec<JSON,?>//decode (~ :x:)))
+ ))))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 04:21:59 +0000