From 13c37a9a7cc0e781a508462d8621e059de73abce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 4 May 2020 19:31:41 +0200 Subject: All warning procedures now uses warning system. --- module/output/html.scm | 11 +- module/util/exceptions.scm | 7 +- module/vcomponent/parse.scm | 357 ++++++++++++++++----------------- module/vcomponent/recurrence/parse.scm | 17 +- 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 -- cgit v1.2.3