- Added more structures for instants and dates.

5 files changed, 278 insertions, 18 deletions

diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux
index 2da6980ac..20f29e943 100644
--- a/stdlib/source/lux/time/date.lux
+++ b/stdlib/source/lux/time/date.lux
@@ -1,5 +1,8 @@
 (;module:
-  lux)
+  lux
+  (lux (control eq
+                order
+                enum)))
 
 (type: #export Year Int)
 
@@ -17,6 +20,87 @@
   #November
   #December)
 
+(struct: #export _ (Eq Month)
+  (def: (= reference sample)
+    (case [reference sample]
+      (^template [<tag>]
+        [<tag> <tag>]
+        true)
+      ([#January]
+       [#February]
+       [#March]
+       [#April]
+       [#May]
+       [#June]
+       [#July]
+       [#August]
+       [#September]
+       [#October]
+       [#November]
+       [#December])
+
+      _
+      false)))
+
+(def: (month-to-nat month)
+  (-> Month Nat)
+  (case month
+    #January   +0
+    #February  +1
+    #March     +2
+    #April     +3
+    #May       +4
+    #June      +5
+    #July      +6
+    #August    +7
+    #September +8
+    #October   +9
+    #November +10
+    #December +11))
+
+(struct: #export _ (Order Month)
+  (def: eq Eq<Month>)
+  (do-template [<name> <comp>]
+    [(def: (<name> reference sample)
+       (<comp> (month-to-nat reference) (month-to-nat sample)))]
+
+    [<  n.<]
+    [<= n.<=]
+    [>  n.>]
+    [>= n.>=]
+    ))
+
+(struct: #export _ (Enum Month)
+  (def: order Order<Month>)
+  (def: (succ month)
+    (case month
+      #January   #February
+      #February  #March
+      #March     #April
+      #April     #May
+      #May       #June
+      #June      #July
+      #July      #August
+      #August    #September
+      #September #October
+      #October   #November
+      #November  #December
+      #December  #January))
+  (def: (pred month)
+    (case month
+      #February  #January
+      #March     #February
+      #April     #March
+      #May       #April
+      #June      #May
+      #July      #June
+      #August    #July
+      #September #August
+      #October   #September
+      #November  #October
+      #December  #November
+      #January   #December)))
+
 (type: #export Day
   #Sunday
   #Monday
@@ -26,7 +110,78 @@
   #Friday
   #Saturday)
 
+(struct: #export _ (Eq Day)
+  (def: (= reference sample)
+    (case [reference sample]
+      (^template [<tag>]
+        [<tag> <tag>]
+        true)
+      ([#Sunday]
+       [#Monday]
+       [#Tuesday]
+       [#Wednesday]
+       [#Thursday]
+       [#Friday]
+       [#Saturday])
+
+      _
+      false)))
+
+(def: (day-to-nat day)
+  (-> Day Nat)
+  (case day
+    #Sunday    +0
+    #Monday    +1
+    #Tuesday   +2
+    #Wednesday +3
+    #Thursday  +4
+    #Friday    +5
+    #Saturday  +6))
+
+(struct: #export _ (Order Day)
+  (def: eq Eq<Day>)
+  (do-template [<name> <comp>]
+    [(def: (<name> reference sample)
+       (<comp> (day-to-nat reference) (day-to-nat sample)))]
+
+    [<  n.<]
+    [<= n.<=]
+    [>  n.>]
+    [>= n.>=]
+    ))
+
+(struct: #export _ (Enum Day)
+  (def: order Order<Day>)
+  (def: (succ day)
+    (case day
+      #Sunday    #Monday
+      #Monday    #Tuesday
+      #Tuesday   #Wednesday
+      #Wednesday #Thursday
+      #Thursday  #Friday
+      #Friday    #Saturday
+      #Saturday  #Sunday))
+  (def: (pred day)
+    (case day
+      #Monday    #Sunday
+      #Tuesday   #Monday
+      #Wednesday #Tuesday
+      #Thursday  #Wednesday
+      #Friday    #Thursday
+      #Saturday  #Friday
+      #Sunday    #Saturday)))
+
 (type: #export Date
   {#year Year
    #month Month
    #day Nat})
+
+(struct: #export _ (Eq Date)
+  (def: (= reference sample)
+    (and (i.= (get@ #year reference)
+              (get@ #year sample))
+         (:: Eq<Month> =
+             (get@ #month reference)
+             (get@ #month sample))
+         (n.= (get@ #day reference)
+              (get@ #day sample)))))
diff --git a/stdlib/source/lux/time/instant.lux b/stdlib/source/lux/time/instant.lux
index ebe637217..a05513374 100644
--- a/stdlib/source/lux/time/instant.lux
+++ b/stdlib/source/lux/time/instant.lux
@@ -3,6 +3,7 @@
   (lux [io #- run]
        (control eq
                 order
+                enum
                 codec
                 [monad #+ do Monad]
                 ["p" parser])
@@ -33,22 +34,6 @@
     (-> Instant Instant duration;Duration)
     (duration;from-millis (i.- (@repr param) (@repr subject))))
 
-  (struct: #export _ (Eq Instant)
-    (def: (= param subject)
-      (i.= (@repr param) (@repr subject))))
-
-  (struct: #export _ (Order Instant)
-    (def: eq Eq<Instant>)
-    (do-template [<name> <op>]
-      [(def: (<name> param subject)
-         (<op> (@repr param) (@repr subject)))]
-
-      [<  i.<]
-      [<= i.<=]
-      [>  i.>]
-      [>= i.>=]
-      ))
-
   (def: #export (shift duration instant)
     (-> duration;Duration Instant Instant)
     (@model (i.+ (duration;to-millis duration) (@repr instant))))
@@ -60,6 +45,28 @@
   (def: #export (absolute offset)
     (-> duration;Duration Instant)
     (|> offset duration;to-millis @model))
+
+  (struct: #export _ (Eq Instant)
+    (def: (= param subject)
+      (:: number;Eq<Int> = (@repr param) (@repr subject))))
+
+  (struct: #export _ (Order Instant)
+    (def: eq Eq<Instant>)
+    (do-template [<name>]
+      [(def: (<name> param subject)
+         (:: number;Order<Int> <name> (@repr param) (@repr subject)))]
+
+      [<] [<=] [>] [>=]
+      ))
+
+  (struct: #export _ (Enum Instant)
+    (def: order Order<Instant>)
+    (do-template [<name>]
+      [(def: <name>
+         (|>. @repr (:: number;Enum<Int> <name>) @model))]
+
+      [succ] [pred]
+      ))
   )
 
 (def: #export epoch
diff --git a/stdlib/test/test/lux/time/date.lux b/stdlib/test/test/lux/time/date.lux
new file mode 100644
index 000000000..e5b5fefc5
--- /dev/null
+++ b/stdlib/test/test/lux/time/date.lux
@@ -0,0 +1,86 @@
+(;module:
+  lux
+  (lux [io]
+       (control [monad #+ do Monad])
+       (math ["r" random "r/" Monad<Random>])
+       (time ["@" date]))
+  lux/test)
+
+(def: month
+  (r;Random @;Month)
+  (r;either (r;either (r;either (r/wrap #@;January)
+                                (r;either (r/wrap #@;February)
+                                          (r/wrap #@;March)))
+                      (r;either (r/wrap #@;April)
+                                (r;either (r/wrap #@;May)
+                                          (r/wrap #@;June))))
+            (r;either (r;either (r/wrap #@;July)
+                                (r;either (r/wrap #@;August)
+                                          (r/wrap #@;September)))
+                      (r;either (r/wrap #@;October)
+                                (r;either (r/wrap #@;November)
+                                          (r/wrap #@;December))))))
+
+(context: "(Month) Eq."
+  [sample month
+   #let [(^open "@/") @;Eq<Month>]]
+  (test "Every value equals itself."
+        (@/= sample sample)))
+
+(context: "(Month) Order."
+  [reference month
+   sample month
+   #let [(^open "@/") @;Order<Month>]]
+  (test "Valid Order."
+        (and (or (@/< reference sample)
+                 (@/>= reference sample))
+             (or (@/> reference sample)
+                 (@/<= reference sample)))))
+
+(context: "(Month) Enum."
+  [sample month
+   #let [(^open "@/") @;Enum<Month>]]
+  (test "Valid Enum."
+        (and (not (@/= (@/succ sample)
+                       sample))
+             (not (@/= (@/pred sample)
+                       sample))
+             (|> sample @/succ @/pred (@/= sample))
+             (|> sample @/pred @/succ (@/= sample)))))
+
+(def: day
+  (r;Random @;Day)
+  (r;either (r;either (r;either (r/wrap #@;Sunday)
+                                (r/wrap #@;Monday))
+                      (r;either (r/wrap #@;Tuesday)
+                                (r/wrap #@;Wednesday)))
+            (r;either (r;either (r/wrap #@;Thursday)
+                                (r/wrap #@;Friday))
+                      (r/wrap #@;Saturday))))
+
+(context: "(Day) Eq."
+  [sample day
+   #let [(^open "@/") @;Eq<Day>]]
+  (test "Every value equals itself."
+        (@/= sample sample)))
+
+(context: "(Day) Order."
+  [reference day
+   sample day
+   #let [(^open "@/") @;Order<Day>]]
+  (test "Valid Order."
+        (and (or (@/< reference sample)
+                 (@/>= reference sample))
+             (or (@/> reference sample)
+                 (@/<= reference sample)))))
+
+(context: "(Day) Enum."
+  [sample day
+   #let [(^open "@/") @;Enum<Day>]]
+  (test "Valid Enum."
+        (and (not (@/= (@/succ sample)
+                       sample))
+             (not (@/= (@/pred sample)
+                       sample))
+             (|> sample @/succ @/pred (@/= sample))
+             (|> sample @/pred @/succ (@/= sample)))))
diff --git a/stdlib/test/test/lux/time/instant.lux b/stdlib/test/test/lux/time/instant.lux
index 2baeff7a7..40ab587d7 100644
--- a/stdlib/test/test/lux/time/instant.lux
+++ b/stdlib/test/test/lux/time/instant.lux
@@ -44,6 +44,17 @@
              (or (@/> reference sample)
                  (@/<= reference sample)))))
 
+(context: "Enum"
+  [sample instant
+   #let [(^open "@/") @;Enum<Instant>]]
+  (test "Valid Enum."
+        (and (not (@/= (@/succ sample)
+                       sample))
+             (not (@/= (@/pred sample)
+                       sample))
+             (|> sample @/succ @/pred (@/= sample))
+             (|> sample @/pred @/succ (@/= sample)))))
+
 (context: "Arithmetic"
   [sample instant
    span duration
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
index 6f593abff..b6dbdfcd2 100644
--- a/stdlib/test/tests.lux
+++ b/stdlib/test/tests.lux
@@ -10,7 +10,8 @@
              ["_;" host]
              ["_;" io]
              (time ["_;" instant]
-                   ["_;" duration])
+                   ["_;" duration]
+                   ["_;" date])
              (concurrency ["_;" actor]
                           ["_;" atom]
                           ["_;" frp]