diff options
Diffstat (limited to '')
-rw-r--r-- | stdlib/source/lux/data/format/json.lux | 104 |
1 files changed, 55 insertions, 49 deletions
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index 2e31a3924..865e92b8c 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -5,7 +5,7 @@ (lux (control functor applicative monad - eq + [eq #+ Eq] codec ["p" parser "p/" Monad<Parser>]) (data [bool] @@ -387,11 +387,11 @@ _ (#R;Error (format "JSON value is not " <desc> ": " (show-json json)))))] - [unit Unit #Null "unit" 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] + [real Real #Number "real" id] + [text Text #String "text" id] ) (do-template [<test> <check> <type> <eq> <encoder> <tag> <desc> <pre>] @@ -524,79 +524,85 @@ =b pb] (wrap [=a =b]))) -(def: #export (alt pa pb json) +(def: #export (alt pa pb) {#;doc "Heterogeneous alternative combinator."} (All [a b] (-> (Parser a) (Parser b) (Parser (| a b)))) - (case (pa json) - (#R;Success a) - (sum;right (sum;left a)) + (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 message0) + (case (pb json) + (#R;Success b) + (sum;right (sum;right b)) - (#R;Error message1) - (#R;Error message0)))) + (#R;Error message1) + (#R;Error message0))))) -(def: #export (either pl pr json) +(def: #export (either pl pr) {#;doc "Homogeneous alternative combinator."} (All [a] (-> (Parser a) (Parser a) (Parser a))) - (case (pl json) - (#R;Success x) - (#R;Success x) + (function [json] + (case (pl json) + (#R;Success x) + (#R;Success x) - _ - (pr json))) + _ + (pr json)))) -(def: #export (opt p json) +(def: #export (opt p) {#;doc "Optionality combinator."} (All [a] (-> (Parser a) (Parser (Maybe a)))) - (case (p json) - (#R;Error _) (#R;Success #;None) - (#R;Success x) (#R;Success (#;Some x)))) + (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 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))) - (case (test json) - (#R;Success _) - (parser json) + (function [json] + (case (test json) + (#R;Success _) + (parser json) - (#R;Error error) - (#R;Error error))) + (#R;Error error) + (#R;Error error)))) -(def: #export (array-size! size json) +(def: #export (array-size! size) {#;doc "Ensures a JSON array has the specified size."} (-> Nat (Parser Unit)) - (case json - (#Array parts) - (if (n.= size (vector;size parts)) - (#R;Success []) - (#R;Error (format "JSON array does no have size " (%n size) " " (show-json json)))) + (function [json] + (case json + (#Array parts) + (if (n.= size (vector;size parts)) + (#R;Success []) + (#R;Error (format "JSON array does no have size " (%n size) " " (show-json json)))) - _ - (#R;Error (format "JSON value is not an array: " (show-json json))))) + _ + (#R;Error (format "JSON value is not an array: " (show-json json)))))) -(def: #export (object-fields! wanted-fields 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)) - (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 (format "JSON object has wrong field-set. Expected: [" (text;join-with ", " wanted-fields) "]. Actual: [" (text;join-with ", " actual-fields) "]")))) + (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 (format "JSON object has wrong field-set. Expected: [" (text;join-with ", " wanted-fields) "]. Actual: [" (text;join-with ", " actual-fields) "]")))) - _ - (#R;Error (format "JSON value is not an object: " (show-json json))))) + _ + (#R;Error (format "JSON value is not an object: " (show-json json)))))) ## [Structures] (struct: #export _ (Eq JSON) |