Major work on, something.

30 files changed, 733 insertions, 738 deletions

diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm
index 3c7e2546..070d1c3f 100644
--- a/module/calp/html/view/calendar.scm
+++ b/module/calp/html/view/calendar.scm
@@ -381,13 +381,11 @@ window.default_calendar='~a';"
              (repeating% regular (partition repeating? flat-events))
              (repeating
               (for ev in repeating%
-                   (define instance (copy-vcomponent ev))
-
-                   (set! (prop instance 'UID) (output-uid instance))
-                   (delete-parameter! (prop* instance 'DTSTART) '-X-HNH-ORIGINAL)
-                   (delete-parameter! (prop* instance 'DTEND)   '-X-HNH-ORIGINAL)
-
-                   instance)))
+                   ;; TODO
+                   (-> (set-properties ev 'UID (output-uid ev))
+                       ;; (focus (prop* instance 'DTSTART) (lambda (vline) (remove-parameter vline key)))
+                       ;; (focus (prop* instance 'DTEND)   (lambda (vline) (remove-parameter vline key)))
+                       ))))
 
         `(
           ;; Mapping showing which events belongs to which calendar,
diff --git a/module/calp/server/webdav.scm b/module/calp/server/webdav.scm
index f26b97f6..781a85d9 100644
--- a/module/calp/server/webdav.scm
+++ b/module/calp/server/webdav.scm
@@ -126,6 +126,7 @@
 (declare-method! "LOCK" 'LOCK)
 (declare-method! "UNLOCK" 'UNLOCK)
 (declare-method! "REPORT" 'REPORT)
+(declare-method! "MKCALENDAR" 'REPORT)
 
 
 
diff --git a/module/calp/webdav/resource/calendar/collection.scm b/module/calp/webdav/resource/calendar/collection.scm
index 9acb6701..e1bf73fd 100644
--- a/module/calp/webdav/resource/calendar/collection.scm
+++ b/module/calp/webdav/resource/calendar/collection.scm
@@ -9,7 +9,7 @@
   :use-module ((vcomponent formats ical) :prefix #{ics:}#)
   :use-module ((vcomponent) :prefix vcs-)
   :use-module ((vcomponent base)
-               :select (type prop make-vcomponent))
+               :select (type prop vcomponent))
 
   :use-module (web request)
   :use-module (web uri)
@@ -33,10 +33,7 @@
   (description init-value: #f
                accessor: description)
   (data-store getter: data-store
-              init-keyword: store:)
-  #;
-  (content% init-value: (make-vcomponent 'VIRTUAL)
-            accessor: content%))
+              init-keyword: store:))
 
 
 (define-method (is-collection? (_ <calendar-collection-resource>))
@@ -57,7 +54,7 @@
 
 (define-method (base-timezone <calendar-collection-resource>)
   ;; (zoneinfo->vtimezone '() "Europe/Stockholm" 'ev)
-  (make-vcomponent 'VTIMEZONE)
+  (vcomponent type: 'VTIMEZONE)
   )
 
 
diff --git a/module/hnh/util/assert.scm b/module/hnh/util/assert.scm
new file mode 100644
index 00000000..74715654
--- /dev/null
+++ b/module/hnh/util/assert.scm
@@ -0,0 +1,9 @@
+(define-module (hnh util assert)
+  :use-module (rnrs base)
+  :export (assert*)
+  )
+
+(define-syntax assert*
+  (syntax-rules ()
+    ((_ assertion)
+     (assert assertion))))
diff --git a/module/hnh/util/lens.scm b/module/hnh/util/lens.scm
index 7a8fbd19..26c75be7 100644
--- a/module/hnh/util/lens.scm
+++ b/module/hnh/util/lens.scm
@@ -9,7 +9,9 @@
            compose-lenses
            lens-compose
 
-           ref car* cdr*))
+           ref car* cdr*
+
+           each))
 
 
 (define (modify object lens f . args)
@@ -97,3 +99,7 @@
 
 (define car* (make-lens car (lambda (pair value) (cons value (cdr pair)))))
 (define cdr* (make-lens cdr (lambda (pair value) (cons (car pair) value))))
+
+(define (each obj lens proc)
+  (modify obj lens
+          (lambda (lst) (map proc lst))))
diff --git a/module/hnh/util/table.scm b/module/hnh/util/table.scm
index 5835851b..a57e6591 100644
--- a/module/hnh/util/table.scm
+++ b/module/hnh/util/table.scm
@@ -8,6 +8,8 @@
   :export ((make-tree . table)
            (tree-get . table-get)
            (tree-put . table-put)
+           (tree-remove . table-remove)
+           (tree->list . table->list)
            (tree? . table?)
            (alist->tree . alist->table)))
 
@@ -41,13 +43,30 @@
                  tree-put k v))))
 
 (define (tree-get tree k)
-  (cond ((tree-terminal? tree) (throw 'out-of-range))
+  (cond ((tree-terminal? tree) #f ; (throw 'out-of-range)
+         )
         ((eq? k (key tree)) (value tree))
         ((symbol<? k (key tree))
          (tree-get (left tree) k))
         (else
          (tree-get (right tree) k))))
 
+(define (tree-remove tree k)
+  (cond ((tree-terminal? tree) tree)
+        ((eq? k (key tree))
+         (merge-trees (left tree) (right tree)))
+        ((symbol<? k (key tree))
+         (modify tree left (lambda (t) (tree-remove t k))))
+        (else
+         (modify tree right (lambda (t) (tree-remove t k))))))
+
+(define (merge-trees a b)
+  ;; TODO write a better version of this
+  (fold (lambda (item tree)
+          (apply tree-put tree item))
+        a
+        b))
+
 ;; in-order traversal
 (define (tree->list tree)
   (if (tree-terminal? tree)
@@ -60,10 +79,10 @@
 (define (tree-map f tree)
   (if (tree-terminal? tree)
       '()
-      (tree-node (key tree)
-                 (f (key tree) (value tree))
-                 (tree-map f (left tree))
-                 (tree-map f (right tree)))))
+      (tree-node key:   (key tree)
+                 value: (f (key tree) (value tree))
+                 left:  (tree-map f (left tree))
+                 right: (tree-map f (right tree)))))
 
 ;; pre-order
 (define (tree-fold f init tree)
@@ -74,7 +93,7 @@
           (tree-fold f b (right tree))))))
 
 (define (alist->tree alist)
-  (fold (lambda (kv tree) (apply tree-put tree kv))
+  (fold (lambda (kv tree) (tree-put tree (car kv) (cdr kv)))
         (tree-terminal)
         alist))
 
diff --git a/module/vcomponent.scm b/module/vcomponent.scm
index 0f000ba5..7930bf92 100644
--- a/module/vcomponent.scm
+++ b/module/vcomponent.scm
@@ -2,12 +2,21 @@
   :use-module (hnh util)
   :use-module (vcomponent base)
   :use-module (vcomponent config)
-  ;; :use-module ((vcomponent util instance methods)
-  ;;              :select (make-vcomponent))
   :use-module ((vcomponent util parse-cal-path)
                :select (parse-cal-path))
-  :re-export (make-vcomponent
+  :re-export (
+              vcomponent
+              set-properties
+              properties
+              children
+              type
+              prop
+              prop*
               parse-cal-path
+              param
+              ;; value
+              vline?
+              vline-parameters
               ;; configuration items
               calendar-files default-calendar))
 
diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm
index 472c5074..ff2382bf 100644
--- a/module/vcomponent/base.scm
+++ b/module/vcomponent/base.scm
@@ -1,41 +1,39 @@
 (define-module (vcomponent base)
   :use-module (hnh util)
   :use-module (srfi srfi-1)
-  :use-module (srfi srfi-9)
-  :use-module (srfi srfi-9 gnu)
   :use-module (srfi srfi-17)
   :use-module (srfi srfi-88)
-  :use-module (ice-9 hash-table)
-  :export (make-vline
+  :use-module (hnh util object)
+  :use-module (hnh util lens)
+  :use-module (hnh util table)
+  :use-module (hnh util uuid)
+  :export (vline
            vline?
-           vline-key
+           vline-value
+           key
+           vline-parameters
            vline-source
 
-           make-vcomponent
+           vcomponent
            vcomponent?
            children type parent
+           add-child
 
-           reparent!
-           abandon!
-           orphan!
-
-           delete-property!
+           remove-property
            prop* prop
            extract extract*
 
-           delete-parameter!
-           value
+           set-properties
+
+           remove-parameter
+           ;; value
            param
 
            parameters
            properties
 
-           copy-as-orphan
-           copy-vcomponent
            x-property?
            internal-field?
-
-
            )
   )
 
@@ -53,170 +51,95 @@
 ;;; </vcomponent>
 ;;;
 
-(define-record-type <vline>
-  (make-vline% key value parameters)
-  vline?
-  (key vline-key)
-  (value get-vline-value set-vline-value!)
-  (parameters get-vline-parameters)
-  (source get-source set-source!)
-  )
-
-(set-record-type-printer!
- <vline>
- (lambda (v p)
-   (format p "#<<vline> key: ~s value: ~s parameters: ~s>"
-           (vline-key v)
-           (get-vline-value v)
-           (hash-map->list list (get-vline-parameters v)))))
-
-(define vline-source
-  (make-procedure-with-setter
-   get-source set-source!))
-
-(define* (make-vline key value optional: (ht (make-hash-table)))
-  (make-vline% key value ht))
-
-(define-record-type <vcomponent>
-  (make-vcomponent% type children properties)
-  vcomponent?
-  (type type)
-  (children children set-component-children!)
-  (properties get-component-properties))
-
-((@ (srfi srfi-9 gnu) set-record-type-printer!)
- <vcomponent>
- (lambda (c p)
-   (format p "#<<vcomponent> ~a, len(child)=~a>"
-           (type c)
-           (length (children c))
-           )))
-
-
-(define parent% (make-object-property))
-(define (parent x) (parent% x))
-
-(define* (make-vcomponent optional: (type 'VIRTUAL))
-  (make-vcomponent% type '() (make-hash-table)))
-
-;; TODO should this be renamed to `adopt!'? Adopting a child better implies
-;; that the old parent should no longer be considered its parent.
-(define (reparent! parent child)
-  (set-component-children! parent (cons child (children parent)))
-  (set! (parent% child) parent))
-
-(define (abandon! parent-component child)
-  (set-component-children! parent-component (delq1! child (children parent-component)))
-  (when (eq? parent-component (parent% child))
-    (orphan! child)))
-
-;; TODO should this exist? It's really weird to remove our reference to our
-;; parent, without the parent removing their reference to us.
-(define (orphan! child)
-  (set! (parent% child) #f))
-
-;;; TODO key=DTSTART, (date? value) => #t
-;;; KRÄVER att (props vline 'VALUE) <- "DATE"
-(define (set-property! component key value)
-  (let ((ht (get-component-properties component)))
-   (cond [(hashq-ref ht key #f)
-          => (lambda (vline) (set-vline-value! vline value))]
-         [else (hashq-set! ht key (make-vline key value))])))
+(define (print-vline v p)
+  (format p "#<<vline> key: ~s value: ~s parameters: ~s>"
+          (key v)
+          (vline-value v)
+          #f
+          ;; (hash-map->list list (get-vline-parameters v))
+          ))
 
+(define-type (vline printer: print-vline)
+  (key type: symbol?)
+  (vline-value)
+  (vline-parameters default: (table) type: table?)
+  (vline-source default: "" type: string?))
 
-
+(define (print-vcomponent c p)
+  (format p "#<<vcomponent> ~a>"
+          (type c)))
 
-;; vline → value
-(define value
-  (make-procedure-with-setter
-   get-vline-value set-vline-value!))
 
-;; vcomponent x (or str symb) → vline
-(define (get-prop* component prop)
-  (hashq-ref (get-component-properties component)
-             (as-symb prop)))
+(define false? not)
 
-(define (set-prop*! component key value)
-  (hashq-set! (get-component-properties component)
-              (as-symb key) value))
+(define-type (vcomponent printer: print-vcomponent)
+  (type                        type: symbol?)
+  (vcomponent-children
+              default: (table) type: table?)
+  (component-properties
+              default: (table) type: table?)
+  (parent     default: #f      type: (or false? vcomponent?)))
 
 (define prop*
-  (make-procedure-with-setter
-   get-prop*
-   set-prop*!))
-
-(define (delete-property! component key)
-  (hashq-remove! (get-component-properties component)
-                 (as-symb key)))
+  (case-lambda
+    ((object key)
+     (table-get (component-properties object) key))
+    ((object key value)
+     (component-properties object
+      (table-put (component-properties object) key value)))))
+
+(define (children c)
+  (map cdr (table->list (vcomponent-children c))))
+
+(define (add-child parent* child)
+  (modify parent* vcomponent-children
+          (lambda (table)
+            (let ((child
+                   (if (prop child 'UID)
+                       child
+                       (prop child 'UID (uuid)))))
+              (table-put table
+                         (as-symb (prop child 'UID))
+                         (parent child parent*))))))
 
+
 
-;; vcomponent x (or str symb) → value
-(define (get-prop component key)
-  (let ((props (get-prop* component key)))
-    (cond [(not props) #f]
-          [(list? props) (map value props)]
-          [else (value props)])))
-
-;; TODO do something sensible here
-(define (set-prop! component key value)
-  (set-property! component (as-symb key) value))
-
+;; (define prop (compose-lens vline-value prop*))
 (define prop
-  (make-procedure-with-setter
-   get-prop
-   set-prop!))
-
+  (case-lambda
+    ((comp key) (and=> (prop* comp key) vline-value))
+    ((comp k v)
+     (cond ((prop* comp k)
+            => (lambda (vline)
+                 (prop* comp k (vline-value vline v))))
+           (else
+            (prop* comp k (vline key: k vline-value: v)))))))
+
+(define (remove-property component key)
+  (component-properties component
+              (table-remove (component-properties component) key)))
 
 (define param
-  (make-procedure-with-setter
-   (lambda (vline parameter-key)
-     ;; TODO `list' is a hack since a bit to much code depends
-     ;; on prop always returning a list of values.
-     (and=> (hashq-ref (get-vline-parameters vline)
-                       (as-symb parameter-key))
-            list))
-   (lambda (vline parameter-key val)
-     (hashq-set! (get-vline-parameters vline)
-                 (as-symb parameter-key) val))))
+  ;; TODO list?
+  (case-lambda ((vline key) (and=> (table-get (vline-parameters vline) key) list))
+               ((vline k v) (vline-parameters
+                             vline
+                             (table-put (vline-parameters vline) k v)))))
 
-
-(define (delete-parameter! vline parameter-key)
-  (hashq-remove! (get-vline-parameters vline)
-                 (as-symb parameter-key)))
+(define (remove-parameter vline key)
+  (vline-parameters vline
+              (table-remove (vline-parameters vline) key)))
 
 
 ;; Returns the parameters of a property as an assoc list.
 ;; @code{(map car <>)} leads to available parameters.
 (define (parameters vline)
-  (hash-map->list list (get-vline-parameters vline)))
+  (map (compose list car+cdr)
+       (table->list (vline-parameters vline))))
 
 (define (properties component)
-  (hash-map->list cons (get-component-properties component)))
-
-(define (copy-vline vline)
-  (make-vline (vline-key vline)
-              (get-vline-value vline)
-              ;; TODO deep-copy on parameters?
-              (get-vline-parameters vline)))
-
-(define (copy-as-orphan component)
-  (make-vcomponent%
-   (type component)
-   (children component)
-   ;; properties
-   (alist->hashq-table
-    (hash-map->list (lambda (key value)
-                      (cons key (if (list? value)
-                                    (map copy-vline value)
-                                    (copy-vline value))))
-                    (get-component-properties component)))))
-
-
-(define (copy-vcomponent component)
-  (let ((ev (copy-as-orphan component)))
-    (when (parent component)
-      (reparent! (parent component) ev))
-    ev))
+  (map (compose list car+cdr)
+       (table->list (component-properties component))))
 
 (define (extract field)
   (lambda (e) (prop e field)))
@@ -231,3 +154,10 @@
   (string=? prefix
             (string-take-to (symbol->string symbol)
                             (string-length prefix))))
+
+
+(define (set-properties component . pairs)
+  ;; (format (current-error-port) "component: ~s, pairs: ~s~%" component pairs)
+  (fold (lambda (pair component) (prop component (car pair) (cdr pair)))
+        component
+        pairs))
diff --git a/module/vcomponent/create.scm b/module/vcomponent/create.scm
index 374da8b4..5704b0f1 100644
--- a/module/vcomponent/create.scm
+++ b/module/vcomponent/create.scm
@@ -1,13 +1,15 @@
 (define-module (vcomponent create)
-  :use-module (vcomponent base)
-  :use-module ((srfi srfi-1) :select (last drop-right car+cdr))
+  :use-module ((vcomponent base) :prefix vcs-)
+  :use-module ((vcomponent base)
+               :select (vline key add-child prop* vline?))
+  :use-module ((srfi srfi-1) :select (fold last drop-right car+cdr))
   :use-module (srfi srfi-9)
   :use-module (srfi srfi-9 gnu)
   :use-module (srfi srfi-17)
   :use-module (srfi srfi-71)
   :use-module (srfi srfi-88)
-  :use-module ((ice-9 hash-table) :select (alist->hashq-table))
-  :use-module ((hnh util) :select (kvlist->assq ->))
+  :use-module ((hnh util table) :select (alist->table))
+  :use-module ((hnh util) :select (swap init+last kvlist->assq ->))
   :export (with-parameters
            as-list
            vcomponent
@@ -40,26 +42,17 @@
 
 
 
-(define-immutable-record-type <almost-vline>
-  (make-almost-vline parameters value)
-  almost-vline?
-  (parameters almost-vline-parameters)
-  (value almost-vline-value))
-
-(define (almost-vline->vline key almost-vline)
-  (make-vline key
-              (almost-vline-value almost-vline)
-              (almost-vline-parameters almost-vline)))
-
-(define (with-parameters . args*)
-  (define parameters (drop-right args* 1))
-  (define value (last args*))
-  (make-almost-vline
+(define (with-parameters . args)
+  (define-values (parameters value)
+    (init+last args))
+  (vline
+   key: 'PLACEHOLDER
+   vline-value: value
+   vline-parameters:
    (-> parameters
        kvlist->assq
        upcase-keys
-       alist->hashq-table)
-   value))
+       alist->table)))
 
 
 
@@ -74,36 +67,26 @@
 
 
 (define (vcomponent type . attrs*)
-  (define component (make-vcomponent type))
-  (define attrs*-len (length attrs*))
-  (unless (zero? attrs*-len)
-    (let ((attrs children
-                 (if (and (list? (list-ref attrs* (- attrs*-len 1)))
-                          (or (= 1 attrs*-len)
-                              (not (keyword? (list-ref attrs* (- attrs*-len 2))))))
-                     (values (drop-right attrs* 1)
-                             (last attrs*))
-                     (values attrs* '()))))
-      (for-each (lambda (pair)
-                  (let ((key value (car+cdr pair)))
-                    (cond
-                     ((almost-vline? value)
-                      (set! (prop* component key)
-                        (almost-vline->vline key value)))
-                     ((list-value? value)
-                      (set! (prop* component key)
-                        (map (lambda (value)
-                               (make-vline key value (make-hash-table)))
-                             (list-value-value value))))
-                     (else
-                      (set! (prop component key) value)))))
-                (upcase-keys (kvlist->assq attrs)))
-
-      ;; Attach children
-      (for-each (lambda (child) (reparent! component child))
-                children)))
-
-  component)
+  (define-values (attrs children)
+    (cond ((null? attrs*)          (values '() '()))
+          ((even? (length attrs*)) (values attrs* '()))
+          (else                    (init+last attrs*))))
+  ;; TODO add-child requires a UID on the child
+  ;; Possibly just genenerate one here if missing
+  (fold (swap add-child)
+        (fold (lambda (pair component)
+                (let ((k value (car+cdr pair)))
+                  (prop* component k
+                         (cond ((vline? value)
+                                (key value k))
+                               ((list-value? value)
+                                (map (lambda (value) (vline key: k vline-value: value))
+                                     (list-value-value value)))
+                               (else (vline key: k vline-value: value))))))
+              (vcs-vcomponent
+               type: type)
+              (upcase-keys (kvlist->assq attrs)))
+        children))
 
 (define (vcalendar . attrs)
   (apply vcomponent 'VCALENDAR attrs))
diff --git a/module/vcomponent/data-stores/sqlite.scm b/module/vcomponent/data-stores/sqlite.scm
index b5b566a8..5d487028 100644
--- a/module/vcomponent/data-stores/sqlite.scm
+++ b/module/vcomponent/data-stores/sqlite.scm
@@ -113,7 +113,7 @@ CREATE TABLE IF NOT EXISTS event_instances_valid_range
 
 (define-method (get-calendar (this <sqlite-data-store>))
   (let ((db (database this))
-        (calendar (make-vcomponent 'VCALENDAR)))
+        (calendar (vcomponent type: 'VCALENDAR)))
     (let ((stmt (sqlite-prepare db "
 SELECT key, value FROM calendar_properties cp
 LEFT JOIN calendar c ON cp.calendar = c.id
diff --git a/module/vcomponent/data-stores/vdir.scm b/module/vcomponent/data-stores/vdir.scm
index f0ed0fdc..9320c44e 100644
--- a/module/vcomponent/data-stores/vdir.scm
+++ b/module/vcomponent/data-stores/vdir.scm
@@ -7,6 +7,9 @@
   :use-module (hnh util path)
   :use-module ((vcomponent formats ical) :select (serialize deserialize))
   :use-module ((ice-9 ftw) :select (scandir))
+  :use-module (ice-9 rdelim)
+  :use-module (srfi srfi-1)
+  :use-module (vcomponent base)
   :export ())
 
 (define-class <vdir-data-store> (<calendar-data-store>)
@@ -29,23 +32,23 @@
 
 (define-method (get-all (this <vdir-data-store>))
   (let ((files (scandir (path this) (lambda (item) (string-ci=? "ics" (filename-extension item)))))
-        (calendar (make-vcomponent 'VCALENDAR)))
-    (set! (prop calendar 'NAME)  (get-attribute (path this) "displayname")
-          (prop calendar 'COLOR) (get-attribute (path this) "color" "#FFFFFF"))
-    (for-each (lambda (item) (reparent! calendar item))
-              (append-map (lambda (file)
-                            (define cal
-                              (call-with-input-file (path-append (path this) file)
-                                deserialize))
-                            (unless (eq? 'VCALENDAR (type cal))
-                              (scm-error 'misc-error "get-all<vdir-data-store>"
-                                         "Unexpected top level component. Expected VCALENDAR, got ~a. In file ~s"
-                                         (list (type cal) file)))
-                            (for-each (lambda (child)
-                                        (set! (prop child '-X-HNH-FILENAME) file))
-                                      (children cal))
-                            )
-                          files))
+        (calendar
+         (fold (swap add-child)
+               (set-properties (vcomponent type: 'VCALENDAR)
+                               (cons 'NAME  (get-attribute (path this) "displayname"))
+                               (cons 'COLOR (get-attribute (path this) "color" "#FFFFFF")))
+               (append-map (lambda (file)
+                             (define cal
+                               (call-with-input-file (path-append (path this) file)
+                                 deserialize))
+                             (unless (eq? 'VCALENDAR (type cal))
+                               (scm-error 'misc-error "get-all<vdir-data-store>"
+                                          "Unexpected top level component. Expected VCALENDAR, got ~a. In file ~s"
+                                          (list (type cal) file)))
+                             (each cal children
+                                   (lambda (child)
+                                     (prop child '-X-HNH-FILENAME file))))
+                           files))))
     (set! (loaded-calendar this) calendar)
     calendar))
 
@@ -63,13 +66,12 @@
 
 
 (define (wrap-for-output . vcomponents)
-  (let ((calendar (make-vcomponent 'VCALENDAR)))
-    (set! (prop calendar 'VERSION) "2.0"
-          (prop calendar 'PRODID) (prodid)
-          (prop calendar 'CALSCALE) "GREGORIAN")
-    (for-each (lambda (vcomponent) (reparent! calendar vcomponent))
-              vcomponents)
-    calendar))
+  (fold (swap add-child)
+        (set-properties (vcomponent type: 'VCALENDAR)
+                        (cons 'VERSION "2.0")
+                        (cons 'PRODID (prodid))
+                        (cons 'CALSCALE "GREGORIAN"))
+        vcomponents))
 
 (define-method (queue-write (this <vdir-data-store>) vcomponent)
   ;; TODO Multiple components
diff --git a/module/vcomponent/data-stores/virtual.scm b/module/vcomponent/data-stores/virtual.scm
new file mode 100644
index 00000000..03c115f5
--- /dev/null
+++ b/module/vcomponent/data-stores/virtual.scm
@@ -0,0 +1,22 @@
+(define-module (vcomponent data-stores virtual)
+  :use-module (oop goops)
+  :use-module ((srfi srfi-88) :select ())
+  :use-module (vcomponent data-stores common)
+  :export (make-file-store))
+
+(define-class <virtual-data-store> (<calendar-data-store>)
+  )
+
+(define-method (get-all (this <virtual-data-store>))
+  #f)
+
+(define-method (get-by-uid (this <virtual-data-store>)
+                    (uid <string>))
+  #f)
+
+
+(define-method (color (this <virtual-data-store>))
+  "")
+
+(define-method (displayname (this <virtual-data-store>))
+  "Virtual Calendar")
diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm
index a66ba38a..5aa6f4ab 100644
--- a/module/vcomponent/datetime.scm
+++ b/module/vcomponent/datetime.scm
@@ -227,75 +227,89 @@ Event must have the DTSTART and DTEND protperty set."
 
 ;; event is for limiter
 (define (zoneinfo->vtimezone zoneinfo zone-name event)
-  (define vtimezone (make-vcomponent 'VTIMEZONE))
   (define last-until (datetime date: (date month: 1 day: 1)))
   (define last-offset (timespec-zero))
-  (set! (prop vtimezone 'TZID) zone-name)
-
-  (for zone-entry in (filter (relevant-zone-entry? event) (get-zone zoneinfo zone-name))
-       (cond [(zone-entry-rule zone-entry) timespec?
-              => (lambda (inline-rule)
-                   (let ((component (make-vcomponent 'DAYLIGHT))
-                         (new-timespec (timespec-add
-                                        (zone-entry-stdoff zone-entry)
-                                        inline-rule)))
-                     (set! (prop component 'DTSTART) last-until
-                           (prop component 'TZOFFSETFROM) last-offset
-                           (prop component 'TZOFFSETTO) new-timespec
-                           (prop component 'TZNAME) (zone-entry-format zone-entry)
-                           last-until (zone-entry-until zone-entry)
-                           last-offset new-timespec)
-                     (reparent! vtimezone component)))]
-
-             [(zone-entry-rule zone-entry)
-              => (lambda (rule-name)
-                   (map (lambda (rule)
-                          (let ((component (make-vcomponent
-                                            ;; NOTE the zoneinfo database doesn't
-                                            ;; come with information if a given
-                                            ;; rule is in standard or daylight time,
-                                            ;; since that's mostly nonsencical
-                                            ;; (e.g. war- and peacetime).
-                                            ;; But the ical standard requires that,
-                                            ;; so this is a fair compromize.
-                                            (if (string-null? (rule-letters rule))
-                                                'STANDARD 'DAYLIGHT)))
-                                (new-timespec (timespec-add
-                                               (zone-entry-stdoff zone-entry)
-                                               (rule-save rule))))
-
-                            (set! (prop component 'DTSTART) (rule->dtstart rule)
-                                  (prop component 'TZOFFSETFROM) last-offset
-                                  (prop component 'TZOFFSETTO) new-timespec
-                                  (prop component 'TZNAME) (zone-format
-                                                            (zone-entry-format zone-entry)
-                                                            (rule-letters rule))
-                                  ;; NOTE this can both be a number or the
-                                  ;; symbol 'maximum
-                                  last-until (zone-entry-until zone-entry)
-                                  last-offset new-timespec)
-
-                            (awhen (rule->rrule rule)
-                                   (set! (prop component 'RRULE) it))
-
-                            (reparent! vtimezone component)))
-                        ;; some of the rules might not apply to us since we only
-                        ;; started using that rule set later. It's also possible
-                        ;; that we stopped using a ruleset which continues existing.
-                        ;;
-                        ;; Both these are filtered here.
-                        (filter
-                         (relevant-zone-rule? event)
-                         (get-rule zoneinfo rule-name))))]
-
-             [else                      ; no rule
-              (let ((component (make-vcomponent 'STANDARD)))
-                ;; DTSTART MUST be a datetime in local time
-                (set! (prop component 'DTSTART) last-until
-                      (prop component 'TZOFFSETFROM) last-offset
-                      (prop component 'TZOFFSETTO) (zone-entry-stdoff zone-entry)
-                      (prop component 'TZNAME) (zone-entry-format zone-entry)
-                      last-until (zone-entry-until zone-entry)
-                      last-offset (zone-entry-stdoff zone-entry))
-                (reparent! vtimezone component))]))
-  vtimezone)
+
+  (fold (lambda (zone-entry vtimezone)
+          (cond [(zone-entry-rule zone-entry) timespec?
+                 => (lambda (inline-rule)
+                      (let ((component (vcomponent type: 'DAYLIGHT))
+                            (new-timespec (timespec-add
+                                           (zone-entry-stdoff zone-entry)
+                                           inline-rule)))
+                        (let ((component
+                               (set-properties
+                                component
+                                (cons 'DTSTART last-until)
+                                (cons 'TZOFFSETFROM last-offset)
+                                (cons 'TZOFFSETTO new-timespec)
+                                (cons 'TZNAME (zone-entry-format zone-entry)))))
+                          (set! last-until (zone-entry-until zone-entry)
+                                last-offset new-timespec)
+                          (add-child vtimezone component))))]
+
+                [(zone-entry-rule zone-entry)
+                 => (lambda (rule-name)
+                      (fold (lambda (rule vtimezone)
+                              (let ((component (vcomponent
+                                                type:
+                                               ;; NOTE the zoneinfo database doesn't
+                                               ;; come with information if a given
+                                               ;; rule is in standard or daylight time,
+                                               ;; since that's mostly nonsencical
+                                               ;; (e.g. war- and peacetime).
+                                               ;; But the ical standard requires that,
+                                               ;; so this is a fair compromize.
+                                               (if (string-null? (rule-letters rule))
+                                                   'STANDARD 'DAYLIGHT)))
+                                   (new-timespec (timespec-add
+                                                  (zone-entry-stdoff zone-entry)
+                                                  (rule-save rule))))
+
+                                (let ((component
+                                       (set-properties
+                                        component
+                                        (cons 'DTSTART (rule->dtstart rule))
+                                        (cons 'TZOFFSETFROM last-offset)
+                                        (cons 'TZOFFSETTO new-timespec)
+                                        (cons 'TZNAME (zone-format
+                                                       (zone-entry-format zone-entry)
+                                                       (rule-letters rule))))))
+
+                                  (set! ;; NOTE this can both be a number or the
+                                      ;; symbol 'maximum
+                                      last-until (zone-entry-until zone-entry)
+                                      last-offset new-timespec)
+
+                                  (add-child
+                                   vtimezone
+                                   (cond ((rule->rrule rule)
+                                          => (lambda (it) (prop component 'RRULE it)))
+                                         (else component))))))
+                            vtimezone
+                           ;; some of the rules might not apply to us since we only
+                           ;; started using that rule set later. It's also possible
+                           ;; that we stopped using a ruleset which continues existing.
+                           ;;
+                           ;; Both these are filtered here.
+                           (filter
+                            (relevant-zone-rule? event)
+                            (get-rule zoneinfo rule-name))))]
+
+                [else                      ; no rule
+                 ;; DTSTART MUST be a datetime in local time
+                 (let ((component
+                        (set-properties
+                         (vcomponent type: 'STANDARD)
+                         (cons 'DTSTART last-until)
+                         (cons 'TZOFFSETFROM last-offset)
+                         (cons 'TZOFFSETTO (zone-entry-stdoff zone-entry))
+                         (cons 'TZNAME (zone-entry-format zone-entry)))))
+                   (set! last-until (zone-entry-until zone-entry)
+                         last-offset (zone-entry-stdoff zone-entry))
+                   (add-child vtimezone component))
+                 ])
+          )
+        (prop (vcomponent type: 'VTIMEZONE) 'TZID zone-name)
+        (filter (relevant-zone-entry? event) (get-zone zoneinfo zone-name))
+        ))
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)))
diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm
index cc725b09..936c2631 100644
--- a/module/vcomponent/recurrence/generate.scm
+++ b/module/vcomponent/recurrence/generate.scm
@@ -339,10 +339,10 @@
                      (rrule-instances-raw rrule (prop event 'DTSTART))))
                (else stream-null)))
         (rdates
-         (cond ((prop* event 'RDATE) => (lambda (v) (map value v)))
+         (cond ((prop* event 'RDATE) => (lambda (v) (map vline-value v)))
                (else '())))
         (exdates
-         (cond ((prop* event 'EXDATE) => (lambda (v) (map value v)))
+         (cond ((prop* event 'EXDATE) => (lambda (v) (map vline-value v)))
                (else #f))))
 
     (let ((items (interleave-streams
@@ -418,21 +418,19 @@
             => (lambda (ht)
                  (aif (hash-ref ht dt)
                       it        ; RECURRENCE-ID objects come with their own DTEND
-                      (let ((ev (copy-vcomponent base-event)))
-                        (set! (prop ev 'DTSTART) dt)
-                        (when duration   ; (and (not (prop ev 'DTEND)) duration)
-                          ;; p. 123 (3.8.5.3 Recurrence Rule)
-                          ;; specifies that the DTEND should be updated to match how the
-                          ;; initial dtend related to the initial DTSTART. It also notes
-                          ;; that an event of 1 day in length might be longer or shorter
-                          ;; than 24h depending on timezone shifts.
-                          (set! (prop ev 'DTEND) (get-endtime dt duration)))
-                        ev))))
+                      (let ((ev (prop base-event 'DTSTART dt)))
+                        (if duration  ; (and (not (prop ev 'DTEND)) duration)
+                            ;; p. 123 (3.8.5.3 Recurrence Rule)
+                            ;; specifies that the DTEND should be updated to match how the
+                            ;; initial dtend related to the initial DTSTART. It also notes
+                            ;; that an event of 1 day in length might be longer or shorter
+                            ;; than 24h depending on timezone shifts.
+                            (prop ev 'DTEND (get-endtime dt duration))
+                            ev)))))
            (else
-            (let ((ev (copy-vcomponent base-event)))
-              (set! (prop ev 'DTSTART) dt)
-              (when duration
-                (set! (prop ev 'DTEND) (get-endtime dt duration)))
-              ev))))
+            (let ((ev (prop base-event 'DTSTART dt)))
+              (if duration
+                  (prop ev 'DTEND (get-endtime dt duration))
+                  ev)))))
    rrule-stream))
 
diff --git a/module/vcomponent/util/parse-cal-path.scm b/module/vcomponent/util/parse-cal-path.scm
index fe3a6b7d..33dbd0cc 100644
--- a/module/vcomponent/util/parse-cal-path.scm
+++ b/module/vcomponent/util/parse-cal-path.scm
@@ -19,24 +19,21 @@
   (define cal
     (case (stat:type st)
       [(regular)
-       (let ((comp (call-with-input-file path parse-calendar)))
-         (set! (prop comp '-X-HNH-SOURCETYPE) 'file)
-         comp) ]
+       (prop (call-with-input-file path parse-calendar)
+             '-X-HNH-SOURCETYPE 'file)]
       [(directory)
        (report-time! (G_ "Parsing ~a") path)
-       (let ((comp (parse-vdir path)))
-         (set! (prop comp '-X-HNH-SOURCETYPE) 'vdir
-               (prop comp '-X-HNH-DIRECTORY) path)
-         comp)]
+       (set-properties (parse-vdir path)
+                       (cons '-X-HNH-SOURCETYPE 'vdir)
+                       (cons '-X-HNH-DIRECTORY path))]
       [(block-special char-special fifo socket unknown symlink)
        => (lambda (t) (scm-error 'misc-error "parse-cal-path"
                             (G_ "Can't parse file of type ~s")
                             (list t)
                             #f))]))
 
-  (unless (prop cal "NAME")
-    (set! (prop cal "NAME")
-      (or (prop cal "X-WR-CALNAME")
-          (string-append "[" (basename path) "]"))))
-
-  cal)
+  (if (prop cal 'NAME)
+      cal
+      (prop cal 'NAME
+            (or (prop cal 'X-WR-CALNAME)
+                (string-append "[" (basename path) "]")))))
diff --git a/tests/formats/test.scm b/tests/formats/test.scm
index b4a00a73..dfa04f22 100755
--- a/tests/formats/test.scm
+++ b/tests/formats/test.scm
@@ -79,15 +79,15 @@ exec $GUILE -s "$0" "$@"
               (call-with-output-string
                 (lambda (p) (serialize component p)))))
 
-           (test-equal "Deserialized object serializes back into source"
-             (sanitize-string component-str)
-             (sanitize-string
-              (call-with-output-string
-                (lambda (p)
-                  (serialize
-                   (call-with-input-string
-                       component-str deserialize)
-                   p)))))
+           (test-group "Deserialize"
+             (let ((object (call-with-input-string component-str deserialize)))
+               (test-assert "Deserialize worked" (vcomponent? object))
+
+               (test-equal "Deserialized object serializes back into source"
+                 (sanitize-string component-str)
+                 (sanitize-string
+                  (call-with-output-string
+                    (lambda (p) (serialize object p)))))))
 
 
            (test-assert "Serialized string can still be read back in"
diff --git a/tests/run-tests.scm b/tests/run-tests.scm
index d3ba53f8..6c6ff95a 100755
--- a/tests/run-tests.scm
+++ b/tests/run-tests.scm
@@ -74,7 +74,8 @@ fi
   '((skip (value #t))
     (only (value #t))
     (verbose (single-char #\v))
-    (coverage (value optional))))
+    (coverage (value optional))
+    (catch)))
 
 (define options (getopt-long (command-line) option-spec))
 
@@ -112,17 +113,22 @@ fi
 
 ;;; Catch/print-trace should intercept thrown exceptions, print them prettily with a stack trace, and then continue
 
-#;
-(define (catch/print-trace proc)
-  (catch #t proc
-    (case-lambda
-      ((err from msg args data)
-       (test-assert (format #f "~a in ~a: ~?" err from msg args)
-         #f))
-      (args
-       (test-assert (format #f "~a (~s)" f args)
-         #f)))))
 
+
+(define catch/print-trace
+  (if (option-ref options 'catch #f)
+      (lambda (proc)
+        (catch #t proc
+          (case-lambda
+            ((err from msg args data)
+             (test-assert (format #f "~a in ~a: ~?" err from msg args)
+               #f))
+            (args
+             (test-assert (format #f "~a (~s)" f args)
+               #f)))))
+      (lambda (proc) (proc))))
+
+#;
 (define (catch/print-trace proc)
   (proc))
 
diff --git a/tests/test/add-and-save.scm b/tests/test/add-and-save.scm
deleted file mode 100644
index efbfe09e..00000000
--- a/tests/test/add-and-save.scm
+++ /dev/null
@@ -1,123 +0,0 @@
-(define-module (test add-and-save)
-  :use-module (srfi srfi-64)
-  :use-module (srfi srfi-88)
-  :use-module (hnh util)
-  :use-module (datetime)
-  :use-module (datetime timespec)
-  ;; :use-module ((vcomponent) :select (prop))
-  :use-module ((vcomponent base) :select (prop type children make-vcomponent))
-  :use-module ((srfi srfi-1) :select (find))
-  :use-module ((vcomponent formats vdir save-delete) :select (save-event))
-  :use-module ((vcomponent create)
-               :select (with-parameters
-                        vcalendar vevent
-                        vtimezone standard daylight))
-  :use-module (vcomponent recurrence)
-  :use-module ((vcomponent util instance methods)
-               :select (add-calendars
-                        add-and-save-event
-                        remove-event
-                        )))
-
-(define timezone
-  (vtimezone
-   tzid: "Europe/Stockholm"
-   (list
-    (standard
-     tzoffsetto: (parse-time-spec "01:00")
-     dtstart: #1996-10-27T01:00:00
-     tzname: "CET"
-     tzoffsetfrom: (parse-time-spec "02:00")
-     rrule: (make-recur-rule
-             freq: 'YEARLY
-             interval: 1
-             byday: (list (cons -1 sun))
-             bymonth: (list 10)
-             ))
-    (daylight
-     tzoffsetto: (parse-time-spec "02:00")
-     dtstart: #1981-03-29T01:00:00
-     tzname: "CEST"
-     tzoffsetfrom: (parse-time-spec "00:00")
-     rrule: (make-recur-rule
-             freq: 'YEARLY
-             interval: 1
-             byday: (list (cons -1 sun))
-             bymonth: (list 3))))))
-
-(define ev
-  (vevent
-   uid: "3da506ad-8d27-4810-94b3-6ab341baa1f2"
-   summary: "Test Event #1"
-   dtstart: (with-parameters
-             tzid: "Europe/Stockholm"
-             #2021-12-21T10:30:00)
-   dtstamp: #2021-12-21T14:10:56Z
-   dtend: (with-parameters
-           tzid: "Europe/Stockholm"
-           #2021-12-21T11:45:00)))
-
-(define rep-ev
-  (vevent
-   uid: "4ebd6632-d192-4bf4-a33a-7a8388185914"
-   summary: "Repeating Test Event #1"
-   rrule: (make-recur-rule freq: 'DAILY)
-   dtstart: (with-parameters
-             tzid: "Europe/Stockholm"
-             #2021-12-21T10:30:00)
-   dtstamp: #2021-12-21T14:10:56Z
-   dtend: (with-parameters
-           tzid: "Europe/Stockholm"
-           #2021-12-21T11:45:00)
-   ))
-
-(define directory (mkdtemp (string-copy"/tmp/guile-test-XXXXXX")))
-(format #t "Using ~a~%" directory)
-
-(define event-object ((@ (oop goops) make)
-                      (@@ (vcomponent util instance methods) <events>)))
-
-
-(define calendar
-  (vcalendar
-   #:-X-HNH-SOURCETYPE 'vdir
-   #:-X-HNH-DIRECTORY directory
-   ))
-
-(add-calendars event-object calendar)
-
-;; Try adding   and saving a  new      regular   event
-(add-and-save-event event-object calendar ev)
-
-;; Try changing and saving an existing regular   event
-(set! (prop ev 'SUMMARY) "Changed summary")
-(add-and-save-event event-object calendar ev)
-
-;; Try adding   and saving a  new      repeating event
-(add-and-save-event event-object calendar rep-ev)
-
-;; Try changing and saving an existing repeating event
-;; TODO setting start time to later than end time leads to nonsense
-;; errors when trying to generate the recurrence set.
-(set! (prop rep-ev 'DTSTART) (datetime+ (prop rep-ev 'DTSTART)
-                                        (datetime time: (time hour: 1))))
-(add-and-save-event event-object calendar rep-ev)
-
-;; Try adding   and saving a  new                event with multiple instances
-;; Try changing and saving an existing           event with multiple instances
-
-;; (add-and-save-event event-object calendar event)
-
-
-(test-equal "Correct amount of children in calendar"
-  5 (length (children calendar)))
-
-
-(define get-events (@@ (vcomponent util instance methods) get-events))
-(test-equal "Event object contains correct number of events (single calendar)"
-  2 (length (get-events event-object)))
-
-(remove-event event-object (car (get-events event-object)))
-
-(test-equal "Correct number of events after removing first element"
-  1 (length (get-events event-object)))
diff --git a/tests/test/annoying-events.scm b/tests/test/annoying-events.scm
index d41ee450..a6f5e946 100644
--- a/tests/test/annoying-events.scm
+++ b/tests/test/annoying-events.scm
@@ -9,7 +9,7 @@
              stream-filter
              stream-take-while))
   :use-module ((vcomponent base)
-   :select (extract prop make-vcomponent))
+   :select (extract prop))
   :use-module ((vcomponent datetime) :select (event-overlaps?))
   :use-module ((datetime) :select (date date+ date<))
   :use-module ((hnh util) :select (set!))
diff --git a/tests/test/create.scm b/tests/test/create.scm
index ca055df1..7cc00419 100644
--- a/tests/test/create.scm
+++ b/tests/test/create.scm
@@ -2,8 +2,12 @@
   :use-module ((srfi srfi-1) :select (every))
   :use-module (srfi srfi-64)
   :use-module (srfi srfi-88)
-  :use-module (vcomponent create)
-  :use-module (vcomponent))
+  :use-module ((vcomponent create)
+               :select (vcomponent
+                        with-parameters
+                        as-list))
+  :use-module ((vcomponent)
+               :select (children properties type prop prop* param vline?)))
 
 ;; vevent, vcalendar, vtimezone, standard, and daylight all trivial
 ;; and therefore not tested
@@ -26,7 +30,8 @@
                         (list child))))
     (test-equal '() (properties ev))
     (test-equal 1 (length (children ev)))
-    (test-eq child (car (children ev)))))
+    ; (test-eq child (car (children ev)))
+    ))
 
 (test-group "Component with both children and properties"
   (let* ((child (vcomponent 'CHILD))
@@ -36,7 +41,8 @@
     (test-equal '(PROP) (map car (properties ev)))
     (test-equal "VALUE" (prop ev 'PROP))
     (test-equal 1 (length (children ev)))
-    (test-eq child (car (children ev)))))
+    ; (test-eq child (car (children ev)))
+    ))
 
 (test-group "Component with no children, where last elements value is a list"
   (let ((ev (vcomponent 'TEST prop: (list 1 2 3))))
diff --git a/tests/test/hnh-util-lens.scm b/tests/test/hnh-util-lens.scm
index bcfafba2..0508553a 100644
--- a/tests/test/hnh-util-lens.scm
+++ b/tests/test/hnh-util-lens.scm
@@ -19,3 +19,41 @@
 (test-equal '(1 (10) 3) (set '(1 (2) 3) (ref 1) (ref 0) 10))
 
 ;; (set (list (iota 10)) first first 11)
+
+(define cadr* (compose-lenses cdr* car*))
+
+(test-group "Primitive lenses get and set"
+  (define lst '(1 2 3 4 5))
+  (test-equal 1 (car* lst))
+  (test-equal '(2 3 4 5) (cdr* lst))
+
+  (test-equal '(10 2 3 4 5)
+    (car* lst 10)))
+
+(test-group "Primitive lens composition"
+  (define lst '(1 2 3 4 5))
+  (test-equal 2 (cadr* lst))
+  (test-equal '(1 10 3 4 5) (cadr* lst 10)))
+
+(test-group "Modify"
+  (define lst '(1 2 3 4 5))
+  (test-equal '(10 2 3 4 5) (modify lst car* * 10))
+  (test-equal '(1 20 3 4 5) (modify lst cadr* * 10))
+  )
+
+(test-group "Modify*"
+  (define lst '(1 2 3 4 5))
+  (test-equal '(1 2 4 4 5) (modify* lst cdr* cdr* car* 1+)))
+
+;; modify
+;; modify*
+;; set
+;; get
+
+;; identity-lens
+;; compose-lenses
+;; lens-compose
+
+;; ref car* cdr*
+
+;; each
diff --git a/tests/test/param.scm b/tests/test/param.scm
index 34f7b826..431a8f46 100644
--- a/tests/test/param.scm
+++ b/tests/test/param.scm
@@ -8,10 +8,10 @@
   :use-module (srfi srfi-64 test-error)
   :use-module (srfi srfi-88)
   :use-module ((vcomponent base)
-               :select (param prop* parameters prop))
+               :select (param prop* parameters prop vline?))
   :use-module ((vcomponent formats ical parse)
                :select (parse-calendar))
-  :use-module ((vcomponent) :select (make-vcomponent))
+  :use-module ((vcomponent) :select (vcomponent properties set-properties))
   :use-module ((hnh util) :select (sort* set!))
   :use-module ((ice-9 ports) :select (call-with-input-string))
   :use-module ((vcomponent formats xcal output)
@@ -23,11 +23,12 @@
 ;; TODO possibly change parsing
 
 (define v
-  (call-with-input-string
-    "BEGIN:DUMMY
+  (car
+   (call-with-input-string
+       "BEGIN:DUMMY
 X-KEY;A=1;B=2:Some text
 END:DUMMY"
-    parse-calendar))
+     parse-calendar)))
 
 (test-equal '("1") (param (prop* v 'X-KEY) 'A))
 
@@ -35,17 +36,20 @@ END:DUMMY"
 
 (test-equal #f (param (prop* v 'X-KEY) 'C))
 
-(test-equal
-  '(A B)
-  (sort* (map car (parameters (prop* v 'X-KEY)))
-         string<?
-         symbol->string))
+
+(test-group "Properties"
+ (let ((p (properties v)))
+   (test-assert (list? p))
+   (test-eqv 1 (length p))
+   (test-eq 'X-KEY (caar p))
+   (test-assert (vline? (cadar p)))))
+
 
 
 ;; TODO possibly move this.
 ;; Checks that a warning is properly raised for
 ;; unkonwn keys (without an X-prefix)
-(test-error
+(test-error "Ensure parse-calendar warns on unknown keys"
   'warning
   (call-with-input-string
     "BEGIN:DUMMY
@@ -54,10 +58,9 @@ END:DUMMY"
     parse-calendar))
 
 ;; Similar thing happens for sxcal, but during serialization instead
-(let ((component (make-vcomponent 'DUMMY)))
-  (set! (prop component 'KEY) "Anything")
+(let ((component (set-properties (vcomponent type: 'DUMMY)
+                                 (cons 'KEY "Anything"))))
+
   (test-error
     'warning
     (vcomponent->sxcal component)))
-
-
diff --git a/tests/test/recurrence-advanced.scm b/tests/test/recurrence-advanced.scm
index c4684ba7..c2d71e61 100644
--- a/tests/test/recurrence-advanced.scm
+++ b/tests/test/recurrence-advanced.scm
@@ -23,7 +23,7 @@
   :use-module ((vcomponent recurrence internal)
                :select (count until))
   :use-module ((vcomponent base)
-               :select (make-vcomponent prop prop* extract make-vline))
+               :select (prop prop* extract))
   :use-module (vcomponent create)
   :use-module ((datetime)
                :select (parse-ics-datetime
diff --git a/tests/test/vcomponent.scm b/tests/test/vcomponent.scm
index a6989776..bdaefa95 100644
--- a/tests/test/vcomponent.scm
+++ b/tests/test/vcomponent.scm
@@ -1,52 +1,103 @@
 ;;; Commentary:
-;; Test that vcomponent parsing works at all.
+;; Test base functionallity of vcomponent structures.
 ;;; Code:
 
 (define-module (test vcomponent)
   :use-module (srfi srfi-17)
   :use-module (srfi srfi-64)
   :use-module (srfi srfi-88)
-  :use-module ((vcomponent base)
-               :select (prop make-vcomponent reparent! abandon!
-                             copy-vcomponent
-                             type parent children)))
+  :use-module (hnh util table)
+  :use-module (datetime)
+  :use-module (vcomponent base))
+
+
+
 
 (define ev
-  (let ((ev (make-vcomponent 'DUMMY)))
-    (set! (prop ev 'X-KEY) "value")
-    ev))
+  (prop (vcomponent type: 'DUMMY)
+        'X-KEY "value"))
 
-(test-assert (eq? #f (prop ev 'MISSING)))
+(test-eqv "Non-existant properties return #f"
+  #f (prop ev 'MISSING))
 
-(test-assert (prop ev 'X-KEY))
+(test-assert "Existing property is non-false"
+  (prop ev 'X-KEY))
 
-(test-equal "value" (prop ev 'X-KEY))
+(test-equal "Getting value of existing property"
+  "value" (prop ev 'X-KEY))
 
-(define calendar (make-vcomponent 'VCALENDAR))
+(define calendar (add-child (vcomponent type: 'VCALENDAR)
+                            ev))
 
-(reparent! calendar ev)
 (test-equal 1 (length (children calendar)))
-(abandon! calendar ev)
-(test-equal 0 (length (children calendar)))
-
-
-(test-group "Copy VComponent"
-  (let ((ev1 (make-vcomponent 'A))
-        (ev2 (make-vcomponent 'B))
-        (ev3 (make-vcomponent 'C)))
-    (set! (prop ev3 'TEST) (list 1 2 3))
-    (reparent! ev1 ev2)
-    (reparent! ev2 ev3)
-    (let* ((ev2* (copy-vcomponent ev2))
-           (ev3* (car (children ev2*))))
-      ;; NOTE replace this with `vcomponent=?' if that gets written
-      (test-group "New object is equivalent to old one"
-        (test-equal (type ev2) (type ev2*))
-        (test-equal (length (children ev2)) (length (children ev2*))))
-      (test-eq ev1 (parent ev2))
-
-      (set! (car (prop ev3* 'TEST)) 10)
-      (test-equal "Property values aren't deep copied"
-        '(10 2 3) (prop ev3 'TEST))
-      (test-equal '(10 2 3) (prop ev3* 'TEST))
-      )))
+
+;;; TODO remove child
+;; (abandon! calendar ev)
+;; (test-equal 0 (length (children calendar)))
+
+
+
+(define vline*
+  (vline
+   key: 'DTSTART
+   vline-value: #2020-01-02
+   vline-parameters: (alist->table
+                      '((VALUE . "DATE")))
+   vline-source: "DTSTART;VALUE=DATE:2020-01-02"))
+
+(test-group "vline"
+ (test-assert "Type check works as expected"
+   (vline? vline*)))
+
+(define vcomponent*
+  (vcomponent type: 'VEVENT))
+
+(test-assert "Type check works as expected"
+  (vcomponent? vcomponent*))
+
+(define child
+  (vcomponent type: 'CHILD))
+
+
+(test-eqv
+    "An added component extends length"
+  1 (length (children (add-child vcomponent* child))))
+
+(test-eqv
+    "But the source isn't modified"
+  0 (length (children vcomponent*)))
+
+(test-equal "Setting property"
+  (list (list 'KEY (vline key: 'KEY vline-value: "Value")))
+  (properties
+   (prop vcomponent* 'KEY "Value")))
+
+(let ((vl (vline key: 'KEY vline-value: "Value")))
+  (test-equal "Setting property vline"
+    (list (list 'KEY vl))
+    (properties
+     (prop* vcomponent* 'KEY vl))))
+
+(test-equal "Set properties test"
+  '(K1 K2)
+  (map car
+   (properties
+    (apply set-properties
+           vcomponent*
+           `((K1 . "V1")
+             (K2 . "V2"))))))
+
+;; remove-property
+
+;; extract extract*
+
+
+;; remove-parameter
+;; value
+;; param
+
+;; parameters
+;; properties
+
+;; x-property?
+;; internal-field?