From 24f5b1f4ba944c2d66c0a5f2ffbfdfd03bfdf47d Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Mon, 5 Apr 2021 08:29:34 -0400
Subject: node: Allow asset/watch slot getters/setter to compose.

---
 starling/node.scm | 39 +++++++++++++++++++++++----------------
 1 file changed, 23 insertions(+), 16 deletions(-)

diff --git a/starling/node.scm b/starling/node.scm
index 578ce2c..7e5933e 100644
--- a/starling/node.scm
+++ b/starling/node.scm
@@ -72,11 +72,14 @@
 
 (define-method (compute-getter-method (class <meta-node>) slot)
   (if (asset-slot? slot)
+      ;; Wrap the original getter procedure with a new procedure that
+      ;; extracts the current value from the asset object.
       (make <method>
         #:specializers (list class)
-        #:procedure (let ((slot-name (slot-definition-name slot)))
+        #:procedure (let ((slot-name (slot-definition-name slot))
+                          (proc (method-procedure (next-method))))
                       (lambda (obj)
-                        (let ((value (slot-ref obj slot-name)))
+                        (let ((value (proc obj)))
                           (if (is-a? value <asset>)
                               (asset-ref value)
                               value)))))
@@ -85,26 +88,30 @@
 (define-generic on-change)
 
 (define-method (compute-setter-method (class <meta-node>) slot)
-  (let ((method (next-method)))
-    (if (watch-slot? slot)
-        (let ((slot-name (slot-definition-name slot))
-              (proc (method-procedure method)))
-          (make <method>
-            #:specializers (list class <top>)
-            #:procedure (lambda (obj new)
-                          (let ((old (and (slot-bound? obj slot-name)
-                                          (slot-ref obj slot-name))))
-                            (proc obj new)
-                            (on-change obj slot-name old new)))))
-        method)))
+  (if (watch-slot? slot)
+      ;; Wrap the original setter procedure with a new procedure that
+      ;; calls the on-change method.
+      (make <method>
+        #:specializers (list class <top>)
+        #:procedure (let ((slot-name (slot-definition-name slot))
+                          (proc (method-procedure (next-method))))
+                      (lambda (obj new)
+                        (let ((old (and (slot-bound? obj slot-name)
+                                        (slot-ref obj slot-name))))
+                          (proc obj new)
+                          (on-change obj slot-name old new)))))
+      (next-method)))
 
 (define-class <developer-meta-node> (<meta-node> <redefinable-class>))
 
 (define-method (compute-setter-method (class <developer-meta-node>) slot)
   (if (asset-slot? slot)
+      ;; Wrap the original setter procedure with a new procedure that
+      ;; manages asset update notifications.
       (make <method>
         #:specializers (list class <top>)
-        #:procedure (let ((slot-name (slot-definition-name slot)))
+        #:procedure (let ((slot-name (slot-definition-name slot))
+                          (proc (method-procedure (next-method))))
                       (lambda (obj new)
                         (let ((old (and (slot-bound? obj slot-name)
                                         (slot-ref obj slot-name))))
@@ -112,7 +119,7 @@
                             (remove-subscriber old obj slot-name))
                           (when (is-a? new <asset>)
                             (add-subscriber new obj slot-name))
-                          (slot-set! obj slot-name new)))))
+                          (proc obj new)))))
       (next-method)))
 
 (define-method (make (class <developer-meta-node>) . initargs)
-- 
cgit v1.2.3