diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/data/format/json.lux | 94 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly/equivalence.lux | 58 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/poly/json.lux | 128 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/codec.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data.lux | 15 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data/format/json.lux | 145 | ||||
| -rw-r--r-- | stdlib/source/test/lux/data/format/xml.lux | 169 |
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))))) + )) + ))) |