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/component.scm | 143 ++++++++++++++++++++++++++++++++++ 1 file changed, 143 insertions(+) create mode 100644 module/vcomponent/parse/component.scm (limited to 'module/vcomponent/parse/component.scm') 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)]))))) -- cgit v1.2.3