[refactor] event-handlers to include a tag

3 files changed, 47 insertions, 25 deletions

diff --git a/gui/menus.lisp b/gui/menus.lisp
index 6c3e5b8..0e51aba 100644
--- a/gui/menus.lisp
+++ b/gui/menus.lisp
@@ -59,7 +59,7 @@
 (defgeneric add-menu-item (menu item))
 (defmethod add-menu-item ((menu menu) item)
   (setf (unit-region item) (unit-region menu)
-        (focusablep item) nil)
+        (focusablep item) nil)  ; so that event handling here doesn't steal menu focus
   (setf (menu-items menu)
         (nconc (menu-items menu) (list item)))
   (when (unit-in-scene-p menu)
diff --git a/src/events/event-handler.lisp b/src/events/event-handler.lisp
index 9d48aea..a88f63d 100644
--- a/src/events/event-handler.lisp
+++ b/src/events/event-handler.lisp
@@ -4,7 +4,7 @@
 
 
 (defclass/std event-handler ()
-  ((event-type handler-function :ri))
+  ((event-type handler-function tag :ri))
   (:metaclass closer-mop:funcallable-standard-class))
 
 (defmethod initialize-instance :after ((eh event-handler) &key)
@@ -24,6 +24,15 @@ can be redefined using this form to support interactive development."
          (closer-mop:set-funcallable-instance-function extant (handler-function ,handler-var))
          (setf (fdefinition ',name) ,handler-var)))))
 
+(eval-when (:compile-toplevel :load-toplevel :execute) 
+  (defun get-tag-from-handler-body (body)
+    (when (eq (first body) :tag)
+      (second body)))
+
+  (defun get-body-from-handler-body (body)
+    (if (get-tag-from-handler-body body)
+        (nthcdr 2 body)
+        body)))
 
 (defmacro on-perframe
     ((&optional (target 'target) (time 'time)) &body body)
@@ -39,12 +48,13 @@ can be redefined using this form to support interactive development."
 "
   `(make-instance
     'event-handler
+    :tag ,(get-tag-from-handler-body body)
     :event-type 'wheelwork::perframe
     :handler-function (lambda (,(intern (symbol-name target))
                                ,(intern (symbol-name time)))
                         (declare (ignorable ,(intern (symbol-name target))
                                             ,(time (intern (symbol-name time)))))
-                        ,@body)))
+                        ,@(get-body-from-handler-body body))))
 
 (defmacro on-keydown
     ((&optional (target 'target) (scancode 'scancode) (modifiers 'modifiers)) &body body)
@@ -64,6 +74,7 @@ can be redefined using this form to support interactive development."
  The members of MODIFIERS look like :LSHIFT, :RCTRL, RALT, etc"
   `(make-instance
     'event-handler
+    :tag ,(get-tag-from-handler-body body)
     :event-type 'wheelwork::keydown
     :handler-function (lambda (,(intern (symbol-name target))
                                ,(intern (symbol-name scancode))
@@ -71,7 +82,7 @@ can be redefined using this form to support interactive development."
                         (declare (ignorable ,(intern (symbol-name target))
                                             ,(intern (symbol-name scancode))
                                             ,(intern (symbol-name modifiers))))
-                        ,@body)))
+                        ,@(get-body-from-handler-body body))))
 
 (defmacro on-keyup
     ((&optional (target 'target) (scancode 'scancode) (modifiers 'modifiers)) &body body)
@@ -92,6 +103,7 @@ can be redefined using this form to support interactive development."
   The members of MODIFIERS look like :LSHIFT, :RCTRL, RALT, etc"
   `(make-instance
     'event-handler
+    :tag ,(get-tag-from-handler-body body)
     :event-type 'wheelwork::keyup
     :handler-function (lambda (,(intern (symbol-name target))
                                ,(intern (symbol-name scancode))
@@ -99,7 +111,7 @@ can be redefined using this form to support interactive development."
                         (declare (ignorable ,(intern (symbol-name target))
                                             ,(intern (symbol-name scancode))
                                             ,(intern (symbol-name modifiers))))
-                        ,@body)))
+                        ,@(get-body-from-handler-body body))))
 
 (defmacro on-mousemotion
     ((&optional
@@ -127,6 +139,7 @@ can be redefined using this form to support interactive development."
 
   `(make-instance
     'event-handler
+    :tag ,(get-tag-from-handler-body body)
     :event-type 'wheelwork::mousemotion
     :handler-function (lambda (,(intern (symbol-name target))
                                ,(intern (symbol-name x))
@@ -148,7 +161,7 @@ can be redefined using this form to support interactive development."
                                             ,(intern (symbol-name win-y))
                                             ,(intern (symbol-name win-xrel))
                                             ,(intern (symbol-name win-yrel))))
-                        ,@body)))
+                        ,@(get-body-from-handler-body body))))
 
 (defmacro on-mousedown
     ((&optional (target 'target)
@@ -171,6 +184,7 @@ can be redefined using this form to support interactive development."
 "
   `(make-instance
     'event-handler
+    :tag ,(get-tag-from-handler-body body)
     :event-type 'wheelwork::mousedown
     :handler-function (lambda
                           (,(intern (symbol-name target))
@@ -188,7 +202,7 @@ can be redefined using this form to support interactive development."
                                             ,(intern (symbol-name button))
                                             ,(intern (symbol-name win-x))
                                             ,(intern (symbol-name win-y))))
-                        ,@body)))
+                        ,@(get-body-from-handler-body body))))
 
 (defmacro on-mouseup
     ((&optional (target 'target)
@@ -212,6 +226,7 @@ can be redefined using this form to support interactive development."
 "
   `(make-instance
     'event-handler
+    :tag ,(get-tag-from-handler-body body)
     :event-type 'wheelwork::mouseup
     :handler-function (lambda
                           (,(intern (symbol-name target))
@@ -229,7 +244,7 @@ can be redefined using this form to support interactive development."
                                             ,(intern (symbol-name button))
                                             ,(intern (symbol-name win-x))
                                             ,(intern (symbol-name win-y))))
-                        ,@body)))
+                        ,@(get-body-from-handler-body body))))
 
 (defmacro on-mousewheel
     ((&optional (target 'target) (horiz 'horiz) (vert 'vert) (dir 'dir)) &body body)
@@ -273,12 +288,13 @@ fires whenever an object loses focus.
 "
   `(make-instance
     'event-handler
+    :tag ,(get-tag-from-handler-body body)
     :event-type 'wheelwork::blur
     :handler-function (lambda
                           (,(intern (symbol-name target)))
                         (declare
                          (ignorable ,(intern (symbol-name target))))
-                        ,@body)))
+                        ,@(get-body-from-handler-body body))))
 
 (defmacro on-focus
     ((&optional (target 'target)) &body body)
@@ -293,9 +309,10 @@ fires when the FOCUS slot of the current APPLICATION instance is changed.
 "
   `(make-instance
     'event-handler
+    :tag ,(get-tag-from-handler-body body)
     :event-type 'wheelwork::focus
     :handler-function (lambda
                           (,(intern (symbol-name target)))
                         (declare
                          (ignorable ,(intern (symbol-name target))))
-                        ,@body)))
+                        ,@(get-body-from-handler-body body))))
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))))))