diff options
Diffstat (limited to 'module/datetime/zic.scm')
| -rw-r--r-- | module/datetime/zic.scm | 197 |
1 files changed, 91 insertions, 106 deletions
diff --git a/module/datetime/zic.scm b/module/datetime/zic.scm index e2600d4f..588a742d 100644 --- a/module/datetime/zic.scm +++ b/module/datetime/zic.scm @@ -12,20 +12,23 @@ ;;; Code: (define-module (datetime zic) :use-module ((hnh util) - :select (awhen group set when sort* iterate group-by let*)) + :select (awhen group set when sort* iterate group-by)) :use-module ((hnh util exceptions) :select (warning)) :use-module (datetime) :use-module (datetime timespec) :use-module ((ice-9 rdelim) :select (read-line)) + :use-module (ice-9 match) :use-module (srfi srfi-1) :use-module (srfi srfi-9) :use-module (srfi srfi-9 gnu) + :use-module (srfi srfi-71) :use-module ((vcomponent recurrence internal) :select (byday make-recur-rule bymonthday)) :use-module (calp translation) ) +;; returns a <zoneinfo> object (define-public (read-zoneinfo ports-or-filenames) (parsed-zic->zoneinfo (concatenate @@ -174,17 +177,16 @@ [(#\u #\g #\z) "UTC"])))) -(define (parse-zone . args) - (let* (((stdoff rule format . until) args)) - (make-zone-entry - (parse-time-spec stdoff) ; stdoff - (cond [(string=? "-" rule) #f] ; rule - [(char-alphabetic? (string-ref rule 0)) - (string->symbol rule)] - [else (parse-time-spec rule)]) - format ; format - (if (null? until) ; until - #f (apply parse-until until))))) +(define (parse-zone stdoff rule format . until) + (make-zone-entry + (parse-time-spec stdoff) ; stdoff + (cond [(string=? "-" rule) #f] ; rule + [(char-alphabetic? (string-ref rule 0)) + (string->symbol rule)] + [else (parse-time-spec rule)]) + format ; format + (if (null? until) ; until + #f (apply parse-until until)))) @@ -196,10 +198,7 @@ (lambda (idx) (string-take str idx))) str)) -;; tokenize a single line -(define (tokenize line) - (remove string-null? (string-split line char-set:whitespace))) - +;; Returns a list of zones, rules, and links (define (parse-zic-file port) (let loop ((done '()) (continued #f)) ;; NOTE @@ -209,11 +208,12 @@ (let ((str (read-line port))) (if (eof-object? str) done - (let* ((tokens (tokenize (strip-comments str)))) + (let ((tokens (string-tokenize (strip-comments str)))) (cond [(null? tokens) (loop done continued)] [continued ;; Zone-continuation - (let* (((name entries) continued) + (let* ((name (car continued)) + (entries (cadr continued)) (zone-entry (apply parse-zone tokens)) (zone-entries (cons zone-entry entries))) (if (zone-entry-until zone-entry) @@ -222,54 +222,49 @@ done) #f)))] [else - (let* (((type . args) tokens)) - (case (string->symbol type) - - [(Rule) - (let* (((name from to type in on at save letters) args)) - (let ((parsed-from (parse-from from))) - (loop - (cons - (make-rule (string->symbol name) ; name - parsed-from ; from - ;; to - (if (string-prefix? to "only") - ;; parsed-from - 'only - (parse-from to)) - (month-name->number in) ; in - (parse-day-spec on) ; on - (parse-time-spec at) ; at - (parse-time-spec save '(#\s #\d)) ; save - (if (string= letters "-") ; letters - "" letters)) - done) #f)))] - - [(Zone) - (let* ((zone-entry (apply parse-zone (cdr args))) - (zones (list zone-entry))) - (if (zone-entry-until zone-entry) - (loop done (list (car args) zones)) - (loop (cons (make-zone (car args) (reverse zones)) - done) - #f)))] - - [(Link) - (let* (((target name) args)) - (loop (cons (make-link name target) - done) #f))] - - [else - ;; NOTE an earlier version of the code the parsers for those. - ;; They were removed since they were unused, uneeded, and was - ;; technical dept. - (scm-error 'misc-error "parse-zic-file" - (_ "Invalid key ~s. Note that leap seconds and expries rules aren't yet implemented.") - (list type) - #f)] - ))])))))) - - + (match tokens + (("Rule" name from to type in on at save letters) + (let ((parsed-from (parse-from from))) + (loop + (cons + (make-rule (string->symbol name) ; name + parsed-from ; from + ;; to + (if (string-prefix? to "only") + ;; parsed-from + 'only + (parse-from to)) + (month-name->number in) ; in + (parse-day-spec on) ; on + (parse-time-spec at) ; at + (parse-time-spec save '(#\s #\d)) ; save + (if (string= letters "-") ; letters + "" letters)) + done) #f))) + (("Zone" name args ...) + (let* ((zone-entry (apply parse-zone args)) + (zones (list zone-entry))) + (if (zone-entry-until zone-entry) + (loop done (list name zones)) + (loop (cons (make-zone name (reverse zones)) + done) + #f)))) + + (("Link" target name) + (loop (cons (make-link name target) + done) #f)) + (_ + ;; NOTE an earlier version of the code the parsers for those. + ;; They were removed since they were unused, uneeded, and was + ;; technical dept. + (scm-error 'misc-error "parse-zic-file" + (_ "Invalid key ~s. Note that leap seconds and expries rules aren't yet implemented.") + (list type) + #f)))])))))) + + +;; Takes a list of zones, rules, and links (as provided by parse-zic-file), and +;; returns a zoneinfo object (define (parsed-zic->zoneinfo lst) (define zones (make-hash-table)) @@ -311,6 +306,7 @@ +;; The first time this rule was/will be applied (define-public (rule->dtstart rule) ;; NOTE 'minimum and 'maximum represent the begining and end of time. ;; since I don't have a way to represent those ideas I just set a very @@ -326,24 +322,22 @@ (define dt (datetime date: - (let ((on (rule-on rule))) - (cond [(number? on) - (set (day d) on)] - [(eq? 'last (car on)) - (iterate (lambda (d) (date- d (date day: 1))) - (lambda (d) (eqv? (cadr on) (week-day d))) - (set (day d) (days-in-month d)))] - [else ; < | > - (let* (((<> wday base-day) on)) - (iterate (lambda (d) ((if (eq? '< <>) - date- date+) - d (date day: 1))) - (lambda (d) (eqv? wday (week-day d))) - (set (day d) base-day)))])) + (match (rule-on rule) + ((? number? on) (set (day d) on)) + (('last n) + (iterate (lambda (d) (date- d (date day: 1))) + (lambda (d) (eqv? n (week-day d))) + (set (day d) (days-in-month d)))) + (((? (lambda (x) (memv x '(< >))) <>) wday base-day) + (iterate (lambda (d) ((if (eq? '< <>) + date- date+) + d (date day: 1))) + (lambda (d) (eqv? wday (week-day d))) + (set (day d) base-day)))) tz: (case (timespec-type (rule-at rule)) ((#\w) #f) ((#\s) (warning (_ "what even is \"Standard time\"‽")) #f) - ((#\u #\g #\z) 'UTC)))) + ((#\u #\g #\z) "UTC")))) (let ((timespec (rule-at rule))) ((case (timespec-sign timespec) @@ -366,9 +360,6 @@ ((minimum) (scm-error 'misc-error "rule->rrule" (_ "Check your input") #f #f)) - ((only) - (datetime - date: (date year: (rule-from rule) month: 1 day: 1))) (else ;; NOTE I possibly need to check the start of ;; the next rule to know when this rule really @@ -377,27 +368,21 @@ date: (date year: to month: 1 day: 1)))))))) - (cond [(number? (rule-on rule)) - (set (bymonthday base) - (list (rule-on rule)))] - - [(eqv? 'last (car (rule-on rule))) - (set (byday base) (list (cons -1 (cadr (rule-on rule)))))] - - [else - ;; Sun<=25 - ;; Sun>=8 - (let* (((<> wday base-day) (rule-on rule))) - (when (eq? '< <>) - (warning (_ "Counting backward for RRULES unsupported"))) - ;; NOTE this only realy works when base-day = 7n + 1, n ∈ N - ;; something like Sun>=5 is hard to fix, since we can only - ;; say which sunday in the month we want (first sunday, - ;; second sunday, ...). - (set (byday base) - (list - (cons (ceiling-quotient base-day 7) - wday))))])))) + (match (rule-on rule) + ((? number? d) (set (bymonthday base) (list d))) + (('last d) (set (byday base) (list (cons -1 d)))) + (('< wday base-day) (scm-error 'misc-error "rule->rrule" (_ "Counting backward for RRULES unsupported") #f #f)) + (('> wday base-day) + ;; Sun<=25 + ;; Sun>=8 + ;; NOTE this only realy works when base-day = 7n + 1, n ∈ N + ;; something like Sun>=5 is hard to fix, since we can only + ;; say which sunday in the month we want (first sunday, + ;; second sunday, ...). + (set (byday base) + (list + (cons (ceiling-quotient base-day 7) + wday)))))))) ;; special case of format which works with %s and %z (define-public (zone-format fmt-string arg) @@ -416,7 +401,7 @@ ;; 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)) + (list (string-ref fmt-string (1+ idx)) fmt-string (1+ idx)) #f)]))) |