Add datetime (#9)

datetime/spago.yaml

@@ -0,0 +1,19 @@
+package:
+  name: datetime
+  dependencies:
+    - bifunctors
+    - control
+    - either
+    - enums
+    - foldable-traversable
+    - functions
+    - gen
+    - integers
+    - lists
+    - maybe
+    - newtype
+    - numbers
+    - ordered-collections
+    - partial
+    - prelude
+    - tuples

datetime/src/Data/Date.ss

@@ -0,0 +1,40 @@
+;; -*- mode: scheme -*-
+
+(library (Data.Date foreign)
+  (export canonicalDateImpl
+          calcWeekday
+          calcDiff)
+  (import (only (rnrs base) define lambda let let* if)
+          (prefix (chezscheme) scm:))
+
+  ;; Note: make-date in chez has a lower bound at 1901:
+  ;; https://github.com/cisco/ChezScheme/blob/57f92bb76aed694437a2e201780654e9c03a576f/s/date.ss#L186
+  (define make-date
+    (lambda (millisecond second minute hour day month year)
+      (scm:make-date (scm:fx* 1000000 millisecond) second minute hour day month year 0)))
+
+  (define canonicalDateImpl
+    (lambda (ctor y m d)
+      (let* ([date (make-date 0 0 0 0 d m y)]
+            [year (scm:date-year date)]
+            [month (scm:date-month date)]
+            [day (scm:date-day date)])
+        (((ctor year) month) day))))
+
+  (define calcWeekday
+    (lambda (year month day)
+      (let ([date (make-date 0 0 0 0 day month year)])
+        (scm:date-week-day date))))
+
+  (define calcDiff
+    (lambda (year1 month1 day1 year2 month2 day2)
+      (let ([date1 (make-date 0 0 0 0 day1 month1 year1)]
+            [date2 (make-date 0 0 0 0 day2 month2 year2)])
+        (scm:fl*
+          1000.0
+          (scm:fixnum->flonum
+            (scm:time-second
+              (scm:time-difference
+                (scm:date->time-utc date1)
+                (scm:date->time-utc date2))))))))
+)

datetime/src/Data/Date/Component.purs

@@ -25,17 +25,17 @@ derive newtype instance ordYear :: Ord Year
 -- Using these year values means `Date bottom bottom bottom` is a valid date,
 -- likewise for `top`.
 instance boundedYear :: Bounded Year where
-  bottom = Year (-271820)
+  bottom = Year 1901
   top = Year 275759
 
 instance enumYear :: Enum Year where
   succ = toEnum <<< (_ + 1) <<< fromEnum
   pred = toEnum <<< (_ - 1) <<< fromEnum
 
 instance boundedEnumYear :: BoundedEnum Year where
-  cardinality = Cardinality 547580
+  cardinality = Cardinality 273859
   toEnum n
-    | n >= (-271820) && n <= 275759 = Just (Year n)
+    | n >= 1901 && n <= 275759 = Just (Year n)
     | otherwise = Nothing
   fromEnum (Year n) = n
 

datetime/src/Data/DateTime.ss

@@ -0,0 +1,74 @@
+;; -*- mode: scheme -*-
+
+(library (Data.DateTime foreign)
+  (export calcDiff
+          adjustImpl)
+  (import (only (rnrs base) define lambda let let*)
+          (prefix (purs runtime) rt:)
+          (prefix (chezscheme) scm:))
+
+  ;; Note: make-date in chez has a lower bound at 1901:
+  ;; https://github.com/cisco/ChezScheme/blob/57f92bb76aed694437a2e201780654e9c03a576f/s/date.ss#L186
+  (define make-date
+    (lambda (millisecond second minute hour day month year)
+      (scm:make-date (scm:fx* 1000000 millisecond) second minute hour day month year 0)))
+
+  (define calcDiff
+    (lambda (datetimeRecord1 datetimeRecord2)
+      (let* ([year1 (rt:record-ref datetimeRecord1 (scm:quote year))]
+            [month1 (rt:record-ref datetimeRecord1 (scm:quote month))]
+            [day1 (rt:record-ref datetimeRecord1 (scm:quote day))]
+            [hour1 (rt:record-ref datetimeRecord1 (scm:quote hour))]
+            [minute1 (rt:record-ref datetimeRecord1 (scm:quote minute))]
+            [second1 (rt:record-ref datetimeRecord1 (scm:quote second))]
+            [millisecond1 (rt:record-ref datetimeRecord1 (scm:quote millisecond))]
+            [year2 (rt:record-ref datetimeRecord2 (scm:quote year))]
+            [month2 (rt:record-ref datetimeRecord2 (scm:quote month))]
+            [day2 (rt:record-ref datetimeRecord2 (scm:quote day))]
+            [hour2 (rt:record-ref datetimeRecord2 (scm:quote hour))]
+            [minute2 (rt:record-ref datetimeRecord2 (scm:quote minute))]
+            [second2 (rt:record-ref datetimeRecord2 (scm:quote second))]
+            [millisecond2 (rt:record-ref datetimeRecord2 (scm:quote millisecond))]
+            ;; note: make-date takes nanoseconds, not milliseconds
+            [date1 (make-date millisecond1 second1 minute1 hour1 day1 month1 year1)]
+            [date2 (make-date millisecond2 second2 minute2 hour2 day2 month2 year2)]
+            [difference (scm:time-difference
+                          (scm:date->time-utc date1)
+                          (scm:date->time-utc date2))]
+            [seconds (scm:time-second difference)]
+            [nanoseconds (scm:time-nanosecond difference)])
+        ;; need to return milliseconds from the sum of seconds and nanoseconds
+        (scm:fl+
+          (scm:fl* (scm:fixnum->flonum seconds) 1000.0)
+          (scm:fl/ (scm:fixnum->flonum nanoseconds) 1000000.0)))))
+
+  (define adjustImpl
+    (lambda (just)
+      (lambda (nothing)
+        (lambda (offset)
+          (lambda (datetime-record)
+            (let* ([year (rt:record-ref datetime-record (scm:quote year))]
+                  [month (rt:record-ref datetime-record (scm:quote month))]
+                  [day (rt:record-ref datetime-record (scm:quote day))]
+                  [hour (rt:record-ref datetime-record (scm:quote hour))]
+                  [minute (rt:record-ref datetime-record (scm:quote minute))]
+                  [second (rt:record-ref datetime-record (scm:quote second))]
+                  [millisecond (rt:record-ref datetime-record (scm:quote millisecond))]
+                  [date (make-date millisecond second minute hour day month year)]
+                  [time (scm:date->time-utc date)]
+                  [duration-seconds (scm:flonum->fixnum (scm:fldiv offset 1000.0))]
+                  [duration-nanoseconds (scm:flonum->fixnum (scm:fl* 1000000.0 (scm:flmod offset 1000.0)))]
+                  [duration (scm:make-time (scm:quote time-duration) duration-nanoseconds duration-seconds)]
+                  [new-time (scm:add-duration time duration)]
+                  [new-date (scm:time-utc->date new-time 0)]
+                  [new-datetime-record
+                    (scm:list
+                      (scm:cons (scm:quote year) (scm:date-year new-date))
+                      (scm:cons (scm:quote month) (scm:date-month new-date))
+                      (scm:cons (scm:quote day) (scm:date-day new-date))
+                      (scm:cons (scm:quote hour) (scm:date-hour new-date))
+                      (scm:cons (scm:quote minute) (scm:date-minute new-date))
+                      (scm:cons (scm:quote second) (scm:date-second new-date))
+                      (scm:cons (scm:quote millisecond) (scm:fx/ (scm:date-nanosecond new-date) 1000000)))])
+              (just new-datetime-record)))))))
+)

datetime/src/Data/DateTime/Instant.ss

@@ -0,0 +1,41 @@
+;; -*- mode: scheme -*-
+
+(library (Data.DateTime.Instant foreign)
+  (export fromDateTimeImpl
+          toDateTimeImpl)
+  (import (only (rnrs base) define lambda let let* if)
+          (prefix (chezscheme) scm:))
+
+  ;; Note: make-date in chez has a lower bound at 1901:
+  ;; https://github.com/cisco/ChezScheme/blob/57f92bb76aed694437a2e201780654e9c03a576f/s/date.ss#L186
+  (define make-date
+    (lambda (millisecond second minute hour day month year)
+      (scm:make-date (scm:fx* 1000000 millisecond) second minute hour day month year 0)))
+
+  (define fromDateTimeImpl
+    (lambda (year month day hour minute second millisecond)
+      (let* ([date (make-date millisecond second minute hour day month year)]
+            [utc-time (scm:date->time-utc date)]
+            [seconds (scm:time-second utc-time)]
+            [nanoseconds (scm:time-nanosecond utc-time)])
+        ;; need to return milliseconds from the sum of seconds and nanoseconds
+        (scm:fl+
+          (scm:fl* (scm:fixnum->flonum seconds) 1000.0)
+          (scm:fl/ (scm:fixnum->flonum nanoseconds) 1000000.0)))))
+
+  (define toDateTimeImpl
+    (lambda (ctor)
+      (lambda (instant)
+        (let* ([instant-seconds (scm:flonum->fixnum (scm:fldiv instant 1000.0))]
+              [instant-nanoseconds (scm:flonum->fixnum (scm:fl* 1000000.0 (scm:flmod instant 1000.0)))]
+              [utc-time (scm:make-time (scm:quote time-utc) instant-nanoseconds instant-seconds)]
+              [date (scm:time-utc->date utc-time 0)]
+              [year (scm:date-year date)]
+              [month (scm:date-month date)]
+              [day (scm:date-day date)]
+              [hour (scm:date-hour date)]
+              [minute (scm:date-minute date)]
+              [second (scm:date-second date)]
+              [millisecond (scm:fxdiv (scm:date-nanosecond date) 1000000)])
+          (((((((ctor year) month) day) hour) minute) second) millisecond)))))
+)

datetime/test/Test/Main.purs

@@ -1,4 +1,4 @@
-module Test.Main where
+module Test.Data.Time.Main where
 
 import Prelude
 
@@ -41,12 +41,13 @@ main = do
   assert $ IsoDuration.mkIsoDuration (mempty)
     == Left (pure IsoDuration.IsEmpty)
 
-  let epochDate = unsafePartial fromJust $ Date.canonicalDate
-                  <$> toEnum 1
-                  <*> pure bottom
-                  <*> pure bottom
+  let
+    epochDate = unsafePartial fromJust $ Date.canonicalDate
+      <$> toEnum 1901
+      <*> pure bottom
+      <*> pure bottom
   let epochDateTime = DateTime.DateTime epochDate bottom
-  let epochMillis = -62135596800000.0
+  let epochMillis = -2177452800000.0
   -- time --------------------------------------------------------------------
 
   log "Check that Hour is a good BoundedEnum"
@@ -130,7 +131,7 @@ main = do
   assert $ Date.isLeapYear (unsafeYear 2016)
 
   log "Check that epoch is correctly constructed"
-  assert $ Just (Date.year epochDate) == toEnum 1
+  assert $ Just (Date.year epochDate) == toEnum 1901
   assert $ Date.month epochDate == bottom
   assert $ Date.day epochDate == bottom
 
@@ -139,7 +140,7 @@ main = do
   assert $ Date.adjust (Duration.Days 999.0) d1 == Just d4
   assert $ Date.adjust (Duration.Days 10000.0) d5 == Just d1
   assert $ Date.adjust (Duration.Days (-31.0)) d2 == Just d1
-  assert $ Date.adjust (Duration.Days (- 999.0)) d4 == Just d1
+  assert $ Date.adjust (Duration.Days (-999.0)) d4 == Just d1
   assert $ Date.adjust (Duration.Days (-10000.0)) d1 == Just d5
 
   -- datetime ----------------------------------------------------------------
@@ -151,19 +152,25 @@ main = do
   let dt5 = DateTime.DateTime d3 t1
 
   log "Check that adjust behaves as expected"
-  assert $ DateTime.adjust (Duration.fromDuration (Duration.Days 31.0) <> Duration.fromDuration (Duration.Minutes 40.0)) dt1 == Just dt4
-  assert $ (Date.year <<< DateTime.date <$>
-           (DateTime.adjust (Duration.Days 735963.0) epochDateTime))
-           == toEnum 2016
+  assert $
+    DateTime.adjust
+      (Duration.fromDuration (Duration.Days 31.0) <> Duration.fromDuration (Duration.Minutes 40.0))
+      dt1 == Just dt4
+  assert $
+    ( Date.year <<< DateTime.date <$>
+        (DateTime.adjust (Duration.Days 735963.0) epochDateTime)
+    )
+      == toEnum 3916
 
   log "Check that diff behaves as expected"
   assert $ DateTime.diff dt2 dt1 == Duration.Minutes 40.0
   assert $ DateTime.diff dt1 dt2 == Duration.Minutes (-40.0)
   assert $ DateTime.diff dt3 dt1 == Duration.Days 31.0
   assert $ DateTime.diff dt5 dt3 == Duration.Days 29.0
   assert $ DateTime.diff dt1 dt3 == Duration.Days (-31.0)
-  assert $ DateTime.diff dt4 dt1 == Duration.fromDuration (Duration.Days 31.0) <> Duration.fromDuration (Duration.Minutes 40.0)
-  assert $ over Duration.Days floor (DateTime.diff dt1 epochDateTime) == Duration.Days 735963.0
+  assert $ DateTime.diff dt4 dt1 == Duration.fromDuration (Duration.Days 31.0) <>
+    Duration.fromDuration (Duration.Minutes 40.0)
+  assert $ over Duration.Days floor (DateTime.diff dt1 epochDateTime) == Duration.Days 42003.0
 
   -- instant -----------------------------------------------------------------
 

test.sh

@@ -66,4 +66,7 @@ echo "Testing quickcheck"
 purescm run --main Test.QuickCheck.Main
 echo
 
+echo "Testing datetime"
+purescm run --main Test.Data.Time.Main
+
 echo "All good!"