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(-) (limited to 'module/vcomponent/parse') 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