[refactor] event-handlers to include a tag

1 files changed, 20 insertions, 15 deletions

diff --git a/src/interactive/interactive.lisp b/src/interactive/interactive.lisp
index 6152c3e..ceacf1b 100644
--- a/src/interactive/interactive.lisp
+++ b/src/interactive/interactive.lisp
@@ -19,24 +19,29 @@ ON-* Macros."
    t))
 
 
-(defun remove-handler (interactive handler-or-event-type)
-  "Handler can be an instance of EVENT-HANDLER or can be a symbol
-  whose name is an event type.  If is an event handler, only that
-  handler will be removed. If it is an event type, all events of that
-  type name are removed from the object."
+(defun remove-handler (interactive thing &key tag)
+  "THING can be an instance of EVENT-HANDLER or can be a symbol whose
+  name is an event type.  If is an event handler, only that handler
+  will be removed. If it is an event type, and if TAG is NIL, then all
+  events of that type name are removed from the object. Otherwise,
+  just the event with the provided TAG is removed. If no such tag is
+  found, none are removed."
   (when (listener interactive)
-    (let ((event-type (etypecase handler-or-event-type
-                        (keyword (intern (symbol-name handler-or-event-type) :wheelwork))
-                        (symbol (intern (symbol-name handler-or-event-type) :wheelwork))
-                        (event-handler (event-type handler-or-event-type)))))
+    (let ((event-type (etypecase thing
+                        (keyword (intern (symbol-name thing) :wheelwork))
+                        (symbol (intern (symbol-name thing) :wheelwork))
+                        (event-handler (event-type thing)))))
       (setf (slot-value (listener interactive) event-type)
-            (if (symbolp handler-or-event-type)
-                ;; remove everything if a symbol
-                nil
-                ;; delete just the handler
-                (delete handler-or-event-type
+            (cond
+              ((and (symbolp thing) tag)
+               (delete-if (lambda (h) (equal (tag h) tag))
+                          (slot-value (listener interactive) event-type)))
+              ((symbolp thing)
+               nil)
+              (t
+                (delete thing
                         (slot-value (listener interactive) event-type)
-                        :test #'eq)))
+                        :test #'eq))))
       ;; remove from from the global table unless any listeners remain on this event
       (unless (slot-value (listener interactive) event-type)
         (remhash interactive (listener-table-for (listener interactive) event-type))))))