Add prototype catbird modules.

1 files changed, 88 insertions, 0 deletions

diff --git a/catbird/cached-slots.scm b/catbird/cached-slots.scm
new file mode 100644
index 0000000..be77103
--- /dev/null
+++ b/catbird/cached-slots.scm
@@ -0,0 +1,88 @@
+(define-module (catbird cached-slots)
+  #:use-module (catbird config)
+  #:use-module (oop goops)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
+  #:export (<cacheable>
+            slot-expired?
+            expire-slot!))
+
+(define-record-type <cached-value>
+  (%make-cached-value value expired? proc)
+  cached-value?
+  (value %cached-value-ref set-cached-value!)
+  (expired? cached-value-expired? set-cached-value-expired!)
+  (proc cached-value-proc))
+
+(define (make-cached-value init proc)
+  (%make-cached-value init #t proc))
+
+(define (refresh-cached-value! cache)
+  (let ((x ((cached-value-proc cache) (%cached-value-ref cache))))
+    (set-cached-value! cache x)
+    (set-cached-value-expired! cache #f)))
+
+(define (cached-value-ref cache)
+  (when (cached-value-expired? cache)
+    (refresh-cached-value! cache))
+  (%cached-value-ref cache))
+
+(define (expire-cached-value! cache)
+  (set-cached-value-expired! cache #t))
+
+(define (expire-slot! obj slot-name)
+  (expire-cached-value! (slot-ref obj slot-name)))
+
+(define (slot-expired? obj slot-name)
+  (cached-value-expired? (slot-ref obj slot-name)))
+
+(define-class <cached-slot-class> (<catbird-metaclass>))
+
+(define (slot-ref* obj slot-name)
+  (and (slot-bound? obj slot-name)
+       (slot-ref obj slot-name)))
+
+(define-method (cached-slot? (slot <slot>))
+  (get-keyword #:cached? (slot-definition-options slot)))
+
+(define-method (slot-refresh-proc (slot <slot>))
+  (get-keyword #:refresh (slot-definition-options slot)))
+
+(define-method (compute-getter-method (class <cached-slot-class>) slot)
+  (if (cached-slot? slot)
+      ;; Wrap the original getter procedure with a new procedure that
+      ;; extracts the current value from the cached value, recomputing
+      ;; it if necessary.
+      (make <method>
+        #:specializers (list class)
+        #:procedure (let ((proc (method-procedure (next-method))))
+                      (lambda (obj)
+                        (cached-value-ref (proc obj)))))
+      (next-method)))
+
+(define-method (compute-setter-method (class <cached-slot-class>) slot)
+  (if (cached-slot? slot)
+      (make <method>
+        #:specializers (list class <top>)
+        #:procedure (lambda (obj new)
+                      (raise-exception
+                       (make-exception-with-message "cached slots cannot be set"))))
+      (next-method)))
+
+(define-class <cacheable> ()
+  #:metaclass <cached-slot-class>)
+
+(define-method (initialize (instance <cacheable>) initargs)
+  (next-method)
+  ;; Setup cached values.
+  (for-each (lambda (slot)
+              (when (cached-slot? slot)
+                (let* ((slot-name (slot-definition-name slot))
+                       (refresh-proc (slot-refresh-proc slot))
+                       (cached-value (make-cached-value
+                                      (slot-ref* instance slot-name)
+                                      (lambda (prev)
+                                        (refresh-proc instance prev)))))
+                  (slot-set! instance slot-name cached-value))))
+            (class-slots (class-of instance))))