- Extended duration and date with Order and Codec implementations.

4 files changed, 268 insertions, 6 deletions

diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux
index 20f29e943..bd7253a59 100644
--- a/stdlib/source/lux/time/date.lux
+++ b/stdlib/source/lux/time/date.lux
@@ -2,7 +2,15 @@
   lux
   (lux (control eq
                 order
-                enum)))
+                enum
+                codec
+                ["p" parser]
+                [monad #+ do])
+       (data ["R" result]
+             [number "int/" Codec<Text,Int>]
+             [text "text/" Monoid<Text>]
+             (text ["l" lexer])
+             (coll ["v" vector]))))
 
 (type: #export Year Int)
 
@@ -185,3 +193,130 @@
              (get@ #month sample))
          (n.= (get@ #day reference)
               (get@ #day sample)))))
+
+(def: (date.< reference sample)
+  (-> Date Date Bool)
+  (or (i.< (get@ #year reference)
+           (get@ #year sample))
+      (:: Order<Month> <
+          (get@ #month reference)
+          (get@ #month sample))
+      (n.< (get@ #day reference)
+           (get@ #day sample))))
+
+(struct: #export _ (Order Date)
+  (def: eq Eq<Date>)
+  (def: < date.<)
+  (def: (> reference sample)
+    (date.< sample reference))
+  (def: (<= reference sample)
+    (or (date.< reference sample)
+        (:: Eq<Date> = reference sample)))
+  (def: (>= reference sample)
+    (or (date.< sample reference)
+        (:: Eq<Date> = sample reference))))
+
+## Based on this: https://stackoverflow.com/a/42936293/6823464
+(def: (pad value)
+  (-> Int Text)
+  (if (i.< 10 value)
+    (text/append "0" (int/encode value))
+    (int/encode value)))
+
+(def: (encode [year month day])
+  (-> Date Text)
+  ($_ text/append
+      (int/encode year) "-"
+      (pad (|> month month-to-nat n.inc nat-to-int)) "-"
+      (pad (|> day nat-to-int))))
+
+(def: lex-year
+  (l;Lexer Int)
+  (do p;Monad<Parser>
+    [sign? (p;opt (l;this "-"))
+     raw-year (l;codec number;Codec<Text,Int> (l;many l;decimal))
+     #let [signum (case sign?
+                    #;None      1
+                    (#;Some _) -1)]]
+    (wrap (i.* signum raw-year))))
+
+(def: lex-section
+  (l;Lexer Int)
+  (l;codec number;Codec<Text,Int> (l;exactly +2 l;decimal)))
+
+(def: (leap-years year)
+  (-> Int Int)
+  (|> (i./ 4 year)
+      (i.- (i./ 100 year))
+      (i.+ (i./ 400 year))))
+
+(def: normal-months
+  (v;Vector Nat)
+  (v;vector +31 +28 +31
+            +30 +31 +30
+            +31 +31 +30
+            +31 +30 +31))
+
+(def: leap-year-months
+  (v;Vector Nat)
+  (v;update [+1] n.inc normal-months))
+
+(def: (divisible? factor input)
+  (-> Int Int Bool)
+  (|> input (i.% factor) (i.= 0)))
+
+(def: (leap-year? year)
+  (-> Int Bool)
+  (and (divisible? 4 year)
+       (or (not (divisible? 100 year))
+           (divisible? 400 year))))
+
+## Based on: https://stackoverflow.com/a/3309340/6823464
+(def: lex-date
+  (l;Lexer Date)
+  (do p;Monad<Parser>
+    [utc-year lex-year
+     _ (l;this "-")
+     utc-month lex-section
+     _ (p;assert "Invalid month."
+                 (and (i.>= 1 utc-month)
+                      (i.<= 12 utc-month)))
+     #let [months (if (leap-year? utc-year)
+                    leap-year-months
+                    normal-months)
+           month-days (|> months
+                          (v;nth (int-to-nat (i.dec utc-month)))
+                          assume)]
+     _ (l;this "-")
+     utc-day lex-section
+     _ (p;assert "Invalid day."
+                 (and (i.>= 1 utc-day)
+                      (i.<= (nat-to-int month-days) utc-day)))]
+    (wrap {#year utc-year
+           #month (case utc-month
+                    1 #January
+                    2 #February
+                    3 #March
+                    4 #April
+                    5 #May
+                    6 #June
+                    7 #July
+                    8 #August
+                    9 #September
+                    10 #October
+                    11 #November
+                    12 #December
+                    _ (undefined))
+           #day (int-to-nat utc-day)})))
+
+(def: (decode input)
+  (-> Text (R;Result Date))
+  (l;run input lex-date))
+
+(struct: #export _
+  {#;doc "Based on ISO 8601.
+
+          For example: 2017-01-15"}
+  (Codec Text Date)
+  (def: encode encode)
+  (def: decode decode))
diff --git a/stdlib/source/lux/time/duration.lux b/stdlib/source/lux/time/duration.lux
index 3deefa944..2f3d019dd 100644
--- a/stdlib/source/lux/time/duration.lux
+++ b/stdlib/source/lux/time/duration.lux
@@ -1,7 +1,14 @@
 (;module:
   lux
   (lux (control eq
-                order)
+                order
+                codec
+                ["p" parser]
+                [monad #+ do])
+       (data [number "int/" Codec<Text,Int> Number<Int>]
+             [text "text/" Monoid<Text>]
+             (text ["l" lexer])
+             ["R" result])
        (type model)))
 
 (model: #export Duration
@@ -68,3 +75,68 @@
 (def: #export week Duration (scale 7 day))
 (def: #export normal-year Duration (scale 365 day))
 (def: #export leap-year Duration (merge day normal-year))
+
+(def: (encode duration)
+  (-> Duration Text)
+  (if (:: Eq<Duration> = empty duration)
+    "0ms"
+    (let [signed? (negative? duration)
+          [hours time-left] [(query hour duration) (frame hour duration)]
+          hours (if signed?
+                  (int/abs hours)
+                  hours)
+          time-left (if signed?
+                      (scale -1 time-left)
+                      time-left)
+          [minutes time-left] [(query minute time-left) (frame minute time-left)]
+          [seconds time-left] [(query second time-left) (frame second time-left)]
+          millis (to-millis time-left)]
+      ($_ text/append
+          (if signed? "-" "")
+          (if (i.= 0 hours) "" (text/append (int/encode hours) "h"))
+          (if (i.= 0 minutes) "" (text/append (int/encode minutes) "m"))
+          (if (i.= 0 seconds) "" (text/append (int/encode seconds) "s"))
+          (if (i.= 0 millis) "" (text/append (int/encode millis) "ms"))
+          ))))
+
+(def: (lex-section suffix)
+  (-> Text (l;Lexer Int))
+  (|> (l;codec number;Codec<Text,Int> (l;many l;decimal))
+      (p;before (l;this suffix))
+      (p;default 0)))
+
+(def: lex-duration
+  (l;Lexer Duration)
+  (do p;Monad<Parser>
+    [signed? (l;this? "-")
+     #let [sign (function [raw] (if signed? (i.* -1 raw) raw))]
+     utc-hour (lex-section "h")
+     utc-minute (lex-section "m")
+     _ (p;assert "Invalid minute."
+                 (and (i.>= 0 utc-minute)
+                      (i.<= 59 utc-minute)))
+     utc-second (lex-section "s")
+     _ (p;assert "Invalid second."
+                 (and (i.>= 0 utc-second)
+                      (i.<= 59 utc-second)))
+     utc-millis (lex-section "ms")
+     _ (p;assert "Invalid milli-seconds."
+                 (and (i.>= 0 utc-millis)
+                      (i.<= 999 utc-millis)))]
+    (wrap (|> empty
+              (merge (scale (sign utc-hour) hour))
+              (merge (scale (sign utc-minute) minute))
+              (merge (scale (sign utc-second) second))
+              (merge (scale (sign utc-millis) milli))))))
+
+(def: (decode input)
+  (-> Text (R;Result Duration))
+  (l;run input lex-duration))
+
+(struct: #export _
+  {#;doc "Based on ISO 8601.
+
+          For example: 21h14m51s827ms"}
+  (Codec Text Duration)
+  (def: encode encode)
+  (def: decode decode))
diff --git a/stdlib/test/test/lux/time/date.lux b/stdlib/test/test/lux/time/date.lux
index e5b5fefc5..2a56fb71a 100644
--- a/stdlib/test/test/lux/time/date.lux
+++ b/stdlib/test/test/lux/time/date.lux
@@ -1,10 +1,14 @@
 (;module:
   lux
   (lux [io]
-       (control [monad #+ do Monad])
+       (control [monad #+ do Monad]
+                [pipe])
+       (data ["R" result])
        (math ["r" random "r/" Monad<Random>])
-       (time ["@" date]))
-  lux/test)
+       (time ["@;" instant]
+             ["@" date]))
+  lux/test
+  (test (lux (time ["_;" instant]))))
 
 (def: month
   (r;Random @;Month)
@@ -84,3 +88,38 @@
                        sample))
              (|> sample @/succ @/pred (@/= sample))
              (|> sample @/pred @/succ (@/= sample)))))
+
+(def: date
+  (r;Random @;Date)
+  (|> _instant;instant (:: r;Monad<Random> map @instant;date)))
+
+(context: "(Date) Eq."
+  [sample date
+   #let [(^open "@/") @;Eq<Date>]]
+  (test "Every value equals itself."
+        (@/= sample sample)))
+
+(context: "(Date) Order."
+  [reference date
+   sample date
+   #let [(^open "@/") @;Order<Date>]]
+  (test "Valid Order."
+        (and (or (@/< reference sample)
+                 (@/>= reference sample))
+             (or (@/> reference sample)
+                 (@/<= reference sample)))))
+
+(context: "(Date) Codec"
+  #seed +1501531301120
+  [sample date
+   #let [(^open "@/") @;Eq<Date>
+         (^open "@/") @;Codec<Text,Date>]]
+  (test "Can encode/decode dates."
+        (|> sample
+            @/encode
+            @/decode
+            (pipe;case> (#R;Success decoded)
+                        (@/= sample decoded)
+
+                        (#R;Error error)
+                        false))))
diff --git a/stdlib/test/test/lux/time/duration.lux b/stdlib/test/test/lux/time/duration.lux
index 18ec46090..565010a07 100644
--- a/stdlib/test/test/lux/time/duration.lux
+++ b/stdlib/test/test/lux/time/duration.lux
@@ -1,7 +1,9 @@
 (;module:
   lux
   (lux [io]
-       (control [monad #+ do Monad])
+       (control [monad #+ do Monad]
+                [pipe])
+       (data ["R" result])
        (math ["r" random])
        (time ["@" duration]))
   lux/test)
@@ -55,3 +57,17 @@
                                                                  (@;scale -1 frame)
                                                                  frame))))))
       ))
+
+(context: "Codec"
+  [sample duration
+   #let [(^open "@/") @;Eq<Duration>
+         (^open "@/") @;Codec<Text,Duration>]]
+  (test "Can encode/decode durations."
+        (|> sample
+            @/encode
+            @/decode
+            (pipe;case> (#R;Success decoded)
+                        (@/= sample decoded)
+
+                        (#R;Error error)
+                        false))))