Change child/parent interface for vcomponent.

12 files changed, 77 insertions, 48 deletions

diff --git a/doc/ref/guile/vcomponent.texi b/doc/ref/guile/vcomponent.texi
index 70af3ad3..2560bdde 100644
--- a/doc/ref/guile/vcomponent.texi
+++ b/doc/ref/guile/vcomponent.texi
@@ -106,6 +106,8 @@ Curried version of @var{prop}.
 @end deftp
 
 @defun copy-vcomponent vcomponent
+Creates a shallow copy of @var{vcomponent}. If the source object has a
+parent, then than parent adopts the new event also.
 @end defun
 
 
diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm
index df452f62..2da939d0 100644
--- a/module/vcomponent/base.scm
+++ b/module/vcomponent/base.scm
@@ -15,7 +15,9 @@
            vcomponent?
            children type parent
 
-           add-child! remove-child!
+           reparent!
+           abandon!
+           orphan!
 
            delete-property!
            prop* prop
@@ -75,40 +77,38 @@
   (make-vline% key value ht))
 
 (define-record-type <vcomponent>
-  (make-vcomponent% type children parent properties)
+  (make-vcomponent% type children properties)
   vcomponent?
   (type type)
   (children children set-component-children!)
-  (parent get-component-parent set-component-parent!)
   (properties get-component-properties))
 
 ((@ (srfi srfi-9 gnu) set-record-type-printer!)
  <vcomponent>
  (lambda (c p)
-   (format p "#<<vcomponent> ~a, len(child)=~a, parent=~a>"
+   (format p "#<<vcomponent> ~a, len(child)=~a>"
            (type c)
            (length (children c))
-           (and=> (get-component-parent c) type))))
+           )))
 
-;; TODO should this also update the parent
-(define parent
-  (make-procedure-with-setter
-   get-component-parent set-component-parent!))
+
+(define parent% (make-object-property))
+(define (parent x) (parent% x))
 
 (define* (make-vcomponent optional: (type 'VIRTUAL))
-  (make-vcomponent% type '() #f (make-hash-table)))
+  (make-vcomponent% type '() (make-hash-table)))
 
-(define (add-child! parent child)
+(define (reparent! parent child)
   (set-component-children! parent (cons child (children parent)))
-  (set-component-parent! child parent))
+  (set! (parent% child) parent))
 
-(define (remove-child! parent-component child)
-  (unless (eq? parent-component (parent child))
-    (scm-error
-     'wrong-type-arg "remove-child!" "Child doesn't belong to parent"
-     (list parent-component child) #f))
+(define (abandon! parent-component child)
   (set-component-children! parent-component (delq1! child (children parent-component)))
-  (set-component-parent! child #f))
+  (when (eq? parent-component (parent% child))
+    (orphan! child)))
+
+(define (orphan! child)
+  (set! (parent% child) #f))
 
 ;;; TODO key=DTSTART, (date? value) => #t
 ;;; KRÄVER att (props vline 'VALUE) <- "DATE"
@@ -195,18 +195,21 @@
               (get-vline-parameters vline)))
 
 (define (copy-vcomponent component)
-  (make-vcomponent%
-   (type component)
-   ;; TODO deep copy?
-   (children component)
-   (parent 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)))))
+  (let ((ev
+         (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))))))
+    (when (parent component)
+      (reparent! (parent component) ev))
+    ev))
+
 
 (define (extract field)
   (lambda (e) (prop e field)))
diff --git a/module/vcomponent/create.scm b/module/vcomponent/create.scm
index 0521b39b..374da8b4 100644
--- a/module/vcomponent/create.scm
+++ b/module/vcomponent/create.scm
@@ -100,7 +100,7 @@
                 (upcase-keys (kvlist->assq attrs)))
 
       ;; Attach children
-      (for-each (lambda (child) (add-child! component child))
+      (for-each (lambda (child) (reparent! component child))
                 children)))
 
   component)
diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm
index 440ec5fd..a66ba38a 100644
--- a/module/vcomponent/datetime.scm
+++ b/module/vcomponent/datetime.scm
@@ -245,7 +245,7 @@ Event must have the DTSTART and DTEND protperty set."
                            (prop component 'TZNAME) (zone-entry-format zone-entry)
                            last-until (zone-entry-until zone-entry)
                            last-offset new-timespec)
-                     (add-child! vtimezone component)))]
+                     (reparent! vtimezone component)))]
 
              [(zone-entry-rule zone-entry)
               => (lambda (rule-name)
@@ -278,7 +278,7 @@ Event must have the DTSTART and DTEND protperty set."
                             (awhen (rule->rrule rule)
                                    (set! (prop component 'RRULE) it))
 
-                            (add-child! vtimezone component)))
+                            (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.
@@ -297,5 +297,5 @@ Event must have the DTSTART and DTEND protperty set."
                       (prop component 'TZNAME) (zone-entry-format zone-entry)
                       last-until (zone-entry-until zone-entry)
                       last-offset (zone-entry-stdoff zone-entry))
-                (add-child! vtimezone component))]))
+                (reparent! vtimezone component))]))
   vtimezone)
diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm
index 252a155e..f0a19ba5 100644
--- a/module/vcomponent/formats/ical/parse.scm
+++ b/module/vcomponent/formats/ical/parse.scm
@@ -306,7 +306,7 @@
                             (if (null? (cdr stack))
                                 ;; return
                                 (car stack)
-                                (begin (add-child! (cadr stack) (car stack))
+                                (begin (reparent! (cadr stack) (car stack))
                                        (cdr stack))))]
                      [else
                       (let ((key value params (parse-itemline head)))
diff --git a/module/vcomponent/formats/vdir/parse.scm b/module/vcomponent/formats/vdir/parse.scm
index 4e21d4d0..8fe69fc6 100644
--- a/module/vcomponent/formats/vdir/parse.scm
+++ b/module/vcomponent/formats/vdir/parse.scm
@@ -66,7 +66,7 @@
               (case (length events)
                 [(0) (warning (G_ "No events in component~%~a")
                               (prop item '-X-HNH-FILENAME))]
-                [(1) (add-child! calendar (car events))]
+                [(1) (reparent! calendar (car events))]
 
                 ;; two or more
                 [else
@@ -108,7 +108,7 @@
                            ;; we need to filter duplicates either way.
                            (map (extract 'RECURRENCE-ID) (cons head rest))
                            (cons head rest))))
-                   (add-child! calendar head))])
+                   (reparent! calendar head))])
 
               ;; return
               calendar)
diff --git a/module/vcomponent/formats/vdir/save-delete.scm b/module/vcomponent/formats/vdir/save-delete.scm
index ab1985b6..d096405e 100644
--- a/module/vcomponent/formats/vdir/save-delete.scm
+++ b/module/vcomponent/formats/vdir/save-delete.scm
@@ -61,4 +61,4 @@
                (list (prop calendar '-X-HNH-SOURCETYPE))
                #f))
   (delete-file (prop event '-X-HNH-FILENAME))
-  (remove-child! parent event))
+  (abandon! parent event))
diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm
index 0e638d36..7200e18d 100644
--- a/module/vcomponent/formats/xcal/parse.scm
+++ b/module/vcomponent/formats/xcal/parse.scm
@@ -258,6 +258,6 @@
   ;; children
   (awhen (assoc-ref sxcal 'components)
          (for child in (map sxcal->vcomponent it)
-              (add-child! component child)))
+              (reparent! component child)))
 
   component)
diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm
index 75510009..fef83958 100644
--- a/module/vcomponent/util/instance/methods.scm
+++ b/module/vcomponent/util/instance/methods.scm
@@ -125,7 +125,7 @@
 ;;; with the same UID, which is BAD.
 (define-method (add-event (this <events>) calendar event)
 
-  (add-child! calendar event)
+  (reparent! calendar event)
   (unless (prop event 'UID)
     (set! (prop event 'UID) (uuid)))
 
@@ -184,7 +184,7 @@
 
          ;; remove old instance of event from runtime
          (remove-event this old-event)
-         (remove-child! old-calendar old-event)
+         (abandon! old-calendar old-event)
 
          ;; Add new event to runtime,
          ;; MUST be done after since the two events SHOULD share UID.
diff --git a/scripts/generate-test-data.scm b/scripts/generate-test-data.scm
index 076558e4..b80c4994 100755
--- a/scripts/generate-test-data.scm
+++ b/scripts/generate-test-data.scm
@@ -63,8 +63,8 @@
   (prop cal 'PRODID) "-//hugo//calp TEST//EN"
   (prop cal 'VERSION) "2.0")
 
-(add-child! cal zoneinfo)
-(add-child! cal ev)
+(reparent! cal zoneinfo)
+(reparent! cal ev)
 
 (define sxcal
   `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")
diff --git a/tests/test/add-and-save.scm b/tests/test/add-and-save.scm
index 70b8cce2..fb3277bb 100644
--- a/tests/test/add-and-save.scm
+++ b/tests/test/add-and-save.scm
@@ -112,7 +112,7 @@
 
 
 (test-equal "Correct amount of children in calendar"
-  2 (length (children calendar)))
+  5 (length (children calendar)))
 
 
 (define get-events (@@ (vcomponent util instance methods) get-events))
diff --git a/tests/test/vcomponent.scm b/tests/test/vcomponent.scm
index 52e1b6bb..a6989776 100644
--- a/tests/test/vcomponent.scm
+++ b/tests/test/vcomponent.scm
@@ -3,11 +3,13 @@
 ;;; 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 add-child! remove-child!
-                             children)))
+               :select (prop make-vcomponent reparent! abandon!
+                             copy-vcomponent
+                             type parent children)))
 
 (define ev
   (let ((ev (make-vcomponent 'DUMMY)))
@@ -22,7 +24,29 @@
 
 (define calendar (make-vcomponent 'VCALENDAR))
 
-(add-child! calendar ev)
+(reparent! calendar ev)
 (test-equal 1 (length (children calendar)))
-(remove-child! calendar ev)
+(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))
+      )))