diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-06-12 21:09:35 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-06-13 04:11:35 +0200 |
commit | 73a4bfc3d8e9bb5365e33a11a6ad3b8340d5195b (patch) | |
tree | e52324edc63a240e5c0b88081c325f789168a4c5 /module/datetime | |
parent | Document timespec and zic. (diff) | |
download | calp-73a4bfc3d8e9bb5365e33a11a6ad3b8340d5195b.tar.gz calp-73a4bfc3d8e9bb5365e33a11a6ad3b8340d5195b.tar.xz |
Remove custom let*.
While it was nice, the most important part was the multi-valued let from
srfi-71 (which is implemented in srfi-71)). The minor pattern matching
structures could often be replaced with car+cdr, or a propper match.
Diffstat (limited to '')
-rw-r--r-- | module/datetime.scm | 51 | ||||
-rw-r--r-- | module/datetime/timespec.scm | 5 | ||||
-rw-r--r-- | module/datetime/zic.scm | 40 |
3 files changed, 50 insertions, 46 deletions
diff --git a/module/datetime.scm b/module/datetime.scm index 5d953cad..48f5042d 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -8,10 +8,11 @@ :use-module (srfi srfi-1) :use-module (srfi srfi-9) :use-module (srfi srfi-9 gnu) + :use-module (srfi srfi-71) :use-module ((hnh util) :select (vector-last define*-public set! -> ->> swap case* set - span-upto let* set->)) + span-upto set->)) :use-module (srfi srfi-41) :use-module (ice-9 i18n) @@ -334,8 +335,8 @@ ;; 0 indexed, starting at sunday. (define-public (week-day date) - (let* ((J K (floor/ (year date) 100)) - (m (month date))) + (let ((J K (floor/ (year date) 100)) + (m (month date))) (if (memv m '(1 2)) (zeller J (1- K) (+ m 12) (day date)) (zeller J K (month date) (day date))))) @@ -559,7 +560,7 @@ (let ((date-diff (cond [start-date - (let* ((end-date (date+ start-date (get-date dt)))) + (let ((end-date (date+ start-date (get-date dt)))) (1- (days-in-interval start-date end-date))) ] [(or (not (zero? (month (get-date dt)))) (not (zero? (year (get-date dt))))) @@ -735,20 +736,20 @@ 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 (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))))) (loop post (cddr fmt) (as-dt (set (month date) @@ -1156,7 +1157,7 @@ Returns -1 on failure" (define hour-almost-fixed (set (hour minute-fixed) = (+ (hour change)))) (if (<= 24 (hour hour-almost-fixed)) - (let* ((div remainder (floor/ (hour hour-almost-fixed) 24))) + (let ((div remainder (floor/ (hour hour-almost-fixed) 24))) (values (set (hour hour-almost-fixed) remainder) div)) (values hour-almost-fixed 0))) @@ -1164,7 +1165,7 @@ Returns -1 on failure" (define-public (time+ base . rest) (let ((sum 0)) (let ((time (fold (lambda (next done) - (let* ((next-time rem (time+% done next))) + (let ((next-time rem (time+% done next))) (set! sum = (+ rem)) next-time)) base rest))) @@ -1214,7 +1215,7 @@ Returns -1 on failure" (define-public (time- base . rest) (let ((sum 0)) (let ((time (fold (lambda (next done) - (let* ((next-time rem (time-% done next))) + (let ((next-time rem (time-% done next))) (set! sum = (+ rem)) next-time)) base rest))) @@ -1225,7 +1226,7 @@ Returns -1 on failure" (define-public (datetime+ base change) - (let* ((time overflow (time+ (get-time% base) (get-time% change)))) + (let ((time overflow (time+ (get-time% base) (get-time% change)))) (datetime date: (date+ (get-date base) (get-date change) (date day: overflow)) @@ -1234,7 +1235,7 @@ Returns -1 on failure" ))) (define-public (datetime- base change) - (let* ((time underflow (time- (get-time% base) (get-time% change)))) + (let ((time underflow (time- (get-time% base) (get-time% change)))) (datetime date: (date- (get-date base) (get-date change) (date day: underflow)) @@ -1308,8 +1309,8 @@ Returns -1 on failure" ;; NOTE, this is only properly defined when end is greater than start. (define-public (datetime-difference end start) ;; NOTE Makes both start and end datetimes in the current local time. - (let* ((fixed-time overflow (time- (get-time% end) - (get-time% start)))) + (let ((fixed-time overflow (time- (get-time% end) + (get-time% start)))) (datetime date: (date-difference (date- (get-date end) (date day: overflow)) (get-date start)) diff --git a/module/datetime/timespec.scm b/module/datetime/timespec.scm index 49a2d90e..9bfcc402 100644 --- a/module/datetime/timespec.scm +++ b/module/datetime/timespec.scm @@ -6,10 +6,11 @@ (define-module (datetime timespec) :export (make-timespec timespec? timespec-time timespec-sign timespec-type) - :use-module ((hnh util) :select (set define*-public unless let*)) + :use-module ((hnh util) :select (set define*-public unless)) :use-module ((hnh util exceptions) :select (warning)) :use-module (datetime) :use-module (srfi srfi-1) + :use-module (srfi srfi-71) :use-module (srfi srfi-9 gnu) :use-module (calp translation) ) @@ -71,7 +72,7 @@ (define*-public (parse-time-spec string optional: (suffixes '(#\s #\w #\u #\g #\z))) - (let* ((type string + (let ((type string (cond [(string-rindex string (list->char-set suffixes)) => (lambda (idx) (values (string-ref string idx) diff --git a/module/datetime/zic.scm b/module/datetime/zic.scm index e8e73977..e5a0706e 100644 --- a/module/datetime/zic.scm +++ b/module/datetime/zic.scm @@ -12,7 +12,7 @@ ;;; 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) @@ -20,6 +20,7 @@ :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) @@ -175,17 +176,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)))) @@ -211,11 +211,12 @@ (let ((str (read-line port))) (if (eof-object? str) done - (let* ((tokens (tokenize (strip-comments str)))) + (let ((tokens (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) @@ -224,11 +225,11 @@ done) #f)))] [else - (let* (((type . args) tokens)) + (let ((type args (car+cdr tokens))) (case (string->symbol type) [(Rule) - (let* (((name from to type in on at save letters) args)) + (let ((name from to type in on at save letters (apply values args))) (let ((parsed-from (parse-from from))) (loop (cons @@ -257,7 +258,8 @@ #f)))] [(Link) - (let* (((target name) args)) + (let ((target (car args)) + (name (cadr args))) (loop (cons (make-link name target) done) #f))] @@ -339,7 +341,7 @@ (lambda (d) (eqv? (cadr on) (week-day d))) (set (day d) (days-in-month d)))] [else ; < | > - (let* (((<> wday base-day) on)) + (let ((<> wday base-day (apply values on))) (iterate (lambda (d) ((if (eq? '< <>) date- date+) d (date day: 1))) @@ -389,7 +391,7 @@ [else ;; Sun<=25 ;; Sun>=8 - (let* (((<> wday base-day) (rule-on rule))) + (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 |