mixins: Add <listener> class.

1 files changed, 39 insertions, 2 deletions

diff --git a/catbird/mixins.scm b/catbird/mixins.scm
index 2443bc1..75e6d50 100644
--- a/catbird/mixins.scm
+++ b/catbird/mixins.scm
@@ -74,8 +74,14 @@
             position-y
             width
             height
-            depth)
-  #:replace (pause))
+            depth
+
+            <listener>
+            ignore
+            listen
+            responds-to?
+            send)
+  #:replace (listen pause send))
 
 (define-class <nameable> ()
   (name #:accessor name #:init-keyword #:name #:init-value #f))
@@ -227,3 +233,34 @@
 (define-accessor width)
 (define-accessor height)
 (define-accessor depth)
+
+
+
+;;;
+;;; Event listener
+;;;
+
+;; For per-instance message passing/event handling.
+(define-class <listener> ()
+  (event-handlers #:getter event-handlers #:init-thunk make-hash-table))
+
+;; listen and send are built-in procedures, so make them generic.
+(define-generic listen)
+(define-generic send)
+
+(define-method (listen (listener <listener>) message proc)
+  (hashq-set! (event-handlers listener) message proc))
+
+(define-method (ignore (listener <listener>) message)
+  (hashq-remove! (event-handlers listener) message))
+
+(define-method (event-handler (listener <listener>) message)
+  (hashq-ref (event-handlers listener) message))
+
+(define-method (responds-to? (listener <listener>) message)
+  (procedure? (event-handler listener)))
+
+(define-method (send (listener <listener>) message . args)
+  (let ((handler (event-handler listener message)))
+    (and (procedure? handler)
+         (apply handler args))))