[add] container lifecycle events and handlers

1 files changed, 91 insertions, 8 deletions

diff --git a/wheelwork.lisp b/wheelwork.lisp
index 3a39dd2..0fdfdf4 100644
--- a/wheelwork.lisp
+++ b/wheelwork.lisp
@@ -24,20 +24,24 @@
   transformation affine transformations methods can be specialzied on
   whole groups of units"))
 
-(defun remove-unit (unit)
+(defgeneric drop-unit (unit))
+
+(defmethod drop-unit ((unit unit))
   "Removes a unit from its container. Returns T if the unit actually was removed."
   (when (unit-container unit)
     (setf
-     (container-units (unit-container unit)) (delete unit (container-units (unit-container units)))
+     (container-units (unit-container unit)) (delete unit (container-units (unit-container unit)))
      (unit-container unit) nil)
     t))
 
-(defun add-unit (container unit)
+(defgeneric add-unit (container unit))
+
+(defmethod add-unit ((container container) (unit unit))
   "Adds a unit to the end of a container (thus affecting render
 order). Makes sure to remove the unit from its current container if
 necessary."
   (when (unit-container unit)
-    (remove-unit unit))
+    (drop-unit unit))
   (setf (container-units container)
         (nconc (container-units container)
                (list unit)))
@@ -52,8 +56,19 @@ necessary."
     (closer-mop:set-funcallable-instance-function eh handler-function)))
 
 (defclass/std listener ()
-  ((keydown keyup mousedown mouseup mousemotion mousewheel focus blur perframe
-            :r :with :type (or null event-handler) :std nil)
+  ((keydown
+    keyup
+    mousedown
+    mouseup
+    mousemotion
+    mousewheel
+    focus
+    blur
+    perframe
+    after-added
+    before-added
+    before-dropped
+    :r :with :type (or null event-handler) :std nil)
    (keydown-table
     keyup-table
     mousedown-table
@@ -63,6 +78,9 @@ necessary."
     focus-table
     blur-table
     perframe-table
+    after-added-table
+    before-added-table
+    before-dropped-table
     :static
     :std (make-hash-table :synchronized t)
     :doc "Keyed by DISPLAY-UNIT instance, holds an EVENT-HANDLER if handler is defined for unit."))
@@ -74,6 +92,19 @@ necessary."
    (focusablep :std t :doc "Whether or not this object can receive application focus."))
   (:documentation "Supplies an object with a listener slot."))
 
+(defmethod drop-unit :before ((unit interactive))
+  (when (unit-container unit) 
+    (when-let (handler (get-handler-for unit 'before-dropped))
+      (funcall handler unit))))
+
+(defmethod add-unit :before ((container container) (unit interactive))
+  (when-let (handler (get-handler-for unit 'before-added))
+    (funcall handler container unit)))
+
+(defmethod add-unit :after ((container container) (unit interactive))
+  (when-let (handler (get-handler-for unit 'after-added))
+    (funcall handler container unit)))
+
 (defun listener-table-for (listener event-type)
   (ecase event-type
     (keydown (keydown-table listener))
@@ -84,7 +115,11 @@ necessary."
     (mousewheel (mousewheel-table listener))
     (focus (focus-table listener))
     (blur (blur-table listener))
-    (perframe (perframe-table listener))))
+    (perframe (perframe-table listener))
+    (after-added (after-added-table listener))
+    (before-added (before-added-table listener))
+    (after-dropped (after-dropped-table listener))
+    (before-dropped (before-dropped-table listener))))
 
 (defun set-handler (interactive handler)
   (when (null (listener interactive))
@@ -193,7 +228,8 @@ necessary."
 
 (defconstant +listener-table-slot-names+
   '(keydown-table keyup-table mousedown-table  mouseup-table  mousemotion-table
-    focus-table blur-table perframe-table))
+    focus-table blur-table perframe-table after-added-table before-added-table
+    before-dropped-table))
 
 (defmethod cleanup ((app application))
   (loop for asset being the hash-value of (application-assets app)
@@ -780,3 +816,50 @@ fires when the FOCUS slot of the current APPLICATION instance is changed.
                         (declare
                          (ignorable ,(intern (symbol-name target))))
                         ,@body)))
+
+(defmacro on-before-dropped
+    ((&optional (target 'target)) &body body)
+  "Creates a handler for BEFORE-DROPPED events, which fire before a
+  unit is removed from its container."
+  `(make-instance
+    'event-handler
+    :event-type 'wheelwork::before-dropped
+    :handler-function (lambda
+                          (,(intern (symbol-name target)))
+                        (declare
+                         (ignorable ,(intern (symbol-name target))))
+                        ,@body)))
+
+(defmacro on-before-added
+    ((&optional (container 'container) (target 'target)) &body body)
+  "Creates a handler for BEFORE-ADDED events, which fire before a unit
+  is added to a container."
+  `(make-instance
+    'event-handler
+    :event-type 'wheelwork::before-added
+    :handler-function (lambda
+                          (,(intern (symbol-name container))
+                           ,(intern (symbol-name target)))
+                        (declare
+                         (ignorable
+                          ,(intern (symbol-name container))
+                          ,(intern (symbol-name target))))
+                        ,@body)))
+
+
+(defmacro on-after-added
+    ((&optional (container 'container) (target 'target)) &body body)
+  "Creates a handler for AFTER-ADDED events, which fire after a unit
+  is added to a container."
+  `(make-instance
+    'event-handler
+    :event-type 'wheelwork::after-added
+    :handler-function (lambda
+                          (,(intern (symbol-name container))
+                           ,(intern (symbol-name target)))
+                        (declare
+                         (ignorable
+                          ,(intern (symbol-name container))
+                          ,(intern (symbol-name target))))
+                        ,@body)))
+