From 2d78e18454545801fbf3ac02c1d32ea68ef65de2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 25 Apr 2019 11:39:38 +0200 Subject: Clean up util and move exceptions. --- module/exceptions.scm | 5 --- module/util.scm | 78 +++++++--------------------------- module/util/exceptions.scm | 40 +++++++++++++++++ module/vcomponent/output.scm | 58 ++++++++++++------------- module/vcomponent/recurrence/parse.scm | 2 +- 5 files changed, 84 insertions(+), 99 deletions(-) delete mode 100644 module/exceptions.scm create mode 100644 module/util/exceptions.scm 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)) -- cgit v1.2.3