From 14464dee966fe415d4c8e1fb8b5205653b22003f Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Mon, 3 Oct 2022 19:22:23 -0400
Subject: Add prototype catbird modules.

---
 catbird/observer.scm | 37 +++++++++++++++++++++++++++++++++++++
 1 file changed, 37 insertions(+)
 create mode 100644 catbird/observer.scm

(limited to 'catbird/observer.scm')

diff --git a/catbird/observer.scm b/catbird/observer.scm
new file mode 100644
index 0000000..0cf01c5
--- /dev/null
+++ b/catbird/observer.scm
@@ -0,0 +1,37 @@
+(define-module (catbird observer)
+  #:use-module (catbird config)
+  #:use-module (oop goops)
+  #:export (<observer>
+            on-change))
+
+;; This is a hack to deal with the fact that specializing GOOPS
+;; accessors does not compose with inheritance.
+;;
+;; See
+;; https://dthompson.us/issues-with-object-oriented-programming-in-guile.html
+;; for details.
+
+(define-class <observer-slot-class> (<catbird-metaclass>))
+
+(define-generic on-change)
+
+(define-method (observer-slot? (slot <slot>))
+  (get-keyword #:observe? (slot-definition-options slot)))
+
+(define-method (compute-setter-method (class <observer-slot-class>) slot)
+  (if (observer-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 <observer> ()
+  #:metaclass <observer-slot-class>)
-- 
cgit v1.2.3