New parser now on feature parity with old.

1 files changed, 77 insertions, 94 deletions

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"))
-;; ⇒ #<<vline> value: "20200407T130000" parameters: #<hash-table 7f4294c913a0 2/31>>
-;; (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" #<hash-table 7f88fb094d80 2/31>)
+;; (parse-itemline '("DTEND"  "20200407T130000"))
+;; => (DTEND "20200407T130000" #<hash-table 7f88facafd20 0/31>)
 ;; ⇒ (DTEND . #<<vline> value: #<<datetime> date: 2020-04-07 time: 13:00:00 tz: #f>
 ;;                      parameters: #<hash-table 7f88fc1207a0 2/31>>
 (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)) → <vcomponent>
 (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)])))))
+