aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/data/format/json.lux910
-rw-r--r--stdlib/source/lux/data/format/json/codec.lux536
-rw-r--r--stdlib/source/lux/data/format/json/reader.lux177
-rw-r--r--stdlib/source/lux/data/text/format.lux5
-rw-r--r--stdlib/test/test/lux/data/format/json.lux69
5 files changed, 769 insertions, 928 deletions
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
index c4951f188..379e3b23b 100644
--- a/stdlib/source/lux/data/format/json.lux
+++ b/stdlib/source/lux/data/format/json.lux
@@ -1,4 +1,4 @@
-(;module: {#;doc "Functionality for reading, generating and processing values in the JSON format.
+(;module: {#;doc "Functionality for generating and processing values in the JSON format.
For more information, please see: http://www.json.org/"}
lux
@@ -51,20 +51,15 @@
[Object (d;Dict String JSON)]
)
-(type: #export (Parser a)
- {#;doc "JSON parsers."}
- (-> JSON (R;Result a)))
-
-(type: #export (Gen a)
- {#;doc "JSON generators."}
- (-> a JSON))
+(type: #export (Reader a)
+ {#;doc "JSON reader."}
+ (p;Parser (List JSON) a))
## [Syntax]
(syntax: #export (json token)
- {#;doc (doc "A way to produce JSON literals."
+ {#;doc (doc "A simple way to produce JSON literals."
(json true)
- (json 123)
- (json 456.78)
+ (json 123.456)
(json "Some text")
(json #null)
(json ["this" "is" "an" "array"])
@@ -77,7 +72,6 @@
[_ (<ast-tag> value)]
(wrap (list (` (: JSON (<json-tag> (~ (<ctor> value))))))))
([#;Bool code;bool #Boolean]
- [#;Int (|>. int-to-real code;real) #Number]
[#;Real code;real #Number]
[#;Text code;text #String])
@@ -104,44 +98,6 @@
(wrap (list token))
)))
-## [Values]
-(def: #hidden (show-null _) (-> Null Text) "null")
-(do-template [<name> <type> <codec>]
- [(def: <name> (-> <type> Text) <codec>)]
-
- [show-boolean Boolean (:: bool;Codec<Text,Bool> encode)]
- [show-number Number (:: number;Codec<Text,Real> encode)]
- [show-string String text;encode])
-
-(def: (show-array show-json elems)
- (-> (-> JSON Text) (-> Array Text))
- ($_ text/append "["
- (|> elems (Vector/map show-json) vector;to-list (text;join-with ","))
- "]"))
-
-(def: (show-object show-json object)
- (-> (-> JSON Text) (-> Object Text))
- ($_ text/append "{"
- (|> object
- d;entries
- (L/map (function [[key value]] ($_ text/append (show-string 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
{#;doc "The null JSON value."}
JSON
@@ -167,10 +123,10 @@
(#R;Success value)
#;None
- (#R;Error ($_ text/append "Missing field " (show-string key) " on object.")))
+ (#R;Error ($_ text/append "Missing field \"" key "\" on object.")))
_
- (#R;Error ($_ text/append "Cannot get field " (show-string key) " of a non-object."))))
+ (#R;Error ($_ text/append "Cannot get field \"" key "\" of a non-object."))))
(def: #export (set key value json)
{#;doc "A JSON object field setter."}
@@ -180,7 +136,7 @@
(#R;Success (#Object (d;put key value obj)))
_
- (#R;Error ($_ text/append "Cannot set field " (show-string key) " of a non-object."))))
+ (#R;Error ($_ text/append "Cannot set field \"" key "\" of a non-object."))))
(do-template [<name> <tag> <type> <desc>]
[(def: #export (<name> key json)
@@ -191,7 +147,7 @@
(#R;Success value)
(#R;Success _)
- (#R;Error ($_ text/append "Wrong value type at key " (show-string key)))
+ (#R;Error ($_ text/append "Wrong value type at key: " key))
(#R;Error error)
(#R;Error error)))]
@@ -206,404 +162,24 @@
(do-template [<name> <type> <tag> <desc>]
[(def: #export (<name> value)
{#;doc (#;TextA ($_ text/append "A JSON generator for " <desc> "."))}
- (Gen <type>)
+ (-> <type> JSON)
(<tag> value))]
- [gen-boolean Boolean #Boolean "booleans"]
- [gen-number Number #Number "numbers"]
- [gen-string String #String "strings"]
- [gen-array Array #Array "arrays"]
- [gen-object Object #Object "objects"]
+ [boolean Boolean #Boolean "booleans"]
+ [number Number #Number "numbers"]
+ [string String #String "strings"]
+ [array Array #Array "arrays"]
+ [object Object #Object "objects"]
)
-(def: #export (gen-nullable gen)
+(def: #export (nullable writer)
{#;doc "Builds a JSON generator for potentially inexistent values."}
- (All [a] (-> (Gen a) (Gen (Maybe a))))
+ (All [a] (-> (-> a JSON) (-> (Maybe a) JSON)))
(function [elem]
(case elem
#;None #Null
- (#;Some value) (gen value))))
-
-## Lexers
-(def: space~
- (l;Lexer Text)
- (l;some l;space))
-
-(def: data-sep
- (l;Lexer [Text Unit Text])
- ($_ p;seq space~ (l;this ",") space~))
-
-(def: null~
- (l;Lexer Null)
- (do p;Monad<Parser>
- [_ (l;this "null")]
- (wrap [])))
-
-(do-template [<name> <token> <value>]
- [(def: <name>
- (l;Lexer Boolean)
- (do p;Monad<Parser>
- [_ (l;this <token>)]
- (wrap <value>)))]
-
- [t~ "true" true]
- [f~ "false" false]
- )
-
-(def: boolean~
- (l;Lexer Boolean)
- (p;either t~ f~))
-
-(def: number~
- (l;Lexer Number)
- (do p;Monad<Parser>
- [signed? (l;this? "-")
- digits (l;many l;decimal)
- decimals (p;default "0"
- (do @
- [_ (l;this ".")]
- (l;many l;decimal)))
- exp (p;default ""
- (do @
- [mark (l;one-of "eE")
- signed?' (l;this? "-")
- offset (l;many l;decimal)]
- (wrap ($_ text/append mark (if signed?' "-" "") offset))))]
- (case (real/decode ($_ text/append (if signed? "-" "") digits "." decimals exp))
- (#R;Error message)
- (p;fail message)
-
- (#R;Success value)
- (wrap value))))
-
-(def: escaped~
- (l;Lexer Text)
- ($_ p;either
- (p;after (l;this "\\t") (p/wrap "\t"))
- (p;after (l;this "\\b") (p/wrap "\b"))
- (p;after (l;this "\\n") (p/wrap "\n"))
- (p;after (l;this "\\r") (p/wrap "\r"))
- (p;after (l;this "\\f") (p/wrap "\f"))
- (p;after (l;this "\\\"") (p/wrap "\""))
- (p;after (l;this "\\\\") (p/wrap "\\"))))
-
-(def: string~
- (l;Lexer String)
- (<| (l;enclosed ["\"" "\""])
- (loop [_ []]
- (do p;Monad<Parser>
- [chars (l;some (l;none-of "\\\""))
- stop l;peek]
- (if (text/= "\\" stop)
- (do @
- [escaped escaped~
- next-chars (recur [])]
- (wrap ($_ text/append chars escaped next-chars)))
- (wrap chars))))))
-
-(def: (kv~ json~)
- (-> (-> Unit (l;Lexer JSON)) (l;Lexer [String JSON]))
- (do p;Monad<Parser>
- [key string~
- _ space~
- _ (l;this ":")
- _ space~
- value (json~ [])]
- (wrap [key value])))
-
-(do-template [<name> <type> <open> <close> <elem-parser> <prep>]
- [(def: (<name> json~)
- (-> (-> Unit (l;Lexer JSON)) (l;Lexer <type>))
- (do p;Monad<Parser>
- [_ (l;this <open>)
- _ space~
- elems (p;sep-by data-sep <elem-parser>)
- _ space~
- _ (l;this <close>)]
- (wrap (<prep> elems))))]
-
- [array~ Array "[" "]" (json~ []) vector;from-list]
- [object~ Object "{" "}" (kv~ json~) (d;from-list text;Hash<Text>)]
- )
-
-(def: (json~' _)
- (-> Unit (l;Lexer JSON))
- ($_ p;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~')))
-
-## [Structures]
-(struct: #export _ (Functor Parser)
- (def: (map f ma)
- (function [json]
- (case (ma json)
- (#R;Error msg)
- (#R;Error msg)
-
- (#R;Success a)
- (#R;Success (f a))))))
-
-(struct: #export _ (Applicative Parser)
- (def: functor Functor<Parser>)
-
- (def: (wrap x json)
- (#R;Success x))
-
- (def: (apply ff fa)
- (function [json]
- (case (ff json)
- (#R;Success f)
- (case (fa json)
- (#R;Success a)
- (#R;Success (f a))
-
- (#R;Error msg)
- (#R;Error msg))
-
- (#R;Error msg)
- (#R;Error msg)))))
-
-(struct: #export _ (Monad Parser)
- (def: applicative Applicative<Parser>)
-
- (def: (join mma)
- (function [json]
- (case (mma json)
- (#R;Error msg)
- (#R;Error msg)
-
- (#R;Success ma)
- (ma json)))))
-
-## [Values]
-## Syntax
-(do-template [<name> <type> <tag> <desc> <pre>]
- [(def: #export (<name> json)
- {#;doc (#;TextA ($_ text/append "Reads a JSON value as " <desc> "."))}
- (Parser <type>)
- (case json
- (<tag> value)
- (#R;Success (<pre> value))
-
- _
- (#R;Error ($_ text/append "JSON value is not " <desc> ": " (show-json json)))))]
-
- [unit Unit #Null "unit" id]
- [bool Bool #Boolean "bool" id]
- [int Int #Number "int" real-to-int]
- [real Real #Number "real" id]
- [text Text #String "text" id]
- )
-
-(do-template [<test> <check> <type> <eq> <encoder> <tag> <desc> <pre>]
- [(def: #export (<test> test json)
- {#;doc (#;TextA ($_ text/append "Asks whether a JSON value is a " <desc> "."))}
- (-> <type> (Parser Bool))
- (case json
- (<tag> value)
- (#R;Success (:: <eq> = test (<pre> value)))
-
- _
- (#R;Error ($_ text/append "JSON value is not a " <desc> ": " (show-json json)))))
-
- (def: #export (<check> test json)
- {#;doc (#;TextA ($_ text/append "Ensures a JSON value is a " <desc> "."))}
- (-> <type> (Parser Unit))
- (case json
- (<tag> value)
- (let [value (<pre> value)]
- (if (:: <eq> = test value)
- (#R;Success [])
- (#R;Error ($_ text/append "Value mismatch: "
- (<encoder> test) "=/=" (<encoder> value)))))
-
- _
- (#R;Error ($_ text/append "JSON value is not a " <desc> ": " (show-json json)))))]
-
- [bool? bool! Bool bool;Eq<Bool> (:: bool;Codec<Text,Bool> encode) #Boolean "boolean" id]
- [int? int! Int number;Eq<Int> (:: number;Codec<Text,Int> encode) #Number "number" real-to-int]
- [real? real! Real number;Eq<Real> (:: number;Codec<Text,Real> encode) #Number "number" id]
- [text? text! Text text;Eq<Text> text;encode #String "string" id]
- )
-
-(def: #export (nullable parser)
- {#;doc "A parser that can handle the presence of null values."}
- (All [a] (-> (Parser a) (Parser (Maybe a))))
- (function [json]
- (case json
- #Null
- (#R;Success #;None)
-
- _
- (case (parser json)
- (#R;Error error)
- (#R;Error error)
-
- (#R;Success value)
- (#R;Success (#;Some value)))
- )))
-
-(def: #export (array parser)
- {#;doc "Parses a JSON array, assuming that every element can be parsed the same way."}
- (All [a] (-> (Parser a) (Parser (List a))))
- (function [json]
- (case json
- (#Array values)
- (do R;Monad<Result>
- [elems (M;map @ parser (vector;to-list values))]
- (wrap elems))
-
- _
- (#R;Error ($_ text/append "JSON value is not an array: " (show-json json))))))
-
-(def: #export (object parser)
- {#;doc "Parses a JSON object, assuming that every field's value can be parsed the same way."}
- (All [a] (-> (Parser a) (Parser (d;Dict String a))))
- (function [json]
- (case json
- (#Object fields)
- (do R;Monad<Result>
- [kvs (M;map @
- (function [[key val']]
- (do @
- [val (parser val')]
- (wrap [key val])))
- (d;entries fields))]
- (wrap (d;from-list text;Hash<Text> kvs)))
-
- _
- (#R;Error ($_ text/append "JSON value is not an object: " (show-json json))))))
+ (#;Some value) (writer value))))
-(def: #export (nth idx parser)
- {#;doc "Parses an element inside a JSON array."}
- (All [a] (-> Nat (Parser a) (Parser a)))
- (function [json]
- (case json
- (#Array values)
- (case (vector;nth idx values)
- (#;Some value)
- (case (parser value)
- (#R;Success output)
- (#R;Success output)
-
- (#R;Error error)
- (#R;Error ($_ text/append "JSON array index [" (nat/encode idx) "]: (" error ") @ " (show-json json))))
-
- #;None
- (#R;Error ($_ text/append "JSON array does not have index " (nat/encode idx) " @ " (show-json json))))
-
- _
- (#R;Error ($_ text/append "JSON value is not an array: " (show-json json))))))
-
-(def: #export (field field-name parser)
- {#;doc "Parses a field inside a JSON object."}
- (All [a] (-> Text (Parser a) (Parser a)))
- (function [json]
- (case (get field-name json)
- (#;Some value)
- (case (parser value)
- (#R;Success output)
- (#R;Success output)
-
- (#R;Error error)
- (#R;Error ($_ text/append "Failed to get JSON object field " (show-string field-name) ": (" error ") @ " (show-json json))))
-
- (#R;Error _)
- (#R;Error ($_ text/append "JSON object does not have field " (show-string field-name) " @ " (show-json json))))))
-
-(def: #export any
- {#;doc "Just returns the JSON input without applying any logic."}
- (Parser JSON)
- (function [json]
- (#R;Success json)))
-
-(def: #export (seq pa pb)
- {#;doc "Sequencing combinator."}
- (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)
- {#;doc "Heterogeneous alternative combinator."}
- (All [a b] (-> (Parser a) (Parser b) (Parser (| a b))))
- (function [json]
- (case (pa json)
- (#R;Success a)
- (sum;right (sum;left a))
-
- (#R;Error message0)
- (case (pb json)
- (#R;Success b)
- (sum;right (sum;right b))
-
- (#R;Error message1)
- (#R;Error message0)))))
-
-(def: #export (either pl pr)
- {#;doc "Homogeneous alternative combinator."}
- (All [a] (-> (Parser a) (Parser a) (Parser a)))
- (function [json]
- (case (pl json)
- (#R;Success x)
- (#R;Success x)
-
- _
- (pr json))))
-
-(def: #export (opt p)
- {#;doc "Optionality combinator."}
- (All [a]
- (-> (Parser a) (Parser (Maybe a))))
- (function [json]
- (case (p json)
- (#R;Error _) (#R;Success #;None)
- (#R;Success x) (#R;Success (#;Some x)))))
-
-(def: #export (run json parser)
- (All [a] (-> JSON (Parser a) (R;Result a)))
- (parser json))
-
-(def: #export (ensure test parser)
- {#;doc "Only parses a JSON if it passes a test (which is also a parser)."}
- (All [a] (-> (Parser Unit) (Parser a) (Parser a)))
- (function [json]
- (case (test json)
- (#R;Success _)
- (parser json)
-
- (#R;Error error)
- (#R;Error error))))
-
-(def: #export (array-size! size)
- {#;doc "Ensures a JSON array has the specified size."}
- (-> Nat (Parser Unit))
- (function [json]
- (case json
- (#Array parts)
- (if (n.= size (vector;size parts))
- (#R;Success [])
- (#R;Error ($_ text/append "JSON array does no have size " (nat/encode size) " " (show-json json))))
-
- _
- (#R;Error ($_ text/append "JSON value is not an array: " (show-json json))))))
-
-(def: #export (object-fields! wanted-fields)
- {#;doc "Ensures that every field in the list of wanted-fields is present in a JSON object."}
- (-> (List String) (Parser Unit))
- (function [json]
- (case json
- (#Object kvs)
- (let [actual-fields (d;keys kvs)]
- (if (and (n.= (list;size wanted-fields) (list;size actual-fields))
- (list;every? (list;member? text;Eq<Text> wanted-fields)
- actual-fields))
- (#R;Success [])
- (#R;Error ($_ text/append "JSON object has wrong field-set. Expected: [" (text;join-with ", " wanted-fields) "]. Actual: [" (text;join-with ", " actual-fields) "]"))))
-
- _
- (#R;Error ($_ text/append "JSON value is not an object: " (show-json json))))))
-
-## [Structures]
(struct: #export _ (Eq JSON)
(def: (= x y)
(case [x y]
@@ -641,451 +217,3 @@
_
false)))
-
-(struct: #export _ (Codec Text JSON)
- (def: encode show-json)
- (def: decode (function [input] (l;run input (json~' [])))))
-
-## [Syntax]
-(type: Shape
- (#ArrayShape (List Code))
- (#ObjectShape (List [Text Code])))
-
-(def: _shape^
- (s;Syntax Shape)
- (p;alt (s;tuple (p;some s;any))
- (s;record (p;some (p;seq s;text s;any)))))
-
-(syntax: #export (shape [shape _shape^])
- {#;doc (doc "Builds a parser that ensures the (inclusive) shape of an array or object."
- (shape [bool! int! real!])
- (shape {"isAlive" bool!
- "age" int!
- "income" real!}))}
- (case shape
- (#ArrayShape parts)
- (let [array-size (list;size parts)
- parsers (|> parts
- (list;zip2 (list;indices array-size))
- (L/map (function [[idx parser]]
- (` (nth (~ (code;nat idx)) (~ parser))))))]
- (wrap (list (` ($_ seq (~@ parsers))))))
-
- (#ObjectShape kvs)
- (let [fields (L/map product;left kvs)
- parsers (L/map (function [[field-name parser]]
- (` (field (~ (code;text field-name)) (~ parser))))
- kvs)]
- (wrap (list (` ($_ seq (~@ parsers))))))
- ))
-
-(syntax: #export (shape! [shape _shape^])
- {#;doc (doc "Builds a parser that ensures the (exclusive) shape of an array or object."
- (shape! [bool! int! real!])
- (shape! {"isAlive" bool!
- "age" int!
- "income" real!}))}
- (case shape
- (#ArrayShape parts)
- (let [array-size (list;size parts)
- parsers (|> parts
- (list;zip2 (list;indices array-size))
- (L/map (function [[idx parser]]
- (` (nth (~ (code;nat idx)) (~ parser))))))]
- (wrap (list (` (ensure (array-size! (~ (code;nat array-size)))
- ($_ seq (~@ parsers)))))))
-
- (#ObjectShape kvs)
- (let [fields (L/map product;left kvs)
- parsers (L/map (function [[field-name parser]]
- (` (field (~ (code;text field-name)) (~ parser))))
- kvs)]
- (wrap (list (` (ensure (object-fields! (list (~@ (L/map code;text fields))))
- ($_ seq (~@ parsers)))))))
- ))
-
-## [Polytypism]
-(def: #hidden _map_
- (All [a b] (-> (-> a b) (List a) (List b)))
- L/map)
-
-(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
- [<basic> (do-template [<type> <matcher> <encoder>]
- [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//encode (` <type>))) <encoder>))))]
-
- [Unit poly;unit (function [(~ (code;symbol ["" "0"]))] #Null)]
- [Bool poly;bool ;;gen-boolean]
- [Int poly;int (|>. ;int-to-real ;;gen-number)]
- [Real poly;real ;;gen-number]
- [Text poly;text ;;gen-string])]
- ($_ macro;either
- <basic>
- (with-gensyms [g!input g!key g!val]
- (do @
- [[:key: :val:] (poly;apply-2 (ident-for d;Dict) :x:)
- _ (poly;text :key:)
- .val. (Codec<JSON,?>//encode env :val:)]
- (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
- (function [(~ g!input)]
- (|> (~ g!input)
- d;entries
- (;;_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 (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 (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 (M;map @
- (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)]
- 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))]))
- )))
- ))
- ## 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. (M;map @ (Codec<JSON,?>//encode env) :args:)]
- (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
- ((~ .func.) (~@ .args.))))))
- ## Bound type-vars
- (poly;bound env :x:)
- ## If all else fails...
- (macro;fail ($_ text/append "Cannot create JSON encoder for: " (type;to-text :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
- [<basic> (do-template [<type> <matcher> <decoder>]
- [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//decode (` <type>))) <decoder>))))]
-
- [Unit poly;unit ;;unit]
- [Bool poly;bool ;;bool]
- [Int poly;int ;;int]
- [Real poly;real ;;real]
- [Text poly;text ;;text])
- <complex> (do-template [<type> <matcher> <decoder>]
- [(do @
- [:sub: (<matcher> :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]
- [List (poly;apply-1 (ident-for ;List)) ;;array])]
- ($_ macro;either
- <basic>
- (with-gensyms [g!input g!output g!key g!val]
- (do @
- [[:key: :val:] (poly;apply-2 (ident-for d;Dict) :x:)
- _ (poly;text :key:)
- .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))
- (~ g!output) (M;map R;Monad<Result>
- (function [(~ g!key)]
- (do R;Monad<Result>
- [(~ g!val) (;;get (~ g!key) (~ g!input))
- (~ g!val) (;;run (~ g!val) (~ .val.))]
- ((~ (' wrap)) [(~ g!key) (~ g!val)])))
- (~ g!key))]
- ((~' wrap) (d;from-list text;Hash<Text> (~ g!output)))))
- )))
- ))
- <complex>
- (with-gensyms [g!type-fun g!case g!input g!_]
- (do @
- [members (poly;sum+ :x:)
- pattern-matching (M;map @
- (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)]
- pattern-matching (M;map @
- (function [[name :case:]]
- (do @
- [#let [tag (code;tag name)]
- 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))]
- ((~ (' wrap)) ((~ tag) (~ g!_)))))))))
- 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 (` ($_ ;;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 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)]
- extraction (M;map @
- (function [[name :slot:]]
- (do @
- [#let [g!member (code;symbol ["" (product;right name)])]
- decoder (Codec<JSON,?>//decode new-env :slot:)]
- (wrap (list g!member
- (` (;;get (~ (code;text (product;right name))) (~ g!input)))
- g!member
- (` ((~ decoder) (~ g!member)))))))
- 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)))))))))]]
- (wrap (` (: (~ :x:+)
- (function [(~@ g!vars) (~ g!input)]
- (do R;Monad<Result>
- [(~@ (L/join extraction))]
- ((~ (' wrap)) (~ (code;record (L/map (function [[name :slot:]]
- [(code;tag name) (code;symbol ["" (product;right name)])])
- members))))))
- )))))
- (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)]
- pattern-matching (M;map @
- (function [:member:]
- (do @
- [g!member (macro;gensym "g!member")
- decoder (Codec<JSON,?>//decode new-env :member:)]
- (wrap [g!member 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)))))))))]
- #let [.decoder. (case g!vars
- #;Nil
- (` (;;shape [(~@ (L/map product;right pattern-matching))]))
-
- _
- (` (function [(~@ g!vars)]
- (;;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. (M;map @ (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:)]
- (wrap g!bound))
- ## If all else fails...
- (macro;fail ($_ text/append "Cannot create JSON decoder for: " (type;to-text :x:)))
- ))))
-
-(syntax: #export (Codec<JSON,?> :x:)
- {#;doc (doc "A macro for automatically producing JSON codecs."
- (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]
- #dict (Dict Text Int)})
-
- (derived: (Codec<JSON,?> Record)))}
- (wrap (list (` (: (Codec JSON (~ :x:))
- (struct (def: (~ (' encode)) (Codec<JSON,?>//encode (~ :x:)))
- (def: (~ (' decode)) (Codec<JSON,?>//decode (~ :x:)))
- ))))))
diff --git a/stdlib/source/lux/data/format/json/codec.lux b/stdlib/source/lux/data/format/json/codec.lux
new file mode 100644
index 000000000..2bd298419
--- /dev/null
+++ b/stdlib/source/lux/data/format/json/codec.lux
@@ -0,0 +1,536 @@
+(;module: {#;doc "Codecs for values in the JSON format.
+
+ For more information, please see: http://www.json.org/"}
+ lux
+ (lux (control functor
+ applicative
+ ["M" monad #+ do Monad]
+ [eq #+ Eq]
+ codec
+ ["p" parser "p/" Monad<Parser>])
+ (data [bool]
+ [text "text/" Eq<Text> Monoid<Text>]
+ (text ["l" lexer])
+ [number "real/" Codec<Text,Real> "nat/" Codec<Text,Nat>]
+ maybe
+ ["R" result]
+ [sum]
+ [product]
+ (coll [list "L/" Fold<List> Monad<List>]
+ [vector #+ Vector vector "Vector/" Monad<Vector>]
+ ["d" dict]))
+ [macro #+ Monad<Lux> with-gensyms]
+ (macro ["s" syntax #+ syntax:]
+ [code]
+ [poly #+ poly:])
+ [type]
+ )
+ [.. #+ JSON]
+ [../reader])
+
+## [Values]
+(def: #hidden (show-null _) (-> ..;Null Text) "null")
+(do-template [<name> <type> <codec>]
+ [(def: <name> (-> <type> Text) <codec>)]
+
+ [show-boolean ..;Boolean (:: bool;Codec<Text,Bool> encode)]
+ [show-number ..;Number (:: number;Codec<Text,Real> encode)]
+ [show-string ..;String text;encode])
+
+(def: (show-array show-json elems)
+ (-> (-> JSON Text) (-> ..;Array Text))
+ ($_ text/append "["
+ (|> elems (Vector/map show-json) vector;to-list (text;join-with ","))
+ "]"))
+
+(def: (show-object show-json object)
+ (-> (-> JSON Text) (-> ..;Object Text))
+ ($_ text/append "{"
+ (|> object
+ d;entries
+ (L/map (function [[key value]] ($_ text/append (show-string 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: space~
+ (l;Lexer Text)
+ (l;some l;space))
+
+(def: data-sep
+ (l;Lexer [Text Unit Text])
+ ($_ p;seq space~ (l;this ",") space~))
+
+(def: null~
+ (l;Lexer ..;Null)
+ (do p;Monad<Parser>
+ [_ (l;this "null")]
+ (wrap [])))
+
+(do-template [<name> <token> <value>]
+ [(def: <name>
+ (l;Lexer ..;Boolean)
+ (do p;Monad<Parser>
+ [_ (l;this <token>)]
+ (wrap <value>)))]
+
+ [t~ "true" true]
+ [f~ "false" false]
+ )
+
+(def: boolean~
+ (l;Lexer ..;Boolean)
+ (p;either t~ f~))
+
+(def: number~
+ (l;Lexer ..;Number)
+ (do p;Monad<Parser>
+ [signed? (l;this? "-")
+ digits (l;many l;decimal)
+ decimals (p;default "0"
+ (do @
+ [_ (l;this ".")]
+ (l;many l;decimal)))
+ exp (p;default ""
+ (do @
+ [mark (l;one-of "eE")
+ signed?' (l;this? "-")
+ offset (l;many l;decimal)]
+ (wrap ($_ text/append mark (if signed?' "-" "") offset))))]
+ (case (real/decode ($_ text/append (if signed? "-" "") digits "." decimals exp))
+ (#R;Error message)
+ (p;fail message)
+
+ (#R;Success value)
+ (wrap value))))
+
+(def: escaped~
+ (l;Lexer Text)
+ ($_ p;either
+ (p;after (l;this "\\t") (p/wrap "\t"))
+ (p;after (l;this "\\b") (p/wrap "\b"))
+ (p;after (l;this "\\n") (p/wrap "\n"))
+ (p;after (l;this "\\r") (p/wrap "\r"))
+ (p;after (l;this "\\f") (p/wrap "\f"))
+ (p;after (l;this "\\\"") (p/wrap "\""))
+ (p;after (l;this "\\\\") (p/wrap "\\"))))
+
+(def: string~
+ (l;Lexer ..;String)
+ (<| (l;enclosed ["\"" "\""])
+ (loop [_ []]
+ (do p;Monad<Parser>
+ [chars (l;some (l;none-of "\\\""))
+ stop l;peek]
+ (if (text/= "\\" stop)
+ (do @
+ [escaped escaped~
+ next-chars (recur [])]
+ (wrap ($_ text/append chars escaped next-chars)))
+ (wrap chars))))))
+
+(def: (kv~ json~)
+ (-> (-> Unit (l;Lexer JSON)) (l;Lexer [..;String JSON]))
+ (do p;Monad<Parser>
+ [key string~
+ _ space~
+ _ (l;this ":")
+ _ space~
+ value (json~ [])]
+ (wrap [key value])))
+
+(do-template [<name> <type> <open> <close> <elem-parser> <prep>]
+ [(def: (<name> json~)
+ (-> (-> Unit (l;Lexer JSON)) (l;Lexer <type>))
+ (do p;Monad<Parser>
+ [_ (l;this <open>)
+ _ space~
+ elems (p;sep-by data-sep <elem-parser>)
+ _ space~
+ _ (l;this <close>)]
+ (wrap (<prep> elems))))]
+
+ [array~ ..;Array "[" "]" (json~ []) vector;from-list]
+ [object~ ..;Object "{" "}" (kv~ json~) (d;from-list text;Hash<Text>)]
+ )
+
+(def: (json~' _)
+ (-> Unit (l;Lexer JSON))
+ ($_ p;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~')))
+
+(struct: #export _ (Codec Text JSON)
+ (def: encode show-json)
+ (def: decode (function [input] (l;run input (json~' [])))))
+
+## [Polytypism]
+(def: #hidden _map_
+ (All [a b] (-> (-> a b) (List a) (List b)))
+ L/map)
+
+(def: tag
+ (-> Nat Real)
+ (|>. nat-to-int int-to-real))
+
+(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
+ [<basic> (do-template [<type> <matcher> <encoder>]
+ [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//encode (` <type>))) <encoder>))))]
+
+ [Unit poly;unit (function [(~ (code;symbol ["" "0"]))] #..;Null)]
+ [Bool poly;bool ..;boolean]
+ [Real poly;real ..;number]
+ [Text poly;text ..;string])]
+ ($_ macro;either
+ <basic>
+ (with-gensyms [g!input g!key g!val]
+ (do @
+ [[:key: :val:] (poly;apply-2 (ident-for d;Dict) :x:)
+ _ (poly;text :key:)
+ .val. (Codec<JSON,?>//encode env :val:)]
+ (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
+ (function [(~ g!input)]
+ (|> (~ g!input)
+ d;entries
+ (;;_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 (poly;to-ast env :x:)))
+ (..;nullable (~ .sub.))))))
+ (do @
+ [:sub: (poly;apply-1 (ident-for ;List) :x:)
+ .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]
+ (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)))
+ (` (..;json [(~ (code;real (;;tag 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)]
+ 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))]))
+ )))
+ ))
+ ## 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. (M;map @ (Codec<JSON,?>//encode env) :args:)]
+ (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
+ ((~ .func.) (~@ .args.))))))
+ ## Bound type-vars
+ (poly;bound env :x:)
+ ## If all else fails...
+ (macro;fail ($_ text/append "Cannot create JSON encoder for: " (type;to-text :x:)))
+ ))))
+
+(poly: #hidden (Codec<JSON,?>//decode env :x:)
+ (let [->Codec//decode (: (-> Code Code)
+ (function [.type.] (` (..;Reader (~ .type.)))))]
+ (with-expansions
+ [<basic> (do-template [<type> <matcher> <decoder>]
+ [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//decode (` <type>))) <decoder>))))]
+
+ [Unit poly;unit ../reader;null]
+ [Bool poly;bool ../reader;boolean]
+ [Real poly;real ../reader;number]
+ [Text poly;text ../reader;string])]
+ ($_ macro;either
+ <basic>
+ (do @
+ [[:key: :val:] (poly;apply-2 (ident-for d;Dict) :x:)
+ _ (poly;text :key:)
+ .val. (Codec<JSON,?>//decode env :val:)]
+ (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
+ (../reader;object (~ .val.))))))
+ (do @
+ [:sub: (poly;apply-1 (ident-for ;Maybe) :x:)
+ .sub. (Codec<JSON,?>//decode env :sub:)]
+ (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
+ (../reader;nullable (~ .sub.))))))
+ (do @
+ [:sub: (poly;apply-1 (ident-for ;List) :x:)
+ .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.))))
+ ))
+ ## 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:))
+ (p;rec (;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. (M;map @ (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:)]
+ (wrap g!bound))
+ ## If all else fails...
+ (macro;fail ($_ text/append "Cannot create JSON decoder for: " (type;to-text :x:)))
+ ))))
+
+(syntax: #export (Codec<JSON,?> :x:)
+ {#;doc (doc "A macro for automatically producing JSON codecs."
+ (type: Variant
+ (#Case0 Bool)
+ (#Case1 Text)
+ (#Case2 Real))
+
+ (type: Record
+ {#unit Unit
+ #bool Bool
+ #real Real
+ #text Text
+ #maybe (Maybe Real)
+ #list (List Real)
+ #variant Variant
+ #tuple [Bool Real Text]
+ #dict (Dict Text Real)})
+
+ (derived: (Codec<JSON,?> Record)))}
+ (with-gensyms [g!inputs]
+ (wrap (list (` (: (Codec ..;JSON (~ :x:))
+ (struct (def: (~' encode) (Codec<JSON,?>//encode (~ :x:)))
+ (def: ((~' decode) (~ g!inputs)) (../reader;run (~ g!inputs) (Codec<JSON,?>//decode (~ :x:))))
+ )))))))
diff --git a/stdlib/source/lux/data/format/json/reader.lux b/stdlib/source/lux/data/format/json/reader.lux
new file mode 100644
index 000000000..83713bcf3
--- /dev/null
+++ b/stdlib/source/lux/data/format/json/reader.lux
@@ -0,0 +1,177 @@
+(;module: {#;doc "Functionality for reading values in the JSON format.
+
+ For more information, please see: http://www.json.org/"}
+ lux
+ (lux (control [monad #+ do Monad]
+ [eq #+ Eq]
+ codec
+ ["p" parser "p/" Monad<Parser>])
+ (data [bool]
+ [text "text/" Monoid<Text>]
+ [number "real/" Codec<Text,Real> "nat/" Codec<Text,Nat>]
+ ["R" result]
+ (coll [list]
+ [vector]
+ ["d" dict]))
+ )
+ [.. #+ JSON Reader])
+
+(def: unconsumed-input-error Text "Unconsumed JSON.")
+
+(def: #export (run json parser)
+ (All [a] (-> JSON (Reader a) (R;Result a)))
+ (case (p;run (list json) parser)
+ (#R;Success [remainder output])
+ (case remainder
+ #;Nil
+ (#R;Success output)
+
+ _
+ (#R;Error unconsumed-input-error))
+
+ (#R;Error error)
+ (#R;Error error)))
+
+(def: #export (fail error)
+ (All [a] (-> Text (Reader a)))
+ (function [inputs]
+ (#R;Error error)))
+
+(def: #export any
+ {#;doc "Just returns the JSON input without applying any logic."}
+ (Reader JSON)
+ (<| (function [inputs])
+ (case inputs
+ #;Nil
+ (#R;Error "Empty JSON stream.")
+
+ (#;Cons head tail)
+ (#R;Success [tail head]))))
+
+(do-template [<name> <type> <tag> <desc>]
+ [(def: #export <name>
+ {#;doc (#;TextA ($_ text/append "Reads a JSON value as " <desc> "."))}
+ (Reader <type>)
+ (do p;Monad<Parser>
+ [head any]
+ (case head
+ (<tag> value)
+ (wrap value)
+
+ _
+ (fail ($_ text/append "JSON value is not " <desc> ".")))))]
+
+ [null Unit #..;Null "null"]
+ [boolean Bool #..;Boolean "boolean"]
+ [number Real #..;Number "number"]
+ [string Text #..;String "string"]
+ )
+
+(do-template [<test> <check> <type> <eq> <encoder> <tag> <desc> <pre>]
+ [(def: #export (<test> test)
+ {#;doc (#;TextA ($_ text/append "Asks whether a JSON value is a " <desc> "."))}
+ (-> <type> (Reader Bool))
+ (do p;Monad<Parser>
+ [head any]
+ (case head
+ (<tag> value)
+ (wrap (:: <eq> = test (<pre> value)))
+
+ _
+ (fail ($_ text/append "JSON value is not " <desc> ".")))))
+
+ (def: #export (<check> test)
+ {#;doc (#;TextA ($_ text/append "Ensures a JSON value is a " <desc> "."))}
+ (-> <type> (Reader Unit))
+ (do p;Monad<Parser>
+ [head any]
+ (case head
+ (<tag> value)
+ (let [value (<pre> value)]
+ (if (:: <eq> = test value)
+ (wrap [])
+ (fail ($_ text/append "Value mismatch: " (<encoder> test) "=/=" (<encoder> value)))))
+
+ _
+ (fail ($_ text/append "JSON value is not a " <desc> ".")))))]
+
+ [boolean? boolean! Bool bool;Eq<Bool> (:: bool;Codec<Text,Bool> encode) #..;Boolean "boolean" id]
+ [number? number! Real number;Eq<Real> (:: number;Codec<Text,Real> encode) #..;Number "number" id]
+ [string? string! Text text;Eq<Text> text;encode #..;String "string" id]
+ )
+
+(def: #export (nullable parser)
+ (All [a] (-> (Reader a) (Reader (Maybe a))))
+ (p;alt null
+ parser))
+
+(def: #export (array parser)
+ {#;doc "Parses a JSON array, assuming that every element can be parsed the same way."}
+ (All [a] (-> (Reader a) (Reader a)))
+ (do p;Monad<Parser>
+ [head any]
+ (case head
+ (#..;Array values)
+ (case (p;run (vector;to-list values) parser)
+ (#R;Error error)
+ (fail error)
+
+ (#R;Success [remainder output])
+ (case remainder
+ #;Nil
+ (wrap output)
+
+ _
+ (fail unconsumed-input-error)))
+
+ _
+ (fail "JSON value is not an array."))))
+
+(def: #export (object parser)
+ {#;doc "Parses a JSON object, assuming that every element can be parsed the same way."}
+ (All [a] (-> (Reader a) (Reader (d;Dict Text a))))
+ (do p;Monad<Parser>
+ [head any]
+ (case head
+ (#..;Object object)
+ (case (do R;Monad<Result>
+ []
+ (|> (d;entries object)
+ (monad;map @ (function [[key val]]
+ (do @
+ [val (run val parser)]
+ (wrap [key val]))))
+ (:: @ map (d;from-list text;Hash<Text>))))
+ (#R;Success table)
+ (wrap table)
+
+ (#R;Error error)
+ (fail error))
+
+ _
+ (fail "JSON value is not an array."))))
+
+(def: #export (field field-name parser)
+ {#;doc "Parses a field inside a JSON object."}
+ (All [a] (-> Text (Reader a) (Reader a)))
+ (do p;Monad<Parser>
+ [head any]
+ (case head
+ (#..;Object object)
+ (case (d;get field-name object)
+ (#;Some value)
+ (case (run value parser)
+ (#R;Success output)
+ (function [tail]
+ (#R;Success [(#;Cons (#..;Object (d;remove field-name object))
+ tail)
+ output]))
+
+ (#R;Error error)
+ (fail error))
+
+ _
+ (fail ($_ text/append "JSON object does not have field \"" field-name "\".")))
+
+ _
+ (fail "JSON value is not an object."))))
diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux
index 88ea5ecc0..37e5e7cb6 100644
--- a/stdlib/source/lux/data/text/format.lux
+++ b/stdlib/source/lux/data/text/format.lux
@@ -8,7 +8,8 @@
[ident]
(coll [list "L/" Monad<List>])
(format [xml]
- [json]))
+ [json]
+ [json/codec]))
(time [instant]
[duration]
[date])
@@ -50,7 +51,7 @@
[%oct Nat (:: number;Octal@Codec<Text,Nat> encode)]
[%hex Nat (:: number;Hex@Codec<Text,Nat> encode)]
[%xml xml;XML (:: xml;Codec<Text,XML> encode)]
- [%json json;JSON (:: json;Codec<Text,JSON> encode)]
+ [%json json;JSON (:: json/codec;Codec<Text,JSON> encode)]
[%instant instant;Instant (:: instant;Codec<Text,Instant> encode)]
[%duration duration;Duration (:: duration;Codec<Text,Duration> encode)]
[%date date;Date (:: date;Codec<Text,Date> encode)]
diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux
index 6372b26f1..68e1427ee 100644
--- a/stdlib/test/test/lux/data/format/json.lux
+++ b/stdlib/test/test/lux/data/format/json.lux
@@ -4,14 +4,17 @@
(control [monad #+ do Monad]
codec
[eq #+ Eq]
- pipe)
+ pipe
+ ["p" parser])
(data [text "Text/" Monoid<Text>]
text/format
["R" result]
[bool]
[maybe]
[number "i/" Number<Int>]
- (format ["&" json])
+ (format ["@" json]
+ (json ["@;" reader]
+ ["@;" codec]))
(coll [vector #+ vector]
["d" dict]
[list]))
@@ -25,7 +28,7 @@
)
(def: gen-json
- (r;Random &;JSON)
+ (r;Random @;JSON)
(r;rec (function [gen-json]
(do r;Monad<Random>
[size (:: @ map (n.% +2) r;nat)]
@@ -40,16 +43,16 @@
(context: "JSON"
[sample gen-json
- #let [(^open "&/") &;Eq<JSON>
- (^open "&/") &;Codec<Text,JSON>]]
+ #let [(^open "@/") @;Eq<JSON>
+ (^open "@/") @codec;Codec<Text,JSON>]]
($_ seq
(test "Every JSON is equal to itself."
- (&/= sample sample))
+ (@/= sample sample))
(test "Can encode/decode JSON."
- (|> sample &/encode &/decode
+ (|> sample @/encode @/decode
(case> (#;Right result)
- (&/= sample result)
+ (@/= sample result)
(#;Left _)
false)))
@@ -57,7 +60,7 @@
(type: Variant
(#Case0 Bool)
- (#Case1 Int)
+ (#Case1 Text)
(#Case2 Real))
(type: #rec Recursive
@@ -67,14 +70,13 @@
(type: Record
{#unit Unit
#bool Bool
- #int Int
#real Real
#text Text
- #maybe (Maybe Int)
- #list (List Int)
+ #maybe (Maybe Real)
+ #list (List Real)
#variant Variant
- #tuple [Int Real Text]
- #dict (d;Dict Text Int)
+ #tuple [Bool Real Text]
+ #dict (d;Dict Text Real)
#recursive Recursive})
(def: gen-recursive
@@ -88,23 +90,21 @@
(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))))]]
+ [size (:: @ map (n.% +2) r;nat)]
($_ 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))
- (r;dict text;Hash<Text> size (r;text size) gen-int)
+ (r;maybe r;real)
+ (r;list size r;real)
+ ($_ r;alt r;bool (r;text size) r;real)
+ ($_ r;seq r;bool r;real (r;text size))
+ (r;dict text;Hash<Text> size (r;text size) r;real)
gen-recursive
)))
-(derived: (&;Codec<JSON,?> Record))
+(derived: (@codec;Codec<JSON,?> Record))
(struct: _ (Eq Record)
(def: (= recL recR)
@@ -114,7 +114,7 @@
(:: bool;Eq<Bool> = left' right')
[(#Case1 left') (#Case1 right')]
- (i.= left' right')
+ (:: text;Eq<Text> = left' right')
[(#Case2 left') (#Case2 right')]
(r.= left' right')
@@ -122,29 +122,28 @@
_
false))]
(and (:: bool;Eq<Bool> = (get@ #bool recL) (get@ #bool recR))
- (i.= (get@ #int recL) (get@ #int recR))
(r.= (get@ #real recL) (get@ #real recR))
(:: text;Eq<Text> = (get@ #text recL) (get@ #text recR))
- (:: (maybe;Eq<Maybe> number;Eq<Int>) = (get@ #maybe recL) (get@ #maybe recR))
- (:: (list;Eq<List> number;Eq<Int>) = (get@ #list recL) (get@ #list recR))
+ (:: (maybe;Eq<Maybe> number;Eq<Real>) = (get@ #maybe recL) (get@ #maybe recR))
+ (:: (list;Eq<List> number;Eq<Real>) = (get@ #list recL) (get@ #list recR))
(variant/= (get@ #variant recL) (get@ #variant recR))
(let [[tL0 tL1 tL2] (get@ #tuple recL)
[tR0 tR1 tR2] (get@ #tuple recR)]
- (and (i.= tL0 tR0)
+ (and (:: bool;Eq<Bool> = tL0 tR0)
(r.= tL1 tR1)
(:: text;Eq<Text> = tL2 tR2)))
- (:: (d;Eq<Dict> i.=) = (get@ #dict recL) (get@ #dict recR))
+ (:: (d;Eq<Dict> number;Eq<Real>) = (get@ #dict recL) (get@ #dict recR))
(:: Eq<Recursive> = (get@ #recursive recL) (get@ #recursive recR))
))))
(context: "Polytypism"
[sample gen-record
- #let [(^open "&/") Eq<Record>
- (^open "&/") Codec<JSON,Record>]]
+ #let [(^open "@/") Eq<Record>
+ (^open "@/") Codec<JSON,Record>]]
(test "Can encode/decode arbitrary types."
- (|> sample &/encode &/decode
- (case> (#;Right result)
- (&/= sample result)
+ (|> sample @/encode @/decode
+ (case> (#R;Success result)
+ (@/= sample result)
- (#;Left _)
+ (#R;Error error)
false))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 23:52:56 +0000