All warning procedures now uses warning system.

4 files changed, 193 insertions, 199 deletions

diff --git a/module/output/html.scm b/module/output/html.scm
index eb675005..3b17d81b 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -374,6 +374,12 @@
                          it))))
          "."))
 
+(define (format-description ev str)
+  (catch #t (lambda () ((get-config 'description-filter) ev str))
+    (lambda (err . args)
+      (warning "~a on formatting description, ~s" err args)
+      str)))
+
 
 ;; For sidebar, just text
 (define* (fmt-single-event ev
@@ -401,10 +407,7 @@
                            ,(string-map (lambda (c) (if (char=? c #\,) #\newline c))
                                         (attr ev 'LOCATION)))))
              ,(and=> (attr ev 'DESCRIPTION)
-                     (lambda (str) (catch #t (lambda () ((get-config 'description-filter) ev str))
-                                (lambda (err . args)
-                                  (warning "~a on formatting description, ~s" err args)
-                                  str))))
+                     (lambda (str) (format-description ev str)))
              ,(awhen (attr ev 'RRULE)
                      (format-recurrence-rule ev))
              ,(when (attr ev 'LAST-MODIFIED)
diff --git a/module/util/exceptions.scm b/module/util/exceptions.scm
index 09bd3f97..41efaff5 100644
--- a/module/util/exceptions.scm
+++ b/module/util/exceptions.scm
@@ -43,11 +43,12 @@
 (define-public warning-handler
   (make-parameter
    (lambda (fmt . args)
-     (format (current-error-port)
-             "WARNING: ~?~%" fmt args))))
+     (format #f "WARNING: ~?~%" fmt args))))
 
 
 ;; forwards return from warning-hander. By default returns an unspecified value,
 ;; but instances are free to provide a proper return value and use it.
 (define-public (warning fmt . args)
-  (apply (warning-handler) fmt (or args '())))
+  (display (apply (warning-handler) fmt (or args '()))
+           (current-error-port)))
+
diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm
index e98761c7..a3e88816 100644
--- a/module/vcomponent/parse.scm
+++ b/module/vcomponent/parse.scm
@@ -14,6 +14,7 @@
   :use-module (util)
   :use-module (util time)
   :use-module (util strbuf)
+  :use-module (util exceptions)
   :use-module (vcomponent base)
   :use-module (vcomponent datetime)
   :use-module (datetime util)
@@ -130,195 +131,189 @@
       (let ((component (make-vcomponent))
             (ctx (make-parse-ctx (port-filename port)))
             (strbuf (make-strbuf)))
-        ;; TODO this would be a good candidate for a parameter,
-        ;; allowing any function to call warning whenever, but easily
-        ;; allowing a parent function to override waring with their
-        ;; own which can provide extra context.
-        (define (warning fmt . args)
-          (display
-           (format #f
-                   "== PARSE WARNING ==
+        (parameterize ((warning-handler
+                        (lambda (fmt . args)
+                          (format #f
+                                  "== PARSE WARNING ==
 filename = ~a
 row ~a	column ~a	ctx = ~a
 ~a ; ~a = ... : ...
 ~?~%~%"
-                   (get-filename ctx)
-                   (get-row ctx) (get-col ctx) (get-ctx ctx)
-                   (get-line-key ctx) (get-param-key ctx)
-                   fmt args)
-           (current-error-port)))
-
-        (with-throw-handler #t
-          (lambda ()
-            (while #t
-              (let ((c (get-u8 (current-input-port))))
-                (cond
-
-                 ;; End of file
-                 [(eof-object? c)
-                  ;; == NOTE ==
-                  ;; We never check the final line here. But since it
-                  ;; ALWAYS should be "END:VCOMPONENT", and we do all
-                  ;; the setup at creation this shouldn't be a problem.
-                  (let ((component
-                         (case (get-ctx ctx)
-                           ;; Line ended before we came here, get the actual root
-                           ;; component (instead of our virtual one:
-                           [(key) (car (children component))]
-                           ;; Line wasn't ended before we get here, so our current
-                           ;; component is our "actual" root. NOTE that this never
-                           ;; actually finalizes the root object, which matters if
-                           ;; if do something with the finalizer below.
-                           ;; At the time of writing we just set the parent.
-                           [(value) component]
-                           [else
-                            => (lambda (a)
-                                 (scm-error
-                                  'wrong-type-arg "parse-break"
-                                  (string-append
-                                   "Bad context at end of file. "
-                                   "Expected `key' or `value', got ~a")
-                                  (list a) #f))])))
+                                  (get-filename ctx)
+                                  (get-row ctx) (get-col ctx) (get-ctx ctx)
+                                  (get-line-key ctx) (get-param-key ctx)
+                                  fmt args))))
+          (with-throw-handler #t
+            (lambda ()
+              (while #t
+                (let ((c (get-u8 (current-input-port))))
+                  (cond
+
+                   ;; End of file
+                   [(eof-object? c)
                     ;; == NOTE ==
-                    ;; This sets to the VCALENDAR, which is correct,
-                    ;; but the program later squashes together everything
-                    ;; and drops this information.
-                    (set! (attr component 'X-HNH-FILENAME) (get-filename ctx)
-                          (parent component) #f)
-                    (break component))]
-
-                 ;; End of line
-                 [(memv (integer->char c) '(#\return #\newline))
-                  (case (fold-proc ctx c)
-                    [(end-of-line)
-                     (let ((str (strbuf->string strbuf)))
-                       (cond [(and (eq? 'key (get-ctx ctx))
-                                   (string-null? str))
-                              ;; I believe that an empty line is against the standard
-                              ;; in every way. But it's nice to handle it.
-                              (warning "Unexpected completely empty line")]
-
-                             [(eq? 'BEGIN (get-line-key ctx))
-                              (let ((child (make-vcomponent (string->symbol str))))
-                                (add-child! component child)
-                                (set! component child))]
-
-                             [(eq? (get-line-key ctx) 'END)
-
-                              ;; Ensure that we have a DTEND
-                              ;; TODO Objects aren't required to have a DTEND, or a DURATION.
-                              ;; write fancier code which acknoledges this.
-                              (when (and (eq? 'VEVENT (type component))
-                                         (not (attr component 'DTEND)))
-                                (set! (attr component 'DTEND)
-                                  (let ((start (attr component 'DTSTART)))
-                                    ;; p. 54, 3.6.1
-                                    ;; If DTSTART is a date then it's an all
-                                    ;; day event. If DTSTART instead is a
-                                    ;; datetime then the event has a length
-                                    ;; of 0?
-                                    (if (date? start)
-                                        (date+ start (date day: 1))
-                                        (datetime+ start (datetime time: (time hour: 1)))))))
-
-                              (set! component (parent component))]
-
-                             [else      ; Regular key-value line
-                              (let ((key (get-line-key ctx))
-                                    (vline (make-vline str (get-param-table ctx))))
-                                ;; Type specific processing
-                                (handle-value! key vline strbuf)
-
-                                ;; From RFC 5545 §3.6.1
-                                ;; DTEND and DURATION are mutually exclusive
-                                ;; DTSTART is required to exist while the other two are optional.
-
-                                ;; Allowed (some) repeated keys
-                                (if (memv key '(EXDATE ATTENDEE))
-                                    (aif (attr* component key)
-                                         ;; updates the current vline
-                                         ;; NOTE that this discards any properties belonging to this object
-                                         ;; TODO a more propper way to do it would be to store multiple vline
-                                         ;; objects for a given key.
-                                         (set! (value it) (cons (value vline) (value it)))
-                                         (begin (mod! (value vline) list)
-                                                (set-vline! component key vline)))
-                                    ;; Keys which aren't allowed to be repeated.
-                                    (begin
-                                      (awhen (attr* component key)
-                                             (warning "Key ~a encountered more than once, overriding old value [~a] with [~a]"
-                                                      key (value it) (value vline)))
-                                      (set-vline! component key vline))))
-                              (set-param-table! ctx (make-hash-table))])
-
-                       (strbuf-reset! strbuf)
-                       (ctx-dump-strings! ctx)
-                       (set-ctx! ctx 'key))]
-                    [(fold) 'noop]     ; Good case, here to catch errors in else
-                    [else => (lambda (a) (error "Bad return from fold, unexpected" a))])]
-
-                 ;; Escaped characters
-                 [(char=? #\\ (integer->char c))
-                  (case (integer->char (get-u8 (current-input-port)))
-                    ;; Escape character '\' and escaped token sepparated by a newline
-                    ;; (since the standard for some reason allows that (!!!))
-                    ;; We are at least guaranteed that it's a folded line, so just
-                    ;; unfold it and continue trying to find a token to escape.
-                    [(#\return #\newline)
-                     => (lambda (c)
-                          (case (fold-proc ctx (char->integer c))
-                            [(end-of-line)
-                             (throw 'escape-error "ESC before not folded line")]
-                            [(fold)
-                             (increment-column! ctx)
-                             (strbuf-append! strbuf (get-u8 (current-input-port)))]))]
-
-                    [(#\n #\N) (strbuf-append! strbuf (char->integer #\newline))]
-                    [(#\; #\, #\\) => (lambda (c) (strbuf-append! strbuf (char->integer c)))]
-                    [else => (lambda (c) (warning "Non-escapable character: ~a" c))])
-                  (increment-column! ctx)]
-
-                 ;; Delimiter between param key and param value
-                 [(and (eq? (get-ctx ctx) 'param-name)
-                       (char=? #\= (integer->char c)))
-                  (set-param-key! ctx (string->symbol (strbuf->string strbuf)))
-                  (strbuf-reset! strbuf)
-                  (set-ctx! ctx 'param-value)]
-
-                 ;; Delimiter between parameters (;), or between
-                 ;; "something" and attribute value (:)
-                 [(and (memv (integer->char c) '(#\: #\;))
-                       (memv (get-ctx ctx) '(param-value key)))
-                  (case (get-ctx ctx)
-                    [(param-value)
-                     (hashq-set! (get-param-table ctx)
-                                 (get-param-key ctx)
-                                 (strbuf->string strbuf))
-                     (strbuf-reset! strbuf)]
-                    [(key)
-                     (set-line-key! ctx (string->symbol (strbuf->string strbuf)))
-                     (strbuf-reset! strbuf)])
-
-                  (set-ctx! ctx (case (integer->char c)
-                                  [(#\:) 'value]
-                                  [(#\;) 'param-name]))]
-
-                 ;; Regular character
-                 [else
-                  (strbuf-append! strbuf c)
-                  (increment-column! ctx)]))))
-
-          (lambda _
-            ;; display is atomic, format isn't
-            (display
-             (format #f
-                     "== PARSE ERROR ==
+                    ;; We never check the final line here. But since it
+                    ;; ALWAYS should be "END:VCOMPONENT", and we do all
+                    ;; the setup at creation this shouldn't be a problem.
+                    (let ((component
+                           (case (get-ctx ctx)
+                             ;; Line ended before we came here, get the actual root
+                             ;; component (instead of our virtual one:
+                             [(key) (car (children component))]
+                             ;; Line wasn't ended before we get here, so our current
+                             ;; component is our "actual" root. NOTE that this never
+                             ;; actually finalizes the root object, which matters if
+                             ;; if do something with the finalizer below.
+                             ;; At the time of writing we just set the parent.
+                             [(value) component]
+                             [else
+                              => (lambda (a)
+                                   (scm-error
+                                    'wrong-type-arg "parse-break"
+                                    (string-append
+                                     "Bad context at end of file. "
+                                     "Expected `key' or `value', got ~a")
+                                    (list a) #f))])))
+                      ;; == NOTE ==
+                      ;; This sets to the VCALENDAR, which is correct,
+                      ;; but the program later squashes together everything
+                      ;; and drops this information.
+                      (set! (attr component 'X-HNH-FILENAME) (get-filename ctx)
+                            (parent component) #f)
+                      (break component))]
+
+                   ;; End of line
+                   [(memv (integer->char c) '(#\return #\newline))
+                    (case (fold-proc ctx c)
+                      [(end-of-line)
+                       (let ((str (strbuf->string strbuf)))
+                         (cond [(and (eq? 'key (get-ctx ctx))
+                                     (string-null? str))
+                                ;; I believe that an empty line is against the standard
+                                ;; in every way. But it's nice to handle it.
+                                (warning "Unexpected completely empty line")]
+
+                               [(eq? 'BEGIN (get-line-key ctx))
+                                (let ((child (make-vcomponent (string->symbol str))))
+                                  (add-child! component child)
+                                  (set! component child))]
+
+                               [(eq? (get-line-key ctx) 'END)
+
+                                ;; Ensure that we have a DTEND
+                                ;; TODO Objects aren't required to have a DTEND, or a DURATION.
+                                ;; write fancier code which acknoledges this.
+                                (when (and (eq? 'VEVENT (type component))
+                                           (not (attr component 'DTEND)))
+                                  (set! (attr component 'DTEND)
+                                    (let ((start (attr component 'DTSTART)))
+                                      ;; p. 54, 3.6.1
+                                      ;; If DTSTART is a date then it's an all
+                                      ;; day event. If DTSTART instead is a
+                                      ;; datetime then the event has a length
+                                      ;; of 0?
+                                      (if (date? start)
+                                          (date+ start (date day: 1))
+                                          (datetime+ start (datetime time: (time hour: 1)))))))
+
+                                (set! component (parent component))]
+
+                               [else     ; Regular key-value line
+                                (let ((key (get-line-key ctx))
+                                      (vline (make-vline str (get-param-table ctx))))
+                                  ;; Type specific processing
+                                  (handle-value! key vline strbuf)
+
+                                  ;; From RFC 5545 §3.6.1
+                                  ;; DTEND and DURATION are mutually exclusive
+                                  ;; DTSTART is required to exist while the other two are optional.
+
+                                  ;; Allowed (some) repeated keys
+                                  (if (memv key '(EXDATE ATTENDEE))
+                                      (aif (attr* component key)
+                                           ;; updates the current vline
+                                           ;; NOTE that this discards any properties belonging to this object
+                                           ;; TODO a more propper way to do it would be to store multiple vline
+                                           ;; objects for a given key.
+                                           (set! (value it) (cons (value vline) (value it)))
+                                           (begin (mod! (value vline) list)
+                                                  (set-vline! component key vline)))
+                                      ;; Keys which aren't allowed to be repeated.
+                                      (begin
+                                        (awhen (attr* component key)
+                                               (warning "Key ~a encountered more than once, overriding old value [~a] with [~a]"
+                                                        key (value it) (value vline)))
+                                        (set-vline! component key vline))))
+                                (set-param-table! ctx (make-hash-table))])
+
+                         (strbuf-reset! strbuf)
+                         (ctx-dump-strings! ctx)
+                         (set-ctx! ctx 'key))]
+                      [(fold) 'noop]    ; Good case, here to catch errors in else
+                      [else => (lambda (a) (error "Bad return from fold, unexpected" a))])]
+
+                   ;; Escaped characters
+                   [(char=? #\\ (integer->char c))
+                    (case (integer->char (get-u8 (current-input-port)))
+                      ;; Escape character '\' and escaped token sepparated by a newline
+                      ;; (since the standard for some reason allows that (!!!))
+                      ;; We are at least guaranteed that it's a folded line, so just
+                      ;; unfold it and continue trying to find a token to escape.
+                      [(#\return #\newline)
+                       => (lambda (c)
+                            (case (fold-proc ctx (char->integer c))
+                              [(end-of-line)
+                               (throw 'escape-error "ESC before not folded line")]
+                              [(fold)
+                               (increment-column! ctx)
+                               (strbuf-append! strbuf (get-u8 (current-input-port)))]))]
+
+                      [(#\n #\N) (strbuf-append! strbuf (char->integer #\newline))]
+                      [(#\; #\, #\\) => (lambda (c) (strbuf-append! strbuf (char->integer c)))]
+                      [else => (lambda (c) (warning "Non-escapable character: ~a" c))])
+                    (increment-column! ctx)]
+
+                   ;; Delimiter between param key and param value
+                   [(and (eq? (get-ctx ctx) 'param-name)
+                         (char=? #\= (integer->char c)))
+                    (set-param-key! ctx (string->symbol (strbuf->string strbuf)))
+                    (strbuf-reset! strbuf)
+                    (set-ctx! ctx 'param-value)]
+
+                   ;; Delimiter between parameters (;), or between
+                   ;; "something" and attribute value (:)
+                   [(and (memv (integer->char c) '(#\: #\;))
+                         (memv (get-ctx ctx) '(param-value key)))
+                    (case (get-ctx ctx)
+                      [(param-value)
+                       (hashq-set! (get-param-table ctx)
+                                   (get-param-key ctx)
+                                   (strbuf->string strbuf))
+                       (strbuf-reset! strbuf)]
+                      [(key)
+                       (set-line-key! ctx (string->symbol (strbuf->string strbuf)))
+                       (strbuf-reset! strbuf)])
+
+                    (set-ctx! ctx (case (integer->char c)
+                                    [(#\:) 'value]
+                                    [(#\;) 'param-name]))]
+
+                   ;; Regular character
+                   [else
+                    (strbuf-append! strbuf c)
+                    (increment-column! ctx)]))))
+
+            (lambda _
+              ;; display is atomic, format isn't
+              (display
+               (format #f
+                       "== PARSE ERROR ==
 filename = ~a
 row ~a	column ~a	ctx = ~a
 ~a ; ~a = ... : ...~%~%"
-                     (get-filename ctx)
-                     (get-row ctx) (get-col ctx) (get-ctx ctx)
-                     (get-line-key ctx) (get-param-key ctx)))))))))
+                       (get-filename ctx)
+                       (get-row ctx) (get-col ctx) (get-ctx ctx)
+                       (get-line-key ctx) (get-param-key ctx))))))))))
 
 
 
diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm
index 36026899..c72ec367 100644
--- a/module/vcomponent/recurrence/parse.scm
+++ b/module/vcomponent/recurrence/parse.scm
@@ -9,6 +9,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (vcomponent recurrence internal)
   #:use-module (util)
+  #:use-module (util exceptions)
   #:use-module (ice-9 match))
 
 
@@ -52,10 +53,11 @@
        ,@(map (match-lambda
                 ((key guard '=> body ...)
                  `((,key) (if (not ,guard)
-                              (begin (warning (quote ,key)
-                                              (quote ,guard)
-                                              (list ,@guard)
-                                              )
+                              (begin (warning
+                                      "RRULE guard failed for key ~a~%    guard: ~a : ~s"
+                                      ,key ,guard (map (lambda (o) (if (procedure? o)
+                                                                  (procedure-name o)
+                                                                  o)) ,@guard))
                                      ,@else-clause)
                               (begin ,@body))))
                 ((key body ...)
@@ -64,13 +66,6 @@
                  `(else ,@body)))
               cases))))
 
-(define (warning key guard extra)
-  (display (format #f "Warning RRULE guard failed for key ~a~%    guard: ~a : ~s~%"
-                   key guard (map (lambda (o) (if (procedure? o)
-                                             (procedure-name o)
-                                             o)) extra))
-           (current-error-port)))
-
 
 ;; RFC 5545, Section 3.3.10. Recurrence Rule, states that the UNTIL value MUST have
 ;; the same type as the DTSTART of the event (date or datetime). I have seen events