aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--stdlib/source/lux/data/format/json.lux137
1 files changed, 102 insertions, 35 deletions
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
index 43b029f60..f9dafee7a 100644
--- a/stdlib/source/lux/data/format/json.lux
+++ b/stdlib/source/lux/data/format/json.lux
@@ -3,7 +3,9 @@
## If a copy of the MPL was not distributed with this file,
## You can obtain one at http://mozilla.org/MPL/2.0/.
-(;module:
+(;module: {#;doc "Functionality for reading, generating and processing values in the JSON format.
+
+ For more information, please see: http://www.json.org/"}
lux
(lux (control functor
applicative
@@ -56,13 +58,24 @@
)
(type: #export (Parser a)
+ {#;doc "JSON parsers."}
(-> JSON (Error a)))
(type: #export (Gen a)
+ {#;doc "JSON generators."}
(-> a JSON))
## [Syntax]
(syntax: #export (json token)
+ {#;doc (doc "A way to produce JSON literals."
+ (json true)
+ (json 123)
+ (json 456.78)
+ (json "Some text")
+ (json #null)
+ (json ["this" "is" "an" "array"])
+ (json {"this" "is"
+ "an" "object"}))}
(let [(^open) Monad<Lux>
wrapper (lambda [x] (` (;;json (~ x))))]
(case token
@@ -136,19 +149,22 @@
))
(def: #export null
+ {#;doc "The null JSON value."}
JSON
#Null)
-(def: #export (keys json)
+(def: #export (fields json)
+ {#;doc "Get all the fields in a JSON object."}
(-> JSON (Error (List String)))
(case json
(#Object obj)
(#;Right (dict;keys obj))
_
- (#;Left (format "Can't get keys of a non-object."))))
+ (#;Left (format "Can't get the fields of a non-object."))))
(def: #export (get key json)
+ {#;doc "A JSON object field getter."}
(-> String JSON (Error JSON))
(case json
(#Object obj)
@@ -163,6 +179,7 @@
(#;Left (format "Can't get field " (show-string key) " of a non-object."))))
(def: #export (set key value json)
+ {#;doc "A JSON object field setter."}
(-> String JSON JSON (Error JSON))
(case json
(#Object obj)
@@ -171,8 +188,9 @@
_
(#;Left (format "Can't set field " (show-string key) " of a non-object."))))
-(do-template [<name> <tag> <type>]
+(do-template [<name> <tag> <type> <desc>]
[(def: #export (<name> key json)
+ {#;doc (#;TextM (format "A JSON object field getter for " <desc> "."))}
(-> Text JSON (Error <type>))
(case (get key json)
(#;Right (<tag> value))
@@ -184,26 +202,28 @@
(#;Left error)
(#;Left error)))]
- [get-boolean #Boolean Boolean]
- [get-number #Number Number]
- [get-string #String String]
- [get-array #Array Array]
- [get-object #Object Object]
+ [get-boolean #Boolean Boolean "booleans"]
+ [get-number #Number Number "numbers"]
+ [get-string #String String "strings"]
+ [get-array #Array Array "arrays"]
+ [get-object #Object Object "objects"]
)
-(do-template [<name> <type> <tag>]
+(do-template [<name> <type> <tag> <desc>]
[(def: #export (<name> value)
+ {#;doc (#;TextM (format "A JSON generator for " <desc> "."))}
(Gen <type>)
(<tag> value))]
- [gen-boolean Boolean #Boolean]
- [gen-number Number #Number]
- [gen-string String #String]
- [gen-array Array #Array]
- [gen-object Object #Object]
+ [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"]
)
(def: #export (gen-nullable gen)
+ {#;doc "Builds a JSON generator for potentially inexistent values."}
(All [a] (-> (Gen a) (Gen (Maybe a))))
(lambda [elem]
(case elem
@@ -378,23 +398,25 @@
## Syntax
(do-template [<name> <type> <tag> <desc> <pre>]
[(def: #export (<name> json)
+ {#;doc (#;TextM (format "Reads a JSON value as " <desc> "."))}
(Parser <type>)
(case json
(<tag> value)
(#;Right (<pre> value))
_
- (#;Left (format "JSON value is not a " <desc> ": " (show-json json)))))]
+ (#;Left (format "JSON value is not " <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]
+ [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> <codec> <tag> <desc> <pre>]
[(def: #export (<test> test json)
+ {#;doc (#;TextM (format "Asks whether a JSON value is a " <desc> "."))}
(-> <type> (Parser Bool))
(case json
(<tag> value)
@@ -404,6 +426,7 @@
(#;Left (format "JSON value is not a " <desc> ": " (show-json json)))))
(def: #export (<check> test json)
+ {#;doc (#;TextM (format "Ensures a JSON value is a " <desc> "."))}
(-> <type> (Parser Unit))
(case json
(<tag> value)
@@ -423,6 +446,7 @@
)
(def: #export (char json)
+ {#;doc "Reads a JSON value as a single-character string."}
(Parser Char)
(case json
(#String input)
@@ -437,6 +461,7 @@
(#;Left (format "JSON value is not a " "string" ": " (show-json json)))))
(def: #export (char? test json)
+ {#;doc "Asks whether a JSON value is a single-character string with the specified character."}
(-> Char (Parser Bool))
(case json
(#String input)
@@ -454,6 +479,7 @@
(#;Left (format "JSON value is not a " "string" ": " (show-json json)))))
(def: #export (char! test json)
+ {#;doc "Ensures a JSON value is a single-character string with the specified character."}
(-> Char (Parser Unit))
(case json
(#String input)
@@ -471,6 +497,7 @@
(#;Left (format "JSON value is not a " "string" ": " (show-json json)))))
(def: #export (nullable parser)
+ {#;doc "A parser that can handle the presence of null values."}
(All [a] (-> (Parser a) (Parser (Maybe a))))
(lambda [json]
(case json
@@ -487,6 +514,7 @@
)))
(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))))
(lambda [json]
(case json
@@ -499,6 +527,7 @@
(#;Left (format "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 (Dict String a))))
(lambda [json]
(case json
@@ -516,6 +545,7 @@
(#;Left (format "JSON value is not an object: " (show-json json))))))
(def: #export (at idx parser)
+ {#;doc "Parses an element inside a JSON array."}
(All [a] (-> Nat (Parser a) (Parser a)))
(lambda [json]
(case json
@@ -536,6 +566,7 @@
(#;Left (format "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)))
(lambda [json]
(case (get field-name json)
@@ -551,11 +582,13 @@
(#;Left (format "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)
(lambda [json]
(#;Right json)))
(def: #export (seq pa pb)
+ {#;doc "Sequencing combinator."}
(All [a b] (-> (Parser a) (Parser b) (Parser [a b])))
(do Monad<Parser>
[=a pa
@@ -563,6 +596,7 @@
(wrap [=a =b])))
(def: #export (alt pa pb json)
+ {#;doc "Heterogeneous alternative combinator."}
(All [a b] (-> (Parser a) (Parser b) (Parser (| a b))))
(case (pa json)
(#;Right a)
@@ -577,6 +611,7 @@
(#;Left message0))))
(def: #export (either pl pr json)
+ {#;doc "Homogeneous alternative combinator."}
(All [a] (-> (Parser a) (Parser a) (Parser a)))
(case (pl json)
(#;Right x)
@@ -586,6 +621,7 @@
(pr json)))
(def: #export (opt p json)
+ {#;doc "Optionality combinator."}
(All [a]
(-> (Parser a) (Parser (Maybe a))))
(case (p json)
@@ -597,6 +633,7 @@
(parser json))
(def: #export (ensure test parser json)
+ {#;doc "Only parses a JSON if it passes a test (which is also a parser)."}
(All [a] (-> (Parser Unit) (Parser a) (Parser a)))
(case (test json)
(#;Right _)
@@ -605,18 +642,20 @@
(#;Left error)
(#;Left error)))
-(def: #export (array-size! array-size json)
+(def: #export (array-size! size json)
+ {#;doc "Ensures a JSON array has the specified size."}
(-> Nat (Parser Unit))
(case json
(#Array parts)
- (if (n.= array-size (vector;size parts))
+ (if (n.= size (vector;size parts))
(#;Right [])
- (#;Left (format "JSON array does no have size " (%n array-size) " " (show-json json))))
+ (#;Left (format "JSON array does no have size " (%n size) " " (show-json json))))
_
(#;Left (format "JSON value is not an array: " (show-json json)))))
(def: #export (object-fields! wanted-fields json)
+ {#;doc "Ensures that every field in the list of wanted-fields is present in a JSON object."}
(-> (List String) (Parser Unit))
(case json
(#Object kvs)
@@ -683,7 +722,12 @@
(syntax;alt (syntax;tuple (syntax;some syntax;any))
(syntax;record (syntax;some (syntax;seq syntax;text syntax;any)))))
-(syntax: #export (shape^ [shape _shape^])
+(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)
@@ -701,7 +745,12 @@
(wrap (list (` ($_ seq (~@ parsers))))))
))
-(syntax: #export (shape!^ [shape _shape^])
+(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)
@@ -726,7 +775,7 @@
(All [a b] (-> (-> a b) (List a) (List b)))
List/map)
-(poly: #export (Codec<JSON,?>//encode *env* :x:)
+(poly: #hidden (Codec<JSON,?>//encode *env* :x:)
(let [->Codec//encode (: (-> AST AST)
(lambda [.type.] (` (-> (~ .type.) JSON))))]
(let% [<basic> (do-template [<type> <matcher> <encoder>]
@@ -877,7 +926,7 @@
(compiler;fail (format "Can't create JSON encoder for: " (%type :x:)))
))))
-(poly: #export (Codec<JSON,?>//decode *env* :x:)
+(poly: #hidden (Codec<JSON,?>//decode *env* :x:)
(let [->Codec//decode (: (-> AST AST)
(lambda [.type.] (` (-> JSON (Error (~ .type.))))))]
(let% [<basic> (do-template [<type> <matcher> <decoder>]
@@ -926,7 +975,7 @@
(wrap (` (: (~ :x:+)
(lambda [(~@ g!vars) (~ g!input)]
(do Monad<Error>
- [(~ g!key) (;;keys (~ g!input))]
+ [(~ g!key) (;;fields (~ g!input))]
(mapM (~ (' %))
(lambda [(~ g!key)]
(do Monad<Error>
@@ -1026,11 +1075,11 @@
(~ (->Codec//decode (` ((~ (type;to-ast :x:)) (~@ g!vars)))))))))]
#let [.decoder. (case g!vars
#;Nil
- (` (;;shape^ [(~@ (List/map product;right pattern-matching))]))
+ (` (;;shape [(~@ (List/map product;right pattern-matching))]))
_
(` (lambda [(~@ g!vars)]
- (;;shape^ [(~@ (List/map product;right pattern-matching))]))))]]
+ (;;shape [(~@ (List/map product;right pattern-matching))]))))]]
(wrap (` (: (~ :x:+) (~ .decoder.))))
))
(do @
@@ -1046,8 +1095,26 @@
))))
(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
+ #char Char
+ #text Text
+ #maybe (Maybe Int)
+ #list (List Int)
+ #variant Variant
+ #tuple [Int Real Char]})
+
+ (derived: (Codec<JSON,?> Record)))}
(wrap (list (` (: (Codec JSON (~ :x:))
- (struct
- (def: (~ (' encode)) (Codec<JSON,?>//encode (~ :x:)))
- (def: (~ (' decode)) (Codec<JSON,?>//decode (~ :x:)))
- ))))))
+ (struct (def: (~ (' encode)) (Codec<JSON,?>//encode (~ :x:)))
+ (def: (~ (' decode)) (Codec<JSON,?>//decode (~ :x:)))
+ ))))))