From dd505e9d5c528388e80ca5a2cd3d08c8001ed634 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 5 Sep 2017 18:38:26 -0400
Subject: - Added polytypic JSON codec support for unit-types.

---
 stdlib/source/lux/macro/poly/json.lux     | 22 ++++++-
 stdlib/test/test/lux/data/format/json.lux | 95 +++++++++++++++++++------------
 stdlib/test/test/lux/time/date.lux        |  2 +-
 stdlib/test/test/lux/time/duration.lux    |  3 +-
 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>]
@@ -108,6 +116,11 @@
       ($_ p;either
           <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")]
@@ -215,6 +228,11 @@
       ($_ p;either
           <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)
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
-- 
cgit v1.2.3