From ee12b9a00e86b0af168d82c436afd8683dc6649b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 13 Jun 2022 04:11:15 +0200 Subject: Cleanup of zic. --- module/datetime/zic.scm | 155 +++++++++++++++++++++--------------------------- tests/test/zic.scm | 4 +- 2 files changed, 70 insertions(+), 89 deletions(-) diff --git a/module/datetime/zic.scm b/module/datetime/zic.scm index e5a0706e..588a742d 100644 --- a/module/datetime/zic.scm +++ b/module/datetime/zic.scm @@ -17,6 +17,7 @@ :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) @@ -197,10 +198,6 @@ (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)) @@ -211,7 +208,7 @@ (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 @@ -225,53 +222,45 @@ done) #f)))] [else - (let ((type args (car+cdr tokens))) - (case (string->symbol type) - - [(Rule) - (let ((name from to type in on at save letters (apply values 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 (car args)) - (name (cadr 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 @@ -333,20 +322,18 @@ (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 (apply values 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) @@ -381,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 (apply values (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) diff --git a/tests/test/zic.scm b/tests/test/zic.scm index 2a4e30ce..99247cf1 100644 --- a/tests/test/zic.scm +++ b/tests/test/zic.scm @@ -294,8 +294,8 @@ Zone America/Menominee -5:00 - EST 1973 Apr 29 2:00 ""))) (test-equal "Crash on counting backwards from date" - '(warning "Counting backward for RRULES unsupported" ()) - (catch 'warning + '(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) -- cgit v1.2.3