diff options
Diffstat (limited to 'module')
| -rw-r--r-- | module/vcomponent/base.scm | 63 | ||||
| -rw-r--r-- | module/vcomponent/create.scm | 2 | ||||
| -rw-r--r-- | module/vcomponent/datetime.scm | 6 | ||||
| -rw-r--r-- | module/vcomponent/formats/ical/parse.scm | 2 | ||||
| -rw-r--r-- | module/vcomponent/formats/vdir/parse.scm | 4 | ||||
| -rw-r--r-- | module/vcomponent/formats/vdir/save-delete.scm | 2 | ||||
| -rw-r--r-- | module/vcomponent/formats/xcal/parse.scm | 2 | ||||
| -rw-r--r-- | module/vcomponent/util/instance/methods.scm | 4 |
8 files changed, 44 insertions, 41 deletions
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. |