From e7e0dd3aa0bb68b924ea29819d2d91640eab6339 Mon Sep 17 00:00:00 2001
From: Don Stewart <dons@cse.unsw.edu.au>
Date: Mon, 12 Mar 2007 01:55:40 +0100
Subject: abstract out setfocus code a bit

darcs-hash:20070312005540-9c5c1-c2498bd553cbd75564139d2114345086a42c1df7
---
 Main.hs | 63 ++++++++++++++++++++++++++++++++-------------------------------
 1 file changed, 32 insertions(+), 31 deletions(-)

diff --git a/Main.hs b/Main.hs
index 006a321..98f360d 100644
--- a/Main.hs
+++ b/Main.hs
@@ -157,33 +157,24 @@ handle e@(MappingNotifyEvent {window = w}) = do
 handle (KeyEvent {event_type = t, state = m, keycode = code})
     | t == keyPress = withDisplay $ \dpy -> do
         s   <- io $ keycodeToKeysym dpy code 0
-        maybe (return ()) id (M.lookup (m,s) keys)
+        whenJust (M.lookup (m,s) keys) id
 
-handle e@(CrossingEvent {event_type = t})
+handle e@(CrossingEvent {window = w, event_type = t})
     | t == enterNotify  && mode e == notifyNormal && detail e /= notifyInferior
-    = withDisplay $ \d -> do
-        let w = window e
-        ws <- gets workspace
-        if W.member w ws
-            then io $ setInputFocus d w revertToPointerRoot 0 -- it is ours, manage it
-            else do rootw <- gets theRoot
-                    when (w == rootw) $ do
-                       let new_w = maybe rootw id (W.peek ws) -- focus to the top of the stack
-                       io $ setInputFocus d new_w revertToPointerRoot 0
-        io $ sync d False
+    = do ws <- gets workspace
+         if W.member w ws
+            then setFocus w
+            else do b <- isRoot w
+                    when b setTopFocus
 
 handle e@(CrossingEvent {event_type = t})
     | t == leaveNotify
-    = withDisplay $ \d -> do
-        let dflt = defaultScreen d
-        rootw <- io $ rootWindow d dflt
-        when (window e == rootw && not (same_screen e)) $
-          io $ setInputFocus d rootw revertToPointerRoot 0
+    = do rootw <- gets theRoot
+         when (window e == rootw && not (same_screen e)) $ setFocus rootw
 
-handle e@(ConfigureRequestEvent {}) = do
+handle e@(ConfigureRequestEvent {window = w}) = do
     dpy <- gets display
     ws  <- gets workspace
-    let w = window e
 
     when (W.member w ws) $ -- already managed, reconfigure (see client:configure() 
         trace ("Reconfigure already managed window: " ++ show w)
@@ -246,7 +237,7 @@ manage w = do
     withDisplay $ \d -> io $ do
         selectInput d w $ structureNotifyMask .|. enterWindowMask .|. propertyChangeMask
         mapWindow d w
-        setInputFocus d w revertToPointerRoot 0 -- CurrentTime
+    setFocus w
     windows $ W.push w
 
 -- | unmanage. A window no longer exists, remove it from the window
@@ -254,18 +245,28 @@ manage w = do
 unmanage :: Window -> X ()
 unmanage w = do
     ws <- gets workspace
-    when (W.member w ws) $ withDisplay $ \d -> withServerX d $ do
-        -- xseterrorhandler(dummy)
+    when (W.member w ws) $ do
         modify $ \s -> s { workspace = W.delete w (workspace s) }
-        new_ws <- gets workspace
-        case W.peek new_ws of
-            Just new -> io $ setInputFocus d new revertToPointerRoot 0
-            Nothing  -> do
-                rootw <- gets theRoot
-                io $ setInputFocus d rootw revertToPointerRoot 0
-
-        io (sync d False)
-        -- xseterrorhandler(error)
+        withDisplay $ \d ->
+           withServerX d $ do
+              setTopFocus
+              io (sync d False)
+
+-- | Explicitly set the keyboard focus to the given window
+setFocus :: Window -> X ()
+setFocus w = withDisplay $ \d -> io $ setInputFocus d w revertToPointerRoot 0
+
+-- | Set the focus to the window on top of the stack, or root
+setTopFocus :: X ()
+setTopFocus = do
+    ws <- gets workspace
+    case W.peek ws of
+        Just new -> setFocus new
+        Nothing  -> gets theRoot >>= setFocus
+
+-- | True if the given window is the root window
+isRoot :: Window -> X Bool
+isRoot w = liftM (w==) (gets theRoot)
 
 -- | Grab the X server (lock it) from the X monad
 withServerX :: Display -> X () -> X ()
-- 
cgit v1.2.3