diff options
Diffstat (limited to 'module/vcomponent/formats')
| -rw-r--r-- | module/vcomponent/formats/xcal.scm | 7 | ||||
| -rw-r--r-- | module/vcomponent/formats/xcal/output.scm | 94 | ||||
| -rw-r--r-- | module/vcomponent/formats/xcal/types.scm | 30 |
3 files changed, 68 insertions, 63 deletions
diff --git a/module/vcomponent/formats/xcal.scm b/module/vcomponent/formats/xcal.scm index 8fadde75..a0c8620d 100644 --- a/module/vcomponent/formats/xcal.scm +++ b/module/vcomponent/formats/xcal.scm @@ -23,6 +23,9 @@ (define* (deserialize port) (-> port xml->namespaced-sxml - root-element ; Strip potential *TOP* - cadr ; Remove containing icalendar + xml-document-root + + ;; Remove containing icalendar + xml-element-children car + sxcal->vcomponent)) diff --git a/module/vcomponent/formats/xcal/output.scm b/module/vcomponent/formats/xcal/output.scm index a5f8a934..f0c11a4e 100644 --- a/module/vcomponent/formats/xcal/output.scm +++ b/module/vcomponent/formats/xcal/output.scm @@ -59,9 +59,10 @@ [(memv k '(GEO)) (lambda (_ v) - `(,(xml xcal 'geo) - (latitude ,(geo-latitude v)) - (longitude ,(geo-longitude v))))] + ((xml xcal 'geo) + (list + ((xml xcal 'latitude) (geo-latitude v)) + ((xml xcal 'longitude) (geo-longitude v)))))] [(memv k '(RRULE)) (get-writer 'RECUR)] @@ -84,60 +85,59 @@ (if (or (eq? tag 'VALUE) (internal-field? tag)) #f - `(,(xml xcal (downcase-symbol tag)) - ,@(map (lambda (v) - ;; TODO parameter types!!!! (rfc6321 3.5.) - `(,(xml xcal 'text) ,(->string v))) - value)))) + (apply (xml xcal (downcase-symbol tag)) + (map (lambda (v) + ;; TODO parameter types!!!! (rfc6321 3.5.) + ((xml xcal 'text) (->string v))) + value)))) -;; ((key value ...) ...) -> `(parameters , ... ) +;; ((key value ...) ...) -> #<xml parameters> (define (parameters-tag parameters) (define outparams (filter-map (lambda (x) (property->value-tag x)) parameters)) - (unless (null? outparams) - `(,(xml xcal 'parameters) ,@outparams))) + (apply (xml xcal 'parameters) outparams)) (define (vcomponent->sxcal component) (define tagsymb (downcase-symbol (type component))) - (remove null? - `(,(xml xcal tagsymb) - ;; only have <properties> when it's non-empty. - ,(let ((props - (filter-map - (match-lambda - [(? (compose internal-field? car)) #f] - - [(key (vlines ...)) - (remove null? - `(,(xml xcal (downcase-symbol key)) - ,(parameters-tag (reduce assq-merge - '() - (map parameters vlines))) - ,@(for vline in vlines - (vline->value-tag vline))))] - - [(key vline) - (remove null? - `(,(xml xcal (downcase-symbol key)) - ,(parameters-tag (parameters vline)) - ,(vline->value-tag vline)))]) - ;; NOTE this sort is unnecesasary, but here so tests can work - ;; Possibly add it as a flag instead - (sort* (properties component) - string< (compose symbol->string car))))) - (unless (null? props) - `(,(xml xcal 'properties) - ;; NOTE - ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME))) - ,@props))) - ,(unless (null? (children component)) - `(,(xml xcal 'components) - ,@(map vcomponent->sxcal (children component))))))) + (apply (xml xcal tagsymb) + (remove (compose null? xml-element-children) + ;; only have <properties> when it's non-empty. + (list + (let ((props + (filter-map + (match-lambda + [(? (compose internal-field? car)) #f] + + [(key (vlines ...)) + (apply (xml xcal (downcase-symbol key)) + (remove (compose null? xml-element-children) + (cons + (parameters-tag (reduce assq-merge + '() + (map parameters vlines))) + (map vline->value-tag vlines))))] + + [(key vline) + (apply (xml xcal (downcase-symbol key)) + (remove (compose null? xml-element-children) + (list + (parameters-tag (parameters vline)) + (vline->value-tag vline))))]) + ;; NOTE this sort is unnecesasary, but here so tests can work + ;; Possibly add it as a flag instead + (sort* (properties component) + string< (compose symbol->string car))))) + (apply (xml xcal 'properties) + ;; NOTE + ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME))) + props)) + (apply (xml xcal 'components) + (map vcomponent->sxcal (children component))))))) (define (ns-wrap sxml) - `(,(xml xcal 'icalendar) - ,sxml)) + ((xml xcal 'icalendar) + sxml)) diff --git a/module/vcomponent/formats/xcal/types.scm b/module/vcomponent/formats/xcal/types.scm index 812f1d20..b9b8239d 100644 --- a/module/vcomponent/formats/xcal/types.scm +++ b/module/vcomponent/formats/xcal/types.scm @@ -9,32 +9,33 @@ :export (get-writer)) (define (write-boolean _ v) - `(,(xml xcal 'boolean) ,(if v "true" "false"))) + ((xml xcal 'boolean) (if v "true" "false"))) (define (write-date _ v) - `(,(xml xcal 'date) ,(date->string v "~Y-~m-~d"))) + ((xml xcal 'date) (date->string v "~Y-~m-~d"))) (define (write-datetime p v) - `(,(xml xcal 'date-time) - ,(datetime->string - (table-get p '-X-HNH-ORIGINAL v) - ;; 'Z' should be included for UTC, - ;; other timezones MUST be specified - ;; in the TZID parameter. - "~Y-~m-~dT~H:~M:~S~Z"))) + ((xml xcal 'date-time) + (datetime->string + (table-get p '-X-HNH-ORIGINAL v) + ;; 'Z' should be included for UTC, + ;; other timezones MUST be specified + ;; in the TZID parameter. + "~Y-~m-~dT~H:~M:~S~Z"))) (define (write-time _ v) - `(,(xml xcal 'time) ,(time->string v "~H:~M:S"))) + ((xml xcal 'time) (time->string v "~H:~M:S"))) (define (write-recur _ v) - `(,(xml xcal 'recur) ,@((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v))) + (apply (xml xcal 'recur) + ((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v))) ;; sepparate since this text shouldn't be escaped (define (write-text _ v) ;; TODO out type should be xsd:string. ;; Look into what that means, and escape ;; from there - `(,(xml xcal 'text) ,v)) + ((xml xcal 'text) v)) @@ -43,8 +44,9 @@ #| TODO PERIOD |# URI UTC-OFFSET) (hashq-set! sxml-writers simple-type (lambda (p v) - `(,(xml xcal (downcase-symbol simple-type)) - ,(((@ (vcomponent formats ical types) get-writer) simple-type) p v))))) + ((xml xcal (downcase-symbol simple-type)) + (((@ (vcomponent formats ical types) get-writer) simple-type) + p v))))) (hashq-set! sxml-writers 'BOOLEAN write-boolean) (hashq-set! sxml-writers 'DATE write-date) |