Major work on, something.

6 files changed, 206 insertions, 177 deletions

diff --git a/module/vcomponent/formats/ical/output.scm b/module/vcomponent/formats/ical/output.scm
index 57860d2a..5fa004bb 100644
--- a/module/vcomponent/formats/ical/output.scm
+++ b/module/vcomponent/formats/ical/output.scm
@@ -14,7 +14,8 @@
   :use-module (vcomponent)
   :use-module (vcomponent datetime)
   :use-module (vcomponent geo)
-  :use-module (vcomponent formats ical types)
+  :use-module ((vcomponent formats ical types)
+               :select (escape-chars get-writer))
   :use-module (vcomponent recurrence)
   :use-module ((calp) :select (prodid))
   :use-module (calp translation)
@@ -98,11 +99,12 @@
 
   (catch #t #; 'wrong-type-arg
     (lambda ()
-      (writer ((@@ (vcomponent base) get-vline-parameters) vline)
-              (value vline)))
+      (writer
+       (vline-parameters vline)
+       (vline-value vline)))
     (lambda (err caller fmt args call-args)
       (define fallback-string
-        (with-output-to-string (lambda () (display value))))
+        (with-output-to-string (lambda () (display (vline-value vline)))))
       (warning "key = ~a, caller = ~s, call-args = ~s~%~k~%Falling back to ~s"
                key caller call-args fmt args
                fallback-string)
@@ -126,11 +128,10 @@
 
 
 (define (vline->string vline)
-  (define key (vline-key vline))
   (ical-line-fold
    ;; Expected output: key;p1=v;p3=10:value
    (string-append
-    (symbol->string key)
+    (symbol->string (key vline))
     (string-concatenate
      (map (match-lambda
             [(? (compose internal-field? car)) ""]
@@ -140,7 +141,7 @@
               (string-join (map (compose escape-chars ->string) values)
                            "," 'infix))])
           (parameters vline)))
-    ":" (value-format key vline))))
+    ":" (value-format (key vline) vline))))
 
 (define (component->ical-string component)
   (format #t "BEGIN:~a\r\n" (type component))
diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm
index f0a19ba5..38257fba 100644
--- a/module/vcomponent/formats/ical/parse.scm
+++ b/module/vcomponent/formats/ical/parse.scm
@@ -1,6 +1,7 @@
 (define-module (vcomponent formats ical parse)
   :use-module ((ice-9 rdelim) :select (read-line))
   :use-module (ice-9 format)
+  :use-module (ice-9 curried-definitions)
   :use-module (hnh util exceptions)
   :use-module (hnh util)
   :use-module (datetime)
@@ -12,6 +13,8 @@
   :use-module (vcomponent geo)
   :use-module (vcomponent formats common types)
   :use-module (calp translation)
+  :use-module (hnh util lens)
+  :use-module (hnh util table)
   :export (parse-calendar))
 
 ;;; TODO a few translated strings here contain explicit newlines. Check if that
@@ -139,7 +142,7 @@
 (define (build-vline key value params)
   (let ((parser
          (cond
-          [(and=> (hashq-ref params 'VALUE) string->symbol) => get-parser]
+          [(and=> (table-get params 'VALUE) string->symbol) => get-parser]
 
           [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID RDATE
                               CREATED DTSTAMP LAST-MODIFIED
@@ -246,9 +249,9 @@
     (let ((parsed (parser params value)))
       (if (list? parsed)
           (apply values
-                 (map (lambda (p) (make-vline key p params))
+                 (map (lambda (p) (vline key: key vline-value: p vline-parameters: params))
                       parsed))
-       (make-vline key parsed params)))))
+       (vline key: key vline-value: parsed vline-parameters: params)))))
 
 ;; (parse-itemline '("DTEND"  "20200407T130000"))
 ;; => DTEND
@@ -256,17 +259,45 @@
 ;; => #<hash-table 7f76b5f82a60 0/31>
 (define (parse-itemline itemline)
   (define key (string->symbol (car itemline)))
-  (define parameters (make-hash-table))
-  (let loop ((rem (cdr itemline)))
-    (if (null? (cdr rem))
-        (values key (car rem) parameters )
-        (let* ((kv (car rem))
-               (idx (string-index kv #\=)))
-          ;; TODO lists in parameters
-          (hashq-set! parameters (string->symbol (substring kv 0 idx))
-                      (substring kv (1+ idx)))
-          (loop (cdr rem))))))
-
+  ;; (define parameters (make-hash-table))
+  (define-values (parameters value) (init+last (cdr itemline)))
+  (values
+   key value
+   (fold (lambda (parameter table)
+           (let ((idx (string-index parameter #\=)))
+             ;; TODO lists in parameters
+             (table-put table (string->symbol (substring parameter 0 idx))
+                        (substring parameter (1+ idx)))))
+         (table)
+         parameters)))
+
+(define ((warning-handler-proc token) fmt . args)
+  (let ((linedata (get-metadata token)))
+    (format
+     #f
+     ;; arguments:
+     ;; linedata
+     ;; ~?
+     ;; source line
+     ;; source file
+     (G_ "WARNING parse error around ~a
+  ~?
+  line ~a ~a~%")
+     (get-string linedata)
+     fmt args
+     (get-line linedata)
+     (get-file linedata)
+     )))
+
+;;; Property keys which are allowed multiple times
+(define repeating-properties
+  '(ATTACH ATTENDEE CATEGORIES
+           COMMENT CONTACT EXDATE
+           REQUEST-STATUS RELATED-TO
+           RESOURCES RDATE
+           ;; x-prop
+           ;; iana-prop
+           ))
 
 ;; (list <tokens>) → <vcomponent>
 (define (parse lst)
@@ -274,69 +305,53 @@
              (stack '()))
     (if (null? lst)
         stack
-        (let* ((head* (car lst))
-               (head (get-data head*)))
+        (let* ((token (car lst))
+               (head (get-data token)))
           (catch 'parse-error
             (lambda ()
-             (parameterize
-                 ((warning-handler
-                   (lambda (fmt . args)
-                     (let ((linedata (get-metadata head*)))
-                       (format
-                        #f
-                        ;; arguments:
-                        ;; linedata
-                        ;; ~?
-                        ;; source line
-                        ;; source file
-                        (G_ "WARNING parse error around ~a
-  ~?
-  line ~a ~a~%")
-                        (get-string linedata)
-                        fmt args
-                        (get-line linedata)
-                        (get-file linedata)
-                        )))))
-               (cond [(string=? "BEGIN" (car head))
-                      (loop (cdr lst)
-                            (cons (make-vcomponent (string->symbol (cadr head)))
-                                  stack))]
-                     [(string=? "END" (car head))
-                      (loop (cdr lst)
-                            (if (null? (cdr stack))
-                                ;; return
-                                (car stack)
-                                (begin (reparent! (cadr stack) (car stack))
-                                       (cdr stack))))]
-                     [else
-                      (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))
-
-                                 (set! (vline-source vline)
-                                   (get-metadata head*))
+              (parameterize ((warning-handler (warning-handler-proc token)))
+                (cond [(string=? "BEGIN" (car head))
+                       (format (current-error-port) "BEGIN ~s~%" (cadr head))
+                       (loop (cdr lst)
+                             (cons (vcomponent type: (string->symbol (cadr head)))
+                                   stack))]
+                      [(string=? "END" (car head))
+                       (format (current-error-port) "END ~s~%" (cadr head))
+                       (loop (cdr lst)
+                             (if (null? (cdr stack))
+                                 ;; return
+                                 stack
+                                 (cons (add-child (cadr stack) (car stack))
+                                       (cddr stack))))]
+                      [else
+                       (let ((k value params (parse-itemline head)))
+                         (loop (cdr lst)
+                               (let (((values . vlines) (build-vline k value params)))
+                                 ;; TODO
+                                 ;; (set! (vline-source vline)
+                                 ;;   (get-metadata token))
 
                                  ;; See RFC 5545 p.53 for list of all repeating types
                                  ;; (for vcomponent)
-                                 ;; TODO templetize this, and allow users to set which types are list types, but also validate this upon creation (elsewhere)
-                                 (if (memv key '(ATTACH ATTENDEE CATEGORIES
-                                                     COMMENT CONTACT EXDATE
-                                                     REQUEST-STATUS RELATED-TO
-                                                     RESOURCES RDATE
-                                                     ;; x-prop
-                                                     ;; iana-prop
-                                                     ))
-                                     (aif (prop* (car stack) key)
-                                          (set! (prop* (car stack) key) (cons vline it))
-                                          (set! (prop* (car stack) key) (list vline)))
-                                     ;; else
-                                     (set! (prop* (car stack) key) vline))))))
-
-                      (loop (cdr lst) stack)])))
+                                 ;; TODO templetize this, and allow users to
+                                 ;; set which types are list types, but also
+                                 ;; validate this upon creation (elsewhere).
+                                 (fold (lambda (vline stack)
+                                         (modify stack car*
+                                                 (lambda (comp)
+                                                   (format (current-error-port)
+                                                           "    stack=~s, comp=~s~%"
+                                                           stack comp)
+                                                   (if (memv (key vline) repeating-properties)
+                                                       (aif (prop* comp (key vline))
+                                                            (prop* comp (key vline) (cons vline it))
+                                                            (prop* comp (key vline) (list vline)))
+                                                       ;; else
+                                                       (prop* comp (key vline) vline)))))
+                                       stack vlines))))])))
+
             (lambda (err proc fmt fmt-args data)
-              (let ((linedata (get-metadata head*)))
+              (let ((linedata (get-metadata token)))
                 (display (format
                           #f
                           ;; arguments
@@ -353,7 +368,10 @@
                           (get-line linedata)
                           (get-file linedata))
                          (current-error-port))
-                (let ((key value params (parse-itemline head)))
-                  (set! (prop* (car stack) key)
-                    (make-vline key value params))
-                  (loop (cdr lst) stack)))))))))
+                (let ((k value params (parse-itemline head)))
+                  (loop (cdr lst)
+                        (modify stack car*
+                                (lambda (c) (prop* c key
+                                              (vline key: k
+                                                     vline-value: value
+                                                     vline-parameters: params)))))))))))))
diff --git a/module/vcomponent/formats/ical/types.scm b/module/vcomponent/formats/ical/types.scm
index 768f5098..c5259f0d 100644
--- a/module/vcomponent/formats/ical/types.scm
+++ b/module/vcomponent/formats/ical/types.scm
@@ -2,6 +2,7 @@
 (define-module (vcomponent formats ical types)
   :use-module (hnh util)
   :use-module (hnh util exceptions)
+  :use-module (hnh util table)
   :use-module (base64)
   :use-module (datetime)
   :use-module (datetime timespec)
@@ -23,7 +24,8 @@
   ;; NOTE We really should output TZID from param here, but
   ;; we first need to change so these writers can output
   ;; parameters.
-  (datetime->string (hashq-ref param '-X-HNH-ORIGINAL value)
+  (datetime->string (or (table-get param '-X-HNH-ORIGINAL)
+                        value)
                     "~Y~m~dT~H~M~S~Z"))
 
 (define (write-duration _ value)
diff --git a/module/vcomponent/formats/vdir/parse.scm b/module/vcomponent/formats/vdir/parse.scm
index 8fe69fc6..7f1439ae 100644
--- a/module/vcomponent/formats/vdir/parse.scm
+++ b/module/vcomponent/formats/vdir/parse.scm
@@ -44,13 +44,14 @@
                 (partition (lambda (e) (eq? 'VEVENT (type e)))
                            (children item)))
 
-
               (unless (eq? 'VCALENDAR (type item))
                 (scm-error 'misc-error "parse-vdir"
                            "Unexepected top level component. Expected VCALENDAR, got ~a. In file ~s"
                            (list (type item) (prop item '-X-HNH-FILENAME))
                            #f))
 
+              ;; TODO
+              #;
               (for child in (children item)
                    (set! (prop child '-X-HNH-FILENAME)
                      (prop (parent child) '-X-HNH-FILENAME)))
@@ -65,8 +66,9 @@
               ;; the standard. Section 3.8.4.4.
               (case (length events)
                 [(0) (warning (G_ "No events in component~%~a")
-                              (prop item '-X-HNH-FILENAME))]
-                [(1) (reparent! calendar (car events))]
+                              (prop item '-X-HNH-FILENAME))
+                 calendar]
+                [(1) (add-child calendar (car events))]
 
                 ;; two or more
                 [else
@@ -93,35 +95,36 @@
                                   (car events)))
                         (rest (delete head events eq?)))
 
-                   (set! (prop head '-X-HNH-ALTERNATIVES)
-                     (alist->hash-table
-                      (map cons
-                           ;; head is added back to the collection to simplify
-                           ;; generation of recurrences. The recurrence
-                           ;; generation assumes that the base event either
-                           ;; contains an RRULE property, OR is in the
-                           ;; -X-HNH-ALTERNATIVES set. This might produce
-                           ;; duplicates, since the base event might also
-                           ;; get included through an RRULE. This however
-                           ;; is almost a non-problem, since RDATES and RRULES
-                           ;; can already produce duplicates, meaning that
-                           ;; we need to filter duplicates either way.
-                           (map (extract 'RECURRENCE-ID) (cons head rest))
-                           (cons head rest))))
-                   (reparent! calendar head))])
+                   (add-child
+                    calendar
+                    ;; TODO this is really ugly
+                    (prop head '-X-HNH-ALTERNATIVES
+                          (alist->hash-table
+                           (map cons
+                                ;; head is added back to the collection to simplify
+                                ;; generation of recurrences. The recurrence
+                                ;; generation assumes that the base event either
+                                ;; contains an RRULE property, OR is in the
+                                ;; -X-HNH-ALTERNATIVES set. This might produce
+                                ;; duplicates, since the base event might also
+                                ;; get included through an RRULE. This however
+                                ;; is almost a non-problem, since RDATES and RRULES
+                                ;; can already produce duplicates, meaning that
+                                ;; we need to filter duplicates either way.
+                                (map (extract 'RECURRENCE-ID) (cons head rest))
+                                (cons head rest))))))])
 
               ;; return
               calendar)
-            (make-vcomponent)
+            (vcomponent type: 'VIRTUAL)
             (map #; (@ (ice-9 threads) par-map)
              (lambda (fname)
                (let ((fullname (path-append path fname)))
-                 (let ((cal (call-with-input-file fullname
-                              parse-calendar)))
-                   (set! (prop cal 'COLOR) color
-                         (prop cal 'NAME) name
-                         (prop cal '-X-HNH-FILENAME) fullname)
-                   cal)))
+                 (set-properties (call-with-input-file fullname
+                                   parse-calendar)
+                                 (cons 'COLOR color)
+                                 (cons 'NAME name)
+                                 (cons '-X-HNH-FILENAME fullname))))
              (scandir path (lambda (s) (and (not (string= "." (string-take s 1)))
                                        (string= "ics" (string-take-right s 3)))))))))
 
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)))