From 11ebbefb55127eee884a9080ece4aa201ad579c1 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Thu, 23 Feb 2023 03:22:04 +0100
Subject: Change child/parent interface for vcomponent.

---
 module/vcomponent/base.scm | 63 ++++++++++++++++++++++++----------------------
 1 file changed, 33 insertions(+), 30 deletions(-)

(limited to 'module/vcomponent/base.scm')

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)))
-- 
cgit v1.2.3