Clean up util and move exceptions.

5 files changed, 84 insertions, 99 deletions

diff --git a/module/exceptions.scm b/module/exceptions.scm
deleted file mode 100644
index 027c75ee..00000000
--- a/module/exceptions.scm
+++ /dev/null
@@ -1,5 +0,0 @@
-(define-module (exceptions)
-  #:export (throw-returnable))
-
-(define-syntax-rule (throw-returnable symb args ...)
-  (call/cc (lambda (cont) (throw symb cont args ...))))
diff --git a/module/util.scm b/module/util.scm
index d1bdfca1..97483222 100644
--- a/module/util.scm
+++ b/module/util.scm
@@ -2,17 +2,14 @@
   #:use-module (srfi srfi-1)
   #:use-module ((ice-9 optargs) #:select (define*-public))
   #:use-module ((sxml fold) #:select (fold-values))
-  #:export (destructure-lambda let-multi fold-lists catch-let
-                               for-each-in for
-                               define-quick-record
-                               mod! sort* sort*!
-                               mod/r! set/r!
-                               find-min
-                               catch-multiple
-                               quote?
-                               tree-map let-lazy)
-  #:replace (let* set! define-syntax)
-  )
+  #:export (for define-quick-record
+                mod! sort* sort*!
+                mod/r! set/r!
+                find-min
+                catch-multiple
+                quote?
+                tree-map let-lazy)
+  #:replace (let* set! define-syntax))
 
 ((@ (guile) define-syntax) define-syntax
   (syntax-rules ()
@@ -33,25 +30,6 @@
 
 (define-public symbol-downcase (compose string->symbol string-downcase symbol->string))
 
-(define-syntax destructure-lambda
-  (syntax-rules ()
-    ((_ expr-list body ...)
-     (lambda (expr)
-       (apply (lambda expr-list body ...) expr)))))
-
-(define-syntax catch-let
-  (syntax-rules ()
-    ((_ thunk ((type handler) ...))
-     (catch #t thunk
-       (lambda (err . args)
-         (case err
-           ((type) (apply handler err args)) ...
-           (else (format #t "Unhandled error type ~a, rethrowing ~%" err)
-                 (apply throw err args))))))))
-
-;;; For-each with arguments in reverse order.
-(define-syntax-rule (for-each-in lst proc)
-  (for-each proc lst))
 
 (define-syntax for
   (syntax-rules (in)
@@ -289,39 +267,6 @@
     (call-with-values (lambda () (apply proc args))
       (lambda args (list-ref args n)))))
 
-;; Takes a (non nested) list, and replaces all single underscore
-;; symbols with a generated symbol. For macro usage.
-(define (multiple-ignore lst)
-  (cond ((not-pair? lst) lst)
-        ((eq? '_ (car lst)) (cons (gensym "ignored_")
-                                  (multiple-ignore (cdr lst))))
-        (else (cons (car lst)
-                    (multiple-ignore (cdr lst))))))
-
-(define (catch-recur% errs thunk cases)
-  (let* ((v (car errs))
-         (case other (partition (lambda (case) (eq? v (car case))) cases))
-         (g!rest (gensym "rest")))
-    `(catch (quote ,v)
-       ,(if (null? (cdr errs))
-            thunk
-            `(lambda () ,(catch-recur% (cdr errs) thunk other)))
-       (lambda (err . ,g!rest)
-         (apply (lambda ,(multiple-ignore (second (car case)))
-                  ,@(cddr (car case)))
-                ,g!rest)))))
-
-;; Like @var{catch}, but multiple handlers can be specified.
-;; Each handler is on the form
-;; @example
-;; [err-symb (args ...) body ...]
-;; @end example
-;; 
-;; Only errors with a handler are caught. Error can *not* be given as
-;; an early argument.
-(define-macro (catch-multiple thunk . cases)
-  (catch-recur% (map car cases) thunk cases))
-
 (define-public (flatten lst)
   (fold (lambda (subl done)
           (append done ((if (list? subl) flatten list) subl)))
@@ -349,3 +294,10 @@
        ,@(tree-map (lambda (t) (if (memv t keys) `(force ,t) t))
                    body #:descend (negate quote?)))))
 
+
+(define-public (map/dotted proc dotted-list)
+  (cond ((null? dotted-list) '())
+        ((not-pair? dotted-list) (proc dotted-list))
+        (else
+         (cons (proc (car dotted-list))
+               (map/dotted proc (cdr dotted-list))))))
diff --git a/module/util/exceptions.scm b/module/util/exceptions.scm
new file mode 100644
index 00000000..d649643c
--- /dev/null
+++ b/module/util/exceptions.scm
@@ -0,0 +1,40 @@
+(define-module (util exceptions)
+  #:use-module (srfi srfi-1)
+  #:use-module (util)
+  #:export (throw-returnable
+            catch-multiple))
+
+(define-syntax-rule (throw-returnable symb args ...)
+  (call/cc (lambda (cont) (throw symb cont args ...))))
+
+;; Takes a (non nested) list, and replaces all single underscore
+;; symbols with a generated symbol. For macro usage.
+(define (multiple-ignore lst)
+  (map/dotted (lambda (symb) (if (eq? symb '_) (gensym "ignored_") symb))
+              lst))
+
+;; Like @var{catch}, but multiple handlers can be specified.
+;; Each handler is on the form
+;; @example
+;; [err-symb (args ...) body ...]
+;; @end example
+;; 
+;; Only errors with a handler are caught. Error can *not* be given as
+;; an early argument.
+(define-macro (catch-multiple thunk . cases)
+  (let catch-recur% ((errs (map car cases)) (cases cases))
+    (let* ((v (car errs))
+           (case other (partition (lambda (case) (eq? v (car case))) cases))
+           (g!rest (gensym "rest")))
+      `(catch (quote ,v)
+         ,(if (null? (cdr errs))
+              thunk
+              `(lambda () ,(catch-recur% (cdr errs) other)))
+         (lambda (err . ,g!rest)
+           (apply (lambda ,(let ((param-list (second (car case))))
+                        (if (not (pair? param-list))
+                            param-list
+                            (multiple-ignore param-list)))
+                    ,@(cddr (car case)))
+                  ,g!rest))))))
+
diff --git a/module/vcomponent/output.scm b/module/vcomponent/output.scm
index 8db2d85b..6d346230 100644
--- a/module/vcomponent/output.scm
+++ b/module/vcomponent/output.scm
@@ -27,16 +27,15 @@
     (format port "~a <~a> :: ~:a~%"
             (make-string depth #\:)
             (type comp) comp)
-    (for-each-in kvs
-                 (lambda (kv)
-                   (let* (((key . at) kv))
-                     (format port "~a ~15@a~{;~a=~{~a~^,~}~}: ~a~%"
-                             (make-string depth #\:)
-                             key
-                             (concatenate (hash-map->list list (cdr at)))
-                             (v at)))))
-    (for-each-in (children comp)
-                 (lambda (e) (print-vcomponent e port #:depth (1+ depth))))))
+    (for kv in kvs
+         (let* (((key . at) kv))
+           (format port "~a ~15@a~{;~a=~{~a~^,~}~}: ~a~%"
+                   (make-string depth #\:)
+                   key
+                   (concatenate (hash-map->list list (cdr at)))
+                   (v at))))
+    (for-each (lambda (e) (print-vcomponent e port #:depth (1+ depth)))
+              (children comp))))
 
 
 
@@ -69,29 +68,28 @@ Removes the X-HNH-FILENAME attribute, and sets PRODID to
    (let ((kvs (map (lambda (key) (list key (attr comp key)))
                    (filter (negate (cut key=? <> 'X-HNH-FILENAME))
                            (attributes comp)))))
-     (for-each-in
-      kvs (lambda (kv)
-            (let* (((key value) kv))
-              (catch 'wrong-type-arg
-                (lambda ()
-                  (format port "~a:~a~%" key
-                          (string->ics-safe-string
-                           (or (case key
-                                 ((DTSTART DTEND)
-                                  (if (string? value)
-                                      value
-                                      (time->string value "~Y~m~dT~H~M~S")))
+     (for kv in kvs
+          (let* (((key value) kv))
+            (catch 'wrong-type-arg
+              (lambda ()
+                (format port "~a:~a~%" key
+                        (string->ics-safe-string
+                         (or (case key
+                               ((DTSTART DTEND)
+                                (if (string? value)
+                                    value
+                                    (time->string value "~Y~m~dT~H~M~S")))
 
-                                 ((DURATION) "Just forget it")
+                               ((DURATION) "Just forget it")
 
-                                 (else value))
-                               ""))))
+                               (else value))
+                             ""))))
 
-                ;; Catch
-                (lambda (type proc fmt . args)
-                  (apply format (current-error-port) "[ERR] ~a in ~a (~a) ~a:~%~?~%"
-                         type key proc (attr comp 'X-HNH-FILENAME)
-                         fmt args))))))
+              ;; Catch
+              (lambda (type proc fmt . args)
+                (apply format (current-error-port) "[ERR] ~a in ~a (~a) ~a:~%~?~%"
+                       type key proc (attr comp 'X-HNH-FILENAME)
+                       fmt args)))))
 
      (for-each (cut serialize-vcomponent <> port) (children comp)))
    (format port "END:~a~%" (type comp))))
diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm
index 0b62d134..15e03f9c 100644
--- a/module/vcomponent/recurrence/parse.scm
+++ b/module/vcomponent/recurrence/parse.scm
@@ -7,7 +7,7 @@
   #:duplicates (last)                   ; Replace @var{count}
   #:use-module (vcomponent recurrence internal)
   #:use-module (util)
-  #:use-module (exceptions)
+  #:use-module (util exceptions)
   #:use-module (ice-9 curried-definitions)
   #:export (parse-recurrence-rule))