aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/data/format/json.lux94
-rw-r--r--stdlib/source/lux/macro/poly/equivalence.lux58
-rw-r--r--stdlib/source/lux/macro/poly/json.lux128
-rw-r--r--stdlib/source/test/lux/control/codec.lux2
-rw-r--r--stdlib/source/test/lux/data.lux15
-rw-r--r--stdlib/source/test/lux/data/format/json.lux145
-rw-r--r--stdlib/source/test/lux/data/format/xml.lux169
7 files changed, 288 insertions, 323 deletions
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
index a213fa1d0..b68101e3c 100644
--- a/stdlib/source/lux/data/format/json.lux
+++ b/stdlib/source/lux/data/format/json.lux
@@ -5,7 +5,7 @@
["." monad (#+ Monad do)]
[equivalence (#+ Equivalence)]
codec
- ["p" parser (#+ Parser) ("#;." monad)]
+ ["p" parser (#+ Parser) ("#@." monad)]
["ex" exception (#+ exception:)]]
[data
["." bit]
@@ -14,12 +14,12 @@
["." sum]
["." product]
[number
- ["." frac ("#;." decimal)]]
- ["." text ("#;." equivalence monoid)
+ ["." frac ("#@." decimal)]]
+ ["." text ("#@." equivalence monoid)
["l" lexer]]
[collection
- ["." list ("#;." fold monad)]
- ["." row (#+ Row row) ("#;." monad)]
+ ["." list ("#@." fold monad)]
+ ["." row (#+ Row row) ("#@." monad)]
["." dictionary (#+ Dictionary)]]]
["." macro (#+ monad with-gensyms)
["s" syntax (#+ syntax:)]
@@ -76,7 +76,7 @@
(wrap (list (` (: JSON #Null))))
[_ (#.Tuple members)]
- (wrap (list (` (: JSON (#Array ((~! row) (~+ (list;map wrapper members))))))))
+ (wrap (list (` (: JSON (#Array ((~! row) (~+ (list@map wrapper members))))))))
[_ (#.Record pairs)]
(do ..monad
@@ -102,7 +102,7 @@
(#error.Success (dictionary.keys obj))
_
- (#error.Failure ($_ text;compose "Cannot get the fields of a non-object."))))
+ (#error.Failure ($_ text@compose "Cannot get the fields of a non-object."))))
(def: #export (get key json)
{#.doc "A JSON object field getter."}
@@ -114,10 +114,10 @@
(#error.Success value)
#.None
- (#error.Failure ($_ text;compose "Missing field '" key "' on object.")))
+ (#error.Failure ($_ text@compose "Missing field '" key "' on object.")))
_
- (#error.Failure ($_ text;compose "Cannot get field '" key "' of a non-object."))))
+ (#error.Failure ($_ text@compose "Cannot get field '" key "' of a non-object."))))
(def: #export (set key value json)
{#.doc "A JSON object field setter."}
@@ -127,18 +127,18 @@
(#error.Success (#Object (dictionary.put key value obj)))
_
- (#error.Failure ($_ text;compose "Cannot set field '" key "' of a non-object."))))
+ (#error.Failure ($_ text@compose "Cannot set field '" key "' of a non-object."))))
(do-template [<name> <tag> <type> <desc>]
[(def: #export (<name> key json)
- {#.doc (code.text ($_ text;compose "A JSON object field getter for " <desc> "."))}
+ {#.doc (code.text ($_ text@compose "A JSON object field getter for " <desc> "."))}
(-> Text JSON (Error <type>))
(case (get key json)
(#error.Success (<tag> value))
(#error.Success value)
(#error.Success _)
- (#error.Failure ($_ text;compose "Wrong value type at key: " key))
+ (#error.Failure ($_ text@compose "Wrong value type at key: " key))
(#error.Failure error)
(#error.Failure error)))]
@@ -165,7 +165,7 @@
[(#Array xs) (#Array ys)]
(and (n/= (row.size xs) (row.size ys))
- (list;fold (function (_ idx prev)
+ (list@fold (function (_ idx prev)
(and prev
(maybe.default #0
(do maybe.monad
@@ -177,7 +177,7 @@
[(#Object xs) (#Object ys)]
(and (n/= (dictionary.size xs) (dictionary.size ys))
- (list;fold (function (_ [xk xv] prev)
+ (list@fold (function (_ [xk xv] prev)
(and prev
(case (dictionary.get xk ys)
#.None #0
@@ -208,16 +208,16 @@
(def: (show-array show-json elems)
(-> (-> JSON Text) (-> Array Text))
- ($_ text;compose "["
- (|> elems (row;map show-json) row.to-list (text.join-with ","))
+ ($_ text@compose "["
+ (|> elems (row@map show-json) row.to-list (text.join-with ","))
"]"))
(def: (show-object show-json object)
(-> (-> JSON Text) (-> Object Text))
- ($_ text;compose "{"
+ ($_ 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 (show-string key) ":" (show-json value))))
(text.join-with ","))
"}"))
@@ -241,7 +241,7 @@
(exception: #export (unconsumed-input {input (List JSON)})
(|> input
- (list;map show-json)
+ (list@map show-json)
(text.join-with text.new-line)))
(exception: #export (empty-input)
@@ -279,7 +279,7 @@
(do-template [<name> <type> <tag> <desc>]
[(def: #export <name>
- {#.doc (code.text ($_ text;compose "Reads a JSON value as " <desc> "."))}
+ {#.doc (code.text ($_ text@compose "Reads a JSON value as " <desc> "."))}
(Reader <type>)
(do p.monad
[head any]
@@ -288,7 +288,7 @@
(wrap value)
_
- (fail ($_ text;compose "JSON value is not " <desc> ".")))))]
+ (fail ($_ text@compose "JSON value is not " <desc> ".")))))]
[null Any #Null "null"]
[boolean Bit #Boolean "boolean"]
@@ -298,7 +298,7 @@
(do-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> "."))}
+ {#.doc (code.text ($_ text@compose "Asks whether a JSON value is a " <desc> "."))}
(-> <type> (Reader Bit))
(do p.monad
[head any]
@@ -307,10 +307,10 @@
(wrap (:: <eq> = test value))
_
- (fail ($_ text;compose "JSON value is not " <desc> ".")))))
+ (fail ($_ text@compose "JSON value is not " <desc> ".")))))
(def: #export (<check> test)
- {#.doc (code.text ($_ text;compose "Ensures a JSON value is a " <desc> "."))}
+ {#.doc (code.text ($_ text@compose "Ensures a JSON value is a " <desc> "."))}
(-> <type> (Reader Any))
(do p.monad
[head any]
@@ -318,10 +318,10 @@
(<tag> value)
(if (:: <eq> = test value)
(wrap [])
- (fail ($_ text;compose "Value mismatch: " (<encoder> test) " =/= " (<encoder> value))))
+ (fail ($_ text@compose "Value mismatch: " (<encoder> test) " =/= " (<encoder> value))))
_
- (fail ($_ text;compose "JSON value is not a " <desc> ".")))))]
+ (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"]
@@ -353,7 +353,7 @@
(fail (ex.construct unconsumed-input remainder))))
_
- (fail (text;compose "JSON value is not an array: " (show-json head))))))
+ (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."}
@@ -364,7 +364,7 @@
(#Object kvs)
(case (p.run (|> kvs
dictionary.entries
- (list;map (function (_ [key value])
+ (list@map (function (_ [key value])
(list (#String key) value)))
list.concat)
parser)
@@ -380,7 +380,7 @@
(fail (ex.construct unconsumed-input remainder))))
_
- (fail (text;compose "JSON value is not an object: " (show-json head))))))
+ (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."}
@@ -388,7 +388,7 @@
(function (recur inputs)
(case inputs
(^ (list& (#String key) value inputs'))
- (if (text;= key field-name)
+ (if (text@= key field-name)
(case (p.run (list value) parser)
(#error.Success [#.Nil output])
(#error.Success [inputs' output])
@@ -409,6 +409,14 @@
_
(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))))
+
############################################################
############################################################
############################################################
@@ -456,8 +464,8 @@
[mark (l.one-of "eE")
signed?' (l.this? "-")
offset (l.many l.decimal)]
- (wrap ($_ text;compose mark (if signed?' "-" "") offset))))]
- (case (frac;decode ($_ text;compose (if signed? "-" "") digits "." decimals exp))
+ (wrap ($_ text@compose mark (if signed?' "-" "") offset))))]
+ (case (frac@decode ($_ text@compose (if signed? "-" "") digits "." decimals exp))
(#error.Failure message)
(p.fail message)
@@ -468,32 +476,32 @@
(l.Lexer Text)
($_ p.either
(p.after (l.this "\t")
- (p;wrap text.tab))
+ (p@wrap text.tab))
(p.after (l.this "\b")
- (p;wrap text.back-space))
+ (p@wrap text.back-space))
(p.after (l.this "\n")
- (p;wrap text.new-line))
+ (p@wrap text.new-line))
(p.after (l.this "\r")
- (p;wrap text.carriage-return))
+ (p@wrap text.carriage-return))
(p.after (l.this "\f")
- (p;wrap text.form-feed))
- (p.after (l.this (text;compose "\" text.double-quote))
- (p;wrap text.double-quote))
+ (p@wrap text.form-feed))
+ (p.after (l.this (text@compose "\" text.double-quote))
+ (p@wrap text.double-quote))
(p.after (l.this "\\")
- (p;wrap "\"))))
+ (p@wrap "\"))))
(def: string~
(l.Lexer String)
(<| (l.enclosed [text.double-quote text.double-quote])
(loop [_ []])
(do p.monad
- [chars (l.some (l.none-of (text;compose "\" text.double-quote)))
+ [chars (l.some (l.none-of (text@compose "\" text.double-quote)))
stop l.peek])
- (if (text;= "\" stop)
+ (if (text@= "\" stop)
(do @
[escaped escaped~
next-chars (recur [])]
- (wrap ($_ text;compose chars escaped next-chars)))
+ (wrap ($_ text@compose chars escaped next-chars)))
(wrap chars))))
(def: (kv~ json~)
diff --git a/stdlib/source/lux/macro/poly/equivalence.lux b/stdlib/source/lux/macro/poly/equivalence.lux
index cd826661c..91b3c6c64 100644
--- a/stdlib/source/lux/macro/poly/equivalence.lux
+++ b/stdlib/source/lux/macro/poly/equivalence.lux
@@ -9,25 +9,27 @@
["." bit]
["." maybe]
[number
- ["." nat ("#;." codec)]
+ ["." nat ("#@." decimal)]
["." int]
["." rev]
["." frac]]
- ["." text ("#;." monoid)
+ ["." text ("#@." monoid)
format]
[collection
- ["." list ("#;." monad)]
+ ["." list ("#@." monad)]
["." row]
["." array]
["." queue]
["." set]
- ["dict" dictionary (#+ Dictionary)]
+ ["." dictionary (#+ Dictionary)]
[tree
["." rose]]]]
[time
- ["du" duration]
- ["da" date]
- ["i" instant]]
+ ["." duration]
+ ["." date]
+ ["." instant]
+ ["." day]
+ ["." month]]
["." macro
["." code]
[syntax (#+ syntax: Syntax)
@@ -36,8 +38,7 @@
["." type
["." unit]]])
-## [Derivers]
-(poly: #export Equivalence<?>
+(poly: #export equivalence
(`` (do @
[#let [g!_ (code.local-identifier "_____________")]
*env* poly.env
@@ -64,7 +65,7 @@
(~~ (do-template [<name> <eq>]
[(do @
[[_ argC] (poly.apply (p.and (poly.exactly <name>)
- Equivalence<?>))]
+ equivalence))]
(wrap (` (: (~ (@Equivalence inputT))
(<eq> (~ argC))))))]
@@ -78,11 +79,11 @@
))
(do @
[[_ _ valC] (poly.apply ($_ p.and
- (poly.exactly dict.Dictionary)
+ (poly.exactly dictionary.Dictionary)
poly.any
- Equivalence<?>))]
+ equivalence))]
(wrap (` (: (~ (@Equivalence inputT))
- ((~! dict.equivalence) (~ valC))))))
+ ((~! dictionary.equivalence) (~ valC))))))
## Models
(~~ (do-template [<type> <eq>]
[(do @
@@ -90,11 +91,12 @@
(wrap (` (: (~ (@Equivalence inputT))
<eq>))))]
- [du.Duration du.equivalence]
- [i.Instant i.equivalence]
- [da.Date da.equivalence]
- [da.Day da.equivalence]
- [da.Month da.equivalence]))
+ [duration.Duration duration.equivalence]
+ [instant.Instant instant.equivalence]
+ [date.Date date.equivalence]
+ [day.Day day.equivalence]
+ [month.Month month.equivalence]
+ ))
(do @
[_ (poly.apply (p.and (poly.exactly unit.Qty)
poly.any))]
@@ -102,14 +104,14 @@
unit.equivalence))))
## Variants
(do @
- [members (poly.variant (p.many Equivalence<?>))
+ [members (poly.variant (p.many equivalence))
#let [g!_ (code.local-identifier "_____________")
g!left (code.local-identifier "_____________left")
g!right (code.local-identifier "_____________right")]]
(wrap (` (: (~ (@Equivalence inputT))
(function ((~ g!_) (~ g!left) (~ g!right))
(case [(~ g!left) (~ g!right)]
- (~+ (list;join (list;map (function (_ [tag g!eq])
+ (~+ (list@join (list@map (function (_ [tag g!eq])
(list (` [((~ (code.nat tag)) (~ g!left))
((~ (code.nat tag)) (~ g!right))])
(` ((~ g!eq) (~ g!left) (~ g!right)))))
@@ -118,19 +120,19 @@
#0))))))
## Tuples
(do @
- [g!eqs (poly.tuple (p.many Equivalence<?>))
+ [g!eqs (poly.tuple (p.many equivalence))
#let [g!_ (code.local-identifier "_____________")
indices (list.indices (list.size g!eqs))
- g!lefts (list;map (|>> nat;encode (text;compose "left") code.local-identifier) indices)
- g!rights (list;map (|>> nat;encode (text;compose "right") code.local-identifier) indices)]]
+ g!lefts (list@map (|>> nat@encode (text@compose "left") code.local-identifier) indices)
+ g!rights (list@map (|>> nat@encode (text@compose "right") code.local-identifier) indices)]]
(wrap (` (: (~ (@Equivalence inputT))
(function ((~ g!_) [(~+ g!lefts)] [(~+ g!rights)])
(and (~+ (|> (list.zip3 g!eqs g!lefts g!rights)
- (list;map (function (_ [g!eq g!left g!right])
+ (list@map (function (_ [g!eq g!left g!right])
(` ((~ g!eq) (~ g!left) (~ g!right)))))))))))))
## Type recursion
(do @
- [[g!self bodyC] (poly.recursive Equivalence<?>)
+ [[g!self bodyC] (poly.recursive equivalence)
#let [g!_ (code.local-identifier "_____________")]]
(wrap (` (: (~ (@Equivalence inputT))
((~! eq.rec) (.function ((~ g!_) (~ g!self))
@@ -138,15 +140,15 @@
poly.recursive-self
## Type applications
(do @
- [[funcC argsC] (poly.apply (p.and Equivalence<?> (p.many Equivalence<?>)))]
+ [[funcC argsC] (poly.apply (p.and equivalence (p.many equivalence)))]
(wrap (` ((~ funcC) (~+ argsC)))))
## Parameters
poly.parameter
## Polymorphism
(do @
- [[funcC varsC bodyC] (poly.polymorphic Equivalence<?>)]
+ [[funcC varsC bodyC] (poly.polymorphic equivalence)]
(wrap (` (: (All [(~+ varsC)]
- (-> (~+ (list;map (|>> (~) ((~! eq.Equivalence)) (`)) varsC))
+ (-> (~+ (list@map (|>> (~) ((~! eq.Equivalence)) (`)) varsC))
((~! eq.Equivalence) ((~ (poly.to-code *env* inputT)) (~+ varsC)))))
(function ((~ funcC) (~+ varsC))
(~ bodyC))))))
diff --git a/stdlib/source/lux/macro/poly/json.lux b/stdlib/source/lux/macro/poly/json.lux
index 9fd7b5aae..6cf596049 100644
--- a/stdlib/source/lux/macro/poly/json.lux
+++ b/stdlib/source/lux/macro/poly/json.lux
@@ -3,7 +3,7 @@
[control
[monad (#+ Monad do)]
[equivalence (#+ Equivalence)]
- codec
+ ["." codec]
["p" parser]]
[data
["." bit]
@@ -13,21 +13,23 @@
["." product]
[number
["." i64]
- ["." nat ("#;." codec)]
- ["." frac ("#;." codec)]]
- ["." text ("#;." equivalence)
+ ["." nat ("#@." decimal)]
+ ["." frac ("#@." decimal)]]
+ ["." text ("#@." equivalence)
["l" lexer]
format]
[format
["/" json (#+ JSON)]]
[collection
- ["." list ("#;." fold monad)]
- ["." row (#+ Row row) ("#;." monad)]
+ ["." list ("#@." fold monad)]
+ ["." row (#+ Row row) ("#@." monad)]
["d" dictionary]]]
[time
- ## ["i" instant]
- ## ["du" duration]
- ["da" date]]
+ ## ["." instant]
+ ## ["." duration]
+ ["." date]
+ ["." day]
+ ["." month]]
[macro (#+ with-gensyms)
["s" syntax (#+ syntax:)]
["." code]
@@ -49,9 +51,9 @@
(def: low-mask Nat (|> 1 (i64.left-shift 32) dec))
(def: high-mask Nat (|> low-mask (i64.left-shift 32)))
-(structure: nat-codec (Codec JSON Nat)
+(structure: nat-codec (codec.Codec JSON Nat)
(def: (encode input)
- (let [high (|> input (i64.and high-mask) (i64.logical-right-shift 32))
+ (let [high (|> input (i64.and high-mask) (i64.logic-right-shift 32))
low (i64.and low-mask input)]
(#/.Array (row (|> high .int int-to-frac #/.Number)
(|> low .int int-to-frac #/.Number)))))
@@ -64,7 +66,7 @@
(wrap (n/+ (|> high frac-to-int .nat (i64.left-shift 32))
(|> low frac-to-int .nat))))))
-(structure: int-codec (Codec JSON Int)
+(structure: int-codec (codec.Codec JSON Int)
(def: encode (|>> .nat (:: nat-codec encode)))
(def: decode
(|>> (:: nat-codec decode) (:: e.functor map .int))))
@@ -78,14 +80,14 @@
(#.Some value) (writer value))))
(structure: qty-codec
- (All [unit] (Codec JSON (unit.Qty unit)))
+ (All [unit] (codec.Codec JSON (unit.Qty unit)))
(def: encode
(|>> unit.out (:: ..int-codec encode)))
(def: decode
(|>> (:: ..int-codec decode) (:: e.functor map unit.in))))
-(poly: codec//encode
+(poly: #export codec//encode
(with-expansions
[<basic> (do-template [<matcher> <encoder>]
[(do @
@@ -104,13 +106,13 @@
[(do @
[_ (poly.exactly <type>)]
(wrap (` (: (~ (@JSON//encode inputT))
- (|>> (:: <codec> (~' encode)) #/.String)))))]
+ (|>> (:: (~! <codec>) (~' encode)) #/.String)))))]
- ## [du.Duration du.codec]
- ## [i.Instant i.codec]
- [da.Date da.date-codec]
- [da.Day da.day-codec]
- [da.Month da.month-codec])]
+ ## [duration.Duration duration.codec]
+ ## [instant.Instant instant.codec]
+ [date.Date date.codec]
+ [day.Day day.codec]
+ [month.Month month.codec])]
(do @
[*env* poly.env
#let [@JSON//encode (: (-> Type Code)
@@ -134,10 +136,10 @@
(poly.exactly .Text)
codec//encode))]
(wrap (` (: (~ (@JSON//encode inputT))
- (|>> d.entries
- ((~! list;map) (function ((~ g!_) [(~ g!key) (~ g!val)])
+ (|>> ((~! d.entries))
+ ((~! list@map) (function ((~ g!_) [(~ g!key) (~ g!val)])
[(~ g!key) ((~ =val=) (~ g!val))]))
- (d.from-list text.hash)
+ ((~! d.from-list) (~! text.hash))
#/.Object)))))
(do @
[[_ =sub=] (poly.apply ($_ p.and
@@ -150,7 +152,7 @@
(poly.exactly .List)
codec//encode))]
(wrap (` (: (~ (@JSON//encode inputT))
- (|>> ((~! list;map) (~ =sub=)) row.from-list #/.Array)))))
+ (|>> ((~! list@map) (~ =sub=)) ((~! row.from-list)) #/.Array)))))
(do @
[#let [g!_ (code.local-identifier "_______")
g!input (code.local-identifier "_______input")]
@@ -158,22 +160,22 @@
(wrap (` (: (~ (@JSON//encode inputT))
(function ((~ g!_) (~ g!input))
(case (~ g!input)
- (~+ (list;join (list;map (function (_ [tag g!encode])
+ (~+ (list@join (list@map (function (_ [tag g!encode])
(list (` ((~ (code.nat tag)) (~ g!input)))
- (` (/.json [(~ (code.frac (..tag tag)))
- ((~ g!encode) (~ g!input))]))))
+ (` ((~! /.json) [(~ (code.frac (..tag tag)))
+ ((~ g!encode) (~ g!input))]))))
(list.enumerate members))))))))))
(do @
[g!encoders (poly.tuple (p.many codec//encode))
#let [g!_ (code.local-identifier "_______")
g!members (|> (list.size g!encoders)
list.indices
- (list;map (|>> nat;encode code.local-identifier)))]]
+ (list@map (|>> nat@encode code.local-identifier)))]]
(wrap (` (: (~ (@JSON//encode inputT))
(function ((~ g!_) [(~+ g!members)])
- (/.json [(~+ (list;map (function (_ [g!member g!encode])
- (` ((~ g!encode) (~ g!member))))
- (list.zip2 g!members g!encoders)))]))))))
+ ((~! /.json) [(~+ (list@map (function (_ [g!member g!encode])
+ (` ((~ g!encode) (~ g!member))))
+ (list.zip2 g!members g!encoders)))]))))))
## Type recursion
(do @
[[selfC non-recC] (poly.recursive codec//encode)
@@ -190,7 +192,7 @@
(do @
[[funcC varsC bodyC] (poly.polymorphic codec//encode)]
(wrap (` (: (All [(~+ varsC)]
- (-> (~+ (list;map (function (_ varC) (` (-> (~ varC) /.JSON)))
+ (-> (~+ (list@map (function (_ varC) (` (-> (~ varC) /.JSON)))
varsC))
(-> ((~ (poly.to-code *env* inputT)) (~+ varsC))
/.JSON)))
@@ -202,31 +204,32 @@
(p.fail (format "Cannot create JSON encoder for: " (type.to-text inputT)))
))))
-(poly: codec//decode
+(poly: #export codec//decode
(with-expansions
[<basic> (do-template [<matcher> <decoder>]
[(do @
[_ <matcher>]
(wrap (` (: (~ (@JSON//decode inputT))
- <decoder>))))]
+ (~! <decoder>)))))]
[(poly.exactly Any) /.null]
[(poly.sub Bit) /.boolean]
- [(poly.sub Nat) (p.codec (~! ..nat-codec) /.any)]
- [(poly.sub Int) (p.codec (~! ..int-codec) /.any)]
+ [(poly.sub Nat) (p.codec ..nat-codec /.any)]
+ [(poly.sub Int) (p.codec ..int-codec /.any)]
[(poly.sub Frac) /.number]
[(poly.sub Text) /.string])
<time> (do-template [<type> <codec>]
[(do @
[_ (poly.exactly <type>)]
(wrap (` (: (~ (@JSON//decode inputT))
- (p.codec <codec> /.string)))))]
+ ((~! p.codec) (~! <codec>) (~! /.string))))))]
- ## [du.Duration du.codec]
- ## [i.Instant i.codec]
- [da.Date da.date-codec]
- [da.Day da.day-codec]
- [da.Month da.month-codec])]
+ ## [duration.Duration duration.codec]
+ ## [instant.Instant instant.codec]
+ [date.Date date.codec]
+ [day.Day day.codec]
+ [month.Month month.codec])
+ ]
(do @
[*env* poly.env
#let [@JSON//decode (: (-> Type Code)
@@ -240,44 +243,44 @@
[unitT (poly.apply (p.after (poly.exactly unit.Qty)
poly.any))]
(wrap (` (: (~ (@JSON//decode inputT))
- (p.codec (~! qty-codec) /.any)))))
+ ((~! p.codec) (~! qty-codec) (~! /.any))))))
(do @
[[_ _ valC] (poly.apply ($_ p.and
(poly.exactly d.Dictionary)
(poly.exactly .Text)
codec//decode))]
(wrap (` (: (~ (@JSON//decode inputT))
- (/.object (~ valC))))))
+ ((~! /.dictionary) (~ valC))))))
(do @
[[_ subC] (poly.apply (p.and (poly.exactly .Maybe)
codec//decode))]
(wrap (` (: (~ (@JSON//decode inputT))
- (/.nullable (~ subC))))))
+ ((~! /.nullable) (~ subC))))))
(do @
[[_ subC] (poly.apply (p.and (poly.exactly .List)
codec//decode))]
(wrap (` (: (~ (@JSON//decode inputT))
- (/.array (p.some (~ subC)))))))
+ ((~! /.array) ((~! p.some) (~ subC)))))))
(do @
[members (poly.variant (p.many codec//decode))]
(wrap (` (: (~ (@JSON//decode inputT))
- ($_ p.or
- (~+ (list;map (function (_ [tag memberC])
+ ($_ ((~! 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 (poly.tuple (p.many codec//decode))]
(wrap (` (: (~ (@JSON//decode inputT))
- (/.array ($_ p.and (~+ g!decoders)))))))
+ ((~! /.array) ($_ ((~! p.and)) (~+ g!decoders)))))))
## Type recursion
(do @
[[selfC bodyC] (poly.recursive codec//decode)
#let [g! (code.local-identifier "____________")]]
(wrap (` (: (~ (@JSON//decode inputT))
- (p.rec (.function ((~ g!) (~ selfC))
- (~ bodyC)))))))
+ ((~! p.rec) (.function ((~ g!) (~ selfC))
+ (~ bodyC)))))))
poly.recursive-self
## Type applications
(do @
@@ -287,7 +290,7 @@
(do @
[[funcC varsC bodyC] (poly.polymorphic codec//decode)]
(wrap (` (: (All [(~+ varsC)]
- (-> (~+ (list;map (|>> (~) /.Reader (`)) varsC))
+ (-> (~+ (list@map (|>> (~) /.Reader (`)) varsC))
(/.Reader ((~ (poly.to-code *env* inputT)) (~+ varsC)))))
(function ((~ funcC) (~+ varsC))
(~ bodyC))))))
@@ -300,9 +303,9 @@
(syntax: #export (codec inputT)
{#.doc (doc "A macro for automatically producing JSON codecs."
(type: Variant
- (#Case0 Bit)
- (#Case1 Text)
- (#Case2 Frac))
+ (#Bit Bit)
+ (#Text Text)
+ (#Frac Frac))
(type: Record
{#bit Bit
@@ -312,11 +315,14 @@
#list (List Frac)
#variant Variant
#tuple [Bit Frac Text]
- #dict (Dictionary Text Frac)})
+ #dictionary (Dictionary Text Frac)})
(derived: (..codec Record)))}
(with-gensyms [g!inputs]
- (wrap (list (` (: (Codec /.JSON (~ inputT))
- (structure (def: (~' encode) ((~! ..codec) (~ inputT)))
- (def: ((~' decode) (~ g!inputs)) (/.run (~ g!inputs) ((~! ..codec) (~ inputT))))
+ (wrap (list (` (: (codec.Codec /.JSON (~ inputT))
+ (structure (def: (~' encode)
+ (..codec//encode (~ inputT)))
+ (def: ((~' decode) (~ g!inputs))
+ ((~! /.run) (~ g!inputs)
+ (..codec//decode (~ inputT))))
)))))))
diff --git a/stdlib/source/test/lux/control/codec.lux b/stdlib/source/test/lux/control/codec.lux
index e061f9e36..f8159838b 100644
--- a/stdlib/source/test/lux/control/codec.lux
+++ b/stdlib/source/test/lux/control/codec.lux
@@ -18,7 +18,7 @@
(do r.monad
[expected generator]
(<| (_.context (%name (name-of /.Codec)))
- (_.test "Reflexivity."
+ (_.test "Isomorphism."
(case (|> expected /@encode /@decode)
(#error.Success actual)
(/@= expected actual)
diff --git a/stdlib/source/test/lux/data.lux b/stdlib/source/test/lux/data.lux
index 907082d99..9175d970e 100644
--- a/stdlib/source/test/lux/data.lux
+++ b/stdlib/source/test/lux/data.lux
@@ -22,9 +22,11 @@
["#." text
["#/." lexer]
["#/." regex]]
- ])
+ [format
+ ["#." json]
+ ["#." xml]]])
-(def: #export number
+(def: number
Test
($_ _.and
/i64.test
@@ -36,13 +38,19 @@
/complex.test
))
-(def: #export text
+(def: text
($_ _.and
/text.test
/text/lexer.test
/text/regex.test
))
+(def: format
+ ($_ _.and
+ /json.test
+ /xml.test
+ ))
+
(def: #export test
Test
($_ _.and
@@ -57,4 +65,5 @@
/sum.test
..number
..text
+ ..format
))
diff --git a/stdlib/source/test/lux/data/format/json.lux b/stdlib/source/test/lux/data/format/json.lux
index cdaeb5d31..11bed07da 100644
--- a/stdlib/source/test/lux/data/format/json.lux
+++ b/stdlib/source/test/lux/data/format/json.lux
@@ -1,20 +1,24 @@
(.module:
[lux #*
+ data/text/format
+ ["_" test (#+ Test)]
[control
- [monad (#+ do Monad)]
+ pipe
codec
+ [monad (#+ do Monad)]
[equivalence (#+ Equivalence)]
- pipe
- ["p" parser]]
+ ["p" parser]
+ {[0 #test]
+ [/
+ ["$." equivalence]
+ ["$." codec]]}]
[data
["." error]
["." bit]
["." maybe]
- ["." number]
- ["." text
- format]
- [format
- ["@" json]]
+ ["." text]
+ [number
+ ["." frac]]
[collection
[row (#+ row)]
["d" dictionary]
@@ -26,58 +30,40 @@
[type
["." unit]]
[math
- ["r" random]]
+ ["r" random (#+ Random)]]
[time
["ti" instant]
["tda" date]
## ["tdu" duration]
- ]
- test]
+ ]]
[test
[lux
[time
["_." instant]
## ["_." duration]
["_." date]]]]
+ {1
+ ["." / (#+ JSON)]}
)
-(def: gen-json
- (r.Random @.JSON)
- (r.rec (function (_ gen-json)
+(def: #export json
+ (Random JSON)
+ (r.rec (function (_ json)
(do r.monad
[size (:: @ map (n/% 2) r.nat)]
($_ r.or
(:: @ wrap [])
r.bit
- (|> r.frac (:: @ map (f/* +1,000,000.0)))
+ r.frac
(r.unicode size)
- (r.row size gen-json)
- (r.dictionary text.hash size (r.unicode size) gen-json)
+ (r.row size json)
+ (r.dictionary text.hash size (r.unicode size) json)
)))))
-(context: "JSON"
- (<| (times 100)
- (do @
- [sample gen-json
- #let [(^open "@/.") @.equivalence
- (^open "@/.") @.codec]]
- ($_ seq
- (test "Every JSON is equal to itself."
- (@/= sample sample))
-
- (test "Can encode/decode JSON."
- (|> sample @/encode @/decode
- (case> (#.Right result)
- (@/= sample result)
-
- (#.Left _)
- #0)))
- ))))
-
(type: Variant
- (#Case0 Bit)
- (#Case1 Text)
- (#Case2 Frac))
+ (#Bit Bit)
+ (#Text Text)
+ (#Frac Frac))
(type: #rec Recursive
(#Number Frac)
@@ -89,9 +75,9 @@
#text Text
#maybe (Maybe Frac)
#list (List Frac)
- #dict (d.Dictionary Text Frac)
- ## #variant Variant
- ## #tuple [Bit Frac Text]
+ #dictionary (d.Dictionary Text Frac)
+ #variant Variant
+ #tuple [Bit Frac Text]
#recursive Recursive
## #instant ti.Instant
## #duration tdu.Duration
@@ -100,19 +86,19 @@
})
(def: gen-recursive
- (r.Random Recursive)
+ (Random Recursive)
(r.rec (function (_ gen-recursive)
(r.or r.frac
(r.and r.frac gen-recursive)))))
-(derived: (poly/equivalence.Equivalence<?> Recursive))
+(derived: recursive-equivalence (poly/equivalence.equivalence Recursive))
(def: qty
- (All [unit] (r.Random (unit.Qty unit)))
+ (All [unit] (Random (unit.Qty unit)))
(|> r.int (:: r.monad map unit.in)))
(def: gen-record
- (r.Random Record)
+ (Random Record)
(do r.monad
[size (:: @ map (n/% 2) r.nat)]
($_ r.and
@@ -122,8 +108,8 @@
(r.maybe r.frac)
(r.list size r.frac)
(r.dictionary text.hash size (r.unicode size) r.frac)
- ## ($_ r.or r.bit (r.unicode size) r.frac)
- ## ($_ r.and r.bit r.frac (r.unicode size))
+ ($_ r.or r.bit (r.unicode size) r.frac)
+ ($_ r.and r.bit r.frac (r.unicode size))
gen-recursive
## _instant.instant
## _duration.duration
@@ -131,53 +117,16 @@
qty
)))
-(derived: (poly/json.codec Record))
-
-(structure: _ (Equivalence Record)
- (def: (= recL recR)
- (let [variant/= (function (_ left right)
- (case [left right]
- [(#Case0 left') (#Case0 right')]
- (:: bit.equivalence = left' right')
-
- [(#Case1 left') (#Case1 right')]
- (:: text.equivalence = left' right')
-
- [(#Case2 left') (#Case2 right')]
- (f/= left' right')
-
- _
- #0))]
- (and (:: bit.equivalence = (get@ #bit recL) (get@ #bit recR))
- (f/= (get@ #frac recL) (get@ #frac recR))
- (:: text.equivalence = (get@ #text recL) (get@ #text recR))
- (:: (maybe.equivalence number.equivalence) = (get@ #maybe recL) (get@ #maybe recR))
- (:: (list.equivalence number.equivalence) = (get@ #list recL) (get@ #list recR))
- (:: (d.equivalence number.equivalence) = (get@ #dict recL) (get@ #dict recR))
- ## (variant/= (get@ #variant recL) (get@ #variant recR))
- ## (let [[tL0 tL1 tL2] (get@ #tuple recL)
- ## [tR0 tR1 tR2] (get@ #tuple recR)]
- ## (and (:: bit.equivalence = tL0 tR0)
- ## (f/= tL1 tR1)
- ## (:: text.equivalence = tL2 tR2)))
- (:: equivalence = (get@ #recursive recL) (get@ #recursive recR))
- ## (:: ti.equivalence = (get@ #instant recL) (get@ #instant recR))
- ## (:: tdu.equivalence = (get@ #duration recL) (get@ #duration recR))
- (:: tda.equivalence = (get@ #date recL) (get@ #date recR))
- (:: unit.equivalence = (get@ #grams recL) (get@ #grams recR))
- ))))
-
-(context: "Polytypism"
- (<| (seed 14562075782602945288)
- ## (times 100)
- (do @
- [sample gen-record
- #let [(^open "@/.") ..equivalence
- (^open "@/.") ..codec]]
- (test "Can encode/decode arbitrary types."
- (|> sample @/encode @/decode
- (case> (#error.Success result)
- (@/= sample result)
-
- (#error.Failure error)
- #0))))))
+(derived: equivalence (poly/equivalence.equivalence Record))
+(derived: codec (poly/json.codec Record))
+
+(def: #export test
+ Test
+ (<| (_.context (%name (name-of /.JSON)))
+ ($_ _.and
+ ($equivalence.spec /.equivalence ..json)
+ ($codec.spec /.equivalence /.codec ..json)
+ (<| (_.context "Polytypism.")
+ (<| (_.seed 14562075782602945288)
+ ($codec.spec ..equivalence ..codec gen-record)))
+ )))
diff --git a/stdlib/source/test/lux/data/format/xml.lux b/stdlib/source/test/lux/data/format/xml.lux
index 35e7dc4a1..221edba97 100644
--- a/stdlib/source/test/lux/data/format/xml.lux
+++ b/stdlib/source/test/lux/data/format/xml.lux
@@ -1,23 +1,27 @@
(.module:
- [lux #*
+ [lux (#- char)
+ data/text/format
+ ["_" test (#+ Test)]
[control
+ pipe
[monad (#+ Monad do)]
["p" parser]
- pipe]
+ {[0 #test]
+ [/
+ ["$." equivalence]
+ ["$." codec]]}]
[data
["." name]
["E" error]
["." maybe]
- ["." text ("#;." equivalence)
- format]
- [format
- ["&" xml]]
+ ["." text ("#@." equivalence)]
[collection
- ["dict" dictionary]
- ["." list ("#;." functor)]]]
+ ["." dictionary]
+ ["." list ("#@." functor)]]]
[math
- ["r" random ("#;." monad)]]]
- lux/test)
+ ["r" random (#+ Random) ("#@." monad)]]]
+ {1
+ ["." / (#+ XML)]})
(def: char-range
Text
@@ -25,97 +29,84 @@
"abcdefghijklmnopqrstuvwxyz"
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
-(def: xml-char^
- (r.Random Nat)
+(def: char
+ (Random Nat)
(do r.monad
[idx (|> r.nat (:: @ map (n/% (text.size char-range))))]
(wrap (maybe.assume (text.nth idx char-range)))))
-(def: (size^ bottom top)
- (-> Nat Nat (r.Random Nat))
+(def: (size bottom top)
+ (-> Nat Nat (Random Nat))
(let [constraint (|>> (n/% top) (n/max bottom))]
- (r;map constraint r.nat)))
+ (r@map constraint r.nat)))
-(def: (xml-text^ bottom top)
- (-> Nat Nat (r.Random Text))
+(def: (text bottom top)
+ (-> Nat Nat (Random Text))
(do r.monad
- [size (size^ bottom top)]
- (r.text xml-char^ size)))
+ [size (..size bottom top)]
+ (r.text ..char size)))
(def: xml-identifier^
- (r.Random Name)
- (r.and (xml-text^ 0 10)
- (xml-text^ 1 10)))
+ (Random Name)
+ (r.and (..text 0 10)
+ (..text 1 10)))
-(def: gen-xml
- (r.Random &.XML)
- (r.rec (function (_ gen-xml)
- (r.or (xml-text^ 1 10)
+(def: #export xml
+ (Random XML)
+ (r.rec (function (_ xml)
+ (r.or (..text 1 10)
(do r.monad
- [size (size^ 0 2)]
+ [size (..size 0 2)]
($_ r.and
xml-identifier^
- (r.dictionary name.hash size xml-identifier^ (xml-text^ 0 10))
- (r.list size gen-xml)))))))
+ (r.dictionary name.hash size xml-identifier^ (..text 0 10))
+ (r.list size xml)))))))
-(context: "XML."
- (<| (times 100)
- (do @
- [sample gen-xml
- #let [(^open "&;.") &.equivalence
- (^open "&;.") &.codec]]
- ($_ seq
- (test "Every XML is equal to itself."
- (&;= sample sample))
+(def: #export test
+ Test
+ (<| (_.context (%name (name-of /.XML)))
+ ($_ _.and
+ ($equivalence.spec /.equivalence ..xml)
+ ($codec.spec /.equivalence /.codec ..xml)
- (test "Can encode/decode XML."
- (|> sample &;encode &;decode
- (case> (#.Right result)
- (&;= sample result)
-
- (#.Left error)
- #0)))
- ))))
-
-(context: "Parsing."
- (<| (times 100)
- (do @
- [text (xml-text^ 1 10)
- num-children (|> r.nat (:: @ map (n/% 5)))
- children (r.list num-children (xml-text^ 1 10))
- tag xml-identifier^
- attr xml-identifier^
- value (xml-text^ 1 10)
- #let [node (#&.Node tag
- (dict.put attr value &.attrs)
- (list;map (|>> #&.Text) children))]]
- ($_ seq
- (test "Can parse text."
- (E.default #0
- (do E.monad
- [output (&.run (#&.Text text)
- &.text)]
- (wrap (text;= text output)))))
- (test "Can parse attributes."
- (E.default #0
- (do E.monad
- [output (|> (&.attr attr)
- (p.before &.ignore)
- (&.run node))]
- (wrap (text;= value output)))))
- (test "Can parse nodes."
- (E.default #0
- (do E.monad
- [_ (|> (&.node tag)
- (p.before &.ignore)
- (&.run node))]
- (wrap #1))))
- (test "Can parse children."
- (E.default #0
- (do E.monad
- [outputs (|> (&.children (p.some &.text))
- (&.run node))]
- (wrap (:: (list.equivalence text.equivalence) =
- children
- outputs)))))
- ))))
+ (do r.monad
+ [text (..text 1 10)
+ num-children (|> r.nat (:: @ map (n/% 5)))
+ children (r.list num-children (..text 1 10))
+ tag xml-identifier^
+ attr xml-identifier^
+ value (..text 1 10)
+ #let [node (#/.Node tag
+ (dictionary.put attr value /.attrs)
+ (list@map (|>> #/.Text) children))]]
+ ($_ _.and
+ (_.test "Can parse text."
+ (E.default #0
+ (do E.monad
+ [output (/.run (#/.Text text)
+ /.text)]
+ (wrap (text@= text output)))))
+ (_.test "Can parse attributes."
+ (E.default #0
+ (do E.monad
+ [output (|> (/.attr attr)
+ (p.before /.ignore)
+ (/.run node))]
+ (wrap (text@= value output)))))
+ (_.test "Can parse nodes."
+ (E.default #0
+ (do E.monad
+ [_ (|> (/.node tag)
+ (p.before /.ignore)
+ (/.run node))]
+ (wrap #1))))
+ (_.test "Can parse children."
+ (E.default #0
+ (do E.monad
+ [outputs (|> (/.children (p.some /.text))
+ (/.run node))]
+ (wrap (:: (list.equivalence text.equivalence) =
+ children
+ outputs)))))
+ ))
+ )))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 13:07:38 +0000