From 4c6d153acdbfa7e71109dbe9c1ae1fcca9e914e6 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 23 Mar 2019 18:46:27 -0400 Subject: Ported tests for format-related modules. --- stdlib/source/lux/data/format/json.lux | 94 ++++++++------- stdlib/source/lux/macro/poly/equivalence.lux | 58 ++++----- stdlib/source/lux/macro/poly/json.lux | 128 ++++++++++---------- stdlib/source/test/lux/control/codec.lux | 2 +- stdlib/source/test/lux/data.lux | 15 ++- stdlib/source/test/lux/data/format/json.lux | 145 ++++++++--------------- stdlib/source/test/lux/data/format/xml.lux | 169 +++++++++++++-------------- 7 files changed, 288 insertions(+), 323 deletions(-) (limited to 'stdlib/source') 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 [ ] [(def: #export ( key json) - {#.doc (code.text ($_ text;compose "A JSON object field getter for " "."))} + {#.doc (code.text ($_ text@compose "A JSON object field getter for " "."))} (-> Text JSON (Error )) (case (get key json) (#error.Success ( 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 [ ] [(def: #export - {#.doc (code.text ($_ text;compose "Reads a JSON value as " "."))} + {#.doc (code.text ($_ text@compose "Reads a JSON value as " "."))} (Reader ) (do p.monad [head any] @@ -288,7 +288,7 @@ (wrap value) _ - (fail ($_ text;compose "JSON value is not " ".")))))] + (fail ($_ text@compose "JSON value is not " ".")))))] [null Any #Null "null"] [boolean Bit #Boolean "boolean"] @@ -298,7 +298,7 @@ (do-template [ ] [(def: #export ( test) - {#.doc (code.text ($_ text;compose "Asks whether a JSON value is a " "."))} + {#.doc (code.text ($_ text@compose "Asks whether a JSON value is a " "."))} (-> (Reader Bit)) (do p.monad [head any] @@ -307,10 +307,10 @@ (wrap (:: = test value)) _ - (fail ($_ text;compose "JSON value is not " "."))))) + (fail ($_ text@compose "JSON value is not " "."))))) (def: #export ( test) - {#.doc (code.text ($_ text;compose "Ensures a JSON value is a " "."))} + {#.doc (code.text ($_ text@compose "Ensures a JSON value is a " "."))} (-> (Reader Any)) (do p.monad [head any] @@ -318,10 +318,10 @@ ( value) (if (:: = test value) (wrap []) - (fail ($_ text;compose "Value mismatch: " ( test) " =/= " ( value)))) + (fail ($_ text@compose "Value mismatch: " ( test) " =/= " ( value)))) _ - (fail ($_ text;compose "JSON value is not a " ".")))))] + (fail ($_ text@compose "JSON value is not a " ".")))))] [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 [ ] [(do @ [[_ argC] (poly.apply (p.and (poly.exactly ) - Equivalence))] + equivalence))] (wrap (` (: (~ (@Equivalence inputT)) ( (~ 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 [ ] [(do @ @@ -90,11 +91,12 @@ (wrap (` (: (~ (@Equivalence inputT)) ))))] - [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 [ (do-template [ ] [(do @ @@ -104,13 +106,13 @@ [(do @ [_ (poly.exactly )] (wrap (` (: (~ (@JSON//encode inputT)) - (|>> (:: (~' encode)) #/.String)))))] + (|>> (:: (~! ) (~' 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 [ (do-template [ ] [(do @ [_ ] (wrap (` (: (~ (@JSON//decode inputT)) - ))))] + (~! )))))] [(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])