From 9c3e6ea56deac8eddc10f8a1ef8390e6bfc7d2c3 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Wed, 3 Jul 2024 16:40:11 +0300 Subject: [PATCH] Add datetime (#9) --- datetime/spago.yaml | 19 +++++++ datetime/src/Data/Date.ss | 40 +++++++++++++++ datetime/src/Data/Date/Component.purs | 6 +-- datetime/src/Data/DateTime.ss | 74 +++++++++++++++++++++++++++ datetime/src/Data/DateTime/Instant.ss | 41 +++++++++++++++ datetime/test/Test/Main.purs | 35 ++++++++----- test.sh | 3 ++ 7 files changed, 201 insertions(+), 17 deletions(-) create mode 100644 datetime/spago.yaml create mode 100644 datetime/src/Data/Date.ss create mode 100644 datetime/src/Data/DateTime.ss create mode 100644 datetime/src/Data/DateTime/Instant.ss diff --git a/datetime/spago.yaml b/datetime/spago.yaml new file mode 100644 index 00000000..4a6ff695 --- /dev/null +++ b/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 diff --git a/datetime/src/Data/Date.ss b/datetime/src/Data/Date.ss new file mode 100644 index 00000000..74b64409 --- /dev/null +++ b/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)))))))) +) diff --git a/datetime/src/Data/Date/Component.purs b/datetime/src/Data/Date/Component.purs index 2762eaac..0f908fd5 100644 --- a/datetime/src/Data/Date/Component.purs +++ b/datetime/src/Data/Date/Component.purs @@ -25,7 +25,7 @@ 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 @@ -33,9 +33,9 @@ instance enumYear :: Enum Year where 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 diff --git a/datetime/src/Data/DateTime.ss b/datetime/src/Data/DateTime.ss new file mode 100644 index 00000000..f59efffe --- /dev/null +++ b/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))))))) +) diff --git a/datetime/src/Data/DateTime/Instant.ss b/datetime/src/Data/DateTime/Instant.ss new file mode 100644 index 00000000..f5675562 --- /dev/null +++ b/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))))) +) diff --git a/datetime/test/Test/Main.purs b/datetime/test/Test/Main.purs index 0388fcbc..46869629 100644 --- a/datetime/test/Test/Main.purs +++ b/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,10 +152,15 @@ 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 @@ -162,8 +168,9 @@ main = do 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 ----------------------------------------------------------------- diff --git a/test.sh b/test.sh index 3ca090cb..5d25b174 100755 --- a/test.sh +++ b/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!"