diff options
Diffstat (limited to '')
| -rw-r--r-- | module/datetime.scm | 39 | ||||
| -rw-r--r-- | module/datetime/timespec.scm | 14 | ||||
| -rw-r--r-- | module/datetime/zic.scm | 32 |
3 files changed, 53 insertions, 32 deletions
diff --git a/module/datetime.scm b/module/datetime.scm index 3b03bf53..478fc479 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -10,12 +10,10 @@ :use-module (srfi srfi-9 gnu) :use-module ((hnh util) - :select (vector-last define*-public set! -> swap case* set + :select (vector-last define*-public set! -> ->> swap case* set span-upto let* set->)) :use-module (srfi srfi-41) - :use-module ((srfi srfi-41 util) - :select (with-streams)) :use-module (ice-9 i18n) :use-module (ice-9 format) :use-module (ice-9 regex) @@ -67,6 +65,11 @@ (year year) (month month) (day day)) (define*-public (date key: (year 0) (month 0) (day 0)) + (unless (and (integer? year) (integer? month) (integer? day)) + (scm-error 'wrong-type-arg "date" + "Year, month, and day must all be integers. ~s, ~s, ~s" + (list year month day) + #f)) (make-date year month day)) (set-record-type-printer! @@ -74,7 +77,7 @@ (lambda (r p) (catch 'misc-error (lambda () (display (date->string r "#~Y-~m-~d") p)) - (lambda (err _ fmt args . rest) + (lambda (err proc fmt args data) (format p "#<<date> BAD year=~s month=~s day=~s>" (year r) (month r) (day r)))))) @@ -535,14 +538,15 @@ (iota (modulo (- (* 7 5) month-len month-start) 7) 1))))) +;; The amount of days in the given interval, both end pointts inclusive (define-public (days-in-interval start-date end-date) (let ((diff (date-difference (date+ end-date (date day: 1)) start-date))) - (with-streams - (fold + (day diff) - (map days-in-month - (take (+ (month diff) - (* 12 (year diff))) - (month-stream start-date))))))) + (->> (month-stream start-date) + (stream-take (+ (month diff) + (* 12 (year diff)))) + (stream-map days-in-month) + (stream-fold + (day diff))))) + ;; Day from start of the year, so 1 feb would be day 32. ;; Also known as Julian day. @@ -676,6 +680,11 @@ Returns -1 on failure" [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) @@ -736,11 +745,15 @@ Returns -1 on failure" (let* ((head post (cond ((null? (cddr fmt)) (values str '())) ((eqv? #\~ (caddr fmt)) (cond ((null? (cdddr fmt)) - (error "Unexpected ~ at end of 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 (error "Can't have format specifier directly after month by name")))) + (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))))) (loop post @@ -1125,7 +1138,7 @@ Returns -1 on failure" ;; overflow is number of days above ;; time x time → time x int -(define-public (time+% base change) +(define (time+% base change) ;; while (day base) > (days-in-month base) ;; month++; days -= (days-in-month base) diff --git a/module/datetime/timespec.scm b/module/datetime/timespec.scm index ea29a423..099634b6 100644 --- a/module/datetime/timespec.scm +++ b/module/datetime/timespec.scm @@ -65,15 +65,6 @@ specs)) -(define (parse-time string) - (apply (lambda* (hour optional: (minute "0") (second "0")) - (time hour: (string->number hour) - minute: (string->number minute) - ;; discard sub-seconds - second: (string->number (car (string-split second #\.))))) - (string-split string #\:))) - - (define*-public (parse-time-spec string optional: (suffixes '(#\s #\w #\u #\g #\z))) (let* ((type string @@ -82,11 +73,12 @@ (values (string-ref string idx) (substring string 0 idx)))] [else (values #\w string)]))) + ;; Note that string->time allows a longer format than the input (cond [(string=? "-" string) (make-timespec (time) '+ type)] [(string-prefix? "-" string) - (make-timespec (parse-time (string-drop string 1)) + (make-timespec (string->time (string-drop string 1) "~H:~M:~S") '- type)] [else - (make-timespec (parse-time string) + (make-timespec (string->time string "~H:~M:~S") '+ type)]))) diff --git a/module/datetime/zic.scm b/module/datetime/zic.scm index 0362ec99..e2600d4f 100644 --- a/module/datetime/zic.scm +++ b/module/datetime/zic.scm @@ -92,14 +92,14 @@ ;; @end example (define-public (get-zone zoneinfo name) (or (hash-ref (zoneinfo-zones zoneinfo) name) - (error "No zone ~a" name))) + (scm-error 'misc-error "get-zone" "No zone ~a" (list name) #f))) ;; @example ;; (get-rule zoneinfo 'EU) ;; @end example (define-public (get-rule zoneinfo name) (or (hashq-ref (zoneinfo-rules zoneinfo) name) - (error "No rule ~a" name))) + (scm-error 'misc-error "get-rule" "No rule ~a" (list name) #f))) @@ -119,7 +119,9 @@ [(string-prefix? name "October") 10] [(string-prefix? name "November") 11] [(string-prefix? name "December") 12] - [else (error "Unknown month" name)])) + [else (scm-error 'misc-error "month-name->number" + "Unknown month ~s" (list name) + #f)])) (define (string->weekday name) @@ -131,7 +133,9 @@ [(string-prefix? name "Friday") fri] [(string-prefix? name "Saturday") sat] [(string-prefix? name "Sunday") sun] - [else (error "Unknown week day" name)])) + [else (scm-error 'misc-error "string->weekday" + "Unknown week day ~s" + (list name) #f)])) (define (parse-from str) @@ -259,8 +263,10 @@ ;; NOTE an earlier version of the code the parsers for those. ;; They were removed since they were unused, uneeded, and was ;; technical dept. - (error (_ "Invalid key ~a. Note that leap seconds and -expries rules aren't yet implemented.") type)] + (scm-error 'misc-error "parse-zic-file" + (_ "Invalid key ~s. Note that leap seconds and expries rules aren't yet implemented.") + (list type) + #f)] ))])))))) @@ -357,7 +363,9 @@ expries rules aren't yet implemented.") type)] until: (let ((to (rule-to rule))) (case to ((maximum) #f) - ((minimum) (error (_ "Check your input"))) + ((minimum) (scm-error 'misc-error "rule->rrule" + (_ "Check your input") + #f #f)) ((only) (datetime date: (date year: (rule-from rule) month: 1 day: 1))) @@ -403,4 +411,12 @@ expries rules aren't yet implemented.") type)] (warning (_ "%z not yet implemented")) fmt-string] - [else (error (_ "Invalid format char"))]))) + [else (scm-error 'misc-error "zone-format" + ;; first slot is the errornous character, + ;; second is the whole string, third is the index + ;; of the faulty character. + (_ "Invalid format char ~s in ~s at position ~a") + (list (string-index fmt-string (1+ idx)) + fmt-string + (1+ idx)) + #f)]))) |