X.H.ScreenCorners rewritten to use InputOnly windows instead of waiting for MotionEvents on the root window

XMonad/Hooks/ScreenCorners.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Hooks.ScreenCorners
@@ -16,73 +17,134 @@ module XMonad.Hooks.ScreenCorners
     (
     -- * Usage
     -- $usage
-    -- * Event hook
-      screenCornerEventHook
-    , ScreenCorner (..)
 
-    -- * X11 input methods
+    -- * Adding screen corners
-    , defaultEventInput
+      ScreenCorner (..)
-    , adjustEventInput
+    , addScreenCorner
+    , addScreenCorners
+
+    -- * Event hook
+    , screenCornerEventHook
     ) where
 
 import Data.Monoid
-import Foreign.C.Types
+import Data.List (find)
-
 import XMonad
-import XMonad.Actions.UpdateFocus (adjustEventInput)
+
+import qualified Data.Map as M
+import qualified XMonad.Util.ExtensibleState as XS
 
 data ScreenCorner = SCUpperLeft
                   | SCUpperRight
                   | SCLowerLeft
                   | SCLowerRight
+                  deriving (Eq, Ord, Show)
 
-inCorner :: ScreenCorner -> X () -> Display -> CInt -> CInt -> X ()
+
-inCorner corner xF dpy ix iy = do
+
+--------------------------------------------------------------------------------
+-- ExtensibleState modifications
+--------------------------------------------------------------------------------
+
+newtype ScreenCornerState = ScreenCornerState (M.Map Window (ScreenCorner, X ()))
+    deriving Typeable
+
+instance ExtensionClass ScreenCornerState where
+    initialValue = ScreenCornerState M.empty
+
+-- | Add one single @X ()@ action to a screen corner
+addScreenCorner :: ScreenCorner -> X () -> X ()
+addScreenCorner corner xF = do
+
+    ScreenCornerState m <- XS.get
+    (win,xFunc) <- case find (\(_,(sc,_)) -> sc == corner) (M.toList m) of
+
+                        Just (w, (_,xF')) -> return (w, xF' >> xF) -- chain X actions
+                        Nothing           -> flip (,) xF `fmap` createWindowAt corner
+
+    XS.modify $ \(ScreenCornerState m') -> ScreenCornerState $ M.insert win (corner,xFunc) m'
+
+-- | Add a list of @(ScreenCorner, X ())@ tuples
+addScreenCorners :: [ (ScreenCorner, X ()) ] -> X ()
+addScreenCorners = mapM_ (\(corner, xF) -> addScreenCorner corner xF)
+
+
+--------------------------------------------------------------------------------
+-- Xlib functions
+--------------------------------------------------------------------------------
+
+fi :: (Integral a, Num b) => a -> b
+fi = fromIntegral
+
+-- "Translate" a ScreenCorner to real (x,y) Positions
+createWindowAt :: ScreenCorner -> X Window
+createWindowAt SCUpperLeft = createWindowAt' 0 0
+createWindowAt SCUpperRight = withDisplay $ \dpy ->
+    let w = displayWidth  dpy (defaultScreen dpy) - 1
+    in createWindowAt' (fi w) 0
+
+createWindowAt SCLowerLeft = withDisplay $ \dpy ->
+    let h = displayHeight dpy (defaultScreen dpy) - 1
+    in createWindowAt' 0 (fi h)
+
+createWindowAt SCLowerRight = withDisplay $ \dpy ->
+    let w = displayWidth  dpy (defaultScreen dpy) - 1
+        h = displayHeight dpy (defaultScreen dpy) - 1
+    in createWindowAt' (fi w) (fi h)
+
+-- Create a new X window at a (x,y) Position
+createWindowAt' :: Position -> Position -> X Window
+createWindowAt' x y = withDisplay $ \dpy -> io $ do
+
+    rootw <- rootWindow dpy (defaultScreen dpy)
 
     let
-        screen = defaultScreen dpy
+        visual   = defaultVisualOfScreen $ defaultScreenOfDisplay dpy
-        xMax   = displayWidth  dpy screen - 1
+        attrmask = cWOverrideRedirect
-        yMax   = displayHeight dpy screen - 1
-        pos    = case (ix,iy, corner) of
-                      (0,0, SCUpperLeft)                           -> Just (50, 50)
-                      (x,0, SCUpperRight) | x == xMax              -> Just (x - 50, 50)
-                      (0,y, SCLowerLeft)  | y == yMax              -> Just (50, y - 50)
-                      (x,y, SCLowerRight) | x == xMax && y == yMax -> Just (x - 50, y - 50)
-                      _                                            -> Nothing
 
-    case pos of
+    w <- allocaSetWindowAttributes $ \attributes -> do
-         Just (x,y) -> do
-             -- Ignore any MotionEvents
-             defaultEventInput
-             -- move the mouse cursor so we avoid an unwanted loop
-             rootw <- asks theRoot
-             io $ warpPointer dpy none rootw 0 0 0 0 (fromIntegral x) (fromIntegral y)
-             -- Run our X ()
-             xF
-             -- Handle MotionEvents again
-             adjustEventInput
 
-         _ -> return ()
+        set_override_redirect attributes True
+        createWindow dpy        -- display
+                     rootw      -- parent window
+                     x          -- x
+                     y          -- y
+                     1          -- width
+                     1          -- height
+                     0          -- border width
+                     0          -- depth
+                     inputOnly  -- class
+                     visual     -- visual
+                     attrmask   -- valuemask
+                     attributes -- attributes
 
--- | The event hook manager for @ScreenCorners@.
+    -- we only need mouse entry events
-screenCornerEventHook :: Event -> [(ScreenCorner, X ())] -> X All
+    selectInput dpy w enterWindowMask
-screenCornerEventHook MotionEvent { ev_event_display = dpy, ev_x = ix, ev_y = iy } lis = do
+    mapWindow dpy w
-
+    sync dpy False
-    mapM_ (\(c,x) -> inCorner c x dpy ix iy) lis
+    return w
-    return $ All True
-
-screenCornerEventHook _ _ = return $ All True
 
 
--- | Use the default input methods
+--------------------------------------------------------------------------------
-defaultEventInput :: X ()
+-- Event hook
-defaultEventInput = withDisplay $ \dpy -> do
+--------------------------------------------------------------------------------
-    rootw <- asks theRoot
+
-    io $ selectInput dpy rootw $  substructureRedirectMask .|. substructureNotifyMask
+-- | Handle screen corner events
-                              .|. enterWindowMask .|. leaveWindowMask .|. structureNotifyMask
+screenCornerEventHook :: Event -> X All
-                              .|. buttonPressMask
+screenCornerEventHook CrossingEvent { ev_window = win } = do
+
+    ScreenCornerState m <- XS.get
+
+    case M.lookup win m of
+         Just (_, xF) -> xF
+         Nothing      -> return ()
+
+    return (All True)
+
+screenCornerEventHook _ = return (All True)
 
 
+--------------------------------------------------------------------------------
 -- $usage
 --
 -- This extension adds KDE-like screen corners to XMonad. By moving your cursor
@@ -94,17 +156,17 @@ defaultEventInput = withDisplay $ \dpy -> do
 --
 -- > import XMonad.Hooks.ScreenCorners
 --
--- Then add @adjustEventInput@ to your startup hook:
+-- Then add your screen corners in our startup hook:
 --
 -- > myStartupHook = do
 -- >     ...
--- >     adjustEventInput
+-- >     addScreenCorner SCUpperRight (goToSelected defaultGSConfig { gs_cellwidth = 200})
+-- >     addScreenCorners [ (SCLowerRight, nextWS)
+-- >                      , (SCLowerLeft,  prevWS)
+-- >                      ]
 --
--- And put your custom ScreenCorners to your event hook:
+-- Then wait for screen corner events in your event hook:
 --
 -- > myEventHook e = do
 -- >     ...
--- >     screenCornerEventHook e [ (SCUpperRight, goToSelected defaultGSConfig { gs_cellwidth = 200 })
+-- >     screenCornerEventHook e
--- >                             , (SCLowerRight, nextWS)
--- >                             , (SCLowerLeft,  prevWS)
--- >                             ]