aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/parser/json.lux201
-rw-r--r--stdlib/source/lux/data/format/json.lux242
-rw-r--r--stdlib/source/lux/macro/poly/json.lux45
-rw-r--r--stdlib/source/lux/world/net/http/request.lux6
-rw-r--r--stdlib/source/test/lux/macro/poly/json.lux6
5 files changed, 256 insertions, 244 deletions
diff --git a/stdlib/source/lux/control/parser/json.lux b/stdlib/source/lux/control/parser/json.lux
new file mode 100644
index 000000000..cf3d308db
--- /dev/null
+++ b/stdlib/source/lux/control/parser/json.lux
@@ -0,0 +1,201 @@
+(.module:
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]]
+ [data
+ ["." bit]
+ ["." error (#+ Error)]
+ ["." text ("#@." equivalence monoid)]
+ [number
+ ["." frac]]
+ [collection
+ ["." list ("#@." functor)]
+ ["." row]
+ ["." dictionary (#+ Dictionary)]]
+ [format
+ ["/" json (#+ JSON)]]]
+ [macro
+ ["." code]]]
+ ["." // ("#@." functor)])
+
+(type: #export (Parser a)
+ {#.doc "JSON parser."}
+ (//.Parser (List JSON) a))
+
+(exception: #export (unconsumed-input {input (List JSON)})
+ (exception.report
+ ["Input" (exception.enumerate /.format input)]))
+
+(exception: #export empty-input)
+
+(def: #export (run json parser)
+ (All [a] (-> JSON (Parser a) (Error a)))
+ (case (//.run (list json) parser)
+ (#error.Success [remainder output])
+ (case remainder
+ #.Nil
+ (#error.Success output)
+
+ _
+ (exception.throw unconsumed-input remainder))
+
+ (#error.Failure error)
+ (#error.Failure error)))
+
+(def: #export (fail error)
+ (All [a] (-> Text (Parser a)))
+ (function (_ inputs)
+ (#error.Failure error)))
+
+(def: #export any
+ {#.doc "Just returns the JSON input without applying any logic."}
+ (Parser JSON)
+ (<| (function (_ inputs))
+ (case inputs
+ #.Nil
+ (exception.throw empty-input [])
+
+ (#.Cons head tail)
+ (#error.Success [tail head]))))
+
+(template [<name> <type> <tag> <desc>]
+ [(def: #export <name>
+ {#.doc (code.text ($_ text@compose "Reads a JSON value as " <desc> "."))}
+ (Parser <type>)
+ (do //.monad
+ [head any]
+ (case head
+ (<tag> value)
+ (wrap value)
+
+ _
+ (fail ($_ text@compose "JSON value is not " <desc> ".")))))]
+
+ [null Any #/.Null "null"]
+ [boolean Bit #/.Boolean "boolean"]
+ [number Frac #/.Number "number"]
+ [string Text #/.String "string"]
+ )
+
+(template [<test> <check> <type> <eq> <encoder> <tag> <desc>]
+ [(def: #export (<test> test)
+ {#.doc (code.text ($_ text@compose "Asks whether a JSON value is a " <desc> "."))}
+ (-> <type> (Parser Bit))
+ (do //.monad
+ [head any]
+ (case head
+ (<tag> value)
+ (wrap (:: <eq> = test value))
+
+ _
+ (fail ($_ text@compose "JSON value is not " <desc> ".")))))
+
+ (def: #export (<check> test)
+ {#.doc (code.text ($_ text@compose "Ensures a JSON value is a " <desc> "."))}
+ (-> <type> (Parser Any))
+ (do //.monad
+ [head any]
+ (case head
+ (<tag> value)
+ (if (:: <eq> = test value)
+ (wrap [])
+ (fail ($_ text@compose "Value mismatch: " (|> test <encoder>) " =/= " (|> value <encoder>))))
+
+ _
+ (fail ($_ text@compose "JSON value is not a " <desc> ".")))))]
+
+ [boolean? boolean! Bit bit.equivalence (<| /.format #/.Boolean) #/.Boolean "boolean"]
+ [number? number! Frac frac.equivalence (:: frac.decimal encode) #/.Number "number"]
+ [string? string! Text text.equivalence text.encode #/.String "string"]
+ )
+
+(def: #export (nullable parser)
+ (All [a] (-> (Parser a) (Parser (Maybe a))))
+ (//.or null
+ parser))
+
+(def: #export (array parser)
+ {#.doc "Parses a JSON array."}
+ (All [a] (-> (Parser a) (Parser a)))
+ (do //.monad
+ [head any]
+ (case head
+ (#/.Array values)
+ (case (//.run (row.to-list values) parser)
+ (#error.Failure error)
+ (fail error)
+
+ (#error.Success [remainder output])
+ (case remainder
+ #.Nil
+ (wrap output)
+
+ _
+ (fail (exception.construct unconsumed-input remainder))))
+
+ _
+ (fail (text@compose "JSON value is not an array: " (/.format head))))))
+
+(def: #export (object parser)
+ {#.doc "Parses a JSON object. Use this with the 'field' combinator."}
+ (All [a] (-> (Parser a) (Parser a)))
+ (do //.monad
+ [head any]
+ (case head
+ (#/.Object kvs)
+ (case (//.run (|> kvs
+ dictionary.entries
+ (list@map (function (_ [key value])
+ (list (#/.String key) value)))
+ list.concat)
+ parser)
+ (#error.Failure error)
+ (fail error)
+
+ (#error.Success [remainder output])
+ (case remainder
+ #.Nil
+ (wrap output)
+
+ _
+ (fail (exception.construct unconsumed-input remainder))))
+
+ _
+ (fail (text@compose "JSON value is not an object: " (/.format head))))))
+
+(def: #export (field field-name parser)
+ {#.doc "Parses a field inside a JSON object. Use this inside the 'object' combinator."}
+ (All [a] (-> Text (Parser a) (Parser a)))
+ (function (recur inputs)
+ (case inputs
+ (^ (list& (#/.String key) value inputs'))
+ (if (text@= key field-name)
+ (case (//.run (list value) parser)
+ (#error.Success [#.Nil output])
+ (#error.Success [inputs' output])
+
+ (#error.Success [inputs'' _])
+ (exception.throw unconsumed-input inputs'')
+
+ (#error.Failure error)
+ (#error.Failure error))
+ (do error.monad
+ [[inputs'' output] (recur inputs')]
+ (wrap [(list& (#/.String key) value inputs'')
+ output])))
+
+ #.Nil
+ (exception.throw empty-input [])
+
+ _
+ (exception.throw unconsumed-input inputs))))
+
+(def: #export dictionary
+ {#.doc "Parses a dictionary-like JSON object."}
+ (All [a] (-> (Parser a) (Parser (Dictionary Text a))))
+ (|>> (//.and ..string)
+ //.some
+ object
+ (//@map (dictionary.from-list text.hash))))
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
index 162cf8387..417db04b6 100644
--- a/stdlib/source/lux/data/format/json.lux
+++ b/stdlib/source/lux/data/format/json.lux
@@ -2,25 +2,23 @@
"For more information, please see: http://www.json.org/")}
[lux #*
[abstract
- ["." monad (#+ Monad do)]
+ ["." monad (#+ do)]
[equivalence (#+ Equivalence)]
codec]
[control
pipe
["p" parser ("#@." monad)
- ["l" text (#+ Parser)]]
- ["ex" exception (#+ exception:)]]
+ ["l" text (#+ Parser)]]]
[data
["." bit]
["." maybe]
["." error (#+ Error)]
- ["." sum]
["." product]
[number
["." frac ("#@." decimal)]]
["." text ("#@." equivalence monoid)]
[collection
- ["." list ("#@." fold monad)]
+ ["." list ("#@." fold functor)]
["." row (#+ Row row) ("#@." monad)]
["." dictionary (#+ Dictionary)]]]
["." macro (#+ monad with-gensyms)
@@ -51,10 +49,6 @@
[Object (Dictionary String JSON)]
)
-(type: #export (Reader a)
- {#.doc "JSON reader."}
- (p.Parser (List JSON) a))
-
(syntax: #export (json token)
{#.doc (doc "A simple way to produce JSON literals."
(json #1)
@@ -194,14 +188,16 @@
############################################################
############################################################
-(def: encode-boolean
- (-> Bit Text)
+(def: (format-null _) (-> Null Text) "null")
+
+(def: format-boolean
+ (-> Boolean Text)
(|>> (case>
#0 "false"
#1 "true")))
-(def: encode-number
- (-> Frac Text)
+(def: format-number
+ (-> Number Text)
(|>> (case>
+0.0 "0.0"
-0.0 "0.0"
@@ -210,231 +206,41 @@
raw
(|> raw (text.split 1) maybe.assume product.right))))))
-(def: (show-null _) (-> Null Text) "null")
-
-(template [<name> <type> <codec>]
- [(def: <name> (-> <type> Text) <codec>)]
-
- [show-boolean Boolean ..encode-boolean]
- [show-number Number ..encode-number]
- [show-string String text.encode]
- )
+(def: format-string (-> String Text) text.encode)
-(def: (show-array show-json elems)
+(def: (format-array format elems)
(-> (-> JSON Text) (-> Array Text))
($_ text@compose "["
- (|> elems (row@map show-json) row.to-list (text.join-with ","))
+ (|> elems (row@map format) row.to-list (text.join-with ","))
"]"))
-(def: (show-object show-json object)
+(def: (format-object format object)
(-> (-> JSON Text) (-> Object Text))
($_ text@compose "{"
(|> object
dictionary.entries
- (list@map (function (_ [key value]) ($_ text@compose (show-string key) ":" (show-json value))))
+ (list@map (function (_ [key value]) ($_ text@compose (format-string key) ":" (format value))))
(text.join-with ","))
"}"))
-(def: (show-json json)
+(def: #export (format json)
(-> JSON Text)
(case json
- (^template [<tag> <show>]
+ (^template [<tag> <format>]
(<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)])
+ (<format> value))
+ ([#Null format-null]
+ [#Boolean format-boolean]
+ [#Number format-number]
+ [#String format-string]
+ [#Array (format-array format)]
+ [#Object (format-object format)])
))
############################################################
############################################################
############################################################
-(exception: #export (unconsumed-input {input (List JSON)})
- (|> input
- (list@map show-json)
- (text.join-with text.new-line)))
-
-(exception: #export (empty-input)
- "")
-
-(def: #export (run json parser)
- (All [a] (-> JSON (Reader a) (Error a)))
- (case (p.run (list json) parser)
- (#error.Success [remainder output])
- (case remainder
- #.Nil
- (#error.Success output)
-
- _
- (ex.throw unconsumed-input remainder))
-
- (#error.Failure error)
- (#error.Failure error)))
-
-(def: #export (fail error)
- (All [a] (-> Text (Reader a)))
- (function (_ inputs)
- (#error.Failure error)))
-
-(def: #export any
- {#.doc "Just returns the JSON input without applying any logic."}
- (Reader JSON)
- (<| (function (_ inputs))
- (case inputs
- #.Nil
- (ex.throw empty-input [])
-
- (#.Cons head tail)
- (#error.Success [tail head]))))
-
-(template [<name> <type> <tag> <desc>]
- [(def: #export <name>
- {#.doc (code.text ($_ text@compose "Reads a JSON value as " <desc> "."))}
- (Reader <type>)
- (do p.monad
- [head any]
- (case head
- (<tag> value)
- (wrap value)
-
- _
- (fail ($_ text@compose "JSON value is not " <desc> ".")))))]
-
- [null Any #Null "null"]
- [boolean Bit #Boolean "boolean"]
- [number Frac #Number "number"]
- [string Text #String "string"]
- )
-
-(template [<test> <check> <type> <eq> <encoder> <tag> <desc>]
- [(def: #export (<test> test)
- {#.doc (code.text ($_ text@compose "Asks whether a JSON value is a " <desc> "."))}
- (-> <type> (Reader Bit))
- (do p.monad
- [head any]
- (case head
- (<tag> value)
- (wrap (:: <eq> = test value))
-
- _
- (fail ($_ text@compose "JSON value is not " <desc> ".")))))
-
- (def: #export (<check> test)
- {#.doc (code.text ($_ text@compose "Ensures a JSON value is a " <desc> "."))}
- (-> <type> (Reader Any))
- (do p.monad
- [head any]
- (case head
- (<tag> value)
- (if (:: <eq> = test value)
- (wrap [])
- (fail ($_ text@compose "Value mismatch: " (<encoder> test) " =/= " (<encoder> value))))
-
- _
- (fail ($_ text@compose "JSON value is not a " <desc> ".")))))]
-
- [boolean? boolean! Bit bit.equivalence encode-boolean #Boolean "boolean"]
- [number? number! Frac frac.equivalence (:: frac.decimal encode) #Number "number"]
- [string? string! Text text.equivalence text.encode #String "string"]
- )
-
-(def: #export (nullable parser)
- (All [a] (-> (Reader a) (Reader (Maybe a))))
- (p.or null
- parser))
-
-(def: #export (array parser)
- {#.doc "Parses a JSON array."}
- (All [a] (-> (Reader a) (Reader a)))
- (do p.monad
- [head any]
- (case head
- (#Array values)
- (case (p.run (row.to-list values) parser)
- (#error.Failure error)
- (fail error)
-
- (#error.Success [remainder output])
- (case remainder
- #.Nil
- (wrap output)
-
- _
- (fail (ex.construct unconsumed-input remainder))))
-
- _
- (fail (text@compose "JSON value is not an array: " (show-json head))))))
-
-(def: #export (object parser)
- {#.doc "Parses a JSON object. Use this with the 'field' combinator."}
- (All [a] (-> (Reader a) (Reader a)))
- (do p.monad
- [head any]
- (case head
- (#Object kvs)
- (case (p.run (|> kvs
- dictionary.entries
- (list@map (function (_ [key value])
- (list (#String key) value)))
- list.concat)
- parser)
- (#error.Failure error)
- (fail error)
-
- (#error.Success [remainder output])
- (case remainder
- #.Nil
- (wrap output)
-
- _
- (fail (ex.construct unconsumed-input remainder))))
-
- _
- (fail (text@compose "JSON value is not an object: " (show-json head))))))
-
-(def: #export (field field-name parser)
- {#.doc "Parses a field inside a JSON object. Use this inside the 'object' combinator."}
- (All [a] (-> Text (Reader a) (Reader a)))
- (function (recur inputs)
- (case inputs
- (^ (list& (#String key) value inputs'))
- (if (text@= key field-name)
- (case (p.run (list value) parser)
- (#error.Success [#.Nil output])
- (#error.Success [inputs' output])
-
- (#error.Success [inputs'' _])
- (ex.throw unconsumed-input inputs'')
-
- (#error.Failure error)
- (#error.Failure error))
- (do error.monad
- [[inputs'' output] (recur inputs')]
- (wrap [(list& (#String key) value inputs'')
- output])))
-
- #.Nil
- (ex.throw empty-input [])
-
- _
- (ex.throw unconsumed-input inputs))))
-
-(def: #export dictionary
- {#.doc "Parses a dictionary-like JSON object."}
- (All [a] (-> (Reader a) (Reader (Dictionary Text a))))
- (|>> (p.and ..string)
- p.some
- object
- (p@map (dictionary.from-list text.hash))))
-
-############################################################
-############################################################
-############################################################
-
(def: space~
(Parser Text)
(l.some l.space))
@@ -548,5 +354,5 @@
($_ p.or null~ boolean~ number~ string~ (array~ json~') (object~ json~')))
(structure: #export codec (Codec Text JSON)
- (def: encode show-json)
+ (def: encode ..format)
(def: decode (function (_ input) (l.run input (json~' [])))))
diff --git a/stdlib/source/lux/macro/poly/json.lux b/stdlib/source/lux/macro/poly/json.lux
index 1253ec328..f30c26437 100644
--- a/stdlib/source/lux/macro/poly/json.lux
+++ b/stdlib/source/lux/macro/poly/json.lux
@@ -7,6 +7,7 @@
[control
["p" parser
["<.>" type]
+ ["</>" json]
["l" text]]]
[data
["." bit]
@@ -60,11 +61,11 @@
(#/.Array (row (|> high .int int-to-frac #/.Number)
(|> low .int int-to-frac #/.Number)))))
(def: (decode input)
- (<| (/.run input)
- /.array
+ (<| (</>.run input)
+ </>.array
(do p.monad
- [high /.number
- low /.number])
+ [high </>.number
+ low </>.number])
(wrap (n/+ (|> high frac-to-int .nat (i64.left-shift 32))
(|> low frac-to-int .nat))))))
@@ -214,17 +215,17 @@
(wrap (` (: (~ (@JSON//decode inputT))
(~! <decoder>)))))]
- [(<type>.exactly Any) /.null]
- [(<type>.sub Bit) /.boolean]
- [(<type>.sub Nat) (p.codec ..nat-codec /.any)]
- [(<type>.sub Int) (p.codec ..int-codec /.any)]
- [(<type>.sub Frac) /.number]
- [(<type>.sub Text) /.string])
+ [(<type>.exactly Any) </>.null]
+ [(<type>.sub Bit) </>.boolean]
+ [(<type>.sub Nat) (p.codec ..nat-codec </>.any)]
+ [(<type>.sub Int) (p.codec ..int-codec </>.any)]
+ [(<type>.sub Frac) </>.number]
+ [(<type>.sub Text) </>.string])
<time> (template [<type> <codec>]
[(do @
[_ (<type>.exactly <type>)]
(wrap (` (: (~ (@JSON//decode inputT))
- ((~! p.codec) (~! <codec>) (~! /.string))))))]
+ ((~! p.codec) (~! <codec>) (~! </>.string))))))]
## [duration.Duration duration.codec]
## [instant.Instant instant.codec]
@@ -236,7 +237,7 @@
[*env* <type>.env
#let [@JSON//decode (: (-> Type Code)
(function (_ type)
- (` (/.Reader (~ (poly.to-code *env* type))))))]
+ (` (</>.Parser (~ (poly.to-code *env* type))))))]
inputT <type>.peek]
($_ p.either
<basic>
@@ -245,37 +246,37 @@
[unitT (<type>.apply (p.after (<type>.exactly unit.Qty)
<type>.any))]
(wrap (` (: (~ (@JSON//decode inputT))
- ((~! p.codec) (~! qty-codec) (~! /.any))))))
+ ((~! p.codec) (~! qty-codec) (~! </>.any))))))
(do @
[[_ _ valC] (<type>.apply ($_ p.and
(<type>.exactly d.Dictionary)
(<type>.exactly .Text)
codec//decode))]
(wrap (` (: (~ (@JSON//decode inputT))
- ((~! /.dictionary) (~ valC))))))
+ ((~! </>.dictionary) (~ valC))))))
(do @
[[_ subC] (<type>.apply (p.and (<type>.exactly .Maybe)
codec//decode))]
(wrap (` (: (~ (@JSON//decode inputT))
- ((~! /.nullable) (~ subC))))))
+ ((~! </>.nullable) (~ subC))))))
(do @
[[_ subC] (<type>.apply (p.and (<type>.exactly .List)
codec//decode))]
(wrap (` (: (~ (@JSON//decode inputT))
- ((~! /.array) ((~! p.some) (~ subC)))))))
+ ((~! </>.array) ((~! p.some) (~ subC)))))))
(do @
[members (<type>.variant (p.many codec//decode))]
(wrap (` (: (~ (@JSON//decode inputT))
($_ ((~! p.or))
(~+ (list@map (function (_ [tag memberC])
(` (|> (~ memberC)
- ((~! p.after) ((~! /.number!) (~ (code.frac (..tag tag)))))
- ((~! /.array)))))
+ ((~! p.after) ((~! </>.number!) (~ (code.frac (..tag tag)))))
+ ((~! </>.array)))))
(list.enumerate members))))))))
(do @
[g!decoders (<type>.tuple (p.many codec//decode))]
(wrap (` (: (~ (@JSON//decode inputT))
- ((~! /.array) ($_ ((~! p.and)) (~+ g!decoders)))))))
+ ((~! </>.array) ($_ ((~! p.and)) (~+ g!decoders)))))))
## Type recursion
(do @
[[selfC bodyC] (<type>.recursive codec//decode)
@@ -292,8 +293,8 @@
(do @
[[funcC varsC bodyC] (<type>.polymorphic codec//decode)]
(wrap (` (: (All [(~+ varsC)]
- (-> (~+ (list@map (|>> (~) /.Reader (`)) varsC))
- (/.Reader ((~ (poly.to-code *env* inputT)) (~+ varsC)))))
+ (-> (~+ (list@map (|>> (~) </>.Parser (`)) varsC))
+ (</>.Parser ((~ (poly.to-code *env* inputT)) (~+ varsC)))))
(function ((~ funcC) (~+ varsC))
(~ bodyC))))))
<type>.parameter
@@ -325,6 +326,6 @@
(structure (def: (~' encode)
(..codec//encode (~ inputT)))
(def: ((~' decode) (~ g!inputs))
- ((~! /.run) (~ g!inputs)
+ ((~! </>.run) (~ g!inputs)
(..codec//decode (~ inputT))))
)))))))
diff --git a/stdlib/source/lux/world/net/http/request.lux b/stdlib/source/lux/world/net/http/request.lux
index e13ae884d..15f3f33e3 100644
--- a/stdlib/source/lux/world/net/http/request.lux
+++ b/stdlib/source/lux/world/net/http/request.lux
@@ -5,7 +5,9 @@
["." monad (#+ do)]
[concurrency
["." promise (#+ Promise)]
- ["." frp]]]
+ ["." frp]]
+ [parser
+ ["<.>" json]]]
[data
["." maybe]
["." error (#+ Error)]
@@ -49,7 +51,7 @@
(def: failure (//response.bad-request ""))
(def: #export (json reader server)
- (All [a] (-> (json.Reader a) (-> a Server) Server))
+ (All [a] (-> (<json>.Reader a) (-> a Server) Server))
(function (_ (^@ request [identification protocol resource message]))
(do promise.monad
[?raw (read-text-body (get@ #//.body message))]
diff --git a/stdlib/source/test/lux/macro/poly/json.lux b/stdlib/source/test/lux/macro/poly/json.lux
index 1209aa90a..78ed58a9a 100644
--- a/stdlib/source/test/lux/macro/poly/json.lux
+++ b/stdlib/source/test/lux/macro/poly/json.lux
@@ -4,7 +4,7 @@
["_" test (#+ Test)]
[abstract
codec
- [monad (#+ do Monad)]
+ [monad (#+ do)]
[equivalence (#+ Equivalence)]
{[0 #test]
[/
@@ -12,7 +12,9 @@
["$." codec]]}]
[control
pipe
- ["p" parser]]
+ ["p" parser
+ ## TODO: Get rid of this import ASAP
+ [json (#+)]]]
[data
["." error]
["." bit]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 22:25:18 +0000