diff options
Diffstat (limited to 'module/vcomponent/formats')
| -rw-r--r-- | module/vcomponent/formats/common/types.scm | 10 | ||||
| -rw-r--r-- | module/vcomponent/formats/ical.scm | 17 | ||||
| -rw-r--r-- | module/vcomponent/formats/ical/output.scm | 11 | ||||
| -rw-r--r-- | module/vcomponent/formats/ical/parse.scm | 17 | ||||
| -rw-r--r-- | module/vcomponent/formats/ical/types.scm | 4 | ||||
| -rw-r--r-- | module/vcomponent/formats/sxcal.scm | 16 | ||||
| -rw-r--r-- | module/vcomponent/formats/vdir/parse.scm | 6 | ||||
| -rw-r--r-- | module/vcomponent/formats/vdir/save-delete.scm | 12 | ||||
| -rw-r--r-- | module/vcomponent/formats/xcal.scm | 27 | ||||
| -rw-r--r-- | module/vcomponent/formats/xcal/output.scm | 37 | ||||
| -rw-r--r-- | module/vcomponent/formats/xcal/parse.scm | 210 | ||||
| -rw-r--r-- | module/vcomponent/formats/xcal/types.scm | 18 |
12 files changed, 230 insertions, 155 deletions
diff --git a/module/vcomponent/formats/common/types.scm b/module/vcomponent/formats/common/types.scm index a8a923da..fcb2b7b6 100644 --- a/module/vcomponent/formats/common/types.scm +++ b/module/vcomponent/formats/common/types.scm @@ -13,7 +13,7 @@ (define (parse-binary props value) ;; p 30 (unless (string=? "BASE64" (hashq-ref props 'ENCODING)) - (warning (_ "Binary field not marked ENCODING=BASE64"))) + (warning (G_ "Binary field not marked ENCODING=BASE64"))) ;; For icalendar no extra whitespace is allowed in a ;; binary field (except for line wrapping). This differs @@ -25,7 +25,7 @@ (cond [(string=? "TRUE" value) #t] [(string=? "FALSE" value) #f] - [else (warning (_ "~a invalid boolean") value)])) + [else (warning (G_ "~a invalid boolean") value)])) ;; CAL-ADDRESS ⇒ uri @@ -58,7 +58,7 @@ (define (parse-integer props value) (let ((n (string->number value))) (unless (integer? n) - (warning (_ "Non integer as integer"))) + (warning (G_ "Non integer as integer"))) n)) ;; PERIOD @@ -89,7 +89,7 @@ (case (cadr rem) [(#\n #\N) (loop (cddr rem) (cons #\newline str) done)] [(#\; #\, #\\) => (lambda (c) (loop (cddr rem) (cons c str) done))] - [else => (lambda (c) (warning (_ "Non-escapable character: ~a") c) + [else => (lambda (c) (warning (G_ "Non-escapable character: ~a") c) (loop (cddr rem) str done))])] [(#\,) (loop (cdr rem) '() (cons (reverse-list->string str) done))] @@ -138,5 +138,5 @@ (define (get-parser type) (or (hashq-ref type-parsers type #f) - (scm-error 'misc-error "get-parser" (_ "No parser for type ~a") + (scm-error 'misc-error "get-parser" (G_ "No parser for type ~a") (list type) #f))) diff --git a/module/vcomponent/formats/ical.scm b/module/vcomponent/formats/ical.scm new file mode 100644 index 00000000..dddca946 --- /dev/null +++ b/module/vcomponent/formats/ical.scm @@ -0,0 +1,17 @@ +(define-module (vcomponent formats ical) + :use-module ((vcomponent formats ical output) + :select (component->ical-string)) + :use-module ((vcomponent formats ical parse) + :select (parse-calendar)) + :export (serialize + deserialize + ) + ) + + +(define (serialize component port) + (with-output-to-port port + (lambda () (component->ical-string component)))) + +(define (deserialize port) + (parse-calendar port)) diff --git a/module/vcomponent/formats/ical/output.scm b/module/vcomponent/formats/ical/output.scm index da891fa6..57860d2a 100644 --- a/module/vcomponent/formats/ical/output.scm +++ b/module/vcomponent/formats/ical/output.scm @@ -16,6 +16,7 @@ :use-module (vcomponent geo) :use-module (vcomponent formats ical types) :use-module (vcomponent recurrence) + :use-module ((calp) :select (prodid)) :use-module (calp translation) :autoload (vcomponent util instance) (global-event-object) :export (component->ical-string @@ -24,10 +25,6 @@ print-events-in-interval )) -(define (prodid) - (format #f "-//hugo//calp ~a//EN" - (@ (calp) version))) - ;; Format value depending on key type. ;; Should NOT emit the key. @@ -96,7 +93,7 @@ (get-writer 'TEXT)] [else - (warning (_ "Unknown key ~a") key) + (warning (G_ "Unknown key ~a") key) (get-writer 'TEXT)])) (catch #t #; 'wrong-type-arg @@ -168,7 +165,9 @@ ;; If we have alternatives, splice them in here. (cond [(prop component '-X-HNH-ALTERNATIVES) - => (lambda (alts) (hash-map->list (lambda (_ comp) (component->ical-string comp)) + => (lambda (alts) (hash-map->list (lambda (_ comp) + (unless (eq? component comp) + (component->ical-string comp))) alts))])) diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm index 49f8f101..f0a19ba5 100644 --- a/module/vcomponent/formats/ical/parse.scm +++ b/module/vcomponent/formats/ical/parse.scm @@ -14,6 +14,9 @@ :use-module (calp translation) :export (parse-calendar)) +;;; TODO a few translated strings here contain explicit newlines. Check if that +;;; is preserved through the translation. + (define string->symbol (let ((ht (make-hash-table 1000))) (lambda (str) @@ -124,7 +127,7 @@ (let ((vv (parser params value))) (when (list? vv) (scm-error 'parse-error "enum-parser" - (_ "List in enum field") + (G_ "List in enum field") #f #f)) (let ((v (string->symbol vv))) (unless (memv v enum) @@ -160,7 +163,7 @@ (lambda (params value) (let ((v ((get-parser 'TEXT) params value))) (unless (= 1 (length v)) - (warning (_ "List in non-list field: ~s") v)) + (warning (G_ "List in non-list field: ~s") v)) (string-join v ",")))] ;; TEXT, but allow a list @@ -198,7 +201,7 @@ [(memv key '(REQUEST-STATUS)) (scm-error 'parse-error "build-vline" - (_ "TODO Implement REQUEST-STATUS") + (G_ "TODO Implement REQUEST-STATUS") #f #f)] [(memv key '(ACTION)) @@ -233,7 +236,7 @@ (compose car (get-parser 'TEXT))] [else - (warning (_ "Unknown key ~a") key) + (warning (G_ "Unknown key ~a") key) (compose car (get-parser 'TEXT))]))) ;; If we produced a list create multiple VLINES from it. @@ -286,7 +289,7 @@ ;; ~? ;; source line ;; source file - (_ "WARNING parse error around ~a + (G_ "WARNING parse error around ~a ~? line ~a ~a~%") (get-string linedata) @@ -303,7 +306,7 @@ (if (null? (cdr stack)) ;; return (car stack) - (begin (add-child! (cadr stack) (car stack)) + (begin (reparent! (cadr stack) (car stack)) (cdr stack))))] [else (let ((key value params (parse-itemline head))) @@ -341,7 +344,7 @@ ;; ~? ;; source line ;; source file - (_ "ERROR parse error around ~a + (G_ "ERROR parse error around ~a ~? line ~a ~a Defaulting to string~%") diff --git a/module/vcomponent/formats/ical/types.scm b/module/vcomponent/formats/ical/types.scm index 7b6aad2e..768f5098 100644 --- a/module/vcomponent/formats/ical/types.scm +++ b/module/vcomponent/formats/ical/types.scm @@ -37,7 +37,7 @@ ;; TODO (define (write-period _ value) - (warning (_ "PERIOD writer not yet implemented")) + (warning (G_ "PERIOD writer not yet implemented")) (with-output-to-string (lambda () (write value)))) @@ -94,4 +94,4 @@ (define (get-writer type) (or (hashq-ref type-writers type #f) - (error (_ "No writer for type") type))) + (error (G_ "No writer for type") type))) diff --git a/module/vcomponent/formats/sxcal.scm b/module/vcomponent/formats/sxcal.scm new file mode 100644 index 00000000..c02dbada --- /dev/null +++ b/module/vcomponent/formats/sxcal.scm @@ -0,0 +1,16 @@ +(define-module (vcomponent formats sxcal) + :use-module ((vcomponent formats xcal parse) + :select (sxcal->vcomponent)) + :export (serialize deserialize) + ) + + +(define (serialize component port) + (write (serialize/object component) port)) + +(define (serialize/object component) + ;; TODO where is this defined? + (vcomponent->sxcal component)) + +(define (deserialize port) + (sxcal->vcomponent port)) diff --git a/module/vcomponent/formats/vdir/parse.scm b/module/vcomponent/formats/vdir/parse.scm index 46626402..8fe69fc6 100644 --- a/module/vcomponent/formats/vdir/parse.scm +++ b/module/vcomponent/formats/vdir/parse.scm @@ -64,9 +64,9 @@ ;; by RECURRENCE-ID. As far as I can tell this goes against ;; the standard. Section 3.8.4.4. (case (length events) - [(0) (warning (_ "No events in component~%~a") + [(0) (warning (G_ "No events in component~%~a") (prop item '-X-HNH-FILENAME))] - [(1) (add-child! calendar (car events))] + [(1) (reparent! calendar (car events))] ;; two or more [else @@ -108,7 +108,7 @@ ;; we need to filter duplicates either way. (map (extract 'RECURRENCE-ID) (cons head rest)) (cons head rest)))) - (add-child! calendar head))]) + (reparent! calendar head))]) ;; return calendar) diff --git a/module/vcomponent/formats/vdir/save-delete.scm b/module/vcomponent/formats/vdir/save-delete.scm index ac520463..d096405e 100644 --- a/module/vcomponent/formats/vdir/save-delete.scm +++ b/module/vcomponent/formats/vdir/save-delete.scm @@ -26,16 +26,16 @@ (unless calendar (scm-error 'wrong-type-arg "save-event" - (_ "Can only save events belonging to calendars, event uid = ~s") + (G_ "Can only save events belonging to calendars, event uid = ~s") (list (prop event 'UID)) #f)) (unless (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE)) (scm-error 'wrong-type-arg "save-event" (string-append - (_ "Can only save events belonging to vdir calendars.") + (G_ "Can only save events belonging to vdir calendars.") " " - (_ "Calendar is of type ~s")) + (G_ "Calendar is of type ~s")) (list (prop calendar '-X-HNH-SOURCETYPE)) #f)) @@ -55,10 +55,10 @@ (define calendar (parent event)) (unless (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE)) (scm-error 'wrong-type-arg "remove-event" - (string-append (_ "Can only remove events belonging to vdir calendars.") + (string-append (G_ "Can only remove events belonging to vdir calendars.") " " - (_ "Calendar is of type ~s")) + (G_ "Calendar is of type ~s")) (list (prop calendar '-X-HNH-SOURCETYPE)) #f)) (delete-file (prop event '-X-HNH-FILENAME)) - (remove-child! parent event)) + (abandon! parent event)) diff --git a/module/vcomponent/formats/xcal.scm b/module/vcomponent/formats/xcal.scm new file mode 100644 index 00000000..29a1d92f --- /dev/null +++ b/module/vcomponent/formats/xcal.scm @@ -0,0 +1,27 @@ +(define-module (vcomponent formats xcal) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :use-module ((vcomponent formats xcal output) + :select (vcomponent->sxcal ns-wrap)) + :use-module ((vcomponent formats xcal parse) + :select (sxcal->vcomponent)) + :use-module ((hnh util) :select (->)) + :export (serialize deserialize)) + + +(define* (serialize component port key: (namespaces '())) + (-> (vcomponent->sxcal component) + ns-wrap + (namespaced-sxml->xml port: port + namespaces: namespaces))) + +(define (serialize/object component) + (call-with-output-string (lambda (p) (serialize component p)))) + + +(define* (deserialize port) + (-> port + xml->namespaced-sxml + root-element ; Strip potential *TOP* + cadr ; Remove containing icalendar + sxcal->vcomponent)) diff --git a/module/vcomponent/formats/xcal/output.scm b/module/vcomponent/formats/xcal/output.scm index 87ebd32b..e4a84efb 100644 --- a/module/vcomponent/formats/xcal/output.scm +++ b/module/vcomponent/formats/xcal/output.scm @@ -8,6 +8,9 @@ :use-module (datetime) :use-module (srfi srfi-1) :use-module (calp translation) + :use-module (calp namespaces) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) :export (vcomponent->sxcal ns-wrap)) @@ -56,7 +59,7 @@ [(memv key '(GEO)) (lambda (_ v) - `(geo + `(,(xml xcal 'geo) (latitude ,(geo-latitude v)) (longitude ,(geo-longitude v))))] @@ -70,19 +73,20 @@ (get-writer 'TEXT)] [else - (warning (_ "Unknown key ~a") key) + (warning (G_ "Unknown key ~a") key) (get-writer 'TEXT)])) - (writer ((@@ (vcomponent base) get-vline-parameters) vline) (value vline))) + (writer ((@@ (vcomponent base) get-vline-parameters) vline) + (value vline))) (define (property->value-tag tag . values) (if (or (eq? tag 'VALUE) (internal-field? tag)) #f - `(,(downcase-symbol tag) + `(,(xml xcal (downcase-symbol tag)) ,@(map (lambda (v) ;; TODO parameter types!!!! (rfc6321 3.5.) - `(text ,(->string v))) + `(,(xml xcal 'text) ,(->string v))) values)))) ;; ((key value ...) ...) -> `(parameters , ... ) @@ -92,15 +96,14 @@ parameters)) (unless (null? outparams) - `(parameters ,@outparams))) + `(,(xml xcal 'parameters) ,@outparams))) (define (vcomponent->sxcal component) (define tagsymb (downcase-symbol (type component))) - (remove null? - `(,tagsymb + `(,(xml xcal tagsymb) ;; only have <properties> when it's non-empty. ,(let ((props (filter-map @@ -109,7 +112,7 @@ [(key vlines ...) (remove null? - `(,(downcase-symbol key) + `(,(xml xcal (downcase-symbol key)) ,(parameters-tag (reduce assq-merge '() (map parameters vlines))) ,@(for vline in vlines @@ -117,18 +120,22 @@ [(key . vline) (remove null? - `(,(downcase-symbol key) + `(,(xml xcal (downcase-symbol key)) ,(parameters-tag (parameters vline)) ,(vline->value-tag vline)))]) - (properties component)))) + ;; 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) - `(properties + `(,(xml xcal 'properties) ;; NOTE ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME))) ,@props))) ,(unless (null? (children component)) - `(components ,@(map vcomponent->sxcal (children component))))))) + `(,(xml xcal 'components) + ,@(map vcomponent->sxcal (children component))))))) (define (ns-wrap sxml) - `(icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0")) - ,sxml)) + `(,(xml xcal 'icalendar) + ,sxml)) diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm index 8537956a..7ed8c637 100644 --- a/module/vcomponent/formats/xcal/parse.scm +++ b/module/vcomponent/formats/xcal/parse.scm @@ -3,18 +3,23 @@ :use-module (hnh util exceptions) :use-module (base64) :use-module (ice-9 match) + :use-module (calp namespaces) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) :use-module (sxml match) :use-module (vcomponent) :use-module (vcomponent geo) :use-module (vcomponent formats common types) :use-module (datetime) :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) :use-module (calp translation) :export (sxcal->vcomponent) ) ;; symbol, ht, (list a) -> non-list -(define (handle-value type props value) +(define (handle-value type parameters value) (case type [(binary) @@ -25,17 +30,17 @@ [(boolean) (string=? "true" (car value))] ;; TODO possibly trim whitespace on text fields - [(cal-address uri text unknown) (car value)] + [(cal-address uri text unknown) (string-concatenate value)] [(date) ;; TODO this is correct, but ensure remaining types - (hashq-set! props 'VALUE "DATE") + (hashq-set! parameters 'VALUE "DATE") (parse-iso-date (car value))] [(date-time) (parse-iso-datetime (car value))] [(duration) - ((get-parser 'DURATION) props value)] + ((get-parser 'DURATION) parameters value)] [(float integer) ; (3.0) (string->number (car value))] @@ -84,7 +89,7 @@ bymonth bysetpos) (string->number value)) (else (scm-error 'key-error "handle-value" - (_ "Invalid type ~a, with value ~a") + (G_ "Invalid type ~a, with value ~a") (list type value) #f)))))) @@ -96,35 +101,39 @@ (for key in '(bysecond byminute byhour byday bymonthday byyearday byweekno bymonth bysetpos freq until count interval wkst) - (define values (assoc-ref-all value key)) - (if (null? values) - #f - (case key - ;; These fields all have zero or one value - ((freq until count interval wkst) - (list (symbol->keyword key) - (parse-value-of-that-type - key (car (map car values))))) - ;; these fields take lists - ((bysecond byminute byhour byday bymonthday - byyearday byweekno bymonth bysetpos) - (list (symbol->keyword key) - (map (lambda (v) (parse-value-of-that-type key v)) - (map car values)))) - (else (scm-error 'misc-error "handle-value" - "Invalid key ~s" - (list key) - #f)))))))))] + (cond ((find-element (xml xcal key) value) + => (lambda (v) + (case key + ;; These fields all have zero or one value + ((freq until count interval wkst) + (list (symbol->keyword key) + (parse-value-of-that-type + key (cadr v)))) + ;; these fields take lists + ((bysecond byminute byhour byday bymonthday + byyearday byweekno bymonth bysetpos) + (list (symbol->keyword key) + (map (lambda (v) (parse-value-of-that-type key v)) + (cadr v)))) + (else (scm-error 'misc-error "handle-value" + "Invalid key ~s" + (list key) + #f))))) + (else #f)))))))] [(time) (parse-iso-time (car value))] - [(utc-offset) ((get-parser 'UTC-OFFSET) props (car value))] + [(utc-offset) ((get-parser 'UTC-OFFSET) parameters (car value))] [(geo) ; ((long 1) (lat 2)) (sxml-match (cons 'geo value) [(geo (latitude ,x) (longitude ,y)) - ((@ (vcomponent geo) make-geo) x y)])])) + ((@ (vcomponent geo) make-geo) x y)])] + + [else (scm-error 'misc-error "handle-value" + "Unknown value type: ~s" + (list type) #f)])) (define (symbol-upcase symb) (-> symb @@ -134,15 +143,20 @@ (define (handle-parameters parameters) + ;; (assert (element-matches? (xml xcal 'parameters) + ;; parameters)) + (define ht (make-hash-table)) - (for param in parameters - (match param - [(ptag (ptype pvalue ...) ...) - ;; TODO parameter type (rfc6321 3.5.) - ;; TODO multi-valued parameters!!! - (hashq-set! ht (symbol-upcase ptag) - (car (concatenate pvalue)))])) + (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) (define* (parse-enum str enum optional: (allow-other #t)) @@ -153,11 +167,12 @@ ;; symbol non-list -> non-list -(define (handle-tag tag-name data) +(define (handle-tag xml-tag data) + (define tag-name (xml-element-tagname xml-tag)) (case tag-name [(request-status) ;; TODO - (warning (_ "Request status not yet implemented")) + (warning (G_ "Request status not yet implemented")) #f] ((transp) (parse-enum @@ -174,6 +189,49 @@ data '(AUDIO DISPLAY EMAIL NONE))) [else data])) +(define (handle-single-property! component tree) + (define xml-tag (car tree)) + (define tag (xml-element-tagname xml-tag)) + (define tag* (symbol-upcase tag)) + + (define body (cdr tree)) + + ;; TODO request-status + (define-values (parameters data) + (if (element-matches? (xml xcal 'parameters) + (car body)) + (values (handle-parameters (car body)) + (cdr body)) + (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 + xml-tag + (let ((v (handle-value type parameters raw-value))) + ;; TODO possibly more list fields + ;; (if (eq? tag 'categories) + ;; (string-split v #\,) + ;; 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)))) + ;; Note ;; This doesn't verify the inter-field validity of the object, ;; meaning that value(DTSTART) == DATE and value(DTEND) == DATE-TIME @@ -181,83 +239,29 @@ ;; TODO ;; since we are feeding user input into this it really should be fixed. (define (sxcal->vcomponent sxcal) - (define type (symbol-upcase (car sxcal))) + + ;; TODO the surrounding icalendar element needs to be removed BEFORE this procedue is called + + (define xml-tag (car sxcal)) + (define type (symbol-upcase (xml-element-tagname xml-tag))) (define component (make-vcomponent type)) - (awhen (assoc-ref sxcal 'properties) + (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 - (for property in it - (match property - ;; TODO request-status - - [(tag ('parameters parameters ...) - (type value ...) ...) - (let ((params (handle-parameters parameters)) - (tag* (symbol-upcase tag))) - (for (type value) in (zip type value) - ;; ignore empty fields - ;; mostly for <text/> - (unless (null? value) - (let () - (define vline - (make-vline tag* - (handle-tag - tag (handle-value type params value)) - params)) - (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))) - ;; else - (set! (prop* component tag*) vline)) - ))))] - - [(tag (type value ...) ...) - (for (type value) in (zip type value) - ;; ignore empty fields - ;; mostly for <text/> - (unless (null? value) - (let ((params (make-hash-table)) - (tag* (symbol-upcase tag))) - (define vline - (make-vline tag* - (handle-tag - tag (let ((v (handle-value type params value))) - ;; TODO possibly more list fields - (if (eq? tag 'categories) - (string-split v #\,) - v))) - params)) - ;; - - (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))) - ;; else - (set! (prop* component tag*) vline)) - )))]))) + (map (lambda (x) (handle-single-property! component x)) + (cdr it))) ;; children - (awhen (assoc-ref sxcal 'components) - (for child in (map sxcal->vcomponent it) - (add-child! component child))) + (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) diff --git a/module/vcomponent/formats/xcal/types.scm b/module/vcomponent/formats/xcal/types.scm index a88b6b04..82121d5e 100644 --- a/module/vcomponent/formats/xcal/types.scm +++ b/module/vcomponent/formats/xcal/types.scm @@ -3,16 +3,18 @@ :use-module (vcomponent formats ical types) :use-module (datetime) :use-module (calp translation) + :use-module ((calp namespaces) :select (xcal)) + :use-module ((sxml namespaced) :select (xml)) :export (get-writer)) (define (write-boolean _ v) - `(boolean ,(if v "true" "false"))) + `(,(xml xcal 'boolean) ,(if v "true" "false"))) (define (write-date _ v) - `(date ,(date->string v "~Y-~m-~d"))) + `(,(xml xcal 'date) ,(date->string v "~Y-~m-~d"))) (define (write-datetime p v) - `(date-time + `(,(xml xcal 'date-time) ,(datetime->string (hashq-ref p '-X-HNH-ORIGINAL v) ;; 'Z' should be included for UTC, @@ -21,17 +23,17 @@ "~Y-~m-~dT~H:~M:~S~Z"))) (define (write-time _ v) - `(time ,(time->string v "~H:~M:S"))) + `(,(xml xcal 'time) ,(time->string v "~H:~M:S"))) (define (write-recur _ v) - `(recur ,@((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v))) + `(,(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 - `(text ,v)) + `(,(xml xcal 'text) ,v)) @@ -40,7 +42,7 @@ #| TODO PERIOD |# URI UTC-OFFSET) (hashq-set! sxml-writers simple-type (lambda (p v) - `(,(downcase-symbol simple-type) + `(,(xml xcal (downcase-symbol simple-type)) ,(((@ (vcomponent formats ical types) get-writer) simple-type) p v))))) (hashq-set! sxml-writers 'BOOLEAN write-boolean) @@ -52,4 +54,4 @@ (define (get-writer type) (or (hashq-ref sxml-writers type #f) - (error (_ "No writer for type") type))) + (error (G_ "No writer for type") type))) |