diff options
author | Eduardo Julian | 2017-09-05 18:38:26 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-09-05 18:38:26 -0400 |
commit | dd505e9d5c528388e80ca5a2cd3d08c8001ed634 (patch) | |
tree | 4aaa61aab097abc4414547d511748ff1f5c209b7 /stdlib | |
parent | 8eec2a1545cf28f2c9e8a5d604d995bfe7332e9b (diff) |
- Added polytypic JSON codec support for unit-types.
Diffstat (limited to 'stdlib')
-rw-r--r-- | stdlib/source/lux/macro/poly/json.lux | 22 | ||||
-rw-r--r-- | stdlib/test/test/lux/data/format/json.lux | 95 | ||||
-rw-r--r-- | stdlib/test/test/lux/time/date.lux | 2 | ||||
-rw-r--r-- | stdlib/test/test/lux/time/duration.lux | 3 | ||||
-rw-r--r-- | stdlib/test/test/lux/time/instant.lux | 9 |
5 files changed, 86 insertions, 45 deletions
diff --git a/stdlib/source/lux/macro/poly/json.lux b/stdlib/source/lux/macro/poly/json.lux index 2c87603d3..379be9f49 100644 --- a/stdlib/source/lux/macro/poly/json.lux +++ b/stdlib/source/lux/macro/poly/json.lux @@ -27,6 +27,7 @@ [code] [poly #+ poly:]) [type] + (type [unit]) )) (def: #hidden _map_ @@ -49,7 +50,7 @@ (struct: #hidden _ (Codec JSON Nat) (def: (encode input) - (let [high (|> input (bit;and high-mask) (bit;unsigned-shift-right +32)) + (let [high (|> input (bit;and high-mask) (bit;shift-right +32)) low (bit;and low-mask input)] (#..;Array (vector (|> high nat-to-int int-to-frac #..;Number) (|> low nat-to-int int-to-frac #..;Number))))) @@ -74,6 +75,13 @@ #;None #..;Null (#;Some value) (writer value)))) +(struct: #hidden (Codec<JSON,Qty> carrier) + (All [unit] (-> unit (Codec JSON (unit;Qty unit)))) + (def: encode + (|>. unit;out (:: Codec<JSON,Int> encode))) + (def: decode + (|>. (:: Codec<JSON,Int> decode) (:: R;Functor<Result> map (unit;in carrier))))) + (poly: #hidden Codec<JSON,?>//encode (with-expansions [<basic> (do-template [<type> <matcher> <encoder>] @@ -92,7 +100,7 @@ [(do @ [_ (poly;this <type>)] (wrap (` (: (~ (@JSON//encode inputT)) - (|>. (:: <codec> (~' encode)) ..;string)))))] + (|>. (:: <codec> (~' encode)) #..;String)))))] [du;Duration du;Codec<Text,Duration>] [i;Instant i;Codec<Text,Instant>] @@ -109,6 +117,11 @@ <basic> <time> (do @ + [unitT (poly;apply (p;after (poly;this unit;Qty) + poly;any))] + (wrap (` (: (~ (@JSON//encode inputT)) + (:: (Codec<JSON,Qty> (:! (~ (poly;to-ast *env* unitT)) [])) (~' encode)))))) + (do @ [#let [g!key (code;local-symbol "\u0000key") g!val (code;local-symbol "\u0000val")] [_ _ .val.] (poly;apply ($_ p;seq @@ -216,6 +229,11 @@ <basic> <time> (do @ + [unitT (poly;apply (p;after (poly;this unit;Qty) + poly;any))] + (wrap (` (: (~ (@JSON//decode inputT)) + (p;codec (Codec<JSON,Qty> (:! (~ (poly;to-ast *env* unitT)) [])) ..;any))))) + (do @ [[_ _ valC] (poly;apply ($_ p;seq (poly;this d;Dict) poly;text diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux index bd0e4ab67..2eca6febd 100644 --- a/stdlib/test/test/lux/data/format/json.lux +++ b/stdlib/test/test/lux/data/format/json.lux @@ -23,7 +23,14 @@ [poly/eq] [poly/json]) ["r" math/random] + (time ["ti" instant] + ["tda" date] + ["tdu" duration]) + (type [unit]) test) + (test (lux (time ["_;" instant] + ["_;" duration] + ["_;" date]))) ) (def: gen-json @@ -67,16 +74,21 @@ (#Addition Frac Recursive)) (type: Record - {#unit Unit - #bool Bool - #frac Frac - #text Text - #maybe (Maybe Frac) - #list (List Frac) - #variant Variant - #tuple [Bool Frac Text] - #dict (d;Dict Text Frac) - #recursive Recursive}) + {## #unit Unit + ## #bool Bool + ## #frac Frac + ## #text Text + ## #maybe (Maybe Frac) + ## #list (List Frac) + ## #variant Variant + ## #tuple [Bool Frac Text] + ## #dict (d;Dict Text Frac) + ## #recursive Recursive + #instant ti;Instant + #duration tdu;Duration + #date tda;Date + #grams (unit;Qty unit;Gram) + }) (def: gen-recursive (r;Random Recursive) @@ -86,21 +98,30 @@ (derived: (poly/eq;Eq<?> Recursive)) +(def: (qty carrier) + (All [unit] (-> unit (r;Random (unit;Qty unit)))) + (|> r;int + (:: r;Monad<Random> map (unit;in carrier)))) + (def: gen-record (r;Random Record) (do r;Monad<Random> [size (:: @ map (n.% +2) r;nat)] ($_ r;seq - (:: @ wrap []) - r;bool - r;frac - (r;text size) - (r;maybe r;frac) - (r;list size r;frac) - ($_ r;alt r;bool (r;text size) r;frac) - ($_ r;seq r;bool r;frac (r;text size)) - (r;dict text;Hash<Text> size (r;text size) r;frac) - gen-recursive + ## (:: @ wrap []) + ## r;bool + ## r;frac + ## (r;text size) + ## (r;maybe r;frac) + ## (r;list size r;frac) + ## ($_ r;alt r;bool (r;text size) r;frac) + ## ($_ r;seq r;bool r;frac (r;text size)) + ## (r;dict text;Hash<Text> size (r;text size) r;frac) + ## gen-recursive + _instant;instant + _duration;duration + _date;date + (qty unit;@Gram) ))) (derived: (poly/json;Codec<JSON,?> Record)) @@ -111,28 +132,32 @@ (case [left right] [(#Case0 left') (#Case0 right')] (:: bool;Eq<Bool> = left' right') - + [(#Case1 left') (#Case1 right')] (:: text;Eq<Text> = left' right') - + [(#Case2 left') (#Case2 right')] (f.= left' right') _ false))] - (and (:: bool;Eq<Bool> = (get@ #bool recL) (get@ #bool recR)) - (f.= (get@ #frac recL) (get@ #frac recR)) - (:: text;Eq<Text> = (get@ #text recL) (get@ #text recR)) - (:: (maybe;Eq<Maybe> number;Eq<Frac>) = (get@ #maybe recL) (get@ #maybe recR)) - (:: (list;Eq<List> number;Eq<Frac>) = (get@ #list recL) (get@ #list recR)) - (variant/= (get@ #variant recL) (get@ #variant recR)) - (let [[tL0 tL1 tL2] (get@ #tuple recL) - [tR0 tR1 tR2] (get@ #tuple recR)] - (and (:: bool;Eq<Bool> = tL0 tR0) - (f.= tL1 tR1) - (:: text;Eq<Text> = tL2 tR2))) - (:: (d;Eq<Dict> number;Eq<Frac>) = (get@ #dict recL) (get@ #dict recR)) - (:: Eq<Recursive> = (get@ #recursive recL) (get@ #recursive recR)) + (and ## (:: bool;Eq<Bool> = (get@ #bool recL) (get@ #bool recR)) + ## (f.= (get@ #frac recL) (get@ #frac recR)) + ## (:: text;Eq<Text> = (get@ #text recL) (get@ #text recR)) + ## (:: (maybe;Eq<Maybe> number;Eq<Frac>) = (get@ #maybe recL) (get@ #maybe recR)) + ## (:: (list;Eq<List> number;Eq<Frac>) = (get@ #list recL) (get@ #list recR)) + ## (variant/= (get@ #variant recL) (get@ #variant recR)) + ## (let [[tL0 tL1 tL2] (get@ #tuple recL) + ## [tR0 tR1 tR2] (get@ #tuple recR)] + ## (and (:: bool;Eq<Bool> = tL0 tR0) + ## (f.= tL1 tR1) + ## (:: text;Eq<Text> = tL2 tR2))) + ## (:: (d;Eq<Dict> number;Eq<Frac>) = (get@ #dict recL) (get@ #dict recR)) + ## (:: Eq<Recursive> = (get@ #recursive recL) (get@ #recursive recR)) + (:: ti;Eq<Instant> = (get@ #instant recL) (get@ #instant recR)) + (:: tdu;Eq<Duration> = (get@ #duration recL) (get@ #duration recR)) + (:: tda;Eq<Date> = (get@ #date recL) (get@ #date recR)) + (:: unit;Eq<Unit> = (get@ #grams recL) (get@ #grams recR)) )))) (context: "Polytypism" diff --git a/stdlib/test/test/lux/time/date.lux b/stdlib/test/test/lux/time/date.lux index 2a56fb71a..a73001026 100644 --- a/stdlib/test/test/lux/time/date.lux +++ b/stdlib/test/test/lux/time/date.lux @@ -89,7 +89,7 @@ (|> sample @/succ @/pred (@/= sample)) (|> sample @/pred @/succ (@/= sample))))) -(def: date +(def: #export date (r;Random @;Date) (|> _instant;instant (:: r;Monad<Random> map @instant;date))) diff --git a/stdlib/test/test/lux/time/duration.lux b/stdlib/test/test/lux/time/duration.lux index 565010a07..020c198e6 100644 --- a/stdlib/test/test/lux/time/duration.lux +++ b/stdlib/test/test/lux/time/duration.lux @@ -8,7 +8,7 @@ (time ["@" duration])) lux/test) -(def: duration +(def: #export duration (r;Random @;Duration) (|> r;int (:: r;Monad<Random> map @;from-millis))) @@ -59,6 +59,7 @@ )) (context: "Codec" + #seed +9664448049824422386 [sample duration #let [(^open "@/") @;Eq<Duration> (^open "@/") @;Codec<Text,Duration>]] diff --git a/stdlib/test/test/lux/time/instant.lux b/stdlib/test/test/lux/time/instant.lux index 2343beac1..c686de5b7 100644 --- a/stdlib/test/test/lux/time/instant.lux +++ b/stdlib/test/test/lux/time/instant.lux @@ -11,7 +11,8 @@ (time ["@" instant] ["@d" duration] ["@date" date])) - lux/test) + lux/test + (.. ["_;" duration])) (def: boundary Int 99_999_999_999_999) @@ -19,10 +20,6 @@ (r;Random @;Instant) (|> r;int (:: r;Monad<Random> map (|>. (i.% boundary) @;from-millis)))) -(def: duration - (r;Random @d;Duration) - (|> r;int (:: r;Monad<Random> map @d;from-millis))) - (context: "Conversion." [millis r;int] (test "Can convert from/to milliseconds." @@ -57,7 +54,7 @@ (context: "Arithmetic" [sample instant - span duration + span _duration;duration #let [(^open "@/") @;Eq<Instant> (^open "@d/") @d;Eq<Duration>]] ($_ seq |