diff options
author | Eduardo Julian | 2017-09-04 21:16:42 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-09-04 21:16:42 -0400 |
commit | 036f3b68983381c6fd2c380f01011ddaf0d8021f (patch) | |
tree | ff0a9b644dc5ecc3b7cfb970c90c747cb922b749 | |
parent | e97796bf4fd2217d3b9eaaf0b20a8f1b5f0f6b29 (diff) |
- Simplified code for JSON format.
- Moved JSON polytypism to the lux/macro/poly/* branch.
-rw-r--r-- | stdlib/source/lux/data/format/json.lux | 366 | ||||
-rw-r--r-- | stdlib/source/lux/data/format/json/reader.lux | 177 | ||||
-rw-r--r-- | stdlib/source/lux/data/text/format.lux | 5 | ||||
-rw-r--r-- | stdlib/source/lux/macro/poly/json.lux (renamed from stdlib/source/lux/data/format/json/codec.lux) | 215 | ||||
-rw-r--r-- | stdlib/test/test/lux/data/format/json.lux | 11 |
5 files changed, 369 insertions, 405 deletions
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index 847b5fa0f..097525b1d 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -1,10 +1,10 @@ -(;module: {#;doc "Functionality for generating and processing values in the JSON format. +(;module: {#;doc "Functionality for reading and writing values in the JSON format. For more information, please see: http://www.json.org/"} lux (lux (control functor applicative - ["M" monad #+ do Monad] + [monad #+ do Monad] [eq #+ Eq] codec ["p" parser "p/" Monad<Parser>]) @@ -26,7 +26,6 @@ [type] )) -## [Types] (do-template [<name> <type>] [(type: #export <name> <type>)] @@ -55,7 +54,6 @@ {#;doc "JSON reader."} (p;Parser (List JSON) a)) -## [Syntax] (syntax: #export (json token) {#;doc (doc "A simple way to produce JSON literals." (json true) @@ -83,27 +81,22 @@ [_ (#;Record pairs)] (do Monad<Lux> - [pairs' (M;map @ - (function [[slot value]] - (case slot - [_ (#;Text key-name)] - (wrap (` [(~ (code;text key-name)) (~ (wrapper value))])) - - _ - (macro;fail "Wrong syntax for JSON object."))) - pairs)] + [pairs' (monad;map @ + (function [[slot value]] + (case slot + [_ (#;Text key-name)] + (wrap (` [(~ (code;text key-name)) (~ (wrapper value))])) + + _ + (macro;fail "Wrong syntax for JSON object."))) + pairs)] (wrap (list (` (: JSON (#Object (d;from-list text;Hash<Text> (list (~@ pairs'))))))))) _ (wrap (list token)) ))) -(def: #export null - {#;doc "The null JSON value."} - JSON - #Null) - -(def: #export (fields json) +(def: #export (get-fields json) {#;doc "Get all the fields in a JSON object."} (-> JSON (R;Result (List String))) (case json @@ -159,27 +152,6 @@ [get-object #Object Object "objects"] ) -(do-template [<name> <type> <tag> <desc>] - [(def: #export (<name> value) - {#;doc (#;TextA ($_ text/append "A JSON generator for " <desc> "."))} - (-> <type> JSON) - (<tag> value))] - - [boolean Boolean #Boolean "booleans"] - [number Number #Number "numbers"] - [string String #String "strings"] - [array Array #Array "arrays"] - [object Object #Object "objects"] - ) - -(def: #export (nullable writer) - {#;doc "Builds a JSON generator for potentially inexistent values."} - (All [a] (-> (-> a JSON) (-> (Maybe a) JSON))) - (function [elem] - (case elem - #;None #Null - (#;Some value) (writer value)))) - (struct: #export _ (Eq JSON) (def: (= x y) (case [x y] @@ -217,3 +189,317 @@ _ false))) + +############################################################ +############################################################ +############################################################ + +(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 Frac #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! Frac number;Eq<Frac> (:: number;Codec<Text,Frac> 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.")))) + +############################################################ +############################################################ +############################################################ + +(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,Frac> 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 (frac/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~' []))))) diff --git a/stdlib/source/lux/data/format/json/reader.lux b/stdlib/source/lux/data/format/json/reader.lux deleted file mode 100644 index 1b26d746d..000000000 --- a/stdlib/source/lux/data/format/json/reader.lux +++ /dev/null @@ -1,177 +0,0 @@ -(;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 "frac/" Codec<Text,Frac> "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 Frac #..;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! Frac number;Eq<Frac> (:: number;Codec<Text,Frac> 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 db33bdc05..d24dbbf59 100644 --- a/stdlib/source/lux/data/text/format.lux +++ b/stdlib/source/lux/data/text/format.lux @@ -8,8 +8,7 @@ [ident] (coll [list "L/" Monad<List>]) (format [xml] - [json] - [json/codec])) + [json])) (time [instant] [duration] [date]) @@ -51,7 +50,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;Codec<Text,JSON> encode)] + [%json json;JSON (:: json;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/source/lux/data/format/json/codec.lux b/stdlib/source/lux/macro/poly/json.lux index 6fa1d566c..2c87603d3 100644 --- a/stdlib/source/lux/data/format/json/codec.lux +++ b/stdlib/source/lux/macro/poly/json.lux @@ -1,6 +1,4 @@ -(;module: {#;doc "Codecs for values in the JSON format. - - For more information, please see: http://www.json.org/"} +(;module: {#;doc "Codecs for values in the JSON format."} lux (lux (control functor applicative @@ -19,7 +17,8 @@ [product] (coll [list "L/" Fold<List> Monad<List>] [vector #+ Vector vector "Vector/" Monad<Vector>] - ["d" dict])) + ["d" dict]) + (format [".." json #+ JSON])) (time ["i" instant] ["du" duration] ["da" date]) @@ -28,158 +27,8 @@ [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,Frac> 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 (frac/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) @@ -202,13 +51,13 @@ (def: (encode input) (let [high (|> input (bit;and high-mask) (bit;unsigned-shift-right +32)) low (bit;and low-mask input)] - (..;array (vector (|> high nat-to-int int-to-frac #..;Number) - (|> low nat-to-int int-to-frac #..;Number))))) + (#..;Array (vector (|> high nat-to-int int-to-frac #..;Number) + (|> low nat-to-int int-to-frac #..;Number))))) (def: (decode input) - (<| (../reader;run input) + (<| (..;run input) (do p;Monad<Parser> - [high ../reader;number - low ../reader;number]) + [high ..;number + low ..;number]) (wrap (n.+ (|> high frac-to-int int-to-nat (bit;shift-left +32)) (|> low frac-to-int int-to-nat)))))) @@ -217,6 +66,14 @@ (def: decode (|>. (:: Codec<JSON,Nat> decode) (:: R;Functor<Result> map nat-to-int)))) +(def: #hidden (nullable writer) + {#;doc "Builds a JSON generator for potentially inexistent values."} + (All [a] (-> (-> a JSON) (-> (Maybe a) JSON))) + (function [elem] + (case elem + #;None #..;Null + (#;Some value) (writer value)))) + (poly: #hidden Codec<JSON,?>//encode (with-expansions [<basic> (do-template [<type> <matcher> <encoder>] @@ -226,11 +83,11 @@ <encoder>))))] [Unit poly;unit (function [(~ (code;symbol ["" "0"]))] #..;Null)] - [Bool poly;bool ..;boolean] + [Bool poly;bool (|>. #..;Boolean)] [Nat poly;nat (:: ;;Codec<JSON,Nat> (~' encode))] [Int poly;int (:: ;;Codec<JSON,Int> (~' encode))] - [Frac poly;frac ..;number] - [Text poly;text ..;string]) + [Frac poly;frac (|>. #..;Number)] + [Text poly;text (|>. #..;String)]) <time> (do-template [<type> <codec>] [(do @ [_ (poly;this <type>)] @@ -269,13 +126,13 @@ (poly;this ;Maybe) Codec<JSON,?>//encode))] (wrap (` (: (~ (@JSON//encode inputT)) - (..;nullable (~ .sub.)))))) + (;;nullable (~ .sub.)))))) (do @ [[_ .sub.] (poly;apply ($_ p;seq (poly;this ;List) Codec<JSON,?>//encode))] (wrap (` (: (~ (@JSON//encode inputT)) - (|>. (;;_map_ (~ .sub.)) vector;from-list ..;array))))) + (|>. (;;_map_ (~ .sub.)) vector;from-list #..;Array))))) (do @ [#let [g!input (code;local-symbol "\u0000input")] members (poly;variant (p;many Codec<JSON,?>//encode))] @@ -332,17 +189,17 @@ (wrap (` (: (~ (@JSON//decode inputT)) <decoder>))))] - [Unit poly;unit ../reader;null] - [Bool poly;bool ../reader;boolean] - [Nat poly;nat (p;codec ;;Codec<JSON,Nat> ../reader;any)] - [Int poly;int (p;codec ;;Codec<JSON,Int> ../reader;any)] - [Frac poly;frac ../reader;number] - [Text poly;text ../reader;string]) + [Unit poly;unit ..;null] + [Bool poly;bool ..;boolean] + [Nat poly;nat (p;codec ;;Codec<JSON,Nat> ..;any)] + [Int poly;int (p;codec ;;Codec<JSON,Int> ..;any)] + [Frac poly;frac ..;number] + [Text poly;text ..;string]) <time> (do-template [<type> <codec>] [(do @ [_ (poly;this <type>)] (wrap (` (: (~ (@JSON//decode inputT)) - (p;codec <codec> ../reader;string)))))] + (p;codec <codec> ..;string)))))] [du;Duration du;Codec<Text,Duration>] [i;Instant i;Codec<Text,Instant>] @@ -364,30 +221,30 @@ poly;text Codec<JSON,?>//decode))] (wrap (` (: (~ (@JSON//decode inputT)) - (../reader;object (~ valC)))))) + (..;object (~ valC)))))) (do @ [[_ subC] (poly;apply (p;seq (poly;this ;Maybe) Codec<JSON,?>//decode))] (wrap (` (: (~ (@JSON//decode inputT)) - (../reader;nullable (~ subC)))))) + (..;nullable (~ subC)))))) (do @ [[_ subC] (poly;apply (p;seq (poly;this ;List) Codec<JSON,?>//decode))] (wrap (` (: (~ (@JSON//decode inputT)) - (../reader;array (p;some (~ subC))))))) + (..;array (p;some (~ subC))))))) (do @ [members (poly;variant (p;many Codec<JSON,?>//decode))] (wrap (` (: (~ (@JSON//decode inputT)) ($_ p;alt (~@ (L/map (function [[tag memberC]] (` (|> (~ memberC) - (p;after (../reader;number! (~ (code;frac (;;tag tag))))) - ../reader;array))) + (p;after (..;number! (~ (code;frac (;;tag tag))))) + ..;array))) (list;enumerate members)))))))) (do @ [g!decoders (poly;tuple (p;many Codec<JSON,?>//decode))] (wrap (` (: (~ (@JSON//decode inputT)) - (../reader;array ($_ p;seq (~@ g!decoders))))))) + (..;array ($_ p;seq (~@ g!decoders))))))) ## Type recursion (do @ [[selfC bodyC] (poly;recursive Codec<JSON,?>//decode)] @@ -435,5 +292,5 @@ (with-gensyms [g!inputs] (wrap (list (` (: (Codec ..;JSON (~ inputT)) (struct (def: (~' encode) (Codec<JSON,?>//encode (~ inputT))) - (def: ((~' decode) (~ g!inputs)) (../reader;run (~ g!inputs) (Codec<JSON,?>//decode (~ inputT)))) + (def: ((~' decode) (~ g!inputs)) (..;run (~ g!inputs) (Codec<JSON,?>//decode (~ inputT)))) ))))))) diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux index 2dce7ad84..bd0e4ab67 100644 --- a/stdlib/test/test/lux/data/format/json.lux +++ b/stdlib/test/test/lux/data/format/json.lux @@ -12,9 +12,7 @@ [bool] [maybe] [number "i/" Number<Int>] - (format ["@" json] - (json ["@;" reader] - ["@;" codec])) + (format ["@" json]) (coll [vector #+ vector] ["d" dict] [list])) @@ -22,7 +20,8 @@ (macro [code] [syntax #+ syntax:] [poly #+ derived:] - [poly/eq]) + [poly/eq] + [poly/json]) ["r" math/random] test) ) @@ -44,7 +43,7 @@ (context: "JSON" [sample gen-json #let [(^open "@/") @;Eq<JSON> - (^open "@/") @codec;Codec<Text,JSON>]] + (^open "@/") @;Codec<Text,JSON>]] ($_ seq (test "Every JSON is equal to itself." (@/= sample sample)) @@ -104,7 +103,7 @@ gen-recursive ))) -(derived: (@codec;Codec<JSON,?> Record)) +(derived: (poly/json;Codec<JSON,?> Record)) (struct: _ (Eq Record) (def: (= recL recR) |