diff options
Diffstat (limited to 'stdlib')
| -rw-r--r-- | stdlib/source/lux/data/format/json.lux | 137 |
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:))) + )))))) |