aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/data/format/json.lux366
-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/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.lux11
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 01:19:15 +0000