Fix datetime issues discovered due to new tests.

2 files changed, 181 insertions, 168 deletions

diff --git a/module/datetime.scm b/module/datetime.scm
index 9118d42f..1a84d421 100644
--- a/module/datetime.scm
+++ b/module/datetime.scm
@@ -11,11 +11,12 @@
 
   :use-module ((hnh util)
                :select (vector-last set! -> ->> swap case* set
-                                    span-upto set->))
+                                    label span-upto set->))
 
   :use-module (ice-9 i18n)
   :use-module (ice-9 format)
   :use-module (ice-9 regex)
+  :use-module (ice-9 match)
   :use-module (calp util config)
 
   :export (date
@@ -52,7 +53,6 @@
            start-of-month
            end-of-month
            start-of-year
-           end-of-year
 
            date-stream
            day-stream
@@ -181,13 +181,7 @@
   (make-date year month day))
 
 (set-record-type-printer!
- <date>
- (lambda (r p)
-   (catch 'misc-error
-     (lambda () (display (date->string r "#~Y-~m-~d") p))
-     (lambda (err proc fmt args data)
-       (format p "#<<date> BAD year=~s month=~s day=~s>"
-               (year r) (month r) (day r))))))
+ <date> (lambda (r p) (display (date->string r "#~1") p)))
 
 
 ;;; TIME
@@ -198,16 +192,16 @@
   (hour hour) (minute minute) (second second))
 
 (define* (time key: (hour 0) (minute 0) (second 0))
+  (unless (and (integer? hour) (integer? minute) (integer? second))
+    (scm-error 'wrong-type-arg "time"
+               "Hour, minute, and second must all be integers. ~s, ~s, ~s"
+               (list hour minute second)
+               #f))
   (make-time hour minute second))
 
 (set-record-type-printer!
  <time>
- (lambda (r p)
-   (catch 'misc-error
-     (lambda () (display (time->string r "#~H:~M:~S") p))
-     (lambda (err _ fmt args rest)
-       (format p "#<<time> hour=~s minute=~s second=~s>"
-               (hour r) (minute r) (second r))))))
+ (lambda (r p) (display (time->string r "#~3") p)))
 
 
 (define (date-zero? date)
@@ -235,21 +229,24 @@
           (year 0) (month 0) (day 0)
           (hour 0) (minute 0) (second 0)
           tz)
-  (make-datetime (or date (make-date year month day))
-                 (or time (make-time hour minute second))
-                 tz))
+  (let ((date (or date (make-date year month day)))
+        (time (or time (make-time hour minute second))))
+    (unless (date? date)
+      (scm-error 'wrong-type-arg "datetime"
+                 "Date must be a date object, got ~s"
+                 (list date) (list date)))
+    (unless (time? time)
+      (scm-error 'wrong-type-arg "datetime"
+                 "Time must be a time object, got ~s"
+                 (list time) (list time)))
+   (make-datetime date time tz)))
 
 (set-record-type-printer!
  <datetime>
  (lambda (r p)
-   (catch 'misc-error
-     (lambda ()
-      (if (and (tz r) (not (string=? "UTC" (tz r))))
-          (write (datetime->sexp r) p)
-          (display (datetime->string r "#~1T~3~Z") p)))
-     (lambda (err _ fmt args . rest)
-       (format p "#<<datetime> BAD date=~s time=~s tz=~s>"
-               (get-date r) (get-time% r) (tz r))))))
+   (if (and (tz r) (not (string=? "UTC" (tz r))))
+       (write (datetime->sexp r) p)
+       (display (datetime->string r "#~1T~3~Z") p))))
 
 
 
@@ -629,6 +626,11 @@
 
 ;; The amount of days in the given interval, both end pointts inclusive
 (define (days-in-interval start-date end-date)
+  (unless (date<= start-date end-date)
+    (scm-error 'misc-error "days-in-interval"
+               "End date must be greater (or equal) to start date: ~s, ~s"
+               (list start-date end-date)
+               #f))
   (let ((diff (date-difference (date+ end-date (date day: 1)) start-date)))
     (->> (month-stream start-date)
          (stream-take (+ (month diff)
@@ -680,7 +682,9 @@
 
 (define* (datetime->string
           datetime
-          optional: (fmt "~Y-~m-~dT~H:~M:~S")
+          optional:
+          (fmt "~1T~3")
+          (locale %global-locale)
           key: allow-unknown?)
   (define date (get-date datetime))
   (define time (get-time% datetime))
@@ -698,17 +702,15 @@
                    ((#\Y) (format #t "~4'0d" (year date)))
                    ((#\m) (format #t "~2'0d" (month date)))
                    ((#\d) (format #t "~2'0d" (day date)))
+                   ((#\e) (format #t "~2' d" (day date)))
                    ;; Should be same as ~_d
                    ((#\s) (display (datetime->unix-time datetime))) ; epoch time!
-                   ((#\e) (format #t "~2' d" (day date)))
-                   ((#\1) (format #t "~4'0d-~2'0d-~2'0d"
-                                  (year date) (month date) (day date)))
-                   ((#\3) (format #t "~2'0d:~2'0d:~2'0d"
-                                  (hour time) (minute time) (second time)))
-                   ((#\A) (display (week-day-name (week-day date))))
-                   ((#\a) (display (week-day-name (week-day date) 3)))
-                   ((#\b) (display (locale-month-short (month date))))
-                   ((#\B) (display (locale-month (month date))))
+                   ((#\1) (display (datetime->string datetime "~Y-~m-~d")))
+                   ((#\3) (display (datetime->string datetime "~H:~M:~S")))
+                   ((#\A) (display (week-day-name (week-day date)   locale: locale)))
+                   ((#\a) (display (week-day-name (week-day date) 3 locale: locale)))
+                   ((#\B) (display (locale-month       (month date) locale)))
+                   ((#\b) (display (locale-month-short (month date) locale)))
                    ((#\Z) (when (equal? "UTC" (get-timezone datetime)) (display "Z")))
                    (else (unless allow-unknown?
                            (scm-error 'misc-error "datetime->string"
@@ -720,17 +722,17 @@
             #f
             (string->list fmt)))))
 
-(define* (date->string date
-                              optional: (fmt "~Y-~m-~d")
-                              key: allow-unknown?)
+(define* (date->string date optional: (fmt "~1") (locale %global-locale)
+                       key: allow-unknown?)
   (datetime->string (datetime date: date)
-                    fmt allow-unknown?: allow-unknown?))
+                    fmt locale
+                    allow-unknown?: allow-unknown?))
 
-(define* (time->string time
-                              optional: (fmt "~H:~M:~S")
-                              key: allow-unknown?)
+(define* (time->string time optional: (fmt "~3") (locale %global-locale)
+                       key: allow-unknown?)
   (datetime->string (datetime time: time)
-                    fmt allow-unknown?: allow-unknown?))
+                    fmt locale
+                    allow-unknown?: allow-unknown?))
 
 
 
@@ -750,59 +752,61 @@ Returns -1 on failure"
          (iota 12 1))
    -1))
 
+(define* (string->datetime string optional: (format-specifier "~Y-~m-~dT~H:~M:~S~Z")
+                           (locale %global-locale)
+                           key: return-trailing)
+
+  (define (err fmt . args)
+    (scm-error 'misc-error "string->datetime"
+               (string-append "When parsing ~s as ~s; " fmt)
+               (cons* string format-specifier args)
+               (list string format-specifier)))
 
-(define* (string->datetime str optional: (fmt "~Y-~m-~dT~H:~M:~S~Z")
-                                  (locale %global-locale))
-  (let loop* ((str (string->list str))
-             (fmt (string->list fmt))
-             (dt (datetime))
-             (ampm identity))
+  (let loop* ((str (string->list string))
+              (fmt (string->list format-specifier))
+              (dt (datetime))
+              (ampm identity))
 
     (define* (loop str fmt dt optional: (ampm ampm))
       (loop* str fmt dt ampm))
 
     (define time (get-time% dt))
     (define date (get-date dt))
+    (define zone (get-timezone dt))
     (define (as-dt dt)
-      (cond [(date? dt) (datetime date: dt time: time)]
-            [(time? dt) (datetime date: date time: dt)]
+      (cond [(date? dt) (datetime date: dt time: time tz: zone)]
+            [(time? dt) (datetime date: date time: dt tz: zone)]
             [else dt]))
 
-    (cond [(null? str)
-           ;; TODO should this be considered an error?
-           ;; Should it be toggleable through a flag.
-           ;; It's sometimes useful to allow it, since it allows optional
-           ;; trailing fields, but sometimes useful to disallow it, since
-           ;; it gives a better check that the data is valid
-           ;; ((@ (hnh util exceptions) warning)
-           ;;  "Premature end of string, still got fmt = ~s"
-           ;;  fmt)
+    (cond [(and (null? str) (null? fmt))
            (ampm dt)]
+          [(null? str)
+           ;; TODO it would be preferable to error out here. However, that fails for
+           ;; optional specifiers (e.g. ~Z).
+           ;; Also see the disabled test in "Premature end of string to parse"
+           (ampm dt)
+           #; (err "Premature end of string, trailing fmt: ~s" fmt)]
           [(null? fmt)
-           ;; ((@ (hnh util exceptions) warning)
-           ;;  "Unsparsed characters at end of string")
-           (ampm dt)]
+           (if return-trailing
+               (values (ampm dt) str)
+               (err "trailing characters: ~s" str))]
+          [(and (eq? #\~ (car fmt))
+                (null? (cdr fmt)))
+           (err "Stray ~ at end of fmt")]
           [(eq? #\~ (car fmt))
            (case (cadr fmt)
              [(#\~) (if (eq? #\~ (car str))
                         (loop (cdr str)
                               (cddr fmt)
                               dt)
-                        ;; TODO name the loop-local variables something
-                        ;; other than the top level, to allow better error
-                        ;; messages.
-                        (scm-error 'misc-error "string->datetime"
-                               "Mismatched symbol, expected ~s got ~s"
-                               (list #\~ (car str))
-                               #f))]
-             ;; TODO is this lost if not at the end?
+                        (err "mismatched symbol, expected ~s got ~s" #\~ (car str)))]
              [(#\Z)
               (if (eq? #\Z (car str))
                   (loop (cdr str)
-                        (cdr fmt)
+                        (cddr fmt)
                         (set (tz dt) "UTC"))
                   (loop str
-                        (cdr fmt)
+                        (cddr fmt)
                         dt))]
              ;; AM/PM
              [(#\p)
@@ -831,20 +835,15 @@ Returns -1 on failure"
               ]
              ;; month by name
              [(#\b #\B #\h)
-              (let ((head post (cond ((null? (cddr fmt)) (values str '()))
-                                     ((eqv? #\~ (caddr fmt))
-                                      (cond ((null? (cdddr fmt))
-                                             (scm-error 'misc-error "string->datetime"
-                                                        "Unexpected ~ at end of fmt"
-                                                        #f #f))
-                                            ((eqv? #\~ (cadddr fmt))
-                                             (span (lambda (c) (not (eqv? #\~ c)))
-                                                   str))
-                                            (else (scm-error 'misc-error "string->datetime"
-                                                             "Can't have format specifier directly after month by name"
-                                                             #f #f))))
-                                     (else (span (lambda (c) (not (eqv? c (caddr fmt))))
-                                                 str)))))
+              (let ((head post
+                          (match (cddr fmt)
+                            (()                   (values str '()))
+                            ;; Manual check so remaining cases becomes clearer
+                            ((#\~)                (err "Unexpected ~ at end of fmt"))
+                            ((#\~ #\~ rest ...)   (span (lambda (c) (not (eqv? #\~ c))) str))
+                            ;; Dissalowed, since we otherwise have no idea where the month name ends.
+                            ((#\~ rest ...)       (err "Can't have format specifier directly after month by name"))
+                            ((next-char rest ...) (span (lambda (c) (not (eqv? c next-char))) str)))))
                 (loop post
                       (cddr fmt)
                       (as-dt (set (month date)
@@ -867,33 +866,32 @@ Returns -1 on failure"
                     [(#\d) (set (day date)    num)]))))]
 
              [(#\Y)
-              (let* ((pre post (split-at str 4))
+              (let* ((pre post (span-upto 4 char-numeric? str))
                      (num (-> pre list->string string->number)))
                 (loop
                  post
                  (cddr fmt)
                  (as-dt (set (year date) num))))]
 
-             [else
-              (scm-error 'misc-error "string->datetime"
-                     "Unimplemented or incorrect parse token ~S"
-                     (list str)
-                     #f)])]
+             [else (err "Unimplemented or incorrect parse token ~S" str)])]
           [else
            (if (eq? (car str) (car fmt))
                (loop (cdr str)
                      (cdr fmt)
                      dt)
-               (scm-error 'misc-error "string->datetime"
-                      "Mismatched symbol, expected ~s got ~s"
-                      (list (car fmt) (car str))
-                      #f))])))
+               (err "Mismatched symbol, expected ~s got ~s" (car fmt) (car str)))])))
+
+
+;; TODO both string->time and string->date accepts format tokens which are invalid for them.
+;; Should this be filtered out?
 
-(define* (string->time str optional: (fmt "~H:~M:~S") (locale %global-locale))
-  (get-time% (string->datetime str fmt locale)))
+(define* (string->time str optional: (fmt "~H:~M:~S") (locale %global-locale)
+                       key: return-trailing)
+  (get-time% (string->datetime str fmt locale return-trailing: return-trailing)))
 
-(define* (string->date str optional: (fmt "~Y-~m-~d") (locale %global-locale))
-  (get-date (string->datetime str fmt locale)))
+(define* (string->date str optional: (fmt "~Y-~m-~d") (locale %global-locale)
+                       key: return-trailing)
+  (get-date (string->datetime str fmt locale return-trailing: return-trailing)))
 
 ;; Parse @var{string} as either a date, time, or date-time.
 ;; String MUST be on iso-8601 format.
@@ -903,7 +901,10 @@ Returns -1 on failure"
 
   (cond [string (contains "T") => string->datetime]
         [string (contains ":") => string->time]
-        [string (contains "-") => string->date]))
+        [string (contains "-") => string->date]
+        [else (scm-error 'misc-error "string->date/-time"
+                         "String doesn't look like a date, time or datetime: ~s"
+                         (list string) (list string))]))
 
 
 (define (parse-ics-date str)
@@ -947,7 +948,7 @@ Returns -1 on failure"
 
 
 (define (date-reader chr port)
-  (define (dt->sexp dt) (datetime->sexp dt #t) )
+  (define (dt->sexp dt) (datetime->sexp dt #t))
   (unread-char chr port)
   (let ((data (string->date/-time (symbol->string (read port)))))
     (cond [data datetime? => dt->sexp]
@@ -993,64 +994,72 @@ Returns -1 on failure"
 (define time=? time=)
 (define datetime=? datetime=)
 
-(define (date<% a b)
-  (let ((ay (year a))
-        (by (year b)))
-    (if (= ay by)
-        (let ((am (month a))
-              (bm (month b)))
-          (if (= am bm)
-              (< (day a) (day b))
-              (< am bm)))
-        (< ay by))))
 
-(define date<
-  (case-lambda
-    [() #t]
-    [(_) #t]
-    [(first second . rest)
-     (and (date<% first second)
-          (apply date< second rest))]))
+;; Extends a binary comparison procedure to work on any
+;; number of arguments.
+(define (fold-comparator <)
+  (label this
+   (case-lambda
+     [() #t]
+     [(_) #t]
+     [(first second . rest)
+      (and (< first second)
+           (apply this second rest))])))
 
-(define (date<=% a b)
-  (or (date= a b)
-      (date< a b)))
+(define date<
+  (fold-comparator
+   (lambda (a b)
+     (let ((ay (year a))
+           (by (year b)))
+       (if (= ay by)
+           (let ((am (month a))
+                 (bm (month b)))
+             (if (= am bm)
+                 (< (day a) (day b))
+                 (< am bm)))
+           (< ay by))))))
 
 (define date<=
-  (case-lambda
-    [() #t]
-    [(_) #t]
-    [(first second . rest)
-     (and (date<=% first second)
-          (apply date<= second rest))]))
-
-(define (time< a b)
-  (let ((ah (hour a))
-        (bh (hour b)))
-    (if (= ah bh)
-        (let ((am (minute a))
-              (bm (minute b)))
-          (if (= am bm)
-              (< (second a) (second b))
-              (< am bm)))
-        (< ah bh))))
-
-(define (time<= a b)
-  (or (time= a b)
-      (time< a b)))
-
-(define (datetime< a b)
-  (if (date= (get-date a) (get-date b))
-      (time< (get-time% a) (get-time% b))
-      (date< (get-date a) (get-date b))))
-
-(define (datetime<= a b)
-  (if (date= (get-date a) (get-date b))
-      (time<= (get-time% a) (get-time% b))
-      (date<= (get-date a) (get-date b))))
-
-(define (date/-time< a b)
-  (datetime< (as-datetime a) (as-datetime b)))
+  (fold-comparator
+   (lambda (a b) (or (date= a b)
+                (date< a b)))))
+
+(define time<
+  (fold-comparator
+   (lambda (a b)
+     (let ((ah (hour a))
+           (bh (hour b)))
+       (if (= ah bh)
+           (let ((am (minute a))
+                 (bm (minute b)))
+             (if (= am bm)
+                 (< (second a) (second b))
+                 (< am bm)))
+           (< ah bh))))))
+
+(define time<=
+  (fold-comparator
+   (lambda (a b)
+     (or (time= a b)
+         (time< a b)))))
+
+(define datetime<
+  (fold-comparator
+   (lambda (a b)
+     (if (date= (get-date a) (get-date b))
+         (time< (get-time% a) (get-time% b))
+         (date< (get-date a) (get-date b))))))
+
+(define datetime<=
+  (fold-comparator
+   (lambda (a b)
+     (if (date= (get-date a) (get-date b))
+         (time<= (get-time% a) (get-time% b))
+         (date<= (get-date a) (get-date b))))))
+
+(define date/-time<
+  (fold-comparator
+   (lambda (a b) (datetime< (as-datetime a) (as-datetime b)))))
 
 (define date<?        date<)
 
@@ -1382,21 +1391,25 @@ Returns -1 on failure"
 
 
 
-;; NOTE, this is only properly defined when b is greater than a.
-(define (date-difference b a)
-  (when (or (negative? (month b))
-            (negative? (day   b))
-            (negative? (month a))
-            (negative? (day   a)) )
+;; Earlier date after later date to have same semantics as subtraction
+(define (date-difference later-date earlier-date)
+  (when (date< later-date earlier-date)
+    (scm-error 'misc-error "date-difference"
+               "The earlier of the two dates must come after. later-date: ~a, earlier-date: ~a"
+               (list later-date earlier-date) #f))
+  (when (or (negative? (month later-date))
+            (negative? (day   later-date))
+            (negative? (month earlier-date))
+            (negative? (day   earlier-date)) )
     (scm-error 'misc-error "date-difference"
            "~a or ~a contains negative months or days"
-           (list a b)
+           (list earlier-date later-date)
            #f))
 
-  (date-difference% (set-> b
+  (date-difference% (set-> later-date
                            (month = (- 1))
                            (day = (- 1)))
-                    (set-> a
+                    (set-> earlier-date
                            (month = (- 1))
                            (day = (- 1)))))
 
diff --git a/module/datetime/timespec.scm b/module/datetime/timespec.scm
index 03e8dd10..46f93a61 100644
--- a/module/datetime/timespec.scm
+++ b/module/datetime/timespec.scm
@@ -92,5 +92,5 @@
            (make-timespec (string->time (string-drop string 1) "~H:~M:~S")
                           '- type)]
           [else
-           (make-timespec (string->time string "~H:~M:~S")
+           (make-timespec (string->time string "~H:~M:~S" return-trailing: #t)
                           '+ type)])))