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 | |
| 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.
43 files changed, 262 insertions, 336 deletions
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/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm index 9e70f910..27a1f994 100644 --- a/module/calp/html/vcomponent.scm +++ b/module/calp/html/vcomponent.scm @@ -229,7 +229,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 @@ -265,10 +266,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 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 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 963e20c8..0f55c942 100644 --- a/module/vulgar/info.scm +++ b/module/vulgar/info.scm @@ -1,10 +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/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/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 |