diff options
49 files changed, 916 insertions, 441 deletions
@@ -26,6 +26,11 @@ GUILE_C_FLAGS = -Lmodule \ PO_FILES = $(shell find po -type f -name \*.po -and -not -name new.po -and -not -name .\*) LOCALIZATIONS = $(PO_FILES:po/%.po=localization/%/LC_MESSAGES/calp.mo) +# Limit test to these files +LIMIT_FILES=$(LIMIT:%=--only %) +# Skip these files when testing +SKIP=--skip $(PWD)/tests/test/web-server.scm + all: go_files README static $(LOCALIZATIONS) $(MAKE) -C doc/ref @@ -72,7 +77,7 @@ README: README.in ./main text < README.in | sed "s/<<today>>/`date -I`/" > README lcov.info: $(GO_FILES) - env DEBUG=0 tests/run-tests.scm --coverage=$@ + env DEBUG=0 tests/run-tests.scm --coverage=$@ $(if $(VERBOSE),--verbose) $(SKIP) $(LIMIT_FILES) test: coverage @@ -85,4 +90,4 @@ coverage: lcov.info genhtml $(GENHTML_FLAGS) --output-directory $@ $< check: - tests/run-tests.scm $(if $(VERBOSE),--verbose) --skip $(PWD)/tests/test/web-server.scm + tests/run-tests.scm $(if $(VERBOSE),--verbose) $(SKIP) $(LIMIT_FILES) diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 2594b9e1..b43847e2 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -2,6 +2,7 @@ @chapter Guile @include guile/datetime.texi +@include guile/zic.texi @include guile/srfi-41.texi @include guile/util.texi @include guile/util-path.texi diff --git a/doc/ref/guile/util.texi b/doc/ref/guile/util.texi index 3f37491d..d7ed0785 100644 --- a/doc/ref/guile/util.texi +++ b/doc/ref/guile/util.texi @@ -46,18 +46,6 @@ If keys are a list, an match-lambda is used instead. @xref{Pattern Matching,,,guile} @end defmac -@defmac let* forms body ... -Replace let* with a version that can bind from lists. -Also supports SRFI-71 (extended let-syntax for multiple values) -@lisp -(let* ([a b (values 1 2)] ; @r{SRFI-71} - [(c d) '(3 4)] ; @r{Let-list (mine)} - [(a b . c) (cons* 1 2 3)] ; @r{Improper list matching (mine)} - [e 5]) ; @r{Regular} - (list e d c b a)) -;; => (5 4 3 2 1) -@end lisp -@end defmac @defmac print-and-return expr Prints @var{expr}, and then returns it. diff --git a/doc/ref/guile/zic.texi b/doc/ref/guile/zic.texi new file mode 100644 index 00000000..5af36fd3 --- /dev/null +++ b/doc/ref/guile/zic.texi @@ -0,0 +1,135 @@ +@node Timespec +@section Timespec + +Specifiers of times, including their offset from some origin, and what +kind they are. + +Refer to zic(8) and the AT field of rules. + +@defun make-timespec time sign type + +@defun timespec? x +@end defun + +@defun timspec-time timespec +Should be a time object. +@end defun + +@defun timspec-sign timespec +@code{'+} or @code{'-} +@end defun + +@defun timspec-type timespec +char +@end defun +@end defun + +@defun timespec-zero +The ``empty'' timespec. +@end defun + +@defun timespec-add specs ... +@end defun + +@defun parse-time-spec string [suffixes='(#\s #\w #\u #\g #\z)] +More or less follows the pattern @code{-?[0-9]@{2@}(:[0-9]@{2@})@{0,2@}[swugz]}. +@end defun + + +@node Zone Info Compiler +@section Zone Info Compiler + +@defun read-zoneinfo ports-or-filenames +Takes a (possibly mixed) list of ports and filenames, and calls +@code{parse-zic-file} on each of them. +@end defun + +@c @defun parse-zic-file port +@c @end defun + +@defun zoneinfo? +@end defun + +@defun get-zone zoneinfo name +Takes a zoneinfo object, and a name as a string (probably something +like ``Europe/Stockholm''), and returns a list of zone-entries. +@end defun + +@defun get-rule zoneinfo name +Gets a list of rule objects, sorted in chronological order. +@var{name} is a symbol. +@end defun + +@defun rule->dtstart rule +Returns the first time a given rule happens. +@end defun + +@defun rule->rrule rule +Converts a given zoneinfo rule into a recurrence rule, of all times +that change occurs. +@end defun + +@defun zone-format fmt-string arg +A special case of format, which handles the format strings containing +``%s'' and ``%z''. +@end defun + + + +@defun make-rule name from to in on at save letters + +See zic(8). + +@defun rule? +@end defun + +@defun rule-name +@end defun + +@defun rule-from +@end defun + +@defun rule-to +@end defun + +@c @defun rule-type +@c @end defun + +@defun rule-in +@end defun + +@defun rule-on +@end defun + +@defun rule-at +@end defun + +@defun rule-save +@end defun + +@defun rule-letters +@end defun + +@end defun + + +@defun make-zone-entry stdoff rule format until + +See zic(8). + +@defun zone-entry? +@end defun + +@defun zone-entry-stdoff +@end defun + +@defun zone-entry-rule +@end defun + +@defun zone-entry-format +@end defun + +@defun zone-entry-until +@end defun +@end defun + diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm index b7702de1..069b9a28 100644 --- a/module/calp/html/vcomponent.scm +++ b/module/calp/html/vcomponent.scm @@ -234,7 +234,8 @@ ;; Single event in side bar (text objects) (define-public (fmt-day day) - (let* (((date . events) day)) + (let ((date (car day)) + (events (cdr day))) `(section (@ (class "text-day")) (header (h2 ,(let ((s (date->string date ;; Header for sidebar day @@ -270,10 +271,10 @@ `(style ,(lambda () (format #t "~:{ [data-calendar=\"~a\"] { --color: ~a; --complement: ~a }~%~}" (map (lambda (c) - (let* ((name (base64encode (prop c 'NAME))) - (bg-color (prop c 'COLOR)) - (fg-color (and=> (prop c 'COLOR) - calculate-fg-color))) + (let ((name (base64encode (prop c 'NAME))) + (bg-color (prop c 'COLOR)) + (fg-color (and=> (prop c 'COLOR) + calculate-fg-color))) (list name (or bg-color 'white) (or fg-color 'black)))) calendars))))) diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index dd94dc16..a6ebdfba 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -22,6 +22,7 @@ :use-module (srfi srfi-26) :use-module (srfi srfi-41) :use-module (srfi srfi-41 util) + :use-module (srfi srfi-71) :use-module ((vcomponent recurrence) :select (repeating? generate-recurrence-set)) :use-module ((vcomponent util group) diff --git a/module/calp/html/view/calendar/month.scm b/module/calp/html/view/calendar/month.scm index 205d6049..1c162aaa 100644 --- a/module/calp/html/view/calendar/month.scm +++ b/module/calp/html/view/calendar/month.scm @@ -7,6 +7,7 @@ :use-module (calp html view calendar shared) :use-module (calp html config) :use-module (vcomponent) + :use-module (ice-9 match) :use-module ((vcomponent datetime) :select (really-long-event? events-between)) @@ -47,15 +48,15 @@ long-event-groups)))) ,@(map (lambda (d) `(div (@ (class "thead")) ,(string-titlecase (week-day-name d)))) (weekday-list)) - ,@(map (lambda (group i) - (let* (((s e . events) group)) - `(div (@ (class "cal-cell longevents event-container") - (style "grid-area: long " ,i ";" - "grid-column: 1 / span 7;") - (data-start ,(date->string s)) - (data-end ,(date->string (add-day e)))) - ,@(lay-out-long-events - s e events)))) + ,@(map (match-lambda* + (((s e events ...) i) + `(div (@ (class "cal-cell longevents event-container") + (style "grid-area: long " ,i ";" + "grid-column: 1 / span 7;") + (data-start ,(date->string s)) + (data-end ,(date->string (add-day e)))) + ,@(lay-out-long-events + s e events)))) long-event-groups (iota (length long-event-groups) 1)) diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm index b68184f9..ed3f00ec 100644 --- a/module/calp/html/view/calendar/week.scm +++ b/module/calp/html/view/calendar/week.scm @@ -2,6 +2,7 @@ :use-module (hnh util) :use-module (srfi srfi-1) :use-module (srfi srfi-41) + :use-module (srfi srfi-71) :use-module (rnrs records syntactic) :use-module (datetime) :use-module (calp html view calendar shared) @@ -122,7 +123,7 @@ ;; Lay out complete day (graphical) ;; (date . (events)) -> sxml (define (lay-out-day day) - (let* (((day-date . events) day) + (let* ((day-date events (car+cdr day)) (time-obj (datetime date: day-date)) (short-events (stream->list events)) #; diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index 762681d9..3d90cc04 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -73,7 +73,7 @@ path-join))) ,(_ "Return up")))) ,@(map (lambda (k) - (let* ((stat (lstat (path-append prefix dir k)))) + (let ((stat (lstat (path-append prefix dir k)))) `(tr (td ,(case (stat:type stat) [(directory) "📁"] [(regular) "📰"] @@ -108,7 +108,7 @@ (lambda (search-term) (aif (hash-ref query-pages search-term) it - (let* ((q (prepare-query + (let ((q (prepare-query (build-query-proc search-term) (get-event-set global-event-object)))) (hash-set! query-pages search-term q) @@ -150,7 +150,7 @@ ;; TODO any exception in this causes the whole page to fail ;; It would be much better if most of the page could still make it. (GET "/week/:start-date.html" (start-date html) - (let* ((start-date (start-of-week (parse-iso-date start-date)))) + (let ((start-date (start-of-week (parse-iso-date start-date)))) (return `((content-type ,(content-type html))) (with-output-to-string (lambda () @@ -166,7 +166,7 @@ ))))))) (GET "/month/:start-date.html" (start-date html) - (let* ((start-date (start-of-month (parse-iso-date start-date)))) + (let ((start-date (start-of-month (parse-iso-date start-date)))) (return `((content-type ,(content-type html))) (with-output-to-string (lambda () diff --git a/module/calp/terminal.scm b/module/calp/terminal.scm index d91dc584..a0fafd11 100644 --- a/module/calp/terminal.scm +++ b/module/calp/terminal.scm @@ -174,8 +174,8 @@ (- height 8 5 (length events) 5))))))) (define (get-line prompt) - (let* ((attr (make-termios)) - (input-string #f)) + (let ((attr (make-termios)) + (input-string #f)) (tcgetattr! attr) (set! (lflag attr) (logior ECHO (lflag attr))) (tcsetattr! attr) 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 099634b6..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) ) @@ -50,8 +51,10 @@ (time-b (timespec-time spec))) (if (time< time-a time-b) (make-timespec (time- time-b time-a) + '- (timespec-type done)) + (make-timespec (time- time-a time-b) '+ (timespec-type done)) - (set (timespec-time done) (time- time-b))))] + ))] ;; + - [(and (eq? '+ (timespec-sign done)) (eq? '- (timespec-sign spec))) @@ -60,14 +63,16 @@ (if (time< time-a time-b) (make-timespec (time- time-b time-a) '- (timespec-type done)) - (set (timespec-time done) (time+ time-b))))])) + (make-timespec (time- time-a time-b) + '+ (timespec-type done)) + ))])) (timespec-zero) specs)) (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 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)]))) diff --git a/module/glob.scm b/module/glob.scm index 82489565..64f97690 100644 --- a/module/glob.scm +++ b/module/glob.scm @@ -26,10 +26,10 @@ (define (glob str) (let ((bv (make-bytevector 100))) - (let* ((globret (glob% (string->pointer str) - glob-flags - (procedure->pointer int glob-err (list '* int)) - (bytevector->pointer bv)))) + (let ((globret (glob% (string->pointer str) + glob-flags + (procedure->pointer int glob-err (list '* int)) + (bytevector->pointer bv)))) (unless (zero? globret) (scm-error 'misc-error "glob" "Globret errror ~a" diff --git a/module/hnh/util.scm b/module/hnh/util.scm index 49fd6ebb..f95a24bf 100644 --- a/module/hnh/util.scm +++ b/module/hnh/util.scm @@ -1,5 +1,6 @@ (define-module (hnh util) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) #:use-module (srfi srfi-88) ; postfix keywords #:use-module ((ice-9 optargs) #:select (define*-public)) #:use-module ((sxml fold) #:select (fold-values)) @@ -15,7 +16,7 @@ begin1 catch* ) - #:replace (let* set! define-syntax + #:replace (set! define-syntax when unless)) ((@ (guile) define-syntax) define-syntax @@ -78,65 +79,6 @@ -;; Replace let* with a version that can bind from lists. -;; Also supports SRFI-71 (extended let-syntax for multiple values) -;; @lisp -;; (let* ([a b (values 1 2)] ; @r{SRFI-71} -;; [(c d) '(3 4)] ; @r{Let-list (mine)} -;; [(a b . c) (cons* 1 2 3)] ; @r{Improper list matching (mine)} -;; [e 5]) ; @r{Regular} -;; (list e d c b a)) -;; ;; => (5 4 3 2 1) -;; @end lisp -(define-syntax let* - (syntax-rules () - - ;; Base case - [(_ () body ...) - (begin body ...)] - - ;; (let (((a b) '(1 2))) (list b a)) => (2 1) - [(_ (((k ... . (k*)) list-value) rest ...) - body ...) - (apply (lambda (k ... k*) - (let* (rest ...) - body ...)) - list-value)] - - ;; Improper list matching - ;; (let* (((a b . c) (cons* 1 2 3))) (list a c)) ; => (1 3) - [(_ (((k1 k ... . k*) imp-list) rest ...) - body ...) - (apply (lambda (k1 k ... k*) - (let* (rest ...) - body ...)) - (improper->proper-list - imp-list (length (quote (k1 k ...)))))] - - ;; "Regular" case - [(_ ((k value) rest ...) body ...) - (let ((k value)) - (let* (rest ...) - body ...))] - - ;; SRFI-71 let-values - [(_ ((k k* ... values) rest ...) body ...) - (call-with-values (lambda () values) - (lambda (k k* ...) - (let* (rest ...) - body ...)))] - - ;; Declare variable without a value (actuall #f). - ;; Useful for inner mutation. - [(_ (v rest ...) body ...) - (let* ((v #f) rest ...) body ...)] - )) - -(define (improper->proper-list lst len) - (let* ((head tail (split-at lst len))) - (append head (list tail)))) - - (define-syntax-rule (begin1 first rest ...) (call-with-values (lambda () first) (lambda returned @@ -337,7 +279,7 @@ ;; @end example (define-public (assq-merge a b) (fold (lambda (entry alist) - (let* (((k . v) entry) + (let* ((k v (car+cdr entry)) (o (assq-ref alist k))) (assq-set! alist k (append v (or o '()))))) (copy-tree a) b)) @@ -415,7 +357,7 @@ (define-public (cross-product . args) (if (null? args) '() - (let* ((last rest (car+cdr (reverse args)))) + (let ((last rest (car+cdr (reverse args)))) (reduce-right cross-product% '() (reverse (cons (map list last) rest )))))) @@ -508,7 +450,7 @@ ;; Requires that width|(length list) (define-public (group list width) (unless (null? list) - (let* ((row rest (split-at list width))) + (let ((row rest (split-at list width))) (cons row (group rest width))))) ;; repeatedly apply @var{proc} to @var{base} diff --git a/module/hnh/util/graph.scm b/module/hnh/util/graph.scm index 03c2ae3c..01e9a63a 100644 --- a/module/hnh/util/graph.scm +++ b/module/hnh/util/graph.scm @@ -7,6 +7,7 @@ (define-module (hnh util graph) :use-module (hnh util) :use-module (srfi srfi-1) + :use-module (srfi srfi-71) :use-module (srfi srfi-9 gnu)) ;; Immutable directed graph @@ -88,7 +89,7 @@ (let loop ((graph graph)) (if (graph-empty? graph) '() - (let* ((node graph* (find-and-remove-node-without-dependencies graph))) + (let ((node graph* (find-and-remove-node-without-dependencies graph))) (cons node (loop graph*)))))) (lambda (err caller fmt args data) (car graph)))) diff --git a/module/hnh/util/path.scm b/module/hnh/util/path.scm index 7eac630b..340c2d8b 100644 --- a/module/hnh/util/path.scm +++ b/module/hnh/util/path.scm @@ -1,5 +1,6 @@ (define-module (hnh util path) :use-module (srfi srfi-1) + :use-module (srfi srfi-71) :use-module (hnh util)) (define // file-name-separator-string) @@ -40,16 +41,16 @@ ;; ⇒ ("" "usr" "lib" "test") ;; @end example (define-public (path-split path) - (let* ((head tail - (car+cdr - (reverse - (map reverse-list->string - (fold (lambda (c done) - (if (/? c) - (cons '() done) - (cons (cons c (car done)) (cdr done)))) - '(()) - (string->list path))))))) + (let ((head tail + (car+cdr + (reverse + (map reverse-list->string + (fold (lambda (c done) + (if (/? c) + (cons '() done) + (cons (cons c (car done)) (cdr done)))) + '(()) + (string->list path))))))) (cons head (remove string-null? tail)))) diff --git a/module/hnh/util/tree.scm b/module/hnh/util/tree.scm index 95328b5f..34e10365 100644 --- a/module/hnh/util/tree.scm +++ b/module/hnh/util/tree.scm @@ -1,5 +1,6 @@ (define-module (hnh util tree) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) #:use-module (hnh util) #:export (make-tree left-subtree right-subtree @@ -13,8 +14,8 @@ ;; both it's children equal to @var{null}. (define (make-tree pred? lst) (unless (null? lst) - (let* ((head tail (partition (lambda (el) (pred? (car lst) el)) - (cdr lst)))) + (let ((head tail (partition (lambda (el) (pred? (car lst) el)) + (cdr lst)))) (list (car lst) (make-tree pred? head) (make-tree pred? tail))))) diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm index 9a172e2d..14e5b672 100644 --- a/module/srfi/srfi-41/util.scm +++ b/module/srfi/srfi-41/util.scm @@ -1,8 +1,9 @@ (define-module (srfi srfi-41 util) #:use-module (srfi srfi-1) #:use-module (srfi srfi-41) + #:use-module (srfi srfi-71) #:use-module ((ice-9 sandbox) :select (call-with-time-limit)) - #:use-module (hnh util) ; let*, find-min + #:use-module (hnh util) ; find-min #:export (stream-car+cdr interleave-streams stream-timeslice-limit)) diff --git a/module/srfi/srfi-64/test-error.scm b/module/srfi/srfi-64/test-error.scm index 33922c32..70f288a2 100644 --- a/module/srfi/srfi-64/test-error.scm +++ b/module/srfi/srfi-64/test-error.scm @@ -36,7 +36,6 @@ (define-module (srfi srfi-64 test-error) :use-module (srfi srfi-64) - :use-module (hnh util) :replace (test-error)) (define %test-source-line2 (@@ (srfi srfi-64) %test-source-line2)) diff --git a/module/text/flow.scm b/module/text/flow.scm index f7e08e1b..3b958480 100644 --- a/module/text/flow.scm +++ b/module/text/flow.scm @@ -7,6 +7,7 @@ :use-module (hnh util) :use-module (text util) :use-module (srfi srfi-1) + :use-module (srfi srfi-71) ) @@ -23,12 +24,12 @@ ;; str -> (str) (define* (justify-line line #:key (width 70)) (let recur ((lst (words line))) - (let* ((head tail (span - (let ((w 0)) - (lambda (word) ; Take words until we are above the limit. - (< (set/r! w = (+ 1 (true-string-length word))) - width))) - lst))) + (let ((head tail (span + (let ((w 0)) + (lambda (word) ; Take words until we are above the limit. + (< (set/r! w = (+ 1 (true-string-length word))) + width))) + lst))) (cond ((null? tail) (list (unwords head))) ; Don't justify last line. ((null? head) ;; an empty head implies that we found a word longer diff --git a/module/text/markup.scm b/module/text/markup.scm index 295ca198..53dab321 100644 --- a/module/text/markup.scm +++ b/module/text/markup.scm @@ -1,6 +1,7 @@ (define-module (text markup) :use-module (hnh util) :use-module (srfi srfi-1) + :use-module (srfi srfi-71) :use-module (ice-9 match) :use-module (ice-9 pretty-print) :use-module (text util) @@ -70,20 +71,20 @@ [(br) "\n"] [(hr) (string-append " " (make-string 60 #\─) " \n")] [(dl) - (let* ((dts dds (partition (lambda (x) (eq? 'dt (car x))) body))) - (let* ((dts* (map sxml->ansi-text dts)) - (m (if (null? dts*) 0 (apply max (map true-string-length dts*))))) - (string-concatenate - (map (lambda (dt dd) - (let ((dds (string-split dd #\newline))) - (string-concatenate - (map (lambda (left right) - (string-append (true-string-pad left m) " │ " right "\n")) - (cons dt (map (const "") (iota (1- (length dds))))) - dds)))) - dts* - (map (compose sxml->ansi-text (add-attributes `((width ,(- 70 m 5))))) - dds)))))] + (let* ((dts dds (partition (lambda (x) (eq? 'dt (car x))) body)) + (dts* (map sxml->ansi-text dts)) + (m (if (null? dts*) 0 (apply max (map true-string-length dts*))))) + (string-concatenate + (map (lambda (dt dd) + (let ((dds (string-split dd #\newline))) + (string-concatenate + (map (lambda (left right) + (string-append (true-string-pad left m) " │ " right "\n")) + (cons dt (map (const "") (iota (1- (length dds))))) + dds)))) + dts* + (map (compose sxml->ansi-text (add-attributes `((width ,(- 70 m 5))))) + dds))))] [(dt) (string-concatenate (map (compose sxml->ansi-text (add-attributes args)) body))] [(dd) diff --git a/module/text/numbers/sv.scm b/module/text/numbers/sv.scm index 2a032525..b70412fb 100644 --- a/module/text/numbers/sv.scm +++ b/module/text/numbers/sv.scm @@ -1,4 +1,5 @@ (define-module (text numbers sv) + :use-module (srfi srfi-71) :use-module (hnh util)) ;; only used in number->string-cardinal @@ -41,37 +42,37 @@ [(= n 20) "tjugo"] [(<= 21 n 29) (format #f "tjugo~a" (number->string-cardinal (- n 20)))] - [(<= 30 n 79) (let* ((big small (floor/ n 10))) + [(<= 30 n 79) (let ((big small (floor/ n 10))) (format #f "~atio~a" (number->string-cardinal big) (number->string-cardinal small)))] [(= n 80) "åttio"] - [(<= 81 n 89) (let* ((_ small (floor/ n 10))) + [(<= 81 n 89) (let ((_ small (floor/ n 10))) (format #f "åttio~a" (number->string-cardinal small)))] [(= n 90) "nittio"] - [(<= 91 n 99) (let* ((_ small (floor/ n 10))) + [(<= 91 n 99) (let ((_ small (floor/ n 10))) (format #f "nittio~a" (number->string-cardinal small)))] [(= n 100) "hundra"] - [(< 100 n 200) (let* ((_ small (floor/ n 100))) + [(< 100 n 200) (let ((_ small (floor/ n 100))) (format #f "hundra~a" (number->string-cardinal small)))] [(= n 200) "tvåhundra"] - [(< 200 n 1000) (let* ((big small (floor/ n 100))) + [(< 200 n 1000) (let ((big small (floor/ n 100))) (format #f "~ahundra~a" (number->string-cardinal big) (number->string-cardinal small)))] [(<= 1000 n 999999) - (let* ((big small (floor/ n 1000))) + (let ((big small (floor/ n 1000))) (format #f "~a tusen ~a~a" (number->string-cardinal big) (if (<= 100 small 199) "ett " "") (number->string-cardinal small)))] [(<= #e10e6 n (1- #e10e66)) - (let* ((e (inexact->exact (floor (log10 n)))) - (big small (floor/ n #e1e6))) + (let ((e (inexact->exact (floor (log10 n)))) + (big small (floor/ n #e1e6))) (if (zero? big) (number->string-cardinal small) (format #f "~a ~a~a~a ~a" @@ -121,7 +122,7 @@ (- n 20) a-form?: a-form?)))] [(<= 30 n 99) - (let* ((big small (floor/ n 10))) + (let ((big small (floor/ n 10))) (format #f "~atio~a" (case big [(8) "åt"] @@ -134,7 +135,7 @@ [(= n 100) "hundrade"] [(= n 1000) "tusende"] [else - (let* ((big small (floor/ n 100))) + (let ((big small (floor/ n 100))) (string-append (number->string-cardinal (* big 100)) (if (zero? small) "de" diff --git a/module/vcomponent/control.scm b/module/vcomponent/control.scm index 586dd4a3..63f1e1e3 100644 --- a/module/vcomponent/control.scm +++ b/module/vcomponent/control.scm @@ -9,7 +9,8 @@ (define (set-temp-values! table component kvs) (for-each (lambda (kv) - (let* (((key val) kv)) + (let ((key (car kv)) + (val (cadr kv))) (when (prop component key) (set! (href table key) (prop component key)) (set! (prop component key) val)))) diff --git a/module/vcomponent/formats/common/types.scm b/module/vcomponent/formats/common/types.scm index 9e18f1eb..1a7ec0da 100644 --- a/module/vcomponent/formats/common/types.scm +++ b/module/vcomponent/formats/common/types.scm @@ -4,6 +4,7 @@ :use-module (base64) :use-module (datetime) :use-module (srfi srfi-9 gnu) + :use-module (srfi srfi-71) :use-module (datetime timespec) :use-module (calp translation) ) @@ -62,7 +63,7 @@ ;; PERIOD (define (parse-period props value) - (let* (((left right) (string-split value #\/))) + (let ((left right (apply values (string-split value #\/)))) ;; TODO timezones? VALUE=DATE? (cons (parse-ics-datetime left) ((if (memv (string-ref right 0) diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm index 4bb2487f..cca306c5 100644 --- a/module/vcomponent/formats/ical/parse.scm +++ b/module/vcomponent/formats/ical/parse.scm @@ -6,6 +6,7 @@ :use-module (datetime) :use-module (srfi srfi-1) :use-module (srfi srfi-26) + :use-module (srfi srfi-71) :use-module (srfi srfi-9 gnu) :use-module (vcomponent base) :use-module (vcomponent geo) @@ -218,7 +219,7 @@ [(memv key '(GEO)) ;; two semicolon sepparated floats (lambda (params value) - (let* (((left right) (string-split value #\;))) + (let ((left right (apply values (string-split value #\;)))) (make-geo ((get-parser 'FLOAT) params left) ((get-parser 'FLOAT) params right))))] @@ -305,7 +306,7 @@ (begin (add-child! (cadr stack) (car stack)) (cdr stack))))] [else - (let* ((key value params (parse-itemline head))) + (let ((key value params (parse-itemline head))) (call-with-values (lambda () (build-vline key value params)) (lambda vlines (for vline in vlines @@ -349,7 +350,7 @@ (get-line linedata) (get-file linedata)) (current-error-port)) - (let* ((key value params (parse-itemline head))) + (let ((key value params (parse-itemline head))) (set! (prop* (car stack) key) (make-vline key value params)) (loop (cdr lst) stack))))))))) diff --git a/module/vcomponent/formats/vdir/save-delete.scm b/module/vcomponent/formats/vdir/save-delete.scm index e020a211..fb84d59c 100644 --- a/module/vcomponent/formats/vdir/save-delete.scm +++ b/module/vcomponent/formats/vdir/save-delete.scm @@ -38,7 +38,7 @@ (list (prop calendar '-X-HNH-SOURCETYPE)) #f)) - (let* ((uid (or (prop event 'UID) (uuid)))) + (let ((uid (or (prop event 'UID) (uuid)))) (set! (prop event 'UID) uid) (unless (prop event 'X-HNH-FILENAME) (set! (prop event '-X-HNH-FILENAME) diff --git a/module/vcomponent/recurrence/display/en.scm b/module/vcomponent/recurrence/display/en.scm index be9bdf53..68d435af 100644 --- a/module/vcomponent/recurrence/display/en.scm +++ b/module/vcomponent/recurrence/display/en.scm @@ -15,7 +15,7 @@ ;; but 1MO, -1MO doesn't become "första och sista måndagen". ;; TODO also, grouping of -dagen. e.g. "första mån- och tisdagen" (define (format-byday-list lst) - (let* ((groups (group-by car lst))) + (let ((groups (group-by car lst))) (intersperse " as well as " (map (lambda (group) diff --git a/module/vcomponent/recurrence/display/sv.scm b/module/vcomponent/recurrence/display/sv.scm index fe580474..35b3569b 100644 --- a/module/vcomponent/recurrence/display/sv.scm +++ b/module/vcomponent/recurrence/display/sv.scm @@ -20,7 +20,7 @@ ;; but 1MO, -1MO doesn't become "första och sista måndagen". ;; TODO also, grouping of -dagen. e.g. "första mån- och tisdagen" (define (format-byday-list lst) - (let* ((groups (group-by car lst))) + (let ((groups (group-by car lst))) (intersperse " samt " (map (lambda (group) diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index 308ec11e..4dccecf1 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -5,6 +5,7 @@ :use-module (srfi srfi-26) :use-module (srfi srfi-41) :use-module (srfi srfi-41 util) + :use-module (srfi srfi-71) :use-module (vcomponent base) :use-module (vcomponent recurrence internal) :use-module (vcomponent recurrence parse) @@ -128,7 +129,7 @@ ;; can extend the recurrence set in weird ways. (branching-fold (lambda (rule dt) - (let* (((key . value) rule) + (let* ((key value (car+cdr rule)) (d (if (date? dt) dt (get-date dt))) ;; NOTE It's proably an error to give BYHOUR, BYMINUTE, and BYSECOND ;; rules for a date object. This doesn't warn if those are given, but @@ -158,7 +159,7 @@ (to-dt (set (month d) value)))] [(BYDAY) - (let* (((offset . value) value)) + (let* ((offset value (car+cdr value))) (case (freq rrule) [(WEEKLY) ;; set day to that day in the week which d lies within @@ -167,7 +168,7 @@ 7))))] [(MONTHLY) - (let* ((instances (all-wday-in-month value (start-of-month d)))) + (let ((instances (all-wday-in-month value (start-of-month d)))) (catch 'out-of-range (lambda () (cond [(eqv? #f offset) @@ -281,9 +282,9 @@ (let loop ((remaining limiters)) (if (null? remaining) #t - (let* (((key . values) (car remaining)) - (t (as-time dt)) - (d (if (date? dt) dt (get-date dt)))) + (let ((key values (car+cdr (car remaining))) + (t (as-time dt)) + (d (if (date? dt) dt (get-date dt)))) (and (case key [(BYMONTH) (memv (month d) values)] [(BYMONTHDAY) (memv (day d) (map (month-mod d) values))] diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm index ae521d77..0503081c 100644 --- a/module/vcomponent/recurrence/internal.scm +++ b/module/vcomponent/recurrence/internal.scm @@ -1,6 +1,7 @@ (define-module (vcomponent recurrence internal) #:export (repeating? format-recur-rule make-recur-rule) + #:use-module (srfi srfi-71) #:use-module (srfi srfi-88) ; better keywords #:use-module ((vcomponent base) :select (prop)) #:use-module (srfi srfi-9) @@ -79,7 +80,7 @@ (define (byday->string pair) - (let* (((off . day) pair)) + (let ((off day (car+cdr pair))) (string-append (or (and=> off number->string) "") (string-upcase diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm index d45cedf9..a64cf4a7 100644 --- a/module/vcomponent/recurrence/parse.scm +++ b/module/vcomponent/recurrence/parse.scm @@ -4,6 +4,7 @@ #:export (parse-recurrence-rule) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) #:use-module (datetime) #:use-module (srfi srfi-26) #:use-module (vcomponent recurrence internal) @@ -87,7 +88,8 @@ (define* (parse-recurrence-rule str optional: (datetime-parser parse-ics-datetime)) (fold (lambda (kv o) - (let* (((key val) kv)) + (let ((key (car kv)) + (val (cadr kv))) (let-lazy ((symb (string->symbol val)) ;; NOTE until MUST have the same value type as DTSTART diff --git a/module/vcomponent/util/control.scm b/module/vcomponent/util/control.scm index 586dd4a3..63f1e1e3 100644 --- a/module/vcomponent/util/control.scm +++ b/module/vcomponent/util/control.scm @@ -9,7 +9,8 @@ (define (set-temp-values! table component kvs) (for-each (lambda (kv) - (let* (((key val) kv)) + (let ((key (car kv)) + (val (cadr kv))) (when (prop component key) (set! (href table key) (prop component key)) (set! (prop component key) val)))) diff --git a/module/vcomponent/util/describe.scm b/module/vcomponent/util/describe.scm index 0c3ab27c..703ac73a 100644 --- a/module/vcomponent/util/describe.scm +++ b/module/vcomponent/util/describe.scm @@ -1,5 +1,6 @@ (define-module (vcomponent util describe) :use-module (hnh util) + :use-module (srfi srfi-71) :use-module (vcomponent base) :use-module (text util)) @@ -14,7 +15,7 @@ (format #t "~aBEGIN ~a~%" ii (type vcomponent)) (for-each (lambda (kv) - (let* (((key . values) kv)) + (let ((key values (car+cdr kv))) (define (out vline) (format #t "~a~a = ~a" iii diff --git a/module/vcomponent/util/group.scm b/module/vcomponent/util/group.scm index f328cd18..b8852975 100644 --- a/module/vcomponent/util/group.scm +++ b/module/vcomponent/util/group.scm @@ -14,8 +14,8 @@ stream-null (let loop ((days (day-stream (as-date (prop (stream-car in-stream) 'DTSTART)))) (stream in-stream)) - (let* ((day (stream-car days)) - (tomorow (stream-car (stream-cdr days)))) + (let ((day (stream-car days)) + (tomorow (stream-car (stream-cdr days)))) (let ((head (stream-take-while (ein? day) stream)) (tail diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm index 0ad1fdc4..7a1d2fc8 100644 --- a/module/vcomponent/util/instance/methods.scm +++ b/module/vcomponent/util/instance/methods.scm @@ -3,6 +3,7 @@ :use-module (hnh util uuid) :use-module (srfi srfi-1) :use-module (srfi srfi-41) + :use-module (srfi srfi-71) :use-module (srfi srfi-41 util) :use-module (datetime) :use-module (vcomponent base) @@ -100,7 +101,7 @@ (slot-set! this 'events (append #|removed|# remaining))) - (let* ((repeating regular (partition repeating? (slot-ref this 'events)))) + (let ((repeating regular (partition repeating? (slot-ref this 'events)))) (slot-set! this 'fixed-events (sort*! regular date/-time<? (extract 'DTSTART))) (slot-set! this 'repeating-events (sort*! repeating date/-time<? (extract 'DTSTART)))) diff --git a/module/vulgar.scm b/module/vulgar.scm index 20b93164..5e32baa5 100644 --- a/module/vulgar.scm +++ b/module/vulgar.scm @@ -26,11 +26,12 @@ (with-vulgar (bitwise-not (bitwise-ior ECHO ICANON)) thunk)) ((bits thunk) - (let* ((ifd (current-input-port)) - (ofd (current-output-port)) - (iattr (make-termios)) - (oattr (make-termios)) - iattr* oattr*) + (let ((ifd (current-input-port)) + (ofd (current-output-port)) + (iattr (make-termios)) + (oattr (make-termios)) + (iattr* #f) + (oattr* #f)) (dynamic-wind (lambda () (tcgetattr! iattr ifd) diff --git a/module/vulgar/components.scm b/module/vulgar/components.scm index 882da849..740e64c3 100644 --- a/module/vulgar/components.scm +++ b/module/vulgar/components.scm @@ -4,9 +4,9 @@ #:export ()) (define-public (display-calendar-header! date) - (let* ((day (number->string (day date))) - (month (number->string (month date))) - (year (number->string (year date)))) + (let ((day (number->string (day date))) + (month (number->string (month date))) + (year (number->string (year date)))) ;; BSD cal only supports setting highlighted day explicitly for ;; testing the functionality. This seems to at least give me ;; an (almost) working display, albeit ugly. diff --git a/module/vulgar/info.scm b/module/vulgar/info.scm index 79e555da..0f55c942 100644 --- a/module/vulgar/info.scm +++ b/module/vulgar/info.scm @@ -1,8 +1,11 @@ (define-module (vulgar info) - :use-module (hnh util)) + :use-module ((srfi srfi-1) :select (car+cdr)) + :use-module (srfi srfi-71)) +;; Sort-of backwards subprocess call since we want the current terminal to be +;; inherited by stty (define-public (get-terminal-size) - (let* (((rpipe . wpipe) (pipe))) + (let ((rpipe wpipe (car+cdr (pipe)))) (system (format #f "stty size > /proc/~s/fd/~s" (getpid) (port->fdes wpipe))) (values (read rpipe) diff --git a/module/web/http/make-routes.scm b/module/web/http/make-routes.scm index 105bba50..f5277ca5 100644 --- a/module/web/http/make-routes.scm +++ b/module/web/http/make-routes.scm @@ -2,8 +2,10 @@ :export (make-routes) :use-module (hnh util) :use-module (ice-9 regex) + :use-module (ice-9 match) :use-module (ice-9 curried-definitions) :use-module (srfi srfi-1) + :use-module (srfi srfi-71) ) @@ -36,26 +38,27 @@ (define ((generate-case regex-table) defn) - (let* (((method uri param-list . body) defn) - (_ tokens (parse-endpoint-string uri)) - (diff intersect (lset-diff+intersection eq? param-list tokens))) - `((and (eq? r:method (quote ,method)) - (regexp-exec ,(car (assoc-ref regex-table uri)) r:path)) - => (lambda (match-object) - ;; (assert - ;; (= (1- (match:count match-object)) - ;; (length intersect))) + (match defn + ((method uri param-list body ...) + (let* ((_ tokens (parse-endpoint-string uri)) + (diff intersect (lset-diff+intersection eq? param-list tokens))) + `((and (eq? r:method (quote ,method)) + (regexp-exec ,(car (assoc-ref regex-table uri)) r:path)) + => (lambda (match-object) + ;; (assert + ;; (= (1- (match:count match-object)) + ;; (length intersect))) - ;; Those parameters which were present in the template uri - ((lambda ,intersect - ;; Those that only are in the query string - (lambda* (,@(unless (null? diff) `(#:key ,@diff #:allow-other-keys)) - #:rest rest) - ,@body)) - ,@(unless (null? intersect) - (map (lambda (i) - `((@ (ice-9 regex) match:substring) match-object ,i)) - (cdr (iota (1+ (length intersect))))))))))) + ;; Those parameters which were present in the template uri + ((lambda ,intersect + ;; Those that only are in the query string + (lambda* (,@(unless (null? diff) `(#:key ,@diff #:allow-other-keys)) + #:rest rest) + ,@body)) + ,@(unless (null? intersect) + (map (lambda (i) + `((@ (ice-9 regex) match:substring) match-object ,i)) + (cdr (iota (1+ (length intersect))))))))))))) (define-macro (make-routes . routes) ;; Ensures that all regexes are only compiled once. diff --git a/module/web/query.scm b/module/web/query.scm index a70903bc..2d62b45d 100644 --- a/module/web/query.scm +++ b/module/web/query.scm @@ -1,6 +1,7 @@ (define-module (web query) :use-module (hnh util) :use-module (srfi srfi-1) + :use-module (srfi srfi-71) :use-module (web uri)) (define*-public (parse-query query-string optional: (encoding "UTF-8")) @@ -8,12 +9,12 @@ (fold (lambda (str list) ;; only split on the first equal. ;; Does HTTP allow multiple equal signs in a data field? - (let* ((key val - (cond ((string-index str #\=) - => (lambda (idx) - (values (uri-decode (substring str 0 idx) encoding: encoding) - (uri-decode (substring str (1+ idx)) encoding: encoding)))) - (else (let ((v (uri-decode str encoding: encoding))) - (values v v)))))) + (let ((key val + (cond ((string-index str #\=) + => (lambda (idx) + (values (uri-decode (substring str 0 idx) encoding: encoding) + (uri-decode (substring str (1+ idx)) encoding: encoding)))) + (else (let ((v (uri-decode str encoding: encoding))) + (values v v)))))) (cons* (-> key string->symbol symbol->keyword) val list))) '() (string-split query-string #\&)))) @@ -126,6 +126,8 @@ msgstr "Grupper krävs i mallen" #. Week number prefix #. Cell 0, 0. The letter v. for week number +#. Week number prefix +#. Cell 0, 0. The letter v. for week number msgid "v." msgstr "v." @@ -433,6 +435,8 @@ msgstr "Start" #. Event end date-time terminal view #. Event start date-time terminal view #. Event end date-time terminal view +#. Event start date-time terminal view +#. Event end date-time terminal view msgid "~Y-~m-~d ~H:~M:~S" msgstr "~Y-~m-~d ~H:~M:~S" @@ -832,6 +836,13 @@ msgstr "<p><b>benchmark</b> <i>modul</i><br/>Kör proceduren 'run-benchmark' " #. Compact event list date only #. Header for sidebar day #. start = end, only return one value +#. Week view header format +#. start date metainfo +#. end date metainfo +#. Generation data +#. Compact event list date only +#. Header for sidebar day +#. start = end, only return one value msgid "~Y-~m-~d" msgstr "~Y-~m-~d" diff --git a/tests/run-tests.scm b/tests/run-tests.scm index 008090d0..b0cd4882 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -51,19 +51,22 @@ fi (define (yellow s) (escaped 33 s)) (define (bold s) (escaped 1 s)) -;;; TODO handle nested grups in a better fassion +(define (make-indent depth) + (make-string (* 2 depth) #\space)) (define (construct-test-runner) (define runner (test-runner-null)) + (define depth 0) ;; end of individual test case (test-runner-on-test-begin! runner (lambda (runner) (test-runner-aux-value! runner (transform-time-of-day (gettimeofday))))) (test-runner-on-test-end! runner (lambda (runner) + (when (verbose?) (display (make-indent depth))) (case (test-result-kind runner) ((pass) (display (green "X"))) - ((fail) (newline) (display (red "E"))) + ((fail) (display (red "E"))) ((xpass) (display (yellow "X"))) ((xfail) (display (yellow "E"))) ((skip) (display (yellow "-")))) @@ -75,15 +78,19 @@ fi => (lambda (p) (with-output-to-string (lambda () (display (bold "[SOURCE]: ")) (truncated-print p)))))))) (when (eq? 'fail (test-result-kind)) (cond ((test-result-ref runner 'actual-error) - => (lambda (err) (format #t "Error: ~s~%" err))) + => (lambda (err) (format #t "~aError: ~s~%" (make-indent (1+ depth)) err))) (else - (format #t "Expected: ~s~%Received: ~s~%" - (test-result-ref runner 'expected-value "[UNKNOWN]") - (test-result-ref runner 'actual-value "[UNKNOWN]")))) - (format #t "Near ~a:~a~%~y" + (format #t "~aExpected: ~s~%~aReceived: ~s~%" + (make-indent (1+ depth)) (test-result-ref runner 'expected-value "[UNKNOWN]") + (make-indent (1+ depth)) (test-result-ref runner 'actual-value "[UNKNOWN]")))) + (format #t "~aNear ~a:~a~%" + (make-indent (1+ depth)) (test-result-ref runner 'source-file) - (test-result-ref runner 'source-line) - (test-result-ref runner 'source-form))) + (test-result-ref runner 'source-line)) + (pretty-print (test-result-ref runner 'source-form) + (current-output-port) + per-line-prefix: (string-append (make-indent (1+ depth)) "> ") + )) (let ((start (test-runner-aux-value runner)) (end (transform-time-of-day (gettimeofday)))) @@ -97,12 +104,19 @@ fi (test-runner-on-group-begin! runner ;; count is number of #f (lambda (runner name count) - (format #t "~a ~a ~a~%" - (make-string 10 #\=) - name - (make-string 10 #\=)))) + (if (<= depth 1) + (format #t "~a ~a ~a~%" + (make-string 10 #\=) + name + (make-string 10 #\=)) + (when (verbose?) + (format #t "~a~a~%" (make-string (* depth 2) #\space) name))) + (set! depth (1+ depth)))) (test-runner-on-group-end! runner - (lambda (runner) (newline))) + (lambda (runner) + (set! depth (1- depth)) + (when (<= depth 1) + (newline)))) ;; after everything else is done (test-runner-on-final! runner (lambda (runner) diff --git a/tests/test/datetime.scm b/tests/test/datetime.scm index 3435aad6..d646052d 100644 --- a/tests/test/datetime.scm +++ b/tests/test/datetime.scm @@ -5,12 +5,12 @@ (define-module (test datetime) :use-module (srfi srfi-64) + :use-module (srfi srfi-71) :use-module (srfi srfi-88) :use-module ((srfi srfi-41) :select (stream->list stream-take)) :use-module (datetime) :use-module ((ice-9 format) :select (format)) - :use-module ((hnh util) :select (let*)) :use-module ((ice-9 i18n) :select (make-locale)) :use-module ((guile) :select (LC_CTYPE LC_TIME))) @@ -164,18 +164,18 @@ (date day: 4) (date day: 5))) -(let* ((diff overflow - (time- #10:20:30 - #10:20:30))) +(let ((diff overflow + (time- #10:20:30 + #10:20:30))) (test-equal "time- self" #00:00:00 diff) (test-equal "time- self overflow" 0 overflow)) -(let* ((diff overflow - (time- #10:00:00 - #10:00:01))) +(let ((diff overflow + (time- #10:00:00 + #10:00:01))) (test-equal "time- overflow 1s" #23:59:59 @@ -185,9 +185,9 @@ 1 overflow)) -(let* ((diff overflow - (time- #10:00:00 - (time hour: (+ 48 4))))) +(let ((diff overflow + (time- #10:00:00 + (time hour: (+ 48 4))))) (test-equal "time- overflow multiple" #06:00:00 diff --git a/tests/test/let.scm b/tests/test/let.scm deleted file mode 100644 index 5312409e..00000000 --- a/tests/test/let.scm +++ /dev/null @@ -1,45 +0,0 @@ -;;; Commentary: -;; Tests my custom let*. -;;; Code: - -(define-module (test let) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module ((hnh util) :select (let*))) - -(test-assert (let* ((a #t)) a)) - -(test-assert (let* (((a . b) (cons #t #f))) a)) - -(test-assert (let* (((a . b) (cons* #f #t))) b)) - -(test-assert - (let* ((a b c (values #f #t #f))) b)) - -(test-assert - (let* (((a b c) (list #f #t #f))) b)) - -(test-assert (let* (((a) '(#t))) a)) - -(test-equal '(2) (let* (((a . b) '(1 2))) b)) - -(test-equal - '(3 4) - (let* (((a b . c) '(1 2 3 4))) c)) - -(test-equal 10 (let* (x) (set! x 10) x)) - -(test-equal - 30 - (let* (x y) (set! x 10) (set! y 20) (+ x y))) - -(test-assert (let* (x) (not x))) - -(test-equal - 6 - (let* ((x 1) y z) - (set! y 2) - (set! z 3) - (+ x y z))) - - diff --git a/tests/test/server.scm b/tests/test/server.scm index 1b5d4775..43b60769 100644 --- a/tests/test/server.scm +++ b/tests/test/server.scm @@ -4,21 +4,21 @@ (define-module (test server) :use-module (srfi srfi-64) + :use-module (srfi srfi-71) :use-module (srfi srfi-88) :use-module ((web http make-routes) - :select (parse-endpoint-string)) - :use-module ((hnh util) :select (let*))) + :select (parse-endpoint-string))) (test-assert "Check that parsing doesn't crash" (parse-endpoint-string "/static/:dir/:file")) ;; Checks that parsing produces correct results -(let* ((path args (parse-endpoint-string "/static/:dir/:file"))) +(let ((path args (parse-endpoint-string "/static/:dir/:file"))) (test-equal "/static/([^/.]+)/([^/.]+)" path) (test-equal '(dir file) args)) ;; Checks that parsing with custom regex works ;; along with literal periods. -(let* ((path args (parse-endpoint-string "/static/:filename{.*}.:ext"))) +(let ((path args (parse-endpoint-string "/static/:filename{.*}.:ext"))) (test-equal "/static/(.*)\\.([^/.]+)" path) (test-equal '(filename ext) args)) diff --git a/tests/test/timespec.scm b/tests/test/timespec.scm new file mode 100644 index 00000000..256c01bf --- /dev/null +++ b/tests/test/timespec.scm @@ -0,0 +1,88 @@ +(define-module (test timespec) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module (datetime) + :use-module (datetime timespec)) + +(test-equal "The empty string parses to the empty timespec" + (timespec-zero) (parse-time-spec "")) + +(test-group "timespec-add" + + (test-equal "Zero operands gives 0" + (timespec-zero) (timespec-add)) + + (let ((ts (make-timespec #10:20:30 '- #\z))) + (test-equal "Single operand gives that operand" + ts (timespec-add ts))) + + (test-equal "0 + 0 = 0" + (timespec-zero) (timespec-add (timespec-zero) (timespec-zero))) + + (test-group + "+ -" + (test-equal "Remove a number less than the base" + (make-timespec #10:00:00 '+ #\w) + (timespec-add (make-timespec #10:20:30 '+ #\w) + (make-timespec #00:20:30 '- #\w))) + + (test-equal "Remove a number greater than the base" + (make-timespec #01:00:00 '- #\w) + (timespec-add (make-timespec #10:00:00 '+ #\w) + (make-timespec #11:00:00 '- #\w))) + + (test-equal "x + -x = 0" + (timespec-zero) (timespec-add (make-timespec #10:20:30 '+ #\w) + (make-timespec #10:20:30 '- #\w)))) + + (test-group "- +" + (test-equal "Add a number less than the (negative) base" + (make-timespec #10:00:00 '+ #\w) + (timespec-add (make-timespec #10:20:30 '- #\w) + (make-timespec #00:20:30 '+ #\w))) + + (test-equal "Add a number greater than the (negative) base" + (make-timespec #01:00:00 '- #\w) + (timespec-add (make-timespec #10:00:00 '- #\w) + (make-timespec #11:00:00 '+ #\w))) + + (test-equal "-x + x = 0" + (timespec-zero) (timespec-add (make-timespec #10:20:30 '- #\w) + (make-timespec #10:20:30 '+ #\w)))) + + (test-group "+ +" + (test-equal "x + x = 2x" + (make-timespec #20:41:00 '+ #\w) + (timespec-add (make-timespec #10:20:30 '+ #\w) + (make-timespec #10:20:30 '+ #\w)))) + + (test-group "- -" + (test-equal "-x + -x = -2x" + (make-timespec #20:41:00 '- #\w) + (timespec-add (make-timespec #10:20:30 '- #\w) + (make-timespec #10:20:30 '- #\w)))) + + ;; add more than two timespecs + + ;; add timespecs of differing types + ) + +(test-group "parse-time-spec" + ;; TODO what even is this case? + (test-equal (make-timespec (time) '+ #\g) (parse-time-spec "-g")) + + (test-equal "Parse direct date, with hour minute and second" + (make-timespec #20:00:00 '+ #\w) (parse-time-spec "20:00:00")) + (test-equal "Parse direct date, with hour and minute" + (make-timespec #20:00:00 '+ #\w) (parse-time-spec "20:00")) + (test-equal "Parse direct date, with just hour" + (make-timespec #20:00:00 '+ #\w) (parse-time-spec "20")) + + (test-equal "Parse timespec with letter at end" + (make-timespec #20:00:00 '+ #\g) (parse-time-spec "20:00g")) + + (test-equal "Parse negative timespec" + (make-timespec #20:00:00 '- #\w) (parse-time-spec "-20")) + + (test-equal "Parse negative timespec with letter at end" + (make-timespec #20:00:00 '- #\z) (parse-time-spec "-20z"))) diff --git a/tests/test/web-server.scm b/tests/test/web-server.scm index e5a796b6..69d18536 100644 --- a/tests/test/web-server.scm +++ b/tests/test/web-server.scm @@ -9,13 +9,13 @@ (define-module (test web-server) :use-module (srfi srfi-64) + :use-module (srfi srfi-71) :use-module (srfi srfi-88) :use-module ((calp server routes) :select (make-make-routes)) :use-module ((web server) :select (run-server)) :use-module ((ice-9 threads) :select (call-with-new-thread cancel-thread)) :use-module ((web client) :select (http-get)) - :use-module ((hnh util) :select (let*)) :use-module ((web response) :select (response-code response-location)) :use-module ((web uri) :select (build-uri uri-path)) :use-module ((guile) @@ -71,39 +71,39 @@ ;; This test should always fail, but should never be run (test-assert "Server returned unexpectedly" #f)))) -(let* ((response - _ - (catch 'system-error - (lambda () - (http-get - (build-uri 'http host: host port: port))) - (lambda (err proc fmt args data) - (format - (current-error-port) - "~a (in ~a) ~?~%" - err - proc - fmt - args) - (values (build-response code: 500) #f))))) +(let ((response + _ + (catch 'system-error + (lambda () + (http-get + (build-uri 'http host: host port: port))) + (lambda (err proc fmt args data) + (format + (current-error-port) + "~a (in ~a) ~?~%" + err + proc + fmt + args) + (values (build-response code: 500) #f))))) (test-eqv "Basic connect" 200 (response-code response))) -(let* ((response - body - (http-get - (build-uri - 'http - host: - host - port: - port - path: - "/today" - query: - "view=week&date=2020-01-04")))) +(let ((response + body + (http-get + (build-uri + 'http + host: + host + port: + port + path: + "/today" + query: + "view=week&date=2020-01-04")))) (test-eqv "Redirect" 302 diff --git a/tests/test/zic.scm b/tests/test/zic.scm new file mode 100644 index 00000000..99247cf1 --- /dev/null +++ b/tests/test/zic.scm @@ -0,0 +1,317 @@ +(define-module (test zic) + :use-module ((srfi srfi-1) :select (every)) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module (datetime) + :use-module (datetime timespec) + :use-module (datetime zic)) + + +(test-expect-fail "Simple Leap") +(test-expect-fail "Simple Expire") + +(define big-sample + "# Rule NAME FROM TO - IN ON AT SAVE LETTER/S +Rule Swiss 1941 1942 - May Mon>=1 1:00 1:00 S +Rule Swiss 1941 1942 - Oct Mon>=1 2:00 0 - +Rule EU 1977 1980 - Apr Sun>=1 1:00u 1:00 S +Rule EU 1977 only - Sep lastSun 1:00u 0 - +Rule EU 1978 only - Oct 1 1:00u 0 - +Rule EU 1979 1995 - Sep lastSun 1:00u 0 - +Rule EU 1981 max - Mar lastSun 1:00u 1:00 S +Rule EU 1996 max - Oct lastSun 1:00u 0 - + +# Zone NAME STDOFF RULES FORMAT [UNTIL] +Zone Europe/Zurich 0:34:08 - LMT 1853 Jul 16 + 0:29:45.50 - BMT 1894 Jun + 1:00 Swiss CE%sT 1981 + 1:00 EU CE%sT + +Link Europe/Zurich Europe/Vaduz +") + +(define parse-zic-file (@@ (datetime zic) parse-zic-file)) + +;; Some of the tests are slightly altered to score better on the coverage +(test-group "From zic(8)" + (test-equal "Basic Rule" + (list ((@@ (datetime zic) make-rule) + 'US 1967 1973 4 '(last 0) + ((@ (datetime zic) make-timespec) #02:00:00 '+ #\w) + ((@ (datetime zic) make-timespec) #01:00:00 '+ #\d) + "D")) + (call-with-input-string "Rule US 1967 1973 - Apr lastSun 2:00w 1:00d D" + parse-zic-file)) + + ;; Technically not from zic(8), since that example has an until field + (test-equal "Basic Zone" + (list ((@@ (datetime zic) make-zone) "Asia/Amman" + (list ((@@ (datetime zic) make-zone-entry) + (make-timespec #02:00:00 '+ #\w) + 'Jordan "EE%sT" #f)))) + + (call-with-input-string + "Zone Asia/Amman 2:00 Jordan EE%sT" + parse-zic-file)) + + ;; Modified from the following example + (test-equal "Basic Zone with continuation" + (list ((@@ (datetime zic) make-zone) "America/Menominee" + (list ((@@ (datetime zic) make-zone-entry) + (make-timespec #05:00:00 '- #\w) + #f "EST" #1973-04-29T02:00:00) + ((@@ (datetime zic) make-zone-entry) + (make-timespec #06:00:00 '- #\w) + 'US "C%sT" #f)))) + ;; Why can't I single read a zone with an until field? + (call-with-input-string + "Zone America/Menominee -5:00 - EST 1973 Apr 29 2:00 + -6:00 US C%sT" + parse-zic-file)) + + + (test-equal "Rules and Zone" + (list ((@@ (datetime zic) make-zone) "America/Menominee" + (list ((@@ (datetime zic) make-zone-entry) + (make-timespec #05:00:00 '- #\w) + #f "EST" #1973-04-29T02:00:00) + ((@@ (datetime zic) make-zone-entry) + (make-timespec #06:00:00 '- #\w) + 'US "C%sT" #f))) + ((@@ (datetime zic) make-rule) + 'US 1967 1973 dec '(last 0) + (make-timespec #02:00:00 '+ #\w) + (make-timespec #01:00:00 '+ #\w) + "D") + ((@@ (datetime zic) make-rule) + 'US 1967 2006 nov '(last 0) + (make-timespec #02:00:00 '+ #\w) + (make-timespec #00:00:00 '+ #\w) + "S")) + (call-with-input-string + "# Rule NAME FROM TO - IN ON AT SAVE LETTER/S +Rule US 1967 2006 - Nov lastSun 2:00 0 S +Rule US 1967 1973 - Dec lastSun 2:00 1:00 D +# Zone NAME STDOFF RULES FORMAT [UNTIL] +Zone America/Menominee -5:00 - EST 1973 Apr 29 2:00 + -6:00 US C%sT +" parse-zic-file)) + + + (test-equal "Simple Link" + (list ((@@ (datetime zic) make-link) "Asia/Istanbul" "Europe/Istanbul")) + (call-with-input-string "Link Europe/Istanbul Asia/Istanbul" + parse-zic-file)) + + (test-equal "Simple Leap" + 'not-yet-implemented + (call-with-input-string "Leap 2016 Dec 31 23:59:60 + S" + parse-zic-file)) + + (test-equal "Simple Expire" + 'not-yet-implemented + (call-with-input-string "Expires 2020 Dec 28 00:00:00" + parse-zic-file)) + + + (test-equal "Extended example" + ;; Items are in reverse order of discovery + (list ((@@ (datetime zic) make-link) "Europe/Vaduz" "Europe/Zurich") + ((@@ (datetime zic) make-zone) "Europe/Zurich" + (list ((@@ (datetime zic) make-zone-entry) + (make-timespec #00:34:08 '+ #\w) + #f "LMT" #1853-07-16T00:00:00) + ((@@ (datetime zic) make-zone-entry) + (make-timespec #00:29:45 '+ #\w) ; NOTE that the .50 is discarded + #f "BMT" #1894-06-01T00:00:00) + ((@@ (datetime zic) make-zone-entry) + (make-timespec #01:00:00 '+ #\w) + 'Swiss "CE%sT" #1981-01-01T00:00:00) + ((@@ (datetime zic) make-zone-entry) + (make-timespec #01:00:00 '+ #\w) + 'EU "CE%sT" #f))) + ((@@ (datetime zic) make-rule) 'EU 1996 'maximum 10 '(last 0) + (make-timespec #01:00:00 '+ #\u) + (make-timespec #00:00:00 '+ #\w) + "") + ((@@ (datetime zic) make-rule) 'EU 1981 'maximum 3 '(last 0) + (make-timespec #01:00:00 '+ #\u) + (make-timespec #01:00:00 '+ #\w) + "S") + ((@@ (datetime zic) make-rule) 'EU 1979 1995 9 `(last ,sun) + (make-timespec #01:00:00 '+ #\u) + (make-timespec #00:00:00 '+ #\w) + "") + ((@@ (datetime zic) make-rule) 'EU 1978 'only 10 1 + (make-timespec #01:00:00 '+ #\u) + (make-timespec #00:00:00 '+ #\w) + "") + ((@@ (datetime zic) make-rule) 'EU 1977 'only 9 `(last ,sun) + (make-timespec #01:00:00 '+ #\u) + (make-timespec #00:00:00 '+ #\w) + "") + ((@@ (datetime zic) make-rule) 'EU 1977 1980 4 `(> ,sun 1) + (make-timespec #01:00:00 '+ #\u) + (make-timespec #01:00:00 '+ #\w) + "S") + ((@@ (datetime zic) make-rule) 'Swiss 1941 1942 10 `(> ,mon 1) + (make-timespec #02:00:00 '+ #\w) + (make-timespec #00:00:00 '+ #\w) + "") + ((@@ (datetime zic) make-rule) 'Swiss 1941 1942 5 `(> ,mon 1) + (make-timespec #01:00:00 '+ #\w) + (make-timespec #01:00:00 '+ #\w) + "S")) + (call-with-input-string big-sample + parse-zic-file))) + +(test-group "rule->dtstart" + (test-equal "last sunday" + #1967-04-30T02:00:00 + (rule->dtstart + ((@@ (datetime zic) make-rule) + 'US 1967 1973 4 '(last 0) + ((@ (datetime zic) make-timespec) #02:00:00 '+ #\w) + ((@ (datetime zic) make-timespec) #01:00:00 '+ #\d) + "D"))) + + (test-equal "sunday >= 1" + #1977-04-03T01:00:00Z + (rule->dtstart + ((@@ (datetime zic) make-rule) 'EU 1977 1980 4 `(> ,sun 1) + (make-timespec #01:00:00 '+ #\u) + (make-timespec #01:00:00 '+ #\w) + "S"))) + + ;; Max and min uses dummy dates, which is slightly wrong + ;; but shouldn't cause any real problems + + (test-equal "Minimum time" + #0000-10-30T01:00:00Z + (rule->dtstart + ((@@ (datetime zic) make-rule) 'EU 'minimum 2000 10 '(last 0) + (make-timespec #01:00:00 '+ #\u) + (make-timespec #00:00:00 '+ #\w) + ""))) + + (test-equal "Maximum time" + (datetime year: 9999 month: oct day: 27 + hour: 1 tz: "UTC") + (rule->dtstart + ((@@ (datetime zic) make-rule) 'EU 'maximum 2000 10 '(last 0) + (make-timespec #01:00:00 '+ #\u) + (make-timespec #00:00:00 '+ #\w) + "")))) + +(test-group "zone-format" + + (test-equal "Zone format with argument" "CEST" (zone-format "CE%sT" "S")) + (test-equal "Zone format with empty" "CET" (zone-format "CE%sT" "")) + + ;; TODO zone-format %z is not yet implemented, and therefore untested + + ;; TODO this error message is currently translatable... + (test-equal "Invalid format specifier" + '(misc-error "zone-format" "Invalid format char ~s in ~s at position ~a" (#\S "%S" 1) #f) + (catch 'misc-error (lambda () (zone-format "%S" "A")) + list))) + +(test-group "Actual object" + ;; NOTE this doesn't test read-zoneinfos ability to + ;; - take filenames + ;; - take multiple items + (let ((zoneinfo (call-with-input-string big-sample (compose read-zoneinfo list)))) + (test-assert "get-zone returns a zone-entry object" + (every zone-entry? (get-zone zoneinfo "Europe/Zurich"))) + (test-equal "A link resolves to the same object as its target" + (get-zone zoneinfo "Europe/Zurich") (get-zone zoneinfo "Europe/Vaduz")) + (test-equal "Get rules returns correctly, and in order" + ;; Rules are sorted + (list ((@@ (datetime zic) make-rule) 'Swiss 1941 1942 5 `(> ,mon 1) + (make-timespec #01:00:00 '+ #\w) + (make-timespec #01:00:00 '+ #\w) + "S") + ((@@ (datetime zic) make-rule) 'Swiss 1941 1942 10 `(> ,mon 1) + (make-timespec #02:00:00 '+ #\w) + (make-timespec #00:00:00 '+ #\w) + "")) + (get-rule zoneinfo 'Swiss)))) + + +(test-group "rule->rrule" + (test-equal "Basic example, and to = maximum" + ((@ (vcomponent recurrence internal) make-recur-rule) + freq: 'YEARLY interval: 1 wkst: mon + byday: (list (cons -1 sun)) + bymonth: (list oct)) + (rule->rrule + ((@@ (datetime zic) make-rule) 'EU 1996 'maximum 10 '(last 0) + (make-timespec #01:00:00 '+ #\u) + (make-timespec #00:00:00 '+ #\w) + "") + )) + + (test-equal "with to = only" + #f + (rule->rrule + ((@@ (datetime zic) make-rule) 'EU 1996 'only 10 '(last 2) + (make-timespec #01:00:00 '+ #\u) + (make-timespec #00:00:00 '+ #\w) + ""))) + + (test-equal "with definitive to year" + ((@ (vcomponent recurrence internal) make-recur-rule) + freq: 'YEARLY interval: 1 wkst: mon + byday: (list (cons -1 tue)) + bymonth: (list oct) + until: #2000-01-01T00:00:00) + (rule->rrule + ((@@ (datetime zic) make-rule) 'EU 1996 2000 10 '(last 2) + (make-timespec #01:00:00 '+ #\u) + (make-timespec #00:00:00 '+ #\w) + ""))) + + (test-equal "on being a month day" + ((@ (vcomponent recurrence internal) make-recur-rule) + freq: 'YEARLY interval: 1 wkst: mon + bymonthday: (list 2) + bymonth: (list oct)) + (rule->rrule + ((@@ (datetime zic) make-rule) 'EU 1996 'maximum 10 2 + (make-timespec #01:00:00 '+ #\u) + (make-timespec #00:00:00 '+ #\w) + ""))) + + (test-equal "on being first day after date" + ((@ (vcomponent recurrence internal) make-recur-rule) + freq: 'YEARLY interval: 1 wkst: mon + byday: (list (cons 1 mon)) + bymonth: (list oct)) + (rule->rrule + ((@@ (datetime zic) make-rule) 'EU 1996 'maximum 10 `(> ,mon 2) + (make-timespec #01:00:00 '+ #\u) + (make-timespec #00:00:00 '+ #\w) + ""))) + + (test-equal "Crash on counting backwards from date" + '(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) + (make-timespec #01:00:00 '+ #\u) + (make-timespec #00:00:00 '+ #\w) + ""))) + list)) + + (test-equal "Crash on to = minimum" + '(misc-error "rule->rrule" "Check your input" #f #f) + (catch 'misc-error + (lambda () + (rule->rrule + ((@@ (datetime zic) make-rule) 'EU 1996 'minimum 10 `(< ,mon 2) + (make-timespec #01:00:00 '+ #\u) + (make-timespec #00:00:00 '+ #\w) + ""))) + list)) + ) |