From c64a4bc56f93c08cf55fb907078e588ad737684c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 5 Sep 2023 00:55:35 +0200 Subject: Major work on, something. --- module/vcomponent/formats/xcal/output.scm | 34 +++++----- module/vcomponent/formats/xcal/parse.scm | 107 +++++++++++++++--------------- 2 files changed, 73 insertions(+), 68 deletions(-) (limited to 'module/vcomponent/formats/xcal') diff --git a/module/vcomponent/formats/xcal/output.scm b/module/vcomponent/formats/xcal/output.scm index e4a84efb..7cf8c591 100644 --- a/module/vcomponent/formats/xcal/output.scm +++ b/module/vcomponent/formats/xcal/output.scm @@ -15,24 +15,24 @@ (define (vline->value-tag vline) - (define key (vline-key vline)) + (define k (key vline)) (define writer (cond [(and=> (param vline 'VALUE) (compose string->symbol car)) => get-writer] - [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID + [(memv k '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID CREATED DTSTAMP LAST-MODIFIED ACKNOWLEDGED EXDATE)) (get-writer 'DATE-TIME)] - [(memv key '(TRIGGER DURATION)) + [(memv k '(TRIGGER DURATION)) (get-writer 'DURATION)] - [(memv key '(FREEBUSY)) + [(memv k '(FREEBUSY)) (get-writer 'PERIOD)] - [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION + [(memv k '(CALSCALE METHOD PRODID COMMENT DESCRIPTION LOCATION SUMMARY TZID TZNAME CONTACT RELATED-TO UID @@ -41,39 +41,39 @@ VERSION)) (get-writer 'TEXT)] - [(memv key '(TRANSP + [(memv k '(TRANSP CLASS PARTSTAT STATUS ACTION)) (lambda (p v) ((get-writer 'TEXT) p (symbol->string v)))] - [(memv key '(TZOFFSETFROM TZOFFSETTO)) + [(memv k '(TZOFFSETFROM TZOFFSETTO)) (get-writer 'UTC-OFFSET)] - [(memv key '(ATTACH TZURL URL)) + [(memv k '(ATTACH TZURL URL)) (get-writer 'URI)] - [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) + [(memv k '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) (get-writer 'INTEGER)] - [(memv key '(GEO)) + [(memv k '(GEO)) (lambda (_ v) `(,(xml xcal 'geo) (latitude ,(geo-latitude v)) (longitude ,(geo-longitude v))))] - [(memv key '(RRULE)) + [(memv k '(RRULE)) (get-writer 'RECUR)] - [(memv key '(ORGANIZER ATTENDEE)) + [(memv k '(ORGANIZER ATTENDEE)) (get-writer 'CAL-ADDRESS)] - [(x-property? key) + [(x-property? k) (get-writer 'TEXT)] [else - (warning (G_ "Unknown key ~a") key) + (warning (G_ "Unknown key ~a") k) (get-writer 'TEXT)])) (writer ((@@ (vcomponent base) get-vline-parameters) vline) @@ -92,7 +92,7 @@ ;; ((key value ...) ...) -> `(parameters , ... ) (define (parameters-tag parameters) (define outparams (filter-map - (lambda (x) (apply property->value-tag x)) + (lambda (x) (property->value-tag x)) parameters)) (unless (null? outparams) @@ -111,10 +111,12 @@ [(? (compose internal-field? car)) #f] [(key vlines ...) + (format (current-error-port) "vlines: ~s~%" vlines) (remove null? `(,(xml xcal (downcase-symbol key)) ,(parameters-tag (reduce assq-merge - '() (map parameters vlines))) + '() + (map parameters vlines))) ,@(for vline in vlines (vline->value-tag vline))))] diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm index 7ed8c637..5ae1b928 100644 --- a/module/vcomponent/formats/xcal/parse.scm +++ b/module/vcomponent/formats/xcal/parse.scm @@ -15,6 +15,7 @@ :use-module (srfi srfi-71) :use-module (srfi srfi-88) :use-module (calp translation) + :use-module (hnh util table) :export (sxcal->vcomponent) ) @@ -146,18 +147,17 @@ ;; (assert (element-matches? (xml xcal 'parameters) ;; parameters)) - (define ht (make-hash-table)) - - (for param in (cdr parameters) - (define ptag (xml-element-tagname (car param))) - ;; (define-values (ptype pvalue) (car+cdr cdr)) - ;; TODO multi-valued parameters!!! - (define-values (pytpe pvalue) (car+cdr (cadr param))) - ;; TODO parameter type (rfc6321 3.5.) - ;; TODO namespaces - (hashq-set! ht (symbol-upcase ptag) - (concatenate pvalue))) - ht) + (fold (lambda (param table) + (define ptag (xml-element-tagname (car param))) + ;; (define-values (ptype pvalue) (car+cdr cdr)) + ;; TODO multi-valued parameters!!! + (define-values (pytpe pvalue) (car+cdr (cadr param))) + ;; TODO parameter type (rfc6321 3.5.) + ;; TODO namespaces + (table-put table (symbol-upcase ptag) + (concatenate pvalue))) + (table) + (cdr parameters))) (define* (parse-enum str enum optional: (allow-other #t)) (let ((symb (string->symbol str))) @@ -189,7 +189,7 @@ data '(AUDIO DISPLAY EMAIL NONE))) [else data])) -(define (handle-single-property! component tree) +(define (handle-single-property component tree) (define xml-tag (car tree)) (define tag (xml-element-tagname xml-tag)) (define tag* (symbol-upcase tag)) @@ -205,12 +205,13 @@ (values (make-hash-table) body))) - (for typetag in data - (define type (xml-element-tagname (car typetag))) - ;; TODO multi valued data - (define raw-value (cdr typetag)) - (define vline - (make-vline tag* (handle-tag + (fold (lambda (typetag component) + (define type (xml-element-tagname (car typetag))) + ;; TODO multi valued data + (define raw-value (cdr typetag)) + (define vline* + (vline type: tag* + value: (handle-tag xml-tag (let ((v (handle-value type parameters raw-value))) ;; TODO possibly more list fields @@ -219,18 +220,19 @@ ;; v) v)) - parameters)) - (if (memv tag* '(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - )) - (aif (prop* component tag*) - (set! (prop* component tag*) (cons vline it)) - (set! (prop* component tag*) (list vline))) - (set! (prop* component tag*) vline)))) + parameters: parameters)) + (if (memv tag* '(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + )) + (aif (prop* component tag*) + (prop* component tag* (cons vline* it)) + (prop* component tag* (list vline*))) + (prop* component tag* vline*))) + component data)) ;; Note ;; This doesn't verify the inter-field validity of the object, @@ -244,24 +246,25 @@ (define xml-tag (car sxcal)) (define type (symbol-upcase (xml-element-tagname xml-tag))) - (define component (make-vcomponent type)) - - (awhen (find-element (xml xcal 'properties) (cdr sxcal)) - ;; Loop over multi valued fields, creating one vline - ;; for every value. So - ;; KEY;p=1:a,b - ;; would be expanded into - ;; KEY;p=1:a - ;; KEY;p=1:b - (map (lambda (x) (handle-single-property! component x)) - (cdr it))) - - ;; children - (awhen (find-element (xml xcal 'components) (cdr sxcal)) - ;; NOTE Order of children is insignificant, but this allows - ;; diffs to be stable (which is used by the format tests). - (for child in (map sxcal->vcomponent - (reverse (cdr it))) - (reparent! component child))) - - component) + + (let ((component + (aif (find-element (xml xcal 'properties) (cdr sxcal)) + ;; Loop over multi valued fields, creating one vline + ;; for every value. So + ;; KEY;p=1:a,b + ;; would be expanded into + ;; KEY;p=1:a + ;; KEY;p=1:b + (fold swap handle-single-property + (vcomponent type: type) (cdr it)) + (vcomponent type: type)))) + + ;; children + (aif (find-element (xml xcal 'components) (cdr sxcal)) + ;; NOTE Order of children is insignificant, but this allows + ;; diffs to be stable (which is used by the format tests). + (fold (swap add-child) + component + (map sxcal->vcomponent + (reverse (cdr it)))) + component))) -- cgit v1.2.3