diff options
| -rw-r--r-- | module/output/html.scm | 11 | ||||
| -rw-r--r-- | module/util/exceptions.scm | 21 | ||||
| -rw-r--r-- | module/vcomponent/base.scm | 30 | ||||
| -rw-r--r-- | module/vcomponent/parse.scm | 2 | ||||
| -rw-r--r-- | module/vcomponent/parse/new.scm | 171 | ||||
| -rw-r--r-- | module/vcomponent/recurrence/generate-alt.scm | 5 | ||||
| -rw-r--r-- | tests/prop.scm | 4 | ||||
| -rw-r--r-- | 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 <vline> type is a bit to many times refered to as a attr ptr. (define-record-type <vline> - (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 <vcomponent> (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")) -;; ⇒ #<<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)]))))) + 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)) |