- Extended duration and date with Order and Codec implementations.

2 files changed, 209 insertions, 2 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))