[add] focus & blur logic in slot-value-using-class for application

1 files changed, 24 insertions, 16 deletions

diff --git a/wheelwork.lisp b/wheelwork.lisp
index d23cd7f..6de9d6b 100644
--- a/wheelwork.lisp
+++ b/wheelwork.lisp
@@ -115,15 +115,30 @@ order). Makes sure to remove the unit from its current container if necessary."
   (set-projection app)
   (setf (listener app) (make-instance 'listener)))
 
+(defun fire-blur-event-on (thing)
+  (when-let (blur-handler (and thing (get-handler-for thing 'blur)))
+    (funcall blur-handler thing)))
+
+(defun fire-focus-event-on (thing)
+  (when-let (focus-handler (and thing (get-handler-for thing 'focus)))
+    (funcall focus-handler thing)))
+
+(defmethod (setf closer-mop:slot-value-using-class ) :before
+    (new-value class (app application) slot)
+  (case (closer-mop:slot-definition-name slot)
+    (focus
+     (when (slot-boundp app 'focus) 
+       (unless (eq new-value (slot-value app 'focus)) 
+         (fire-blur-event-on (slot-value app 'focus))
+         (fire-focus-event-on new-value))))))
+
 (defmethod (setf closer-mop:slot-value-using-class) :after
     (new-value class (app application) slot)
-  (let ((slot-name
-          (closer-mop:slot-definition-name slot))) 
-    (cond
-      ((member slot-name '(scale width height))
-       (set-projection app))
-      ((eql slot-name 'fps)
-       (setf (slot-value app 'frame-wait) (/ 1.0 new-value))))))
+  (case (closer-mop:slot-definition-name slot)
+    ((scale width height)
+     (set-projection app))
+    (fps
+     (setf (slot-value app 'frame-wait) (/ 1.0 new-value)))))
 
 
 (defgeneric boot (app)
@@ -316,16 +331,9 @@ order). Makes sure to remove the unit from its current container if necessary."
   are keyed by UNIT and hold Event-Handler instances."))
 
 
-
-
 (defun refocus-on (target &optional (app *application*))
-  "Handles changing application focus, calling appropriate blur and focus handlers."
-  (when-let (blur-handler (and (application-focus app)
-                               (get-handler-for (application-focus app) 'blur)))
-    (funcall blur-handler (application-focus app)))
-  (setf (application-focus app) target)
-  (when-let (focus-handler (get-handler-for target 'focus))
-    (funcall focus-handler target)))
+  "Sets focus of application to target"
+  (setf (application-focus app) target))
 
 (defun get-focus (&optional (app *application*))
   (or (application-focus app) app))