From 228d485e10f44b402843badabba4f09599f3c2a3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 5 May 2020 21:34:52 +0200 Subject: Change to only call get-datetime in parse. --- module/datetime.scm | 56 +++++++++++++++++------------------------- module/datetime/util.scm | 5 ++-- module/output/html.scm | 4 +-- module/vcomponent/datetime.scm | 8 +++--- module/vcomponent/parse.scm | 12 +++++++-- 5 files changed, 41 insertions(+), 44 deletions(-) diff --git a/module/datetime.scm b/module/datetime.scm index 0cca216b..b2a3d38e 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -188,7 +188,7 @@ [else (error "Object not a date, time, or datetime object ~a" date/-time)])) (define-public (as-time date/-time) - (cond [(datetime? date/-time) (get-time% (get-datetime date/-time))] + (cond [(datetime? date/-time) (get-time% date/-time)] [(date? date/-time) (time)] [(time? date/-time) date/-time] [else (error "Object not a date, time, or datetime object ~a" date/-time)])) @@ -219,10 +219,8 @@ (= (second a) (second b)))) (define-public (datetime= a b) - (let ((a (get-datetime a)) - (b (get-datetime b))) - (and (date= (get-date a) (get-date b)) - (time= (get-time% a) (get-time% b))))) + (and (date= (get-date a) (get-date b)) + (time= (get-time% a) (get-time% b)))) (define-many define-public (date=?) date= @@ -276,18 +274,14 @@ (time< a b))) (define-public (datetime< a b) - (let ((a (get-datetime a)) - (b (get-datetime b))) - (if (date= (get-date a) (get-date b)) - (time< (get-time% a) (get-time% b)) - (date< (get-date a) (get-date b))))) + (if (date= (get-date a) (get-date b)) + (time< (get-time% a) (get-time% b)) + (date< (get-date a) (get-date b)))) (define-public (datetime<= a b) - (let ((a (get-datetime a)) - (b (get-datetime b))) - (if (date= (get-date a) (get-date b)) - (time<= (get-time% a) (get-time% b)) - (date<= (get-date a) (get-date b))))) + (if (date= (get-date a) (get-date b)) + (time<= (get-time% a) (get-time% b)) + (date<= (get-date a) (get-date b)))) (define-public (date/-time< a b) (datetime< (as-datetime a) (as-datetime b))) @@ -560,15 +554,13 @@ ;; NOTE that base is re-normalized, but change isn't. This is due to base ;; hopefully being a real date, but change just being a difference. (define-public (datetime+ base change) - (let (; (base (get-datetime base)) - ) - (let* ((time overflow (time+ (get-time% base) (get-time% change)))) - (datetime date: (date+ (get-date base) - (get-date change) - (date day: overflow)) - time: time - tz: (get-timezone base) - )))) + (let* ((time overflow (time+ (get-time% base) (get-time% change)))) + (datetime date: (date+ (get-date base) + (get-date change) + (date day: overflow)) + time: time + tz: (get-timezone base) + ))) ;; (define (datetime->srfi-19-date date) ;; ((@ (srfi srfi-19) make-date) @@ -658,16 +650,14 @@ (day = (- 1))))) -(define-public (datetime-difference end* start*) +(define-public (datetime-difference end start) ;; NOTE Makes both start and end datetimes in the current local time. - (let ((end (get-datetime end*)) - (start (get-datetime 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)) - time: fixed-time)))) + (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)) + time: fixed-time))) diff --git a/module/datetime/util.scm b/module/datetime/util.scm index 910c42d3..d310992c 100644 --- a/module/datetime/util.scm +++ b/module/datetime/util.scm @@ -157,9 +157,8 @@ str))) (define*-public (datetime->string datetime optional: (fmt "~Y-~m-~dT~H:~M:~S") key: allow-unknown?) - (define dt (get-datetime datetime)) - (define date (get-date dt)) - (define time ((@ (datetime) get-time%) dt)) + (define date (get-date datetime)) + (define time ((@ (datetime) get-time%) datetime)) (with-output-to-string (lambda () (fold (lambda (token state) diff --git a/module/output/html.scm b/module/output/html.scm index 3b17d81b..6dc9591b 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -234,12 +234,12 @@ (make-block ev `((class - ,(when (date 2 elements - (let ((start (get-datetime (attr e 'DTSTART))) - (end (get-datetime (attr e 'DTEND)))) + (let ((start (attr e 'DTSTART)) + (end (attr e 'DTEND))) (cond [(and (date= (as-date start) (as-date end)) (date= (as-date start) diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index b5bb17e9..a21d6ca1 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -118,10 +118,18 @@ (let ((type (and=> (prop vline 'VALUE) car))) (if (or (and=> type (cut string=? <> "DATE-TIME")) (string-contains (value vline) "T")) - (set! (value vline) (parse-ics-datetime (value vline) tz) + ;; TODO TODO TODO + ;; we move all parsed datetimes to local time here. This + ;; gives a MASSIVE performance boost over calling get-datetime + ;; in all procedures which want to guarantee local time for proper calculations. + ;; 20s vs 70s runtime on my laptop. + ;; We sohuld however save the original datetime in a file like X-HNH-DTSTART, + ;; since we don't want to lose that information. + (set! (value vline) (get-datetime (parse-ics-datetime (value vline) tz)) (prop vline 'VALUE) 'DATE-TIME) (set! (value vline) (parse-ics-date (value vline)) - (prop vline 'VALUE) 'DATE))))])) + (prop vline 'VALUE) 'DATE))) + )])) ;; Reads a vcomponent from the given port. (define-public (parse-calendar port) -- cgit v1.2.3 From 1eadb9ad346e7326cea9b88ba92ecd24d672e400 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 6 May 2020 12:43:28 +0200 Subject: Made benchmark main runnable again. --- module/entry-points/benchmark.scm | 8 ++++---- module/entry-points/html.scm | 5 ++++- module/output/html.scm | 2 ++ 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/module/entry-points/benchmark.scm b/module/entry-points/benchmark.scm index 4843a80a..701d786b 100644 --- a/module/entry-points/benchmark.scm +++ b/module/entry-points/benchmark.scm @@ -3,15 +3,15 @@ :use-module (ice-9 getopt-long) :use-module (util) - :use-module (vcomponent) + :use-module (util app) ) (define opt-spec - '((file (value #t) (single-char #\f)))) + '()) (define (main args) (define opts (getopt-long args opt-spec)) - (cond [(option-ref opts 'file #f) => (compose load-calendars* list)] - [else (load-calendars)])) + (write (getf 'calendars app: (current-app))) +) diff --git a/module/entry-points/html.scm b/module/entry-points/html.scm index e03e5907..1237f628 100644 --- a/module/entry-points/html.scm +++ b/module/entry-points/html.scm @@ -66,4 +66,7 @@ [(table) (html-table-main count start)] [else - (error "Unknown html style: ~a" style)])) + (error "Unknown html style: ~a" style)]) + + ((@ (util time) report-time!) "all done") + ) diff --git a/module/output/html.scm b/module/output/html.scm index 6dc9591b..31b57228 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -783,6 +783,8 @@ (define calendars (getf 'calendars)) (define events (getf 'event-set)) + ((@ (util time) report-time!) "html start") + ;; TODO This still doesn't account for PWD, file existing but is of ;; wrong type, html directory existing but static symlink missing, ;; static being a different file type, and probably something else -- cgit v1.2.3 From 17417228af681fabfeaa49b75d7c04f1838e8e4f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 8 May 2020 19:35:37 +0200 Subject: Remove unused with-vline-tz. --- module/vcomponent/parse.scm | 4 ---- 1 file changed, 4 deletions(-) diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index a21d6ca1..2fdd03a8 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -54,10 +54,6 @@ ;; (set-param-table! ctx (make-hash-table)) ) -(define-macro (with-vline-tz object . body) - `(let-env ((TZ (and=> (prop ,object 'TZID) car))) - ,@body)) - -- cgit v1.2.3 From 2cfbec3682b93cdf20e7c1135222070acec634b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 9 May 2020 02:53:24 +0200 Subject: Move vcalendar parse code into own file. --- .gitignore | 1 - module/vcomponent/parse.scm | 310 +-------------------------------------- module/vcomponent/parse/old.scm | 315 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 319 insertions(+), 307 deletions(-) create mode 100644 module/vcomponent/parse/old.scm diff --git a/.gitignore b/.gitignore index fe87e20e..a6b94637 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,2 @@ -parse *.x html diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 2fdd03a8..94eaaef2 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -1,323 +1,21 @@ (define-module (vcomponent parse) - :use-module ((rnrs io ports) :select (get-u8)) :use-module (rnrs bytevectors) :use-module (srfi srfi-1) - :use-module (srfi srfi-9) - :use-module (datetime) - :use-module (datetime util) - :use-module (srfi srfi-26) + :use-module ((ice-9 hash-table) :select (alist->hash-table)) :use-module ((ice-9 rdelim) :select (read-line)) - :use-module ((ice-9 textual-ports) :select (unget-char)) :use-module ((ice-9 ftw) :select (scandir ftw)) :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) - ) - -(use-modules ((rnrs base) #:select (assert))) - - - -(define-record-type - (make-parse-ctx% filename row col ctx line-key param-key param-table) - parse-ctx? - (filename get-filename) ; string - (row get-row set-row!) ; [0, ] - (col get-col set-col!) ; [1, ) - (ctx get-ctx set-ctx!) ; '(key value param-name param-value escape) - (line-key get-line-key set-line-key!) ; string - (param-key get-param-key set-param-key!) ; string - (param-table get-param-table set-param-table!) ; hash-map + :use-module (vcomponent parse old) + :re-export (parse-calendar) ) -(define (make-parse-ctx filename) - (make-parse-ctx% filename 1 0 'key - #f #f (make-hash-table))) - -(define (increment-column! ctx) - (set-col! ctx (1+ (get-col ctx)))) - -(define (increment-row! ctx) - (set-col! ctx 0) - (set-row! ctx (1+ (get-row ctx)))) - -(define (ctx-dump-strings! ctx) - (set-line-key! ctx "") - (set-param-key! ctx "") - ;; (set-param-table! ctx (make-hash-table)) - ) - - - - -(define (fold-proc ctx c) - ;; First extra character optional read is to get the \n if our line - ;; ended with \r\n. Secound read is to get the first character of the - ;; next line. The initial \r which might recide in @var{c} is discarded. - (let ((pair (cons (if (char=? #\newline (integer->char c)) - c (get-u8 (current-input-port))) - (get-u8 (current-input-port))))) - (increment-row! ctx) - (cond [(not (char=? #\newline (integer->char (car pair)))) - (error "Expected newline after CR")] - - ;; The standard (3.4, l. 2675) says that each icalobject must - ;; end with CRLF. My files however does not. This means that - ;; an EOF can immideately follow a \n\r pair. But this case is the - ;; same as that we are at the end of line, so we spoof it and let - ;; the regular parser loop handle it. - [(eof-object? (cdr pair)) - 'end-of-line] - - ;; Following line begins with a whitespace character, - ;; meaning that we don't break the logical line here. - [(memv (integer->char (cdr pair)) '(#\space #\tab)) - (increment-column! ctx) ; since we just read the space - 'fold] - - [else - ;; TODO check if this failed, and signal a writeback error - (unget-char (current-input-port) - (integer->char (cdr pair))) - - 'end-of-line]))) - -(define (handle-value! key vline strbuf) - (case key - ;; As far as I can tell the RFC says nothing about special - ;; encoding for individual fields. It mentieons UTF-8, and - ;; that transfer encoding should be set in the mime-headers. - ;; That however seems like a breach of abstractions. - ;; Currently I allow a CHARSET property on SUMMARY fields, - ;; since I know that at least www.lysator.liu.se/alma/alma.cgi - ;; uses it. - [(SUMMARY) - (cond [(and=> (prop vline 'CHARSET) car) - => (lambda (encoding) - (set! (value vline) - (strbuf->string strbuf ((@ (rnrs io ports) make-transcoder) - encoding))))])] - - [(DTSTART DTEND RECURRENCE-ID LAST-MODIFIED DTSTAMP EXDATE) - - ;; '("Africa/Ceuta" "Europe/Stockholm" "local") - (let ((tz (or (and=> (prop vline 'TZID) car) - (and (string= "Z" (string-take-right (value vline) 1)) "UTC")))) - - (let ((type (and=> (prop vline 'VALUE) car))) - (if (or (and=> type (cut string=? <> "DATE-TIME")) - (string-contains (value vline) "T")) - ;; TODO TODO TODO - ;; we move all parsed datetimes to local time here. This - ;; gives a MASSIVE performance boost over calling get-datetime - ;; in all procedures which want to guarantee local time for proper calculations. - ;; 20s vs 70s runtime on my laptop. - ;; We sohuld however save the original datetime in a file like X-HNH-DTSTART, - ;; since we don't want to lose that information. - (set! (value vline) (get-datetime (parse-ics-datetime (value vline) tz)) - (prop vline 'VALUE) 'DATE-TIME) - (set! (value vline) (parse-ics-date (value vline)) - (prop vline 'VALUE) 'DATE))) - )])) - -;; Reads a vcomponent from the given port. -(define-public (parse-calendar port) - ;; (report-time! "Parsing ~a" port) - (with-input-from-port port - (lambda () - (let ((component (make-vcomponent)) - (ctx (make-parse-ctx (port-filename port))) - (strbuf (make-strbuf))) - (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)))) - (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))]))) - ;; == 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)))))))))) +(use-modules ((rnrs base) #:select (assert))) diff --git a/module/vcomponent/parse/old.scm b/module/vcomponent/parse/old.scm new file mode 100644 index 00000000..648f9bc5 --- /dev/null +++ b/module/vcomponent/parse/old.scm @@ -0,0 +1,315 @@ +(define-module (vcomponent parse old) + :use-module (util) + :use-module (util strbuf) + :use-module (util exceptions) + + :use-module ((rnrs io ports) :select (get-u8)) + :use-module ((ice-9 textual-ports) :select (unget-char)) + + :use-module (srfi srfi-1) + :use-module (srfi srfi-9) + :use-module (srfi srfi-26) + + :use-module (datetime) + :use-module (datetime util) + + :use-module (vcomponent base) + :use-module (vcomponent datetime) + ;; export (parse-calendar) +) + +(define-record-type + (make-parse-ctx% filename row col ctx line-key param-key param-table) + parse-ctx? + (filename get-filename) ; string + (row get-row set-row!) ; [0, ] + (col get-col set-col!) ; [1, ) + (ctx get-ctx set-ctx!) ; '(key value param-name param-value escape) + (line-key get-line-key set-line-key!) ; string + (param-key get-param-key set-param-key!) ; string + (param-table get-param-table set-param-table!) ; hash-map + ) + +(define (make-parse-ctx filename) + (make-parse-ctx% filename 1 0 'key + #f #f (make-hash-table))) + +(define (increment-column! ctx) + (set-col! ctx (1+ (get-col ctx)))) + +(define (increment-row! ctx) + (set-col! ctx 0) + (set-row! ctx (1+ (get-row ctx)))) + +(define (ctx-dump-strings! ctx) + (set-line-key! ctx "") + (set-param-key! ctx "") + ;; (set-param-table! ctx (make-hash-table)) + ) + + + + +(define (fold-proc ctx c) + ;; First extra character optional read is to get the \n if our line + ;; ended with \r\n. Secound read is to get the first character of the + ;; next line. The initial \r which might recide in @var{c} is discarded. + (let ((pair (cons (if (char=? #\newline (integer->char c)) + c (get-u8 (current-input-port))) + (get-u8 (current-input-port))))) + (increment-row! ctx) + (cond [(not (char=? #\newline (integer->char (car pair)))) + (error "Expected newline after CR")] + + ;; The standard (3.4, l. 2675) says that each icalobject must + ;; end with CRLF. My files however does not. This means that + ;; an EOF can immideately follow a \n\r pair. But this case is the + ;; same as that we are at the end of line, so we spoof it and let + ;; the regular parser loop handle it. + [(eof-object? (cdr pair)) + 'end-of-line] + + ;; Following line begins with a whitespace character, + ;; meaning that we don't break the logical line here. + [(memv (integer->char (cdr pair)) '(#\space #\tab)) + (increment-column! ctx) ; since we just read the space + 'fold] + + [else + ;; TODO check if this failed, and signal a writeback error + (unget-char (current-input-port) + (integer->char (cdr pair))) + + 'end-of-line]))) + +(define (handle-value! key vline strbuf) + (case key + ;; As far as I can tell the RFC says nothing about special + ;; encoding for individual fields. It mentieons UTF-8, and + ;; that transfer encoding should be set in the mime-headers. + ;; That however seems like a breach of abstractions. + ;; Currently I allow a CHARSET property on SUMMARY fields, + ;; since I know that at least www.lysator.liu.se/alma/alma.cgi + ;; uses it. + [(SUMMARY) + (cond [(and=> (prop vline 'CHARSET) car) + => (lambda (encoding) + (set! (value vline) + (strbuf->string strbuf ((@ (rnrs io ports) make-transcoder) + encoding))))])] + + [(DTSTART DTEND RECURRENCE-ID LAST-MODIFIED DTSTAMP EXDATE) + + ;; '("Africa/Ceuta" "Europe/Stockholm" "local") + (let ((tz (or (and=> (prop vline 'TZID) car) + (and (string= "Z" (string-take-right (value vline) 1)) "UTC")))) + + (let ((type (and=> (prop vline 'VALUE) car))) + (if (or (and=> type (cut string=? <> "DATE-TIME")) + (string-contains (value vline) "T")) + ;; TODO TODO TODO + ;; we move all parsed datetimes to local time here. This + ;; gives a MASSIVE performance boost over calling get-datetime + ;; in all procedures which want to guarantee local time for proper calculations. + ;; 20s vs 70s runtime on my laptop. + ;; We sohuld however save the original datetime in a file like X-HNH-DTSTART, + ;; since we don't want to lose that information. + (set! (value vline) (get-datetime (parse-ics-datetime (value vline) tz)) + (prop vline 'VALUE) 'DATE-TIME) + (set! (value vline) (parse-ics-date (value vline)) + (prop vline 'VALUE) 'DATE))) + )])) + +;; Reads a vcomponent from the given port. +(define-public (parse-calendar port) + ;; (report-time! "Parsing ~a" port) + (with-input-from-port port + (lambda () + (let ((component (make-vcomponent)) + (ctx (make-parse-ctx (port-filename port))) + (strbuf (make-strbuf))) + (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)))) + (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))]))) + ;; == 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)))))))))) + + -- cgit v1.2.3 From 41fecf53f49b7a1c63b5e66f9d244bb75e564875 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 9 May 2020 02:54:38 +0200 Subject: Add draft of new parser. --- module/vcomponent/parse/new.scm | 91 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 91 insertions(+) create mode 100644 module/vcomponent/parse/new.scm diff --git a/module/vcomponent/parse/new.scm b/module/vcomponent/parse/new.scm new file mode 100644 index 00000000..46660a9f --- /dev/null +++ b/module/vcomponent/parse/new.scm @@ -0,0 +1,91 @@ +(define-module (vcomponent parse new) + :use-module (util) + :use-module ((ice-9 rdelim) :select (read-line)) + :use-module (vcomponent base) + ) + + +;; (define f (open-input-file (car (glob "~/.local/var/cal/Calendar/c17*")))) +;; (parse (map tokenize (read-file file))) + +;; port → (list string) +(define (read-file port) + (let loop ((done '())) + (let ((line (read-line port))) + (if (eof-object? line) + (reverse! done) + (loop + (if (char=? #\space (string-ref line 0)) + (cons (string-append (car done) + (string-drop line 1)) + (cdr done)) + (cons line done))))))) + +;; (list string) → (list (key kv ... value)) +(define (tokenize line) + (define colon-idx (string-index line #\:)) + (define semi-idxs + (let loop ((idx 0)) + (aif (string-index line #\; idx colon-idx) + (cons it (loop (1+ it))) + (list colon-idx (string-length line))))) + (map (lambda (start end) + (substring line (1+ start) end)) + (cons -1 semi-idxs) + semi-idxs)) + + +;; (parse-itemline '("DTEND" "TZID=Europe/Stockholm" "VALUE=DATE-TIME" "20200407T130000")) +;; ⇒ #< value: "20200407T130000" parameters: #> +(define (parse-itemline itemline) + (define all + (reverse + (let loop ((rem (cdr itemline))) + (if (null? (cdr rem)) + rem ; (list (car rem)) + (let* ((kv (car rem)) + (idx (string-index kv #\=))) + (cons (cons (string->symbol (substring kv 0 idx)) + ;; NOTE handle value parsing here? + (substring kv (1+ idx))) + (loop (cdr rem)))))))) + + (make-vline% (car all) (alist->hashq-table (cdr all)))) + + + +(use-modules (srfi srfi-9)) +(define-record-type + (make-component% type children attributes parent) + component? + (type type) + (children children) + (attributes attributes)) + +(define (make-component args) + (let* ((type (car args)) + (children attributes (partition component? (cdr args)))) + (make-component% type children attributes))) + +;; (list (key kv ... value)) → +(define (parse lst) + (let loop ((lst lst) + (stack '())) + (if (null? lst) + stack + (let ((head (car lst))) + (cond [(string=? "BEGIN" (car head)) + (loop (cdr lst) (cons (list (string->symbol (cadr head))) stack))] + [(string=? "END" (car head)) + (loop (cdr lst) + (let* ((frame (reverse (car stack))) + (component (make-component frame))) + (if (null? (cdr stack)) + component + (cons (cons component (cadr stack)) + (cddr stack)))))] + [else + (loop (cdr lst) + (cons (cons (parse-itemline head) + (car stack)) + (cdr stack)))]))))) -- cgit v1.2.3 From bba0ac5316239f121e0413325c03090df7a97f2e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 9 May 2020 05:17:02 +0200 Subject: Set X-HNH-FILENAME outside parse-calendar. --- module/vcomponent/parse.scm | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 94eaaef2..b2332042 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -11,7 +11,7 @@ :use-module (util exceptions) :use-module (vcomponent base) - :use-module (vcomponent parse old) + :use-module (vcomponent parse new) :re-export (parse-calendar) ) @@ -39,6 +39,7 @@ (define-values (events other) (partition (lambda (e) (eq? 'VEVENT (type e))) (children item))) + ;; (assert (eq? 'VCALENDAR (type calendar))) (assert (eq? 'VCALENDAR (type item))) @@ -88,15 +89,17 @@ ;; return calendar) (make-vcomponent) - ((@ (ice-9 threads) par-map) (lambda (fname) - (let ((fullname (/ path fname))) - (let ((cal (call-with-input-file fullname - parse-calendar))) - (set! (attr cal 'COLOR) color - (attr cal 'NAME) name) - cal))) - (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) - (string= "ics" (string-take-right s 3)))))))))) + (map #; (@ (ice-9 threads) par-map) + (lambda (fname) + (let ((fullname (/ path fname))) + (let ((cal (call-with-input-file fullname + parse-calendar))) + (set! (attr cal 'COLOR) color + (attr cal 'NAME) name + (attr cal 'X-HNH-FILENAME) fullname) + cal))) + (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) + (string= "ics" (string-take-right s 3)))))))))) ;; Parse a vdir or ics file at the given path. (define-public (parse-cal-path path) -- cgit v1.2.3 From 7b79745666bc1564878192d501277298bdecde49 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 9 May 2020 05:17:17 +0200 Subject: Work on new parser, almost works. --- module/vcomponent/parse/new.scm | 126 ++++++++++++++++++++++++++++------------ 1 file changed, 90 insertions(+), 36 deletions(-) diff --git a/module/vcomponent/parse/new.scm b/module/vcomponent/parse/new.scm index 46660a9f..e87ed020 100644 --- a/module/vcomponent/parse/new.scm +++ b/module/vcomponent/parse/new.scm @@ -2,11 +2,20 @@ :use-module (util) :use-module ((ice-9 rdelim) :select (read-line)) :use-module (vcomponent base) + :use-module (datetime) + :use-module (srfi srfi-1) + :use-module (srfi srfi-26) + :use-module ((ice-9 hash-table) :select (alist->hashq-table)) ) +(define-public (parse-calendar port) + (let ((component (parse (map tokenize (read-file port))))) + ;; (set! (attr component 'X-HNH-FILENAME) (or (port-filename port) "MISSING")) + (link-parents! component) + component)) + ;; (define f (open-input-file (car (glob "~/.local/var/cal/Calendar/c17*")))) -;; (parse (map tokenize (read-file file))) ;; port → (list string) (define (read-file port) @@ -14,12 +23,13 @@ (let ((line (read-line port))) (if (eof-object? line) (reverse! done) - (loop - (if (char=? #\space (string-ref line 0)) - (cons (string-append (car done) - (string-drop line 1)) - (cdr done)) - (cons line done))))))) + (let ((line (string-trim-right line))) + (loop + (if (char=? #\space (string-ref line 0)) + (cons (string-append (car done) + (string-drop line 1)) + (cdr done)) + (cons line done)))))))) ;; (list string) → (list (key kv ... value)) (define (tokenize line) @@ -37,35 +47,69 @@ ;; (parse-itemline '("DTEND" "TZID=Europe/Stockholm" "VALUE=DATE-TIME" "20200407T130000")) ;; ⇒ #< value: "20200407T130000" parameters: #> +;; (define (parse-itemline itemline) +;; (define all +;; (reverse +;; (let loop ((rem (cdr itemline))) +;; (if (null? (cdr rem)) +;; rem ; (list (car rem)) +;; (let* ((kv (car rem)) +;; (idx (string-index kv #\=))) +;; (cons (cons (string->symbol (substring kv 0 idx)) +;; ;; NOTE handle value parsing here? +;; (substring kv (1+ idx))) +;; (loop (cdr rem)))))))) + +;; (make-vline% (car all) (alist->hashq-table (cdr all)))) + +(define (handle-value! key vline) + (case key + [(DTSTART DTEND RECURRENCE-ID LAST-MODIFIED DTSTAMP EXDATE) + + ;; '("Africa/Ceuta" "Europe/Stockholm" "local") + (let ((tz (or (and=> (prop vline 'TZID) car) + (and (string= "Z" (string-take-right (value vline) 1)) "UTC")))) + + (let ((type (and=> (prop vline 'VALUE) car))) + (if (or (and=> type (cut string=? <> "DATE-TIME")) + (string-contains (value vline) "T")) + ;; TODO TODO TODO + ;; we move all parsed datetimes to local time here. This + ;; gives a MASSIVE performance boost over calling get-datetime + ;; in all procedures which want to guarantee local time for proper calculations. + ;; 20s vs 70s runtime on my laptop. + ;; We sohuld however save the original datetime in a file like X-HNH-DTSTART, + ;; since we don't want to lose that information. + (set! (value vline) (get-datetime (parse-ics-datetime (value vline) tz)) + (prop vline 'VALUE) 'DATE-TIME) + (set! (value vline) (parse-ics-date (value vline)) + (prop vline 'VALUE) 'DATE))))]) + vline) + +;; (parse-itemline '("DTEND" "TZID=Europe/Stockholm" "VALUE=DATE-TIME" "20200407T130000")) +;; ⇒ (DTEND . #< value: #< date: 2020-04-07 time: 13:00:00 tz: #f> +;; parameters: #> (define (parse-itemline itemline) - (define all - (reverse - (let loop ((rem (cdr itemline))) - (if (null? (cdr rem)) - rem ; (list (car rem)) - (let* ((kv (car rem)) - (idx (string-index kv #\=))) - (cons (cons (string->symbol (substring kv 0 idx)) - ;; NOTE handle value parsing here? - (substring kv (1+ idx))) - (loop (cdr rem)))))))) - - (make-vline% (car all) (alist->hashq-table (cdr all)))) - - - -(use-modules (srfi srfi-9)) -(define-record-type - (make-component% type children attributes parent) - component? - (type type) - (children children) - (attributes attributes)) - -(define (make-component args) - (let* ((type (car args)) - (children attributes (partition component? (cdr args)))) - (make-component% type children attributes))) + (define key (string->symbol (car itemline))) + (let loop ((rem (cdr itemline)) + (done '())) + (if (null? (cdr rem)) + ;; TODO repeated keys + (cons key + (handle-value! + key (make-vline (car rem) + (alist->hashq-table done)))) + (let* ((kv (car rem)) + (idx (string-index kv #\=))) + (loop (cdr rem) + (cons (cons (string->symbol (substring kv 0 idx)) + (substring kv (1+ idx))) + done)))))) + + +(define (make-component type . children-and-attributes) + (let* ((children attributes (partition vcomponent? children-and-attributes))) + ((@@ (vcomponent base) make-vcomponent%) type children #f (alist->hashq-table attributes)))) ;; (list (key kv ... value)) → (define (parse lst) @@ -79,7 +123,7 @@ [(string=? "END" (car head)) (loop (cdr lst) (let* ((frame (reverse (car stack))) - (component (make-component frame))) + (component (apply make-component frame))) (if (null? (cdr stack)) component (cons (cons component (cadr stack)) @@ -89,3 +133,13 @@ (cons (cons (parse-itemline head) (car stack)) (cdr stack)))]))))) + +(define (link-parents! component) + (for child in (children component) + ((@@ (vcomponent base) set-component-parent!) child component) + (link-parents! child))) + + + +;; DTEND when missing in VEVENT +;; Repeated keys ('(EXDATE ATTENDEE)) -- cgit v1.2.3 From 6682ea207191419dbbf3a2849d8519c52ac5860a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 9 May 2020 13:31:23 +0200 Subject: New parser now works with old code. A DTEND filed is added as before. One of the EXDATE fields is saves as a list, the remaining are however thrown away. --- module/vcomponent/parse/new.scm | 27 +++++++++++++++++++++++---- 1 file changed, 23 insertions(+), 4 deletions(-) diff --git a/module/vcomponent/parse/new.scm b/module/vcomponent/parse/new.scm index e87ed020..9c97a7c8 100644 --- a/module/vcomponent/parse/new.scm +++ b/module/vcomponent/parse/new.scm @@ -83,7 +83,11 @@ (set! (value vline) (get-datetime (parse-ics-datetime (value vline) tz)) (prop vline 'VALUE) 'DATE-TIME) (set! (value vline) (parse-ics-date (value vline)) - (prop vline 'VALUE) 'DATE))))]) + (prop vline 'VALUE) 'DATE))) + ;; TOOD actually handle repeated keys + (when (eq? key 'EXDATE) + (set! (value vline) (list (value vline)))) + )]) vline) ;; (parse-itemline '("DTEND" "TZID=Europe/Stockholm" "VALUE=DATE-TIME" "20200407T130000")) @@ -108,8 +112,24 @@ (define (make-component type . children-and-attributes) - (let* ((children attributes (partition vcomponent? children-and-attributes))) - ((@@ (vcomponent base) make-vcomponent%) type children #f (alist->hashq-table attributes)))) + (define component + (let* ((children attributes (partition vcomponent? children-and-attributes))) + ((@@ (vcomponent base) make-vcomponent%) type children #f (alist->hashq-table attributes)))) + + ;; TODO This is an ugly hack until the rest of the code is updated + ;; to work on events without an explicit DTEND attribute. + (when (and (eq? type 'VEVENT) (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))))))) + component) ;; (list (key kv ... value)) → (define (parse lst) @@ -141,5 +161,4 @@ -;; DTEND when missing in VEVENT ;; Repeated keys ('(EXDATE ATTENDEE)) -- cgit v1.2.3 From b3bb50420a17987fcd0c4aec7a57df67a5b7d756 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 9 May 2020 13:44:53 +0200 Subject: Un-escape escaped characters. Slow? --- module/vcomponent/parse/new.scm | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/module/vcomponent/parse/new.scm b/module/vcomponent/parse/new.scm index 9c97a7c8..bba74316 100644 --- a/module/vcomponent/parse/new.scm +++ b/module/vcomponent/parse/new.scm @@ -1,5 +1,6 @@ (define-module (vcomponent parse new) :use-module (util) + :use-module (util exceptions) :use-module ((ice-9 rdelim) :select (read-line)) :use-module (vcomponent base) :use-module (datetime) @@ -86,8 +87,21 @@ (prop vline 'VALUE) 'DATE))) ;; TOOD actually handle repeated keys (when (eq? key 'EXDATE) - (set! (value vline) (list (value vline)))) - )]) + (set! (value vline) (list (value vline)))))] + + [else (set! (value vline) + (list->string + (let loop ((rem (string->list (value vline)))) + (if (null? rem) + '() + (if (char=? #\\ (car rem)) + (case (cadr rem) + [(#\n #\N) (cons #\newline (loop (cddr rem)))] + [(#\; #\, #\\) => (lambda (c) (cons c (loop (cddr rem))))] + [else => (lambda (c) (warning "Non-escapable character: ~a" c) + (loop (cddr rem)))]) + (cons (car rem) (loop (cdr rem))))) + ))) ]) vline) ;; (parse-itemline '("DTEND" "TZID=Europe/Stockholm" "VALUE=DATE-TIME" "20200407T130000")) -- cgit v1.2.3 From c1feb55a2013116c3291cf0df26f9ab39ad3e8c3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 9 May 2020 21:43:16 +0200 Subject: New parser now on feature parity with old. --- module/output/html.scm | 11 +- module/util/exceptions.scm | 21 +++- module/vcomponent/base.scm | 30 +++-- module/vcomponent/parse.scm | 2 - module/vcomponent/parse/new.scm | 171 ++++++++++++-------------- module/vcomponent/recurrence/generate-alt.scm | 5 +- tests/prop.scm | 4 +- tests/vcomponent.scm | 6 +- 8 files changed, 137 insertions(+), 113 deletions(-) diff --git a/module/output/html.scm b/module/output/html.scm index 31b57228..da5c0659 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -145,12 +145,17 @@ ,(fmt-single-event ev)))) +(define (->string a) + (format #f "~a" a)) + (define (data-attributes event) (hash-map->list (match-lambda* + [(key (vlines ...)) (list (string->symbol (format #f "data-~a" key)) + (string-join (map (compose ->string value) vlines) ","))] [(key vline) (list (string->symbol (format #f "data-~a" key)) - (format #f "~a" (value vline)))] + (->string (value vline)))] [_ (error "What are you doing‽")]) (attributes event))) @@ -354,7 +359,7 @@ ,((compose (@ (vcomponent recurrence display) format-recurrence-rule) (@ (vcomponent recurrence parse) parse-recurrence-rule)) (attr ev 'RRULE)) - ,@(awhen (attr ev 'EXDATE) + ,@(awhen (attr* ev 'EXDATE) (list ", undantaget " (add-enumeration-punctuation @@ -371,7 +376,7 @@ '(HOURLY MINUTELY SECONDLY)) (datetime->string d "~e ~b ~k:~M") (datetime->string d "~e ~b")))) - it)))) + (map value it))))) ".")) (define (format-description ev str) diff --git a/module/util/exceptions.scm b/module/util/exceptions.scm index 41efaff5..4673b182 100644 --- a/module/util/exceptions.scm +++ b/module/util/exceptions.scm @@ -2,7 +2,8 @@ #:use-module (srfi srfi-1) #:use-module (util) #:export (throw-returnable - catch-multiple)) + catch-multiple + assert)) (define-syntax-rule (throw-returnable symb args ...) (call/cc (lambda (cont) (throw symb cont args ...)))) @@ -52,3 +53,21 @@ (display (apply (warning-handler) fmt (or args '())) (current-error-port))) + +(define (prettify-tree tree) + (cond [(null? tree) '()] + [(pair? tree) (cons (prettify-tree (car tree)) + (prettify-tree (cdr tree)))] + [(list? tree) (map prettify-tree tree)] + [(and (procedure? tree) + (procedure-name tree)) + => identity] + [else tree])) + + + +(define-macro (assert form) + `(unless ,form + (throw 'assertion-error "Assertion for ~a failed, ~a" + (quote ,form) + ((@@ (util exceptions) prettify-tree) ,(cons 'list form))))) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index e0d7d11e..994ac197 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -11,8 +11,9 @@ ;; The type is a bit to many times refered to as a attr ptr. (define-record-type - (make-vline% value parameters) + (make-vline% key value parameters) vline? + (key vline-key) (value get-vline-value set-vline-value!) (parameters get-vline-parameters) ;; TODO Add slot for optional source object, containing @@ -21,8 +22,10 @@ ;; - source string, before value parsing. ) -(define*-public (make-vline value #:optional (ht (make-hash-table))) - (make-vline% value ht)) +(export vline-key) + +(define*-public (make-vline key value #:optional (ht (make-hash-table))) + (make-vline% key value ht)) (define-record-type (make-vcomponent% type children parent attributes) @@ -53,6 +56,7 @@ (set-component-children! parent (cons child (children parent))) (set-component-parent! child parent)) +;; TODO this doesn't handle multi-valued items (define* (get-attribute-value component key #:optional default) (cond [(hashq-ref (get-component-attributes component) key #f) @@ -67,7 +71,7 @@ (let ((ht (get-component-attributes component))) (cond [(hashq-ref ht key #f) => (lambda (vline) (set-vline-value! vline value))] - [else (hashq-set! ht key (make-vline value))]))) + [else (hashq-set! ht key (make-vline key value))]))) (define-public (set-vline! component key vline) (hashq-set! (get-component-attributes component) @@ -81,10 +85,19 @@ get-vline-value set-vline-value!)) ;; vcomponent x (or str symb) → vline -(define-public (attr* component attr) +(define (get-attr* component attr) (hashq-ref (get-component-attributes component) (as-symb attr))) +(define (set-attr*! component key value) + (hashq-set! (get-component-attributes component) + (as-symb key) value)) + +(define-public attr* + (make-procedure-with-setter + get-attr* + set-attr*!)) + ;; vcomponent x (or str symb) → value (define (get-attr component key) (get-attribute-value component (as-symb key) #f)) @@ -122,7 +135,8 @@ (map car (hash-map->list cons (get-component-attributes component)))) (define (copy-vline vline) - (make-vline (get-vline-value vline) + (make-vline (vline-key vline) + (get-vline-value vline) ;; TODO deep-copy on properties? (get-vline-parameters vline))) @@ -132,7 +146,9 @@ (parent component) ;; attributes (alist->hashq-table - (hash-map->list (lambda (key value) (cons key (copy-vline value))) + (hash-map->list (lambda (key value) (cons key (if (list? value) + (map copy-vline value) + (copy-vline value)))) (get-component-attributes component))))) (define-public (extract field) diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index b2332042..906936d9 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -15,8 +15,6 @@ :re-export (parse-calendar) ) -(use-modules ((rnrs base) #:select (assert))) - diff --git a/module/vcomponent/parse/new.scm b/module/vcomponent/parse/new.scm index bba74316..90614820 100644 --- a/module/vcomponent/parse/new.scm +++ b/module/vcomponent/parse/new.scm @@ -12,7 +12,6 @@ (define-public (parse-calendar port) (let ((component (parse (map tokenize (read-file port))))) ;; (set! (attr component 'X-HNH-FILENAME) (or (port-filename port) "MISSING")) - (link-parents! component) component)) @@ -45,35 +44,18 @@ (cons -1 semi-idxs) semi-idxs)) - -;; (parse-itemline '("DTEND" "TZID=Europe/Stockholm" "VALUE=DATE-TIME" "20200407T130000")) -;; ⇒ #< value: "20200407T130000" parameters: #> -;; (define (parse-itemline itemline) -;; (define all -;; (reverse -;; (let loop ((rem (cdr itemline))) -;; (if (null? (cdr rem)) -;; rem ; (list (car rem)) -;; (let* ((kv (car rem)) -;; (idx (string-index kv #\=))) -;; (cons (cons (string->symbol (substring kv 0 idx)) -;; ;; NOTE handle value parsing here? -;; (substring kv (1+ idx))) -;; (loop (cdr rem)))))))) - -;; (make-vline% (car all) (alist->hashq-table (cdr all)))) - -(define (handle-value! key vline) +;; params could be made optional, with an empty hashtable as default +(define (build-vline key value params) (case key [(DTSTART DTEND RECURRENCE-ID LAST-MODIFIED DTSTAMP EXDATE) ;; '("Africa/Ceuta" "Europe/Stockholm" "local") - (let ((tz (or (and=> (prop vline 'TZID) car) - (and (string= "Z" (string-take-right (value vline) 1)) "UTC")))) + (let ((tz (or (hashq-ref params 'TZID) + (and (string= "Z" (string-take-right value 1)) "UTC")))) - (let ((type (and=> (prop vline 'VALUE) car))) + (let ((type (hashq-ref params 'VALUE))) (if (or (and=> type (cut string=? <> "DATE-TIME")) - (string-contains (value vline) "T")) + (string-index value #\T)) ;; TODO TODO TODO ;; we move all parsed datetimes to local time here. This ;; gives a MASSIVE performance boost over calling get-datetime @@ -81,69 +63,46 @@ ;; 20s vs 70s runtime on my laptop. ;; We sohuld however save the original datetime in a file like X-HNH-DTSTART, ;; since we don't want to lose that information. - (set! (value vline) (get-datetime (parse-ics-datetime (value vline) tz)) - (prop vline 'VALUE) 'DATE-TIME) - (set! (value vline) (parse-ics-date (value vline)) - (prop vline 'VALUE) 'DATE))) - ;; TOOD actually handle repeated keys - (when (eq? key 'EXDATE) - (set! (value vline) (list (value vline)))))] - - [else (set! (value vline) - (list->string - (let loop ((rem (string->list (value vline)))) - (if (null? rem) - '() - (if (char=? #\\ (car rem)) - (case (cadr rem) - [(#\n #\N) (cons #\newline (loop (cddr rem)))] - [(#\; #\, #\\) => (lambda (c) (cons c (loop (cddr rem))))] - [else => (lambda (c) (warning "Non-escapable character: ~a" c) - (loop (cddr rem)))]) - (cons (car rem) (loop (cdr rem))))) - ))) ]) - vline) + (let ((datetime (parse-ics-datetime value tz))) + (hashq-set! params 'VALUE 'DATE-TIME) + (values (make-vline key (get-datetime datetime) params) + (make-vline (symbol-append 'X-ORIGINAL- key) datetime params))) + (begin (hashq-set! params 'VALUE 'DATE) + (make-vline key (parse-ics-date value) params)))))] + + [else + (make-vline key + (list->string + (let loop ((rem (string->list value))) + (if (null? rem) + '() + (if (char=? #\\ (car rem)) + (case (cadr rem) + [(#\n #\N) (cons #\newline (loop (cddr rem)))] + [(#\; #\, #\\) => (lambda (c) (cons c (loop (cddr rem))))] + [else => (lambda (c) (warning "Non-escapable character: ~a" c) + (loop (cddr rem)))]) + (cons (car rem) (loop (cdr rem))))))) + params)])) ;; (parse-itemline '("DTEND" "TZID=Europe/Stockholm" "VALUE=DATE-TIME" "20200407T130000")) +;; => (DTEND "20200407T130000" #) +;; (parse-itemline '("DTEND" "20200407T130000")) +;; => (DTEND "20200407T130000" #) ;; ⇒ (DTEND . #< value: #< date: 2020-04-07 time: 13:00:00 tz: #f> ;; parameters: #> (define (parse-itemline itemline) (define key (string->symbol (car itemline))) - (let loop ((rem (cdr itemline)) - (done '())) + (define parameters (make-hash-table)) + (let loop ((rem (cdr itemline))) (if (null? (cdr rem)) - ;; TODO repeated keys - (cons key - (handle-value! - key (make-vline (car rem) - (alist->hashq-table done)))) + (values key (car rem) parameters ) (let* ((kv (car rem)) (idx (string-index kv #\=))) - (loop (cdr rem) - (cons (cons (string->symbol (substring kv 0 idx)) - (substring kv (1+ idx))) - done)))))) - - -(define (make-component type . children-and-attributes) - (define component - (let* ((children attributes (partition vcomponent? children-and-attributes))) - ((@@ (vcomponent base) make-vcomponent%) type children #f (alist->hashq-table attributes)))) - - ;; TODO This is an ugly hack until the rest of the code is updated - ;; to work on events without an explicit DTEND attribute. - (when (and (eq? type 'VEVENT) (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))))))) - component) + (hashq-set! parameters (string->symbol (substring kv 0 idx)) + (substring kv (1+ idx))) + (loop (cdr rem)))))) + ;; (list (key kv ... value)) → (define (parse lst) @@ -153,25 +112,49 @@ stack (let ((head (car lst))) (cond [(string=? "BEGIN" (car head)) - (loop (cdr lst) (cons (list (string->symbol (cadr head))) stack))] + (loop (cdr lst) (cons (make-vcomponent (string->symbol (cadr head))) stack))] [(string=? "END" (car head)) + + ;; TODO This is an ugly hack until the rest of the code is updated + ;; to work on events without an explicit DTEND attribute. + (when (and (eq? (type (car stack)) 'VEVENT) + (not (attr (car stack) 'DTEND))) + (set! (attr (car stack) 'DTEND) + (let ((start (attr (car stack) '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))))))) + (loop (cdr lst) - (let* ((frame (reverse (car stack))) - (component (apply make-component frame))) - (if (null? (cdr stack)) - component - (cons (cons component (cadr stack)) - (cddr stack)))))] + (if (null? (cdr stack)) + ;; return + (car stack) + ;; TODO link parent here? + (begin (add-child! (cadr stack) (car stack)) + (cdr stack)) + ))] [else - (loop (cdr lst) - (cons (cons (parse-itemline head) - (car stack)) - (cdr stack)))]))))) - -(define (link-parents! component) - (for child in (children component) - ((@@ (vcomponent base) set-component-parent!) child component) - (link-parents! child))) + (let* ((key value params (parse-itemline head))) + (call-with-values (lambda () (build-vline key value params)) + (lambda vlines + (for vline in vlines + (define key (vline-key vline)) + + ;; Which types are allowed to be given multiple times + (if (memv (vline-key vline) '(EXDATE ATTENDEE)) + (aif (attr* (car stack) key) + (set! (attr* (car stack) key) (cons vline it)) + (set! (attr* (car stack) key) (list vline))) + ;; else + (set! (attr* (car stack) key) vline)))))) + + (loop (cdr lst) stack)]))))) + diff --git a/module/vcomponent/recurrence/generate-alt.scm b/module/vcomponent/recurrence/generate-alt.scm index d48e471d..c48a6c82 100644 --- a/module/vcomponent/recurrence/generate-alt.scm +++ b/module/vcomponent/recurrence/generate-alt.scm @@ -1,6 +1,7 @@ (define-module (vcomponent recurrence generate-alt) :export (generate-recurrence-set) :use-module (util) + :use-module (util exceptions) :use-module (srfi srfi-1) :use-module (srfi srfi-26) :use-module (srfi srfi-41) @@ -278,7 +279,9 @@ ;; 3.8.5.1 exdate are evaluated AFTER rrule (and rdate) (let ((date-stream (stream-remove - (cut member <> (or (attr event 'EXDATE) '())) + (aif (attr* event 'EXDATE) + (cut member <> (map value it)) + (const #f)) (generate-posibilities rrule (attr event 'DTSTART)) ;; TODO ideally I should merge the limited recurrence set ;; with the list of rdates here. However, I have never diff --git a/tests/prop.scm b/tests/prop.scm index a302d790..a178170d 100644 --- a/tests/prop.scm +++ b/tests/prop.scm @@ -3,9 +3,9 @@ ((util) sort*)) (define v (call-with-input-string - "BEGIN:VCOMPONENT + "BEGIN:DUMMY KEY;A=1;B=2:Some text -END:VCOMPONENT" +END:DUMMY" parse-calendar)) (test-equal '("1") (prop (attr* v 'KEY) 'A)) diff --git a/tests/vcomponent.scm b/tests/vcomponent.scm index c64f1a9b..7a392e9e 100644 --- a/tests/vcomponent.scm +++ b/tests/vcomponent.scm @@ -2,11 +2,11 @@ ((vcomponent) parse-calendar)) (define ev (call-with-input-string - "BEGIN:VEVENT + "BEGIN:DUMMY KEY:value -END:VEVENT" +END:DUMMY" parse-calendar)) -(test-assert (eq? #f (attr ev 'MISSING)) ) +(test-assert (eq? #f (attr ev 'MISSING))) (test-assert (attr ev 'KEY)) (test-equal "value" (attr ev 'KEY)) -- cgit v1.2.3 From 3b8ef9b49a2ecc39ab209a67dfaac05e86c192ab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 9 May 2020 22:04:30 +0200 Subject: Minor cleanup. --- module/vcomponent/parse/new.scm | 28 +++++----------------------- 1 file changed, 5 insertions(+), 23 deletions(-) diff --git a/module/vcomponent/parse/new.scm b/module/vcomponent/parse/new.scm index 90614820..4244725a 100644 --- a/module/vcomponent/parse/new.scm +++ b/module/vcomponent/parse/new.scm @@ -6,16 +6,10 @@ :use-module (datetime) :use-module (srfi srfi-1) :use-module (srfi srfi-26) - :use-module ((ice-9 hash-table) :select (alist->hashq-table)) ) (define-public (parse-calendar port) - (let ((component (parse (map tokenize (read-file port))))) - ;; (set! (attr component 'X-HNH-FILENAME) (or (port-filename port) "MISSING")) - component)) - - -;; (define f (open-input-file (car (glob "~/.local/var/cal/Calendar/c17*")))) + (parse (map tokenize (read-file port)))) ;; port → (list string) (define (read-file port) @@ -56,13 +50,10 @@ (let ((type (hashq-ref params 'VALUE))) (if (or (and=> type (cut string=? <> "DATE-TIME")) (string-index value #\T)) - ;; TODO TODO TODO ;; we move all parsed datetimes to local time here. This ;; gives a MASSIVE performance boost over calling get-datetime ;; in all procedures which want to guarantee local time for proper calculations. ;; 20s vs 70s runtime on my laptop. - ;; We sohuld however save the original datetime in a file like X-HNH-DTSTART, - ;; since we don't want to lose that information. (let ((datetime (parse-ics-datetime value tz))) (hashq-set! params 'VALUE 'DATE-TIME) (values (make-vline key (get-datetime datetime) params) @@ -85,12 +76,10 @@ (cons (car rem) (loop (cdr rem))))))) params)])) -;; (parse-itemline '("DTEND" "TZID=Europe/Stockholm" "VALUE=DATE-TIME" "20200407T130000")) -;; => (DTEND "20200407T130000" #) ;; (parse-itemline '("DTEND" "20200407T130000")) -;; => (DTEND "20200407T130000" #) -;; ⇒ (DTEND . #< value: #< date: 2020-04-07 time: 13:00:00 tz: #f> -;; parameters: #> +;; => DTEND +;; => "20200407T130000" +;; => # (define (parse-itemline itemline) (define key (string->symbol (car itemline))) (define parameters (make-hash-table)) @@ -134,10 +123,8 @@ (if (null? (cdr stack)) ;; return (car stack) - ;; TODO link parent here? (begin (add-child! (cadr stack) (car stack)) - (cdr stack)) - ))] + (cdr stack))))] [else (let* ((key value params (parse-itemline head))) (call-with-values (lambda () (build-vline key value params)) @@ -154,8 +141,3 @@ (set! (attr* (car stack) key) vline)))))) (loop (cdr lst) stack)]))))) - - - - -;; Repeated keys ('(EXDATE ATTENDEE)) -- cgit v1.2.3 From 742ae45ce7bdaae3c95a4a74afa5d17381fc76b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 9 May 2020 22:16:24 +0200 Subject: Remove old parser, rename new parser to component. --- module/vcomponent/parse.scm | 2 +- module/vcomponent/parse/component.scm | 143 +++++++++++++++ module/vcomponent/parse/new.scm | 143 --------------- module/vcomponent/parse/old.scm | 315 ---------------------------------- 4 files changed, 144 insertions(+), 459 deletions(-) create mode 100644 module/vcomponent/parse/component.scm delete mode 100644 module/vcomponent/parse/new.scm delete mode 100644 module/vcomponent/parse/old.scm diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 906936d9..3bf444c9 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -11,7 +11,7 @@ :use-module (util exceptions) :use-module (vcomponent base) - :use-module (vcomponent parse new) + :use-module (vcomponent parse component) :re-export (parse-calendar) ) diff --git a/module/vcomponent/parse/component.scm b/module/vcomponent/parse/component.scm new file mode 100644 index 00000000..565c129d --- /dev/null +++ b/module/vcomponent/parse/component.scm @@ -0,0 +1,143 @@ +(define-module (vcomponent parse component) + :use-module (util) + :use-module (util exceptions) + :use-module ((ice-9 rdelim) :select (read-line)) + :use-module (vcomponent base) + :use-module (datetime) + :use-module (srfi srfi-1) + :use-module (srfi srfi-26) + ) + +(define-public (parse-calendar port) + (parse (map tokenize (read-file port)))) + +;; port → (list string) +(define (read-file port) + (let loop ((done '())) + (let ((line (read-line port))) + (if (eof-object? line) + (reverse! done) + (let ((line (string-trim-right line))) + (loop + (if (char=? #\space (string-ref line 0)) + (cons (string-append (car done) + (string-drop line 1)) + (cdr done)) + (cons line done)))))))) + +;; (list string) → (list (key kv ... value)) +(define (tokenize line) + (define colon-idx (string-index line #\:)) + (define semi-idxs + (let loop ((idx 0)) + (aif (string-index line #\; idx colon-idx) + (cons it (loop (1+ it))) + (list colon-idx (string-length line))))) + (map (lambda (start end) + (substring line (1+ start) end)) + (cons -1 semi-idxs) + semi-idxs)) + +;; params could be made optional, with an empty hashtable as default +(define (build-vline key value params) + (case key + [(DTSTART DTEND RECURRENCE-ID LAST-MODIFIED DTSTAMP EXDATE) + + ;; '("Africa/Ceuta" "Europe/Stockholm" "local") + (let ((tz (or (hashq-ref params 'TZID) + (and (string= "Z" (string-take-right value 1)) "UTC")))) + + (let ((type (hashq-ref params 'VALUE))) + (if (or (and=> type (cut string=? <> "DATE-TIME")) + (string-index value #\T)) + ;; we move all parsed datetimes to local time here. This + ;; gives a MASSIVE performance boost over calling get-datetime + ;; in all procedures which want to guarantee local time for proper calculations. + ;; 20s vs 70s runtime on my laptop. + (let ((datetime (parse-ics-datetime value tz))) + (hashq-set! params 'VALUE 'DATE-TIME) + (values (make-vline key (get-datetime datetime) params) + (make-vline (symbol-append 'X-ORIGINAL- key) datetime params))) + (begin (hashq-set! params 'VALUE 'DATE) + (make-vline key (parse-ics-date value) params)))))] + + [else + (make-vline key + (list->string + (let loop ((rem (string->list value))) + (if (null? rem) + '() + (if (char=? #\\ (car rem)) + (case (cadr rem) + [(#\n #\N) (cons #\newline (loop (cddr rem)))] + [(#\; #\, #\\) => (lambda (c) (cons c (loop (cddr rem))))] + [else => (lambda (c) (warning "Non-escapable character: ~a" c) + (loop (cddr rem)))]) + (cons (car rem) (loop (cdr rem))))))) + params)])) + +;; (parse-itemline '("DTEND" "20200407T130000")) +;; => DTEND +;; => "20200407T130000" +;; => # +(define (parse-itemline itemline) + (define key (string->symbol (car itemline))) + (define parameters (make-hash-table)) + (let loop ((rem (cdr itemline))) + (if (null? (cdr rem)) + (values key (car rem) parameters ) + (let* ((kv (car rem)) + (idx (string-index kv #\=))) + (hashq-set! parameters (string->symbol (substring kv 0 idx)) + (substring kv (1+ idx))) + (loop (cdr rem)))))) + + +;; (list (key kv ... value)) → +(define (parse lst) + (let loop ((lst lst) + (stack '())) + (if (null? lst) + stack + (let ((head (car lst))) + (cond [(string=? "BEGIN" (car head)) + (loop (cdr lst) (cons (make-vcomponent (string->symbol (cadr head))) stack))] + [(string=? "END" (car head)) + + ;; TODO This is an ugly hack until the rest of the code is updated + ;; to work on events without an explicit DTEND attribute. + (when (and (eq? (type (car stack)) 'VEVENT) + (not (attr (car stack) 'DTEND))) + (set! (attr (car stack) 'DTEND) + (let ((start (attr (car stack) '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))))))) + + (loop (cdr lst) + (if (null? (cdr stack)) + ;; return + (car stack) + (begin (add-child! (cadr stack) (car stack)) + (cdr stack))))] + [else + (let* ((key value params (parse-itemline head))) + (call-with-values (lambda () (build-vline key value params)) + (lambda vlines + (for vline in vlines + (define key (vline-key vline)) + + ;; Which types are allowed to be given multiple times + (if (memv (vline-key vline) '(EXDATE ATTENDEE)) + (aif (attr* (car stack) key) + (set! (attr* (car stack) key) (cons vline it)) + (set! (attr* (car stack) key) (list vline))) + ;; else + (set! (attr* (car stack) key) vline)))))) + + (loop (cdr lst) stack)]))))) diff --git a/module/vcomponent/parse/new.scm b/module/vcomponent/parse/new.scm deleted file mode 100644 index 4244725a..00000000 --- a/module/vcomponent/parse/new.scm +++ /dev/null @@ -1,143 +0,0 @@ -(define-module (vcomponent parse new) - :use-module (util) - :use-module (util exceptions) - :use-module ((ice-9 rdelim) :select (read-line)) - :use-module (vcomponent base) - :use-module (datetime) - :use-module (srfi srfi-1) - :use-module (srfi srfi-26) - ) - -(define-public (parse-calendar port) - (parse (map tokenize (read-file port)))) - -;; port → (list string) -(define (read-file port) - (let loop ((done '())) - (let ((line (read-line port))) - (if (eof-object? line) - (reverse! done) - (let ((line (string-trim-right line))) - (loop - (if (char=? #\space (string-ref line 0)) - (cons (string-append (car done) - (string-drop line 1)) - (cdr done)) - (cons line done)))))))) - -;; (list string) → (list (key kv ... value)) -(define (tokenize line) - (define colon-idx (string-index line #\:)) - (define semi-idxs - (let loop ((idx 0)) - (aif (string-index line #\; idx colon-idx) - (cons it (loop (1+ it))) - (list colon-idx (string-length line))))) - (map (lambda (start end) - (substring line (1+ start) end)) - (cons -1 semi-idxs) - semi-idxs)) - -;; params could be made optional, with an empty hashtable as default -(define (build-vline key value params) - (case key - [(DTSTART DTEND RECURRENCE-ID LAST-MODIFIED DTSTAMP EXDATE) - - ;; '("Africa/Ceuta" "Europe/Stockholm" "local") - (let ((tz (or (hashq-ref params 'TZID) - (and (string= "Z" (string-take-right value 1)) "UTC")))) - - (let ((type (hashq-ref params 'VALUE))) - (if (or (and=> type (cut string=? <> "DATE-TIME")) - (string-index value #\T)) - ;; we move all parsed datetimes to local time here. This - ;; gives a MASSIVE performance boost over calling get-datetime - ;; in all procedures which want to guarantee local time for proper calculations. - ;; 20s vs 70s runtime on my laptop. - (let ((datetime (parse-ics-datetime value tz))) - (hashq-set! params 'VALUE 'DATE-TIME) - (values (make-vline key (get-datetime datetime) params) - (make-vline (symbol-append 'X-ORIGINAL- key) datetime params))) - (begin (hashq-set! params 'VALUE 'DATE) - (make-vline key (parse-ics-date value) params)))))] - - [else - (make-vline key - (list->string - (let loop ((rem (string->list value))) - (if (null? rem) - '() - (if (char=? #\\ (car rem)) - (case (cadr rem) - [(#\n #\N) (cons #\newline (loop (cddr rem)))] - [(#\; #\, #\\) => (lambda (c) (cons c (loop (cddr rem))))] - [else => (lambda (c) (warning "Non-escapable character: ~a" c) - (loop (cddr rem)))]) - (cons (car rem) (loop (cdr rem))))))) - params)])) - -;; (parse-itemline '("DTEND" "20200407T130000")) -;; => DTEND -;; => "20200407T130000" -;; => # -(define (parse-itemline itemline) - (define key (string->symbol (car itemline))) - (define parameters (make-hash-table)) - (let loop ((rem (cdr itemline))) - (if (null? (cdr rem)) - (values key (car rem) parameters ) - (let* ((kv (car rem)) - (idx (string-index kv #\=))) - (hashq-set! parameters (string->symbol (substring kv 0 idx)) - (substring kv (1+ idx))) - (loop (cdr rem)))))) - - -;; (list (key kv ... value)) → -(define (parse lst) - (let loop ((lst lst) - (stack '())) - (if (null? lst) - stack - (let ((head (car lst))) - (cond [(string=? "BEGIN" (car head)) - (loop (cdr lst) (cons (make-vcomponent (string->symbol (cadr head))) stack))] - [(string=? "END" (car head)) - - ;; TODO This is an ugly hack until the rest of the code is updated - ;; to work on events without an explicit DTEND attribute. - (when (and (eq? (type (car stack)) 'VEVENT) - (not (attr (car stack) 'DTEND))) - (set! (attr (car stack) 'DTEND) - (let ((start (attr (car stack) '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))))))) - - (loop (cdr lst) - (if (null? (cdr stack)) - ;; return - (car stack) - (begin (add-child! (cadr stack) (car stack)) - (cdr stack))))] - [else - (let* ((key value params (parse-itemline head))) - (call-with-values (lambda () (build-vline key value params)) - (lambda vlines - (for vline in vlines - (define key (vline-key vline)) - - ;; Which types are allowed to be given multiple times - (if (memv (vline-key vline) '(EXDATE ATTENDEE)) - (aif (attr* (car stack) key) - (set! (attr* (car stack) key) (cons vline it)) - (set! (attr* (car stack) key) (list vline))) - ;; else - (set! (attr* (car stack) key) vline)))))) - - (loop (cdr lst) stack)]))))) diff --git a/module/vcomponent/parse/old.scm b/module/vcomponent/parse/old.scm deleted file mode 100644 index 648f9bc5..00000000 --- a/module/vcomponent/parse/old.scm +++ /dev/null @@ -1,315 +0,0 @@ -(define-module (vcomponent parse old) - :use-module (util) - :use-module (util strbuf) - :use-module (util exceptions) - - :use-module ((rnrs io ports) :select (get-u8)) - :use-module ((ice-9 textual-ports) :select (unget-char)) - - :use-module (srfi srfi-1) - :use-module (srfi srfi-9) - :use-module (srfi srfi-26) - - :use-module (datetime) - :use-module (datetime util) - - :use-module (vcomponent base) - :use-module (vcomponent datetime) - ;; export (parse-calendar) -) - -(define-record-type - (make-parse-ctx% filename row col ctx line-key param-key param-table) - parse-ctx? - (filename get-filename) ; string - (row get-row set-row!) ; [0, ] - (col get-col set-col!) ; [1, ) - (ctx get-ctx set-ctx!) ; '(key value param-name param-value escape) - (line-key get-line-key set-line-key!) ; string - (param-key get-param-key set-param-key!) ; string - (param-table get-param-table set-param-table!) ; hash-map - ) - -(define (make-parse-ctx filename) - (make-parse-ctx% filename 1 0 'key - #f #f (make-hash-table))) - -(define (increment-column! ctx) - (set-col! ctx (1+ (get-col ctx)))) - -(define (increment-row! ctx) - (set-col! ctx 0) - (set-row! ctx (1+ (get-row ctx)))) - -(define (ctx-dump-strings! ctx) - (set-line-key! ctx "") - (set-param-key! ctx "") - ;; (set-param-table! ctx (make-hash-table)) - ) - - - - -(define (fold-proc ctx c) - ;; First extra character optional read is to get the \n if our line - ;; ended with \r\n. Secound read is to get the first character of the - ;; next line. The initial \r which might recide in @var{c} is discarded. - (let ((pair (cons (if (char=? #\newline (integer->char c)) - c (get-u8 (current-input-port))) - (get-u8 (current-input-port))))) - (increment-row! ctx) - (cond [(not (char=? #\newline (integer->char (car pair)))) - (error "Expected newline after CR")] - - ;; The standard (3.4, l. 2675) says that each icalobject must - ;; end with CRLF. My files however does not. This means that - ;; an EOF can immideately follow a \n\r pair. But this case is the - ;; same as that we are at the end of line, so we spoof it and let - ;; the regular parser loop handle it. - [(eof-object? (cdr pair)) - 'end-of-line] - - ;; Following line begins with a whitespace character, - ;; meaning that we don't break the logical line here. - [(memv (integer->char (cdr pair)) '(#\space #\tab)) - (increment-column! ctx) ; since we just read the space - 'fold] - - [else - ;; TODO check if this failed, and signal a writeback error - (unget-char (current-input-port) - (integer->char (cdr pair))) - - 'end-of-line]))) - -(define (handle-value! key vline strbuf) - (case key - ;; As far as I can tell the RFC says nothing about special - ;; encoding for individual fields. It mentieons UTF-8, and - ;; that transfer encoding should be set in the mime-headers. - ;; That however seems like a breach of abstractions. - ;; Currently I allow a CHARSET property on SUMMARY fields, - ;; since I know that at least www.lysator.liu.se/alma/alma.cgi - ;; uses it. - [(SUMMARY) - (cond [(and=> (prop vline 'CHARSET) car) - => (lambda (encoding) - (set! (value vline) - (strbuf->string strbuf ((@ (rnrs io ports) make-transcoder) - encoding))))])] - - [(DTSTART DTEND RECURRENCE-ID LAST-MODIFIED DTSTAMP EXDATE) - - ;; '("Africa/Ceuta" "Europe/Stockholm" "local") - (let ((tz (or (and=> (prop vline 'TZID) car) - (and (string= "Z" (string-take-right (value vline) 1)) "UTC")))) - - (let ((type (and=> (prop vline 'VALUE) car))) - (if (or (and=> type (cut string=? <> "DATE-TIME")) - (string-contains (value vline) "T")) - ;; TODO TODO TODO - ;; we move all parsed datetimes to local time here. This - ;; gives a MASSIVE performance boost over calling get-datetime - ;; in all procedures which want to guarantee local time for proper calculations. - ;; 20s vs 70s runtime on my laptop. - ;; We sohuld however save the original datetime in a file like X-HNH-DTSTART, - ;; since we don't want to lose that information. - (set! (value vline) (get-datetime (parse-ics-datetime (value vline) tz)) - (prop vline 'VALUE) 'DATE-TIME) - (set! (value vline) (parse-ics-date (value vline)) - (prop vline 'VALUE) 'DATE))) - )])) - -;; Reads a vcomponent from the given port. -(define-public (parse-calendar port) - ;; (report-time! "Parsing ~a" port) - (with-input-from-port port - (lambda () - (let ((component (make-vcomponent)) - (ctx (make-parse-ctx (port-filename port))) - (strbuf (make-strbuf))) - (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)))) - (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))]))) - ;; == 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)))))))))) - - -- cgit v1.2.3 From 4526a54ef07f2dd30bc61cc34934a157e02ab446 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 9 May 2020 22:18:48 +0200 Subject: Add short commentary on difference between parse and parse/component. --- module/vcomponent/parse.scm | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 3bf444c9..9e5be8a3 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -1,3 +1,9 @@ +;;; Commentary: +;; Code for parsing vdir's and icalendar files. +;; This module handles the finding of files, while +;; (vcomponent parse component) handles reading data from icalendar files. +;;; Code: + (define-module (vcomponent parse) :use-module (rnrs bytevectors) :use-module (srfi srfi-1) -- cgit v1.2.3