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/vcomponent/parse/new.scm | 171 ++++++++++++++++++---------------------- 1 file changed, 77 insertions(+), 94 deletions(-) (limited to 'module/vcomponent/parse') 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)]))))) + -- cgit v1.2.3