diff options
Diffstat (limited to 'src/events/event-handler.lisp')
| -rw-r--r-- | src/events/event-handler.lisp | 35 |
1 files changed, 26 insertions, 9 deletions
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)))) |