From 712654d4c023a2ab13190c6905d313e0ba897965 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 2 Oct 2023 19:26:40 +0200 Subject: Rewrite test running system. --- tests/unit/datetime/datetime.scm | 812 +++++++++++++++++++++++++++++++++++++++ tests/unit/datetime/timespec.scm | 98 +++++ tests/unit/datetime/tz.scm | 88 +++++ tests/unit/datetime/zic.scm | 319 +++++++++++++++ 4 files changed, 1317 insertions(+) create mode 100644 tests/unit/datetime/datetime.scm create mode 100644 tests/unit/datetime/timespec.scm create mode 100644 tests/unit/datetime/tz.scm create mode 100644 tests/unit/datetime/zic.scm (limited to 'tests/unit/datetime') diff --git a/tests/unit/datetime/datetime.scm b/tests/unit/datetime/datetime.scm new file mode 100644 index 00000000..9f32d4a1 --- /dev/null +++ b/tests/unit/datetime/datetime.scm @@ -0,0 +1,812 @@ +(define-module (test datetime) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module ((srfi srfi-41) + :select (stream->list stream-take)) + :use-module (datetime) + :use-module ((ice-9 format) :select (format)) + :use-module ((ice-9 i18n) :select (make-locale)) + :use-module ((guile) :select (LC_CTYPE LC_TIME))) + +;;; Skipped since the code generating the (expected) error is disabled, due to +;;; optional fields at the end of string. See the (null? str) case is +;;; datetime->string +(test-expect-fail "Premature end of string to parse") + +;;; Global locale objects, to save all tests from creating them +(define en_US (make-locale (list LC_CTYPE LC_TIME) "en_US.UTF-8")) +(define sv_SE (make-locale (list LC_CTYPE LC_TIME) "sv_SE.UTF-8")) + +;;; These tests begin by testing the basic objects, +;;; followed by the string parser. +;;; This to finally test the read syntax, to be able to +;;; us it in the rest of the tests. + +(test-group "Creation of basic objects" + (test-group "Date" + (test-group "Empty date" + (let ((d (date))) + (test-assert "Date creates date objects" (date? d)) + (test-equal "Year is zero" 0 (year d)) + (test-equal "Month is zero" 0 (month d)) + (test-equal "Day is zero" 0 (day d)) + (test-assert "Date-zero? agrees" (date-zero? d)))) + + (test-group "Date with keys" + ;; Implicitly tests that month and day can go above + ;; "regular" bounds + (let ((d (date day: 40 month: 20 year: 10))) + (test-assert "Date creation still works" (date? d)) + (test-equal "Year is stored" 10 (year d)) + (test-equal "Month is stored" 20 (month d)) + (test-equal "Day is stored" 40 (day d)))) + + (test-group "Can't create date with non-integer components" + (test-error "Invalid year" 'wrong-type-arg (date year: #f)) + (test-error "Invalid month" 'wrong-type-arg (date month: #f)) + (test-error "Invalid day" 'wrong-type-arg (date day: #f)))) + + (test-group "Time" + (test-group "Empty time" + (let ((t (time))) + (test-assert "Time creates time objects" (time? t)) + (test-equal "hour is zero" 0 (hour t)) + (test-equal "minute is zero" 0 (minute t)) + (test-equal "second is zero" 0 (second t)) + (test-assert "Time zero agrees" (time-zero? t)))) + + (test-group "Time with keys" + (let ((t (time second: 10 minute: 20 hour: 30))) + (test-assert "Time creation still works" (time? t)) + (test-equal "Hour is stored" 30 (hour t)) + (test-equal "Minute is stored" 20 (minute t)) + (test-equal "Second is stored" 10 (second t)))) + + (test-group "Can't create time with non-integer components" + (test-error "Invalid hour" 'wrong-type-arg (time hour: #f)) + (test-error "Invalid minute" 'wrong-type-arg (time minute: #f)) + (test-error "Invalid second" 'wrong-type-arg (time second: #f)))) + + (test-group "Datetime" + (let () + (test-group "Empty datetime" + (let ((dt (datetime))) + (test-assert "Datetime date is date" (date? (datetime-date dt))) + (test-assert "Datetime date is zero" (date-zero? (datetime-date dt))) + (test-assert "Datetime time is time" (time? (datetime-time dt))) + (test-assert "Datetime time is zero" (time-zero? (datetime-time dt))) + (test-eqv "Defalut timezone is #f" #f (tz dt)))) + + (test-group "Datetime with keys" + (let ((dt (datetime date: (date day: 10) + time: (time minute: 20)))) + (test-equal "Given date is stored" + 10 (day (datetime-date dt))) + (test-equal "Given time is stored" + 20 (minute (datetime-time dt)))) + (test-error "Date must be a date" 'wrong-type-arg (datetime date: 1)) + (test-error "Date must be a date" 'wrong-type-arg (datetime date: (time))) + (test-assert "Date: #f gives still constructs a date" (date? (datetime-date (datetime date: #f)))) + (test-error "Time must be a time" 'wrong-type-arg (datetime time: 1)) + (test-error "Time must be a time" 'wrong-type-arg (datetime time: (date))) + (test-assert "Time: #f gives still constructs a time" (time? (datetime-time (datetime time: #f)))) + + (let ((dt (datetime hour: 20 day: 30))) + (test-equal "Time objects can be implicitly created" 20 (hour (datetime-time dt))) + (test-equal "Date objects can be implicitly created" 30 (day (datetime-date dt)))) + (let ((dt (datetime day: 30 time: (time hour: 20)))) + (test-equal "\"Upper\" and \"lower\" keys can be mixed" + 20 (hour (datetime-time dt))) + (test-equal "\"Upper\" and \"lower\" keys can be mixed" + 30 (day (datetime-date dt)))) + + (let ((dt (datetime hour: 30 time: (time hour: 20)))) + (test-equal "time: has priority over hour: (and the like)" + 20 (hour (datetime-time dt))))) + (let ((dt (datetime day: 30 date: (date day: 20)))) + (test-equal "date: has priority over day: (and the like)" + 20 (day (datetime-date dt))))))) + +;; Before the general parser, since it's a dependency string->datetime. +(test-group "Parse Month" + + (test-equal "Parse full month name" jan (parse-month "January" en_US)) + (test-equal "Parse full weird case" jan (parse-month "jaNuaRy" en_US)) + (test-equal "Parse partial month name" jan (parse-month "Jan" en_US)) + (test-equal "Failing parse of month name" -1 (parse-month "Unknown" en_US)) + (test-equal "Overlap gives earliest month" mar (parse-month "m" en_US)) + + (test-equal "Parse month with different locale" may (parse-month "maj" sv_SE))) + + +(test-group "Parser" + (test-group "Simple individual rules" + (test-group "Year" + (test-equal "~Y year" (datetime year: 2020) (string->datetime "2020" "~Y")) + (test-equal "~Y year single digit" (datetime year: 2) (string->datetime "2" "~Y")) + (test-equal "~Y year leading zero" (datetime year: 2) (string->datetime "02" "~Y")) + (test-error "~Y parses at max four digits" 'misc-error (string->datetime "14411" "~Y"))) + + (test-group "Month" + (test-equal "~m month" (datetime month: 10) (string->datetime "10" "~m")) + (test-equal "~m month single digit" (datetime month: 1) (string->datetime "1" "~m")) + (test-equal "~m month leading zero" (datetime month: 1) (string->datetime "01" "~m")) + (test-error "~m parses at max two digits" 'misc-error (string->datetime "111" "~m"))) + + ;; Extra tests are skipped for these, since they are shared with Month + (test-equal "~d day" (datetime day: 20) (string->datetime "20" "~d")) + (test-equal "~H hour" (datetime hour: 15) (string->datetime "15" "~H")) + (test-equal "~M minute" (datetime minute: 30) (string->datetime "30" "~M")) + (test-equal "~S second" (datetime second: 59) (string->datetime "59" "~S"))) + + + (test-equal "Literal character" (datetime) (string->datetime "T" "T")) + (test-equal "~~ '~'" (datetime) (string->datetime "~" "~~")) + (test-error "Mismatched literal ~" 'misc-error (string->datetime "A" "~~")) + + (test-error "Stray ~ at end of fmt" 'misc-error (string->datetime "~" "~")) + (test-error "Stray ~ in middle of fmt" 'misc-error (string->datetime "~ 1" "~ ~d")) + (test-error "Unknown escape" 'misc-error (string->datetime "10" "~x")) + (test-error "Premature end of string to parse" 'misc-error (string->datetime "" "~Y")) + (test-error "Wrong Literal character" 'misc-error (string->datetime "T" "Z")) + + + ;; Does the parser continue correctly + (test-group "Tokens following each other" + (test-equal "Year indirectly followed by month" + (datetime year: 2020 month: 1) + (string->datetime "2020-01" "~Y-~m")) + ;; Does the parser handle tokens without delimiters, instead going by their max size + (test-equal "Year directly follewed by month" + (datetime year: 2020 month: 1) + (string->datetime "202001" "~Y~m"))) + + + (test-group "Timezone" + (test-equal "~Z 'Z'" + (datetime tz: "UTC") (string->datetime "Z" "~Z")) + (test-equal "~Z Is optional" + (datetime) (string->datetime "" "~Z")) + (test-equal "~Z Is optional with stuff after" + (datetime hour: 20) (string->datetime "20" "~Z~H")) + ;; This was earlier a bug + (test-equal "Zoneinfo is kept while not at end" + (datetime year: 2020 tz: "UTC") + (string->datetime "Z2020" "~Z~Y"))) + + + (test-group "Month by name" + ;; ~b, ~B, and ~h all does the same thing, and exists for symmetry with + ;; datetime->string (where they don't do the exact same thing). Each is used + ;; at least once below to ensure that they all work. + (test-equal "Standalone month, and at end" + (datetime month: 1) + (string->datetime "Jan" "~b" en_US)) + + ;; Separate test from above, since month does the check itself + (test-error "Stray ~ after month" + 'misc-error (string->datetime "Jan" "~b~" en_US)) + + (test-equal "Month with explicit ~ after" + (datetime month: mar) + (string->datetime "M~" "~B~~" en_US)) + + (test-error "Month with other specifier directly after" + 'misc-error (string->datetime "January" "~b~b")) + + (test-equal "Month with other explict char after" + (datetime month: mar) + (string->datetime "Mar|" "~h|" en_US)) + + (test-equal "Locale information is used" + (datetime month: may) + (string->datetime "Maj" "~h" sv_SE))) + + ;; TODO AM/PM string ~p + + (test-group "Complete parses" + (test-equal "Parse complete ISO date" + (datetime year: 2020 month: 3 day: 10) + (string->datetime "2020-03-10" "~Y-~m-~d")) + + (test-equal "Parse complete ISO time" + (datetime hour: 10 minute: 20 second: 30) + (string->datetime "10:20:30" "~H:~M:~S")) + + (test-equal "Parse complete ISO date-time" + (datetime year: 2020 month: 3 day: 10 + hour: 10 minute: 20 second: 30) + (string->datetime "2020-03-10T10:20:30" + "~Y-~m-~dT~H:~M:~S"))) + + (test-group "string->datetime default format-specifier" + (test-equal "Default date-time format-specifier takes ISO date-times" + (datetime year: 2020 month: 3 day: 10 + hour: 10 minute: 20 second: 30) + (string->datetime "2020-03-10T10:20:30")) + + (test-equal "Default date-time format-specifier takes ISO date-times (with zone)" + (datetime year: 2020 month: 3 day: 10 + hour: 10 minute: 20 second: 30 + tz: "UTC") + (string->datetime "2020-03-10T10:20:30Z"))) + + + (test-group "string->time" + (test-assert "String->time returns time objects" + (time? (string->time "10" "~H"))) + + (test-equal "String->time complete parse" + (time hour: 10 minute: 20 second: 30) + (string->time "10:20:30" "~H:~M:~S")) + + (test-equal "String->time complete parse, default format-specifier" + (time hour: 10 minute: 20 second: 30) + (string->time "10:20:30"))) + + (test-group "string->date" + (test-assert "String->date returns time objects" + (date? (string->date "10" "~Y"))) + + (test-equal "String->date complete parse" + (date year: 2020 month: 3 day: 10) + (string->date "2020-03-10" "~Y-~m-~d")) + + (test-equal "String->date complete parse, default format-specifier" + (date year: 2020 month: 3 day: 10) + (string->date "2020-03-10"))) + + (test-group "Pre-specified parsers" + (test-group "ICS (RFC 5545)" + (test-equal "date" + (date year: 2020 month: 10 day: 20) + (parse-ics-date "20201020")) + (test-equal "time" + (time hour: 10 minute: 20 second: 30) + (parse-ics-time "102030")) + (test-equal "datetime" + (datetime year: 2020 month: 10 day: 20 + hour: 10 minute: 20 second: 30) + (parse-ics-datetime "20201020T102030")) + (test-equal "datetime (with zone)" + (datetime year: 2020 month: 10 day: 20 + hour: 10 minute: 20 second: 30 + tz: "UTC") + (parse-ics-datetime "20201020T102030Z"))) + + (test-group "ISO" + (test-equal "date" + (date year: 2020 month: 10 day: 20) + (parse-iso-date "2020-10-20")) + (test-equal "time" + (time hour: 10 minute: 20 second: 30) + (parse-iso-time "10:20:30")) + (test-equal "datetime" + (datetime year: 2020 month: 10 day: 20 + hour: 10 minute: 20 second: 30) + (parse-iso-datetime "2020-10-20T10:20:30"))) + + ;; Parse freeform date + ) + + (test-group "string->date/-time" + (test-equal "Date like gives date" + (date year: 2020 month: 10 day: 20) + (string->date/-time "2020-10-20")) + (test-equal "Time like gives time" + (time hour: 10 minute: 20 second: 30) + (string->date/-time "10:20:30")) + (test-equal "Datetime like gives datetime" + (datetime year: 2020 month: 10 day: 20 + hour: 10 minute: 20 second: 30) + (string->date/-time "2020-10-20T10:20:30")) + + ;; These are disabled since trailing fmt is allowed + ;; (test-error "Bad date-like crashes" + ;; 'misc-error (string->date/-time "2020-10")) + ;; (test-error "Bad time-like crashes" + ;; 'misc-error (string->date/-time "20:10")) + (test-error "Really bad crashes" + 'misc-error (string->date/-time "Hello")) + )) + + +(test-group "Reader extensions" + + ;; All tests have a list variant, to ensure that it plays nice with the rest + ;; of scheme's syntax + + (test-equal "Basic time read syntax" + (time hour: 10 minute: 20 second: 30) + (test-read-eval-string "#10:20:30")) + + (test-equal "Basic time read syntax in list" + (list (time hour: 10 minute: 20 second: 30)) + (test-read-eval-string "(list #10:20:30)")) + + (test-equal "Basic date read syntax" + (date year: 2020 month: 3 day: 10) + (test-read-eval-string "#2020-03-10")) + + (test-equal "Basic date read syntax in list" + (list (date year: 2020 month: 3 day: 10)) + (test-read-eval-string "(list #2020-03-10)")) + + (test-equal "Basic datetime read syntax" + (datetime date: (date year: 2020 month: 3 day: 10) + time: (time hour: 10 minute: 20 second: 30)) + (test-read-eval-string "#2020-03-10T10:20:30")) + + (test-equal "Basic datetime read syntax in list" + (list (datetime date: (date year: 2020 month: 3 day: 10) + time: (time hour: 10 minute: 20 second: 30))) + (test-read-eval-string "(list #2020-03-10T10:20:30)")) + + (test-equal "Basic datetime read syntax with Z" + (datetime date: (date year: 2020 month: 3 day: 10) + time: (time hour: 10 minute: 20 second: 30) + tz: "UTC") + (test-read-eval-string "#2020-03-10T10:20:30Z")) + + (test-equal "Basic datetime read syntax with Z in list" + (list + (datetime date: (date year: 2020 month: 3 day: 10) + time: (time hour: 10 minute: 20 second: 30) + tz: "UTC")) + (test-read-eval-string "(list #2020-03-10T10:20:30Z)")) + ) + + + + +(test-equal "Datetime->unix-time" + 1656005146 (datetime->unix-time (datetime year: 2022 month: 06 day: 23 hour: 17 minute: 25 second: 46 tz: "UTC"))) + +(test-equal "Datetime->unix-time before epoch" + -62167219200 + (datetime->unix-time (datetime year: 0000 month: 01 day: 01 hour: 00 minute: 00 second: 00 tz: "UTC"))) + +(test-equal "unix-time->datetime" (datetime year: 2020 month: 09 day: 13 hour: 12 minute: 26 second: 40 tz: "UTC") + (unix-time->datetime 1600000000)) +(test-equal "unix-time->datetime on epoch" (datetime year: 1970 month: 01 day: 01 hour: 00 minute: 00 second: 00 tz: "UTC") + (unix-time->datetime 0)) +(test-equal "unix-time->datetime before epoch" (datetime year: 1919 month: 04 day: 20 hour: 11 minute: 33 second: 20 tz: "UTC") + (unix-time->datetime -1600000000)) + +;; (unix-time->datetime (expt 2 31)) ; => (datetime year: 2038 month: 01 day: 19 hour: 03 minute: 14 second: 08 tz: "UTC") +;; (unix-time->datetime (1+ (expt 2 31))) ; => (datetime year: 2038 month: 01 day: 19 hour: 03 minute: 14 second: 09 tz: "UTC") +;; (unix-time->datetime (- (expt 2 31))) ; => (datetime year: 1901 month: 12 day: 13 hour: 20 minute: 45 second: 52 tz: "UTC") + + +(test-assert "Current datetime returns a datetime" + (datetime? (current-datetime))) +(test-equal "Current datetime returns with tz: UTC" + "UTC" (tz (current-datetime))) +(test-assert "Current-date returns a date" + (date? (current-date))) + + +;; TODO write these, also, check connection to get-time% +get-datetime +as-date +as-time +as-datetime + +(test-group "Leap years" + (test-assert "Most years are't leap years" (not (leap-year? 1999))) + (test-assert "Except if it's divisible by 4" (leap-year? 2020)) + (test-assert "But not by 100" (not (leap-year? 1900))) + (test-assert "Except if also divisible by 400" (leap-year? 2000))) + +(test-assert "31 days in most month" (days-in-month (date month: jan))) +(test-assert "30 days in some month" (days-in-month (date month: apr))) +(test-assert "28 days in februrary on regular year" + (days-in-month (date month: feb year: 2022))) +(test-assert "29 days in februrary on leap year" + (days-in-month (date month: feb year: 2000))) +(test-error "To low month" 'out-of-range (days-in-month (date month: 0))) +(test-error "To high month" 'out-of-range (days-in-month (date month: 13))) + +(test-equal "365 days in regular year" 365 (days-in-year (date year: 2022))) +(test-equal "366 days in leap year" 366 (days-in-year (date year: 2000))) + +(test-equal "Start of month" (date year: 2020 month: 01 day: 01) (start-of-month (date year: 2020 month: 01 day: 15))) +(test-equal "End of month" (date year: 2000 month: 02 day: 29) (end-of-month (date year: 2000 month: 02 day: 01))) + +(test-equal "Start of year" (date year: 2020 month: 01 day: 01) (start-of-year (date year: 2020 month: 12 day: 31))) +;; Note that end-of-year (apparently) doesn't exist + +(test-group "Date streams" + (test-equal "Day stream" + (list (date year: 2020 month: 01 day: 01) (date year: 2020 month: 01 day: 02) (date year: 2020 month: 01 day: 03) (date year: 2020 month: 01 day: 04) (date year: 2020 month: 01 day: 05)) + (stream->list 5 (day-stream (date year: 2020 month: 01 day: 01)))) + (test-equal "Week stream" + (list (date year: 2020 month: 01 day: 01) (date year: 2020 month: 02 day: 01) (date year: 2020 month: 03 day: 01) (date year: 2020 month: 04 day: 01) (date year: 2020 month: 05 day: 01)) + (stream->list 5 (month-stream (date year: 2020 month: 01 day: 01)))) + (test-equal "Month stream" + (list (date year: 2020 month: 01 day: 01) (date year: 2020 month: 01 day: 08) (date year: 2020 month: 01 day: 15) (date year: 2020 month: 01 day: 22) (date year: 2020 month: 01 day: 29)) + (stream->list 5 (week-stream (date year: 2020 month: 01 day: 01))))) + +;; See time< tests for more context +(test-group "Min/max" + (test-equal "Time min" + (time hour: 07 minute: 40 second: 50) (time-min (time hour: 10 minute: 20 second: 30) (time hour: 07 minute: 40 second: 50))) + (test-equal "Time max" + (time hour: 10 minute: 20 second: 30) (time-max (time hour: 10 minute: 20 second: 30) (time hour: 07 minute: 40 second: 50))) + + (test-equal "Date min" + (date year: 2020 month: 02 day: 02) (date-min (date year: 2020 month: 02 day: 02) (date year: 2020 month: 03 day: 01))) + (test-equal "Date max" + (date year: 2020 month: 03 day: 01) (date-max (date year: 2020 month: 02 day: 02) (date year: 2020 month: 03 day: 01))) + + (test-equal "Datetime min" + (datetime year: 2020 month: 02 day: 02 hour: 10 minute: 20 second: 30) (datetime-min (datetime year: 2020 month: 02 day: 02 hour: 10 minute: 20 second: 30) (datetime year: 2020 month: 03 day: 01 hour: 07 minute: 40 second: 50))) + (test-equal "Datetime max" + (datetime year: 2020 month: 03 day: 01 hour: 07 minute: 40 second: 50) (datetime-max (datetime year: 2020 month: 02 day: 02 hour: 10 minute: 20 second: 30) (datetime year: 2020 month: 03 day: 01 hour: 07 minute: 40 second: 50)))) + +(test-equal "Week day" thu (week-day (date year: 2022 month: 06 day: 23))) + +(test-equal "week-1-start" (date year: 2019 month: 12 day: 30) (week-1-start (date year: 2020 month: 01 day: 01) mon)) + +;; Possibly add case where the end of the year uses next years week numbers +(test-equal "Week number at end of year" 53 (week-number (date year: 2008 month: 12 day: 31) sun)) +(test-equal "Week number at start of year" 53 (week-number (date year: 2009 month: 01 day: 01) sun)) + +(test-equal (date year: 2008 month: 12 day: 28) (date-starting-week 53 (date year: 2008) sun)) +(test-equal (date year: 2007 month: 12 day: 30) (date-starting-week 1 (date year: 2008) sun)) + +(test-group "Week day name" + (test-equal "Simple" "Saturday" (week-day-name sat locale: en_US)) + (test-equal "Truncated" "Sa" (week-day-name sat 2 locale: en_US)) + (test-equal "Other locale" "lördag" (week-day-name sat locale: sv_SE)) + (test-equal "Other locale, truncated" "lö" (week-day-name sat 2 locale: sv_SE))) + +;; TODO timespans can be both date, times, and datetimes +;; Check those cases? +(test-group "Overlapping timespans" + ;; A B C D E ¬F + ;; |s1| : |s2| : |s1| : |s2| : : |s1| + ;; | | : | | : | ||s2| : |s1|| | : |s1||s2| : | | + ;; | ||s2| : |s1|| | : | || | : | || | : | || | : + ;; | | : | | : | || | : | || | : | || | : |s2| + ;; | | : | | : | | : | | : : | | + (test-assert "End of S1 overlaps start of S2" + (timespan-overlaps? (time hour: 10 minute: 00 second: 00) (time hour: 12 minute: 00 second: 00) + (time hour: 11 minute: 00 second: 00) (time hour: 13 minute: 00 second: 00))) + (test-assert "Start of S1 overlaps end of S2" + (timespan-overlaps? (time hour: 11 minute: 00 second: 00) (time hour: 13 minute: 00 second: 00) + (time hour: 10 minute: 00 second: 00) (time hour: 12 minute: 00 second: 00))) + (test-assert "S1 complete encompasses S2" + (timespan-overlaps? (time hour: 10 minute: 00 second: 00) (time hour: 13 minute: 00 second: 00) + (time hour: 11 minute: 00 second: 00) (time hour: 12 minute: 00 second: 00))) + (test-assert "S2 complete encompasses S1" + (timespan-overlaps? (time hour: 11 minute: 00 second: 00) (time hour: 12 minute: 00 second: 00) + (time hour: 10 minute: 00 second: 00) (time hour: 13 minute: 00 second: 00))) + (test-assert "S1 is equal to S2" + (timespan-overlaps? (time hour: 11 minute: 00 second: 00) (time hour: 12 minute: 00 second: 00) + (time hour: 11 minute: 00 second: 00) (time hour: 12 minute: 00 second: 00))) + (test-assert "S1 dosesn't overlap S2" + (not + (timespan-overlaps? (time hour: 10 minute: 00 second: 00) (time hour: 11 minute: 00 second: 00) + (time hour: 12 minute: 00 second: 00) (time hour: 13 minute: 00 second: 00)))) + (test-assert "If the events only share an instant they don't overlap" + (not + (timespan-overlaps? (time hour: 10 minute: 00 second: 00) (time hour: 12 minute: 00 second: 00) + (time hour: 12 minute: 00 second: 00) (time hour: 14 minute: 00 second: 00))))) + +(test-equal (date year: 2022 month: 06 day: 25) (find-first-week-day sat (date year: 2022 month: 06 day: 23))) + +(test-group "All weekdays in <>" + (test-equal "month, if starting from beginning of month" + (list (date year: 2022 month: 06 day: 03) (date year: 2022 month: 06 day: 10) (date year: 2022 month: 06 day: 17) (date year: 2022 month: 06 day: 24)) + (all-wday-in-month fri (date year: 2022 month: 06 day: 01))) + + (test-equal "month, if starting from the middle" + (list (date year: 2022 month: 06 day: 24)) + (all-wday-in-month fri (date year: 2022 month: 06 day: 23))) + + (test-equal "year, if starting from the beggining" + (list (date year: 2022 month: 01 day: 07) (date year: 2022 month: 01 day: 14) (date year: 2022 month: 01 day: 21) (date year: 2022 month: 01 day: 28) (date year: 2022 month: 02 day: 04) (date year: 2022 month: 02 day: 11) (date year: 2022 month: 02 day: 18) (date year: 2022 month: 02 day: 25) (date year: 2022 month: 03 day: 04) (date year: 2022 month: 03 day: 11) (date year: 2022 month: 03 day: 18) (date year: 2022 month: 03 day: 25) (date year: 2022 month: 04 day: 01) (date year: 2022 month: 04 day: 08) (date year: 2022 month: 04 day: 15) (date year: 2022 month: 04 day: 22) (date year: 2022 month: 04 day: 29) (date year: 2022 month: 05 day: 06) (date year: 2022 month: 05 day: 13) (date year: 2022 month: 05 day: 20) (date year: 2022 month: 05 day: 27) (date year: 2022 month: 06 day: 03) (date year: 2022 month: 06 day: 10) (date year: 2022 month: 06 day: 17) (date year: 2022 month: 06 day: 24) (date year: 2022 month: 07 day: 01) (date year: 2022 month: 07 day: 08) (date year: 2022 month: 07 day: 15) (date year: 2022 month: 07 day: 22) (date year: 2022 month: 07 day: 29) (date year: 2022 month: 08 day: 05) (date year: 2022 month: 08 day: 12) (date year: 2022 month: 08 day: 19) (date year: 2022 month: 08 day: 26) (date year: 2022 month: 09 day: 02) (date year: 2022 month: 09 day: 09) (date year: 2022 month: 09 day: 16) (date year: 2022 month: 09 day: 23) (date year: 2022 month: 09 day: 30) (date year: 2022 month: 10 day: 07) (date year: 2022 month: 10 day: 14) (date year: 2022 month: 10 day: 21) (date year: 2022 month: 10 day: 28) (date year: 2022 month: 11 day: 04) (date year: 2022 month: 11 day: 11) (date year: 2022 month: 11 day: 18) (date year: 2022 month: 11 day: 25) (date year: 2022 month: 12 day: 02) (date year: 2022 month: 12 day: 09) (date year: 2022 month: 12 day: 16) (date year: 2022 month: 12 day: 23) (date year: 2022 month: 12 day: 30)) + (all-wday-in-year fri (date year: 2022 month: 01 day: 01))) + + (test-equal "year, if starting from the middle" + (list (date year: 2022 month: 06 day: 03) (date year: 2022 month: 06 day: 10) (date year: 2022 month: 06 day: 17) (date year: 2022 month: 06 day: 24) (date year: 2022 month: 07 day: 01) (date year: 2022 month: 07 day: 08) (date year: 2022 month: 07 day: 15) (date year: 2022 month: 07 day: 22) (date year: 2022 month: 07 day: 29) (date year: 2022 month: 08 day: 05) (date year: 2022 month: 08 day: 12) (date year: 2022 month: 08 day: 19) (date year: 2022 month: 08 day: 26) (date year: 2022 month: 09 day: 02) (date year: 2022 month: 09 day: 09) (date year: 2022 month: 09 day: 16) (date year: 2022 month: 09 day: 23) (date year: 2022 month: 09 day: 30) (date year: 2022 month: 10 day: 07) (date year: 2022 month: 10 day: 14) (date year: 2022 month: 10 day: 21) (date year: 2022 month: 10 day: 28) (date year: 2022 month: 11 day: 04) (date year: 2022 month: 11 day: 11) (date year: 2022 month: 11 day: 18) (date year: 2022 month: 11 day: 25) (date year: 2022 month: 12 day: 02) (date year: 2022 month: 12 day: 09) (date year: 2022 month: 12 day: 16) (date year: 2022 month: 12 day: 23) (date year: 2022 month: 12 day: 30)) + (all-wday-in-year fri (date year: 2022 month: 06 day: 01)))) + +;; TODO +in-date-range? + +(test-equal "weekday-list" (list wed thu fri sat sun mon tue) (weekday-list wed)) +(test-equal "start of week" (date year: 2022 month: 06 day: 20) (start-of-week (date year: 2022 month: 06 day: 23) mon)) +(test-equal "end of week" (date year: 2022 month: 06 day: 26) (end-of-week (date year: 2022 month: 06 day: 23) mon)) + + +(test-group "month-days" + (call-with-values (lambda () (month-days (date year: 2022 month: 06 day: 01) mon)) + (lambda (before actual after) + (test-equal "before" (list (date year: 2022 month: 05 day: 30) (date year: 2022 month: 05 day: 31)) before) + (test-equal "actual" (stream->list 30 (day-stream (date year: 2022 month: 06 day: 01))) actual) + (test-equal "after" (list (date year: 2022 month: 07 day: 01) (date year: 2022 month: 07 day: 02) (date year: 2022 month: 07 day: 03)) after)))) + +(test-group "Days in interval" + (test-equal "Steps from start to end of month" 31 (days-in-interval (date year: 2022 month: 01 day: 01) (date year: 2022 month: 01 day: 31))) + (test-error "Negative intervals should fail" 'misc-error (days-in-interval (date year: 2022 month: 01 day: 01) (date year: 2020 month: 01 day: 31)))) + +(test-equal "Year day" 191 (year-day (date year: 2020 month: 07 day: 09))) + +(test-group "Convertions to decimal time" + (test-group "Time->decimal-hour" + (test-equal "Exact number of hours is whole number" 5.0 (time->decimal-hour (time hour: 5))) + (test-equal "Minutes are \"base\" 60" 5.5 (time->decimal-hour (time hour: 5 minute: 30))) + (test-equal "60 Minutes gives a whole hour" 6.0 (time->decimal-hour (time hour: 5 minute: 60))) + (test-equal "A second is the right length" (/ 1.0 3600) (time->decimal-hour (time second: 1)))) + + (test-group "Datetime->decimal-hour" + (test-equal "Datetimes without dates work as times" + 5.5 (datetime->decimal-hour (datetime hour: 5 minute: 30))) + (test-equal "Full day" 24.0 (datetime->decimal-hour (datetime day: 1))) + (test-error "Can't get length of month without information about which month" + 'misc-error (datetime->decimal-hour (datetime month: 1))) + (test-equal "Can get length of month if we have a month" + (* 31 24.0) (datetime->decimal-hour (datetime month: 1) (date year: 2020 month: 01 day: 01))))) + +;; TODO +date-range + +(test-group "To string" + (test-group "Datetime->string" + (test-equal "A letter becomes itself" + "H" (datetime->string (datetime) "H")) + (test-group "Single rules" + (test-equal "~" (datetime->string (datetime) "~~")) + (test-equal "01" (datetime->string (datetime hour: 1) "~H")) + (test-equal " 1" (datetime->string (datetime hour: 1) "~k")) + (test-equal "02" (datetime->string (datetime minute: 2) "~M")) + (test-equal "03" (datetime->string (datetime second: 3) "~S")) + (test-equal "0002" (datetime->string (datetime year: 2) "~Y")) + (test-equal "02" (datetime->string (datetime month: 2) "~m")) + (test-equal "04" (datetime->string (datetime day: 4) "~d")) + (test-equal " 4" (datetime->string (datetime day: 4) "~e")) + (test-equal "1600000000" (datetime->string (datetime year: 2020 month: 09 day: 13 hour: 12 minute: 26 second: 40 tz: "UTC") "~s")) + + (test-equal "2022-10-20" (datetime->string (datetime date: (date year: 2022 month: 10 day: 20)) "~1")) + (test-equal "10:20:30" (datetime->string (datetime time: (time hour: 10 minute: 20 second: 30)) "~3")) + + (test-group "Locale dependant (en_US)" + (test-equal "Saturday" (datetime->string (datetime date: (find-first-week-day sat (date year: 2020 month: 01 day: 01))) "~A" en_US)) + (test-equal "Sat" (datetime->string (datetime date: (find-first-week-day sat (date year: 2020 month: 01 day: 01))) "~a" en_US)) + (test-equal "January" (datetime->string (datetime date: (date month: 1)) "~B" en_US)) + (test-equal "Jan" (datetime->string (datetime date: (date month: 1)) "~b" en_US))) + + (test-group "Locale dependant (sv_SE)" + (test-equal "lördag" (datetime->string (datetime date: (find-first-week-day sat (date year: 2020 month: 01 day: 01))) "~A" sv_SE)) + (test-equal "lör" (datetime->string (datetime date: (find-first-week-day sat (date year: 2020 month: 01 day: 01))) "~a" sv_SE)) + (test-equal "januari" (datetime->string (datetime date: (date month: 1)) "~B" sv_SE)) + (test-equal "jan" (datetime->string (datetime date: (date month: 1)) "~b" sv_SE))) + + (test-group "Timezone" + (test-equal "Z" (datetime->string (datetime tz: "UTC") "~Z")) + (test-equal "" (datetime->string (datetime tz: #f) "~Z")) + (test-equal "" (datetime->string (datetime tz: "Anything else") "~Z")))) + + + (test-equal "Default fomat specifier gives ISO-formatted date" + "2006-01-02T15:04:05" (datetime->string (datetime year: 2006 month: 01 day: 02 hour: 15 minute: 04 second: 05))) + + (test-group "Invalid specifiers" + (test-equal "" (datetime->string (datetime) "~x" allow-unknown?: #t)) + (test-error 'misc-error (datetime->string (datetime) "~x"))) + + (test-group "Print syntax for datatypes" + (test-equal "Date writer" "#2020-01-02" (with-output-to-string (lambda () (write (date year: 2020 month: 01 day: 02))))) + (test-equal "Time writer" "#20:30:40" (with-output-to-string (lambda () (write (time hour: 20 minute: 30 second: 40))))) + (test-equal "Datetime writer" "#2020-01-02T20:30:40" (with-output-to-string (lambda () (write (datetime year: 2020 month: 01 day: 02 hour: 20 minute: 30 second: 40))))) + (test-equal "Datetime writer (with tz)" "#2020-01-02T20:30:40Z" (with-output-to-string (lambda () (write (datetime year: 2020 month: 01 day: 02 hour: 20 minute: 30 second: 40 tz: "UTC"))))))) + + ;; Really basic tests, since these are rather thin wrappers + (test-equal "date->string" "0000-00-00" (date->string (date))) + (test-equal "time->string" "00:00:00" (time->string (time)))) + +(test-group "Equals" + ;; date=?, time=?, and datetime=? are alias to their non-question-mark + ;; alternatives. Using them interchangably below. + (test-group "date" + (test-assert "Zero dates are all equal" + (date=)) + (test-assert "A single date is equal to itself" + (date=? (date year: 2020 month: 10 day: 20))) + (test-assert "Two dates are equal to each other" + (date= (date year: 2020 month: 10 day: 20) (date year: 2020 month: 10 day: 20))) + (test-assert "Two dates which are NOT equal to each other" + (not (date= (date year: 2020 month: 10 day: 20) (date year: 2020 month: 10 day: 21)))) + (test-assert "More than two dates which are all equal" + (date=? (date year: 2020 month: 10 day: 20) (date year: 2020 month: 10 day: 20) (date year: 2020 month: 10 day: 20)))) + + (test-group "time" + (test-assert "Zero times are all equal" + (time=)) + (test-assert "A single time is equal to itself" + (time=? (time hour: 20 minute: 30 second: 40))) + (test-assert "Two times are equal to each other" + (time= (time hour: 20 minute: 30 second: 40) (time hour: 20 minute: 30 second: 40))) + (test-assert "Two times which are NOT equal to each other" + (not (time= (time hour: 20 minute: 30 second: 40) (time hour: 10 minute: 30 second: 40)))) + (test-assert "More than two times which are all equal" + (time=? (time hour: 20 minute: 30 second: 40) (time hour: 20 minute: 30 second: 40) (time hour: 20 minute: 30 second: 40)))) + + (test-group "Datetime" + (test-assert "Zero datetimes \"all\" are equal" + (datetime=)) + (test-assert "A single datetime is equal to itself" + (datetime= (datetime))) + (test-assert "Two equal datetimes are equal" + (datetime= (datetime hour: 1) (datetime hour: 1))) + (test-assert "Two dissimmalar datetimes aren't equal" + (not (datetime= (datetime hour: 1) (datetime hour: 2)))) + + ;; NOTE timezone interactions are non-existant + (test-assert "Two datetimes are equal, regardless of timezone" + (datetime= (datetime) (datetime tz: "Something Else"))) + + (test-assert "Three equal datetimes are equal" + (datetime= (datetime hour: 1) (datetime hour: 1) (datetime hour: 1))))) + +(test-group "Comparisons" + (test-group "Zero arguments" + (test-group "Dates" + (test-assert "zero dates are greater" (date<)) + (test-assert "zero dates are less" (date>))) + (test-group "Times" + (test-assert "zero times are greater" (time<)) + (test-assert "zero times are less" (time>))) + (test-group "Datetimes" + (test-assert "zero datetimes are greater" (datetime<)) + (test-assert "zero datetimes are less" (datetime>)))) + + (test-group "Single argument" + (test-group "Dates" + (test-assert "one date are greater" (date< (date))) + (test-assert "one date are less" (date> (date)))) + (test-group "Times" + (test-assert "one time are greater" (time< (time))) + (test-assert "one time are less" (time> (time)))) + (test-group "Datetimes" + (test-assert "one datetime are greater" (datetime< (datetime))) + (test-assert "one datetime are less" (datetime> (datetime))))) + + + (test-group "Two arguments" + (test-group "Dates" + (test-assert "positive comparison" (date< (date day: 1) (date day: 2))) + (test-assert "negative comparison" (not (date> (date day: 1) (date day: 2))))) + (test-group "Times" + (test-assert "positive comparison" (time< (time hour: 1) (time hour: 2))) + (test-assert "negative comparison" (not (time> (time hour: 1) (time hour: 2))))) + (test-group "Datetimes" + (test-assert "positive comparison" (datetime< (datetime day: 1) (datetime day: 2))) + (test-assert "negative comparison" (not (datetime> (datetime day: 1) (datetime day: 2)))))) + + (test-group "Two arguments" + (test-group "Dates" + (test-assert "positive comparison" + (date< (date day: 1) (date day: 2) (date day: 3))) + (test-assert "negative comparison" + (not (date< (date day: 1) (date day: 2) (date day: 1))))) + (test-group "Times" + (test-assert "positive comparison" + (time< (time hour: 1) (time hour: 2) (time hour: 3))) + (test-assert "negative comparison" + (not (date< (date day: 1) (date day: 2) (date day: 1))))) + (test-group "Datetimes" + (test-assert "positive comparison" + (datetime< (datetime day: 1) (datetime day: 2) (datetime day: 3))) + (test-assert "negative comparison" + (not (datetime< (datetime day: 1) (datetime day: 2) (datetime day: 1))))))) + +;; TODO +date<= +time<= +datetime<= + +;; TODO +date/-time< date/-time date/-time>? date/-time>= date/-time>=? + +(test-group "Arithmetic" + (test-group "Date" + (test-group "Unary application" + (test-equal "Date+ single argument returns itself" (date) (date+ (date))) + (test-equal "Date- single argument returns itself" (date) (date- (date)))) + + (test-group "Simple cases" + (test-group "Days" + (test-equal "Add" (date year: 2020 month: 01 day: 06) (date+ (date year: 2020 month: 01 day: 01) (date day: 5))) + (test-equal "Remove" (date year: 2020 month: 01 day: 01) (date- (date year: 2020 month: 01 day: 06) (date day: 5)))) + (test-group "Months" + (test-equal "Add" (date year: 2020 month: 06 day: 01) (date+ (date year: 2020 month: 01 day: 01) (date month: 5))) + (test-equal "Remove" (date year: 2020 month: 01 day: 01) (date- (date year: 2020 month: 06 day: 01) (date month: 5)))) + (test-group "Years" + (test-equal "Add" (date year: 2022 month: 01 day: 01) (date+ (date year: 2020 month: 01 day: 01) (date year: 2))) + (test-equal "Remove" (date year: 2020 month: 01 day: 01) (date- (date year: 2022 month: 01 day: 01) (date year: 2))))) + + (test-group "Many operands" + (test-equal (date year: 2021 month: 02 day: 02) + (date+ (date year: 2020 month: 01 day: 01) + (date day: 1) + (date month: 1) + (date year: 1)))) + + (test-group "Overflow" + ;; Years don't overflow, so no need to test + (test-equal "Day overflow" (date year: 2022 month: 02 day: 01) (date+ (date year: 2022 month: 01 day: 31) (date day: 1))) + (test-equal "Month overflow" (date year: 2023 month: 01 day: 01) (date+ (date year: 2022 month: 12 day: 01) (date month: 1))) + (test-equal "Date+Month overflow" (date year: 2023 month: 01 day: 01) (date+ (date year: 2022 month: 12 day: 31) (date day: 1)))) + + ;; NOTE + (test-equal (date year: 2020 month: 02 day: 31) (date+ (date year: 2020 month: 01 day: 31) (date month: 1))) + ) + + (test-group "Time" + (test-group "Unary application" + (test-equal "Time+ single argument returns itself" (time) (time+ (time))) + (test-equal "Time- single argument returns itself" (time) (time- (time)))) + + (test-group "Simple cases" + (test-group "Seconds" + (test-equal "Add" (time hour: 20 minute: 00 second: 40) (time+ (time hour: 20 minute: 00 second: 00) (time second: 40))) + (test-equal "Remove" (time hour: 20 minute: 00 second: 00) (time- (time hour: 20 minute: 00 second: 40) (time second: 40)))) + (test-group "Minutes" + (test-equal "Add" (time hour: 20 minute: 10 second: 00) (time+ (time hour: 20 minute: 00 second: 00) (time minute: 10))) + (test-equal "Remove" (time hour: 20 minute: 00 second: 00) (time- (time hour: 20 minute: 10 second: 00) (time minute: 10)))) + (test-group "Hours" + (test-equal "Add" (time hour: 22 minute: 00 second: 00) (time+ (time hour: 20 minute: 00 second: 00) (time hour: 2))) + (test-equal "Remove" (time hour: 20 minute: 00 second: 00) (time- (time hour: 22 minute: 00 second: 00) (time hour: 2))))) + + (test-group "Overflowing cases" + (test-group "Addition" + (test-group "Single overflow" + (call-with-values (lambda () (time+ (time hour: 20 minute: 00 second: 00) (time hour: 5))) + (lambda (result overflow) + (test-equal "Time" (time hour: 1) result) + (test-equal "Overflow" 1 overflow)))) + (test-group "Mulitple overflows" + (call-with-values (lambda () (time+ (time hour: 20 minute: 00 second: 00) (time hour: 5) (time hour: 24))) + (lambda (result overflow) + (test-equal "Time" (time hour: 1) result) + (test-equal "Overflow" 2 overflow))))) + + (test-group "Subtraction" + (test-group "Single overflow" + (call-with-values (lambda () (time- (time hour: 20 minute: 00 second: 00) (time hour: 25))) + (lambda (result overflow) + (test-equal "Time" (time hour: 19) result) + (test-equal "Overflow" 1 overflow)))) + (test-group "Mulitple overflows" + (call-with-values (lambda () (time- (time hour: 4) (time hour: 10) (time hour: 24))) + (lambda (result overflow) + (test-equal "Time" (time hour: 18) result) + (test-equal "Overflow" 2 overflow)))))))) + +;; TODO +datetime+ datetime- + +(test-group "Date difference" + (test-assert "The differente between a date and itself is zero" + (date-zero? (date-difference (date year: 2022 month: 02 day: 02) (date year: 2022 month: 02 day: 02)))) + + (test-error "Later date must be first" 'misc-error + (date-difference (date year: 2020 month: 01 day: 01) (date year: 2021 month: 01 day: 01))) + + (test-error "Negative months are invalid" 'misc-error + (date-difference (date) (date month: -1))) + (test-error "Negative days are invalid" 'misc-error + (date-difference (date) (date day: -1))) + (test-equal "Negative years ARE valid" + (date year: 1) (date-difference (date) (date year: -1)))) + +;; TODO +datetime-difference + +'((datetime)) diff --git a/tests/unit/datetime/timespec.scm b/tests/unit/datetime/timespec.scm new file mode 100644 index 00000000..76fdd572 --- /dev/null +++ b/tests/unit/datetime/timespec.scm @@ -0,0 +1,98 @@ +(define-module (test timespec) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module (datetime) + :use-module (datetime timespec)) + +(test-equal "The empty string parses to the empty timespec" + (timespec-zero) (parse-time-spec "")) + +(test-group "timespec-add" + + (test-equal "Zero operands gives 0" + (timespec-zero) (timespec-add)) + + (let ((ts (make-timespec (time hour: 10 minute: 20 second: 30) '- #\z))) + (test-equal "Single operand gives that operand" + ts (timespec-add ts))) + + (test-equal "0 + 0 = 0" + (timespec-zero) (timespec-add (timespec-zero) (timespec-zero))) + + (test-group + "+ -" + (test-equal "Remove a number less than the base" + (make-timespec (time hour: 10 minute: 00 second: 00) '+ #\w) + (timespec-add (make-timespec (time hour: 10 minute: 20 second: 30) + '+ #\w) + (make-timespec (time minute: 20 second: 30) + '- #\w))) + + (test-equal "Remove a number greater than the base" + (make-timespec (time hour: 01 minute: 00 second: 00) '- #\w) + (timespec-add (make-timespec (time hour: 10 minute: 00 second: 00) '+ #\w) + (make-timespec (time hour: 11 minute: 00 second: 00) '- #\w))) + + (test-equal "x + -x = 0" + (timespec-zero) (timespec-add (make-timespec (time hour: 10 minute: 20 second: 30) '+ #\w) + (make-timespec (time hour: 10 minute: 20 second: 30) '- #\w)))) + + (test-group "- +" + (test-equal "Add a number less than the (negative) base" + (make-timespec (time hour: 10 minute: 00 second: 00) '+ #\w) + (timespec-add (make-timespec (time hour: 10 minute: 20 second: 30) '- #\w) + (make-timespec (time hour: 00 minute: 20 second: 30) '+ #\w))) + + (test-equal "Add a number greater than the (negative) base" + (make-timespec (time hour: 01 minute: 00 second: 00) '- #\w) + (timespec-add (make-timespec (time hour: 10 minute: 00 second: 00) '- #\w) + (make-timespec (time hour: 11 minute: 00 second: 00) '+ #\w))) + + (test-equal "-x + x = 0" + (timespec-zero) (timespec-add (make-timespec (time hour: 10 minute: 20 second: 30) '- #\w) + (make-timespec (time hour: 10 minute: 20 second: 30) '+ #\w)))) + + (test-group "+ +" + (test-equal "x + x = 2x" + (make-timespec (time hour: 20 minute: 41 second: 00) '+ #\w) + (timespec-add (make-timespec (time hour: 10 minute: 20 second: 30) '+ #\w) + (make-timespec (time hour: 10 minute: 20 second: 30) '+ #\w)))) + + (test-group "- -" + (test-equal "-x + -x = -2x" + (make-timespec (time hour: 20 minute: 41 second: 00) '- #\w) + (timespec-add (make-timespec (time hour: 10 minute: 20 second: 30) '- #\w) + (make-timespec (time hour: 10 minute: 20 second: 30) '- #\w)))) + + ;; add more than two timespecs + + ;; add timespecs of differing types + ) + +(test-group "parse-time-spec" + ;; TODO what even is this case? + (test-equal (make-timespec (time) '+ #\g) (parse-time-spec "-g")) + + (test-equal "Parse direct date, with hour minute and second" + (make-timespec (time hour: 20 minute: 00 second: 00) '+ #\w) + (parse-time-spec "20:00:00")) + (test-equal "Parse direct date, with hour and minute" + (make-timespec (time hour: 20 minute: 00 second: 00) '+ #\w) + (parse-time-spec "20:00")) + (test-equal "Parse direct date, with just hour" + (make-timespec (time hour: 20 minute: 00 second: 00) '+ #\w) + (parse-time-spec "20")) + + (test-equal "Parse timespec with letter at end" + (make-timespec (time hour: 20 minute: 00 second: 00) '+ #\g) + (parse-time-spec "20:00g")) + + (test-equal "Parse negative timespec" + (make-timespec (time hour: 20 minute: 00 second: 00) '- #\w) + (parse-time-spec "-20")) + + (test-equal "Parse negative timespec with letter at end" + (make-timespec (time hour: 20 minute: 00 second: 00) '- #\z) + (parse-time-spec "-20z"))) + +'((datetime timespec)) diff --git a/tests/unit/datetime/tz.scm b/tests/unit/datetime/tz.scm new file mode 100644 index 00000000..d335ced3 --- /dev/null +++ b/tests/unit/datetime/tz.scm @@ -0,0 +1,88 @@ +;;; Commentary: +;; Tests that datetime->unix-time correctly converts between Olssen +;; timezone definitions (e.g. Europe/Stockholm), into correct times +;; and offsets (in unix time). +;; Also indirectly tests the Zone Info Compiler (datetime zic), since +;; the zoneinfo comes from there. +;;; Code: + +(define-module (test tz) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((datetime) + :select (parse-ics-datetime + datetime + date + time + datetime->unix-time + unix-time->datetime + get-datetime)) + :use-module ((hnh util env) :select (let-env))) + +;; London alternates between +0000 and +0100 +(let-env + ((TZ "Europe/London")) + (test-equal + "London winter" + (datetime year: 2020 month: 01 day: 12 hour: 13 minute: 30 second: 00) + (get-datetime + (parse-ics-datetime "20200112T133000Z"))) + (test-equal + "London summer" + (datetime year: 2020 month: 06 day: 12 hour: 14 minute: 30 second: 00) + (get-datetime + (parse-ics-datetime "20200612T133000Z")))) + +;; Stockholm alternates between +0100 and +0200 +(let-env + ((TZ "Europe/Stockholm")) + (test-equal + "Stockholm winter" + (datetime year: 2020 month: 01 day: 12 hour: 14 minute: 30 second: 00) + (get-datetime + (parse-ics-datetime "20200112T133000Z"))) + (test-equal + "Stockholm summer" + (datetime year: 2020 month: 06 day: 12 hour: 15 minute: 30 second: 00) + (get-datetime + (parse-ics-datetime "20200612T133000Z")))) + +(test-equal + -10800 + (datetime->unix-time + (parse-ics-datetime + "19700101T000000" + "Europe/Tallinn"))) + +(test-equal + -3600 + (datetime->unix-time + (parse-ics-datetime + "19700101T000000" + "Europe/Stockholm"))) + +(test-equal + 0 + (datetime->unix-time + (parse-ics-datetime "19700101T000000Z"))) + +;; yes, really +(test-equal + -3600 + (datetime->unix-time + (parse-ics-datetime + "19700101T000000" + "Europe/London"))) + +(test-equal + (datetime + date: + (date year: 1970 month: 01 day: 01) + time: + (time hour: 00 minute: 00 second: 00) + tz: + "UTC") + (unix-time->datetime 0)) + + +'((datetime)) diff --git a/tests/unit/datetime/zic.scm b/tests/unit/datetime/zic.scm new file mode 100644 index 00000000..19af169c --- /dev/null +++ b/tests/unit/datetime/zic.scm @@ -0,0 +1,319 @@ +(define-module (test zic) + :use-module ((srfi srfi-1) :select (every)) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module (datetime) + :use-module (datetime timespec) + :use-module (datetime zic)) + + +(test-expect-fail "Simple Leap") +(test-expect-fail "Simple Expire") + +(define big-sample + "# Rule NAME FROM TO - IN ON AT SAVE LETTER/S +Rule Swiss 1941 1942 - May Mon>=1 1:00 1:00 S +Rule Swiss 1941 1942 - Oct Mon>=1 2:00 0 - +Rule EU 1977 1980 - Apr Sun>=1 1:00u 1:00 S +Rule EU 1977 only - Sep lastSun 1:00u 0 - +Rule EU 1978 only - Oct 1 1:00u 0 - +Rule EU 1979 1995 - Sep lastSun 1:00u 0 - +Rule EU 1981 max - Mar lastSun 1:00u 1:00 S +Rule EU 1996 max - Oct lastSun 1:00u 0 - + +# Zone NAME STDOFF RULES FORMAT [UNTIL] +Zone Europe/Zurich 0:34:08 - LMT 1853 Jul 16 + 0:29:45.50 - BMT 1894 Jun + 1:00 Swiss CE%sT 1981 + 1:00 EU CE%sT + +Link Europe/Zurich Europe/Vaduz +") + +(define parse-zic-file (@@ (datetime zic) parse-zic-file)) + +;; Some of the tests are slightly altered to score better on the coverage +(test-group "From zic(8)" + (test-equal "Basic Rule" + (list ((@@ (datetime zic) make-rule) + 'US 1967 1973 4 '(last 0) + ((@ (datetime zic) make-timespec) (time hour: 02 minute: 00 second: 00) '+ #\w) + ((@ (datetime zic) make-timespec) (time hour: 01 minute: 00 second: 00) '+ #\d) + "D")) + (call-with-input-string "Rule US 1967 1973 - Apr lastSun 2:00w 1:00d D" + parse-zic-file)) + + ;; Technically not from zic(8), since that example has an until field + (test-equal "Basic Zone" + (list ((@@ (datetime zic) make-zone) "Asia/Amman" + (list ((@@ (datetime zic) make-zone-entry) + (make-timespec (time hour: 02 minute: 00 second: 00) '+ #\w) + 'Jordan "EE%sT" #f)))) + + (call-with-input-string + "Zone Asia/Amman 2:00 Jordan EE%sT" + parse-zic-file)) + + ;; Modified from the following example + (test-equal "Basic Zone with continuation" + (list ((@@ (datetime zic) make-zone) "America/Menominee" + (list ((@@ (datetime zic) make-zone-entry) + (make-timespec (time hour: 05 minute: 00 second: 00) '- #\w) + #f "EST" (datetime year: 1973 month: 04 day: 29 hour: 02 minute: 00 second: 00)) + ((@@ (datetime zic) make-zone-entry) + (make-timespec (time hour: 06 minute: 00 second: 00) '- #\w) + 'US "C%sT" #f)))) + ;; Why can't I single read a zone with an until field? + (call-with-input-string + "Zone America/Menominee -5:00 - EST 1973 Apr 29 2:00 + -6:00 US C%sT" + parse-zic-file)) + + + (test-equal "Rules and Zone" + (list ((@@ (datetime zic) make-zone) "America/Menominee" + (list ((@@ (datetime zic) make-zone-entry) + (make-timespec (time hour: 05 minute: 00 second: 00) '- #\w) + #f "EST" (datetime year: 1973 month: 04 day: 29 hour: 02 minute: 00 second: 00)) + ((@@ (datetime zic) make-zone-entry) + (make-timespec (time hour: 06 minute: 00 second: 00) '- #\w) + 'US "C%sT" #f))) + ((@@ (datetime zic) make-rule) + 'US 1967 1973 dec '(last 0) + (make-timespec (time hour: 02 minute: 00 second: 00) '+ #\w) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\w) + "D") + ((@@ (datetime zic) make-rule) + 'US 1967 2006 nov '(last 0) + (make-timespec (time hour: 02 minute: 00 second: 00) '+ #\w) + (make-timespec (time hour: 00 minute: 00 second: 00) '+ #\w) + "S")) + (call-with-input-string + "# Rule NAME FROM TO - IN ON AT SAVE LETTER/S +Rule US 1967 2006 - Nov lastSun 2:00 0 S +Rule US 1967 1973 - Dec lastSun 2:00 1:00 D +# Zone NAME STDOFF RULES FORMAT [UNTIL] +Zone America/Menominee -5:00 - EST 1973 Apr 29 2:00 + -6:00 US C%sT +" parse-zic-file)) + + + (test-equal "Simple Link" + (list ((@@ (datetime zic) make-link) "Asia/Istanbul" "Europe/Istanbul")) + (call-with-input-string "Link Europe/Istanbul Asia/Istanbul" + parse-zic-file)) + + (test-equal "Simple Leap" + 'not-yet-implemented + (call-with-input-string "Leap 2016 Dec 31 23:59:60 + S" + parse-zic-file)) + + (test-equal "Simple Expire" + 'not-yet-implemented + (call-with-input-string "Expires 2020 Dec 28 00:00:00" + parse-zic-file)) + + + (test-equal "Extended example" + ;; Items are in reverse order of discovery + (list ((@@ (datetime zic) make-link) "Europe/Vaduz" "Europe/Zurich") + ((@@ (datetime zic) make-zone) "Europe/Zurich" + (list ((@@ (datetime zic) make-zone-entry) + (make-timespec (time hour: 00 minute: 34 second: 08) '+ #\w) + #f "LMT" (datetime year: 1853 month: 07 day: 16 hour: 00 minute: 00 second: 00)) + ((@@ (datetime zic) make-zone-entry) + (make-timespec (time hour: 00 minute: 29 second: 45) '+ #\w) ; NOTE that the .50 is discarded + #f "BMT" (datetime year: 1894 month: 06 day: 01 hour: 00 minute: 00 second: 00)) + ((@@ (datetime zic) make-zone-entry) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\w) + 'Swiss "CE%sT" (datetime year: 1981 month: 01 day: 01 hour: 00 minute: 00 second: 00)) + ((@@ (datetime zic) make-zone-entry) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\w) + 'EU "CE%sT" #f))) + ((@@ (datetime zic) make-rule) 'EU 1996 'maximum 10 '(last 0) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\u) + (make-timespec (time hour: 00 minute: 00 second: 00) '+ #\w) + "") + ((@@ (datetime zic) make-rule) 'EU 1981 'maximum 3 '(last 0) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\u) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\w) + "S") + ((@@ (datetime zic) make-rule) 'EU 1979 1995 9 `(last ,sun) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\u) + (make-timespec (time hour: 00 minute: 00 second: 00) '+ #\w) + "") + ((@@ (datetime zic) make-rule) 'EU 1978 'only 10 1 + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\u) + (make-timespec (time hour: 00 minute: 00 second: 00) '+ #\w) + "") + ((@@ (datetime zic) make-rule) 'EU 1977 'only 9 `(last ,sun) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\u) + (make-timespec (time hour: 00 minute: 00 second: 00) '+ #\w) + "") + ((@@ (datetime zic) make-rule) 'EU 1977 1980 4 `(> ,sun 1) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\u) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\w) + "S") + ((@@ (datetime zic) make-rule) 'Swiss 1941 1942 10 `(> ,mon 1) + (make-timespec (time hour: 02 minute: 00 second: 00) '+ #\w) + (make-timespec (time hour: 00 minute: 00 second: 00) '+ #\w) + "") + ((@@ (datetime zic) make-rule) 'Swiss 1941 1942 5 `(> ,mon 1) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\w) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\w) + "S")) + (call-with-input-string big-sample + parse-zic-file))) + +(test-group "rule->dtstart" + (test-equal "last sunday" + (datetime year: 1967 month: 04 day: 30 hour: 02 minute: 00 second: 00) + (rule->dtstart + ((@@ (datetime zic) make-rule) + 'US 1967 1973 4 '(last 0) + ((@ (datetime zic) make-timespec) (time hour: 02 minute: 00 second: 00) '+ #\w) + ((@ (datetime zic) make-timespec) (time hour: 01 minute: 00 second: 00) '+ #\d) + "D"))) + + (test-equal "sunday >= 1" + (datetime year: 1977 month: 04 day: 03 hour: 01 minute: 00 second: 00 tz: "UTC") + (rule->dtstart + ((@@ (datetime zic) make-rule) 'EU 1977 1980 4 `(> ,sun 1) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\u) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\w) + "S"))) + + ;; Max and min uses dummy dates, which is slightly wrong + ;; but shouldn't cause any real problems + + (test-equal "Minimum time" + (datetime year: 0000 month: 10 day: 30 hour: 01 minute: 00 second: 00 tz: "UTC") + (rule->dtstart + ((@@ (datetime zic) make-rule) 'EU 'minimum 2000 10 '(last 0) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\u) + (make-timespec (time hour: 00 minute: 00 second: 00) '+ #\w) + ""))) + + (test-equal "Maximum time" + (datetime year: 9999 month: oct day: 27 + hour: 1 tz: "UTC") + (rule->dtstart + ((@@ (datetime zic) make-rule) 'EU 'maximum 2000 10 '(last 0) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\u) + (make-timespec (time hour: 00 minute: 00 second: 00) '+ #\w) + "")))) + +(test-group "zone-format" + + (test-equal "Zone format with argument" "CEST" (zone-format "CE%sT" "S")) + (test-equal "Zone format with empty" "CET" (zone-format "CE%sT" "")) + + ;; TODO zone-format %z is not yet implemented, and therefore untested + + ;; TODO this error message is currently translatable... + (test-equal "Invalid format specifier" + '(misc-error "zone-format" "Invalid format char ~s in ~s at position ~a" (#\S "%S" 1) #f) + (catch 'misc-error (lambda () (zone-format "%S" "A")) + list))) + +(test-group "Actual object" + ;; NOTE this doesn't test read-zoneinfos ability to + ;; - take filenames + ;; - take multiple items + (let ((zoneinfo (call-with-input-string big-sample (compose read-zoneinfo list)))) + (test-assert "get-zone returns a zone-entry object" + (every zone-entry? (get-zone zoneinfo "Europe/Zurich"))) + (test-equal "A link resolves to the same object as its target" + (get-zone zoneinfo "Europe/Zurich") (get-zone zoneinfo "Europe/Vaduz")) + (test-equal "Get rules returns correctly, and in order" + ;; Rules are sorted + (list ((@@ (datetime zic) make-rule) 'Swiss 1941 1942 5 `(> ,mon 1) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\w) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\w) + "S") + ((@@ (datetime zic) make-rule) 'Swiss 1941 1942 10 `(> ,mon 1) + (make-timespec (time hour: 02 minute: 00 second: 00) '+ #\w) + (make-timespec (time hour: 00 minute: 00 second: 00) '+ #\w) + "")) + (get-rule zoneinfo 'Swiss)))) + + +(test-group "rule->rrule" + (test-equal "Basic example, and to = maximum" + ((@ (vcomponent recurrence internal) make-recur-rule) + freq: 'YEARLY interval: 1 wkst: mon + byday: (list (cons -1 sun)) + bymonth: (list oct)) + (rule->rrule + ((@@ (datetime zic) make-rule) 'EU 1996 'maximum 10 '(last 0) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\u) + (make-timespec (time hour: 00 minute: 00 second: 00) '+ #\w) + "") + )) + + (test-equal "with to = only" + #f + (rule->rrule + ((@@ (datetime zic) make-rule) 'EU 1996 'only 10 '(last 2) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\u) + (make-timespec (time hour: 00 minute: 00 second: 00) '+ #\w) + ""))) + + (test-equal "with definitive to year" + ((@ (vcomponent recurrence internal) make-recur-rule) + freq: 'YEARLY interval: 1 wkst: mon + byday: (list (cons -1 tue)) + bymonth: (list oct) + until: (datetime year: 2000 month: 01 day: 01 hour: 00 minute: 00 second: 00)) + (rule->rrule + ((@@ (datetime zic) make-rule) 'EU 1996 2000 10 '(last 2) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\u) + (make-timespec (time hour: 00 minute: 00 second: 00) '+ #\w) + ""))) + + (test-equal "on being a month day" + ((@ (vcomponent recurrence internal) make-recur-rule) + freq: 'YEARLY interval: 1 wkst: mon + bymonthday: (list 2) + bymonth: (list oct)) + (rule->rrule + ((@@ (datetime zic) make-rule) 'EU 1996 'maximum 10 2 + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\u) + (make-timespec (time hour: 00 minute: 00 second: 00) '+ #\w) + ""))) + + (test-equal "on being first day after date" + ((@ (vcomponent recurrence internal) make-recur-rule) + freq: 'YEARLY interval: 1 wkst: mon + byday: (list (cons 1 mon)) + bymonth: (list oct)) + (rule->rrule + ((@@ (datetime zic) make-rule) 'EU 1996 'maximum 10 `(> ,mon 2) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\u) + (make-timespec (time hour: 00 minute: 00 second: 00) '+ #\w) + ""))) + + (test-equal "Crash on counting backwards from date" + '(misc-error "rule->rrule" "Counting backward for RRULES unsupported" #f #f) + (catch 'misc-error + (lambda () + (rule->rrule + ((@@ (datetime zic) make-rule) 'EU 1996 'maximum 10 `(< ,mon 2) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\u) + (make-timespec (time hour: 00 minute: 00 second: 00) '+ #\w) + ""))) + list)) + + (test-equal "Crash on to = minimum" + '(misc-error "rule->rrule" "Check your input" #f #f) + (catch 'misc-error + (lambda () + (rule->rrule + ((@@ (datetime zic) make-rule) 'EU 1996 'minimum 10 `(< ,mon 2) + (make-timespec (time hour: 01 minute: 00 second: 00) '+ #\u) + (make-timespec (time hour: 00 minute: 00 second: 00) '+ #\w) + ""))) + list)) + ) + +'((datetime zic)) -- cgit v1.2.3