Merge pull request #80 from f1u77y/managedocks-global-cache

Make strut cache global

XMonad/Actions/FloatSnap.hs

@@ -33,7 +33,7 @@ import Data.Maybe (listToMaybe,fromJust,isNothing)
 import qualified XMonad.StackSet as W
 import qualified Data.Set as S
 
-import XMonad.Hooks.ManageDocks (calcGapForAll)
+import XMonad.Hooks.ManageDocks (calcGap)
 import XMonad.Util.Types (Direction2D(..))
 import XMonad.Actions.AfterDrag
 
@@ -291,7 +291,7 @@ getSnap horiz collidedist d w = do
     screen <- W.current <$> gets windowset
     let sr = screenRect $ W.screenDetail screen
         wl = W.integrate' . W.stack $ W.workspace screen
-    gr <- fmap ($sr) $ calcGapForAll $ S.fromList [minBound .. maxBound]
+    gr <- fmap ($sr) $ calcGap $ S.fromList [minBound .. maxBound]
     wla <- filter (collides wa) `fmap` (io $ mapM (getWindowAttributes d) $ filter (/=w) wl)
 
     return ( neighbours (back wa sr gr wla) (wpos wa)

XMonad/Config/Bluetile.hs

@@ -180,8 +180,7 @@ bluetileManageHook :: ManageHook
 bluetileManageHook = composeAll
                [ workspaceByPos, positionStoreManageHook (Just defaultThemeWithButtons)
                 , className =? "MPlayer" --> doFloat
-                , isFullscreen --> doFullFloat
+                , isFullscreen --> doFullFloat]
-                , manageDocks]
 
 bluetileLayoutHook = avoidStruts $ minimize $ boringWindows $ (
                         named "Floating" floating |||
@@ -199,6 +198,7 @@ bluetileLayoutHook = avoidStruts $ minimize $ boringWindows $ (
             floatingDeco l = buttonDeco shrinkText defaultThemeWithButtons l
 
 bluetileConfig =
+    docks $
     def
         { modMask = mod4Mask,   -- logo key
           manageHook = bluetileManageHook,

XMonad/Config/Desktop.hs

@@ -164,11 +164,9 @@ import qualified Data.Map as M
 -- >        adjustEventInput
 --
 
-desktopConfig = ewmh def
+desktopConfig = docks $ ewmh def
-    { startupHook     = setDefaultCursor xC_left_ptr <+> docksStartupHook <+> startupHook def
+    { startupHook     = setDefaultCursor xC_left_ptr <+> startupHook def
     , layoutHook      = desktopLayoutModifiers $ layoutHook def
-    , manageHook      = manageDocks <+> manageHook def
-    , handleEventHook = docksEventHook <+> handleEventHook def
     , keys            = desktopKeys <+> keys def }
 
 desktopKeys (XConfig {modMask = modm}) = M.fromList $

XMonad/Config/Dmwit.hs

@@ -205,7 +205,7 @@ instance PPrint ScreenId
 instance (Show a, Show b) => PPrint (Map a b)
 -- }}}
 -- main {{{
-dmwitConfig nScreens = def {
+dmwitConfig nScreens = docks $ def {
     borderWidth             = 2,
     workspaces              = withScreens nScreens (map show [1..5]),
     terminal                = "urxvt",
@@ -221,7 +221,6 @@ dmwitConfig nScreens = def {
                               <+> (appName =? "huludesktop" --> doRectFloat fullscreen43on169)
                               <+> fullscreenMPlayer
                               <+> floatAll ["Gimp", "Wine"]
-                              <+> manageDocks
                               <+> manageSpawn,
     logHook                 = allPPs nScreens,
     startupHook             = refresh

XMonad/Config/Droundy.hs

@@ -42,7 +42,7 @@ import XMonad.Actions.DynamicWorkspaces ( withNthWorkspace, withWorkspace,
 import XMonad.Actions.CycleWS ( moveTo, WSType( HiddenNonEmptyWS ),
                                 Direction1D( Prev, Next) )
 
-import XMonad.Hooks.ManageDocks ( avoidStruts, manageDocks )
+import XMonad.Hooks.ManageDocks ( avoidStruts, docks )
 import XMonad.Hooks.EwmhDesktops ( ewmh )
 
 myXPConfig :: XPConfig
@@ -117,7 +117,7 @@ keys x = M.fromList $
     ++
     zip (zip (repeat (modMask x .|. shiftMask)) [xK_F1..xK_F12]) (map (withNthWorkspace copy) [0..])
 
-config = ewmh def
+config = docks $ ewmh def
          { borderWidth = 1 -- Width of the window border in pixels.
          , XMonad.workspaces = ["mutt","iceweasel"]
          , layoutHook = showWName $ workspaceDir "~" $
@@ -129,7 +129,6 @@ config = ewmh def
                         named "widescreen" ((mytab *||* mytab)
                                                 ****//* combineTwo Square mytab mytab) --   |||
                         --mosaic 0.25 0.5
-         , manageHook = manageHook def <+> manageDocks -- add panel-handling
          , terminal = "xterm" -- The preferred terminal program.
          , normalBorderColor = "#222222" -- Border color for unfocused windows.
          , focusedBorderColor = "#00ff00" -- Border color for focused windows.

XMonad/Config/Sjanssen.hs

@@ -21,7 +21,7 @@ import XMonad.Layout.TwoPane
 import qualified Data.Map as M
 
 sjanssenConfig =
-    ewmh $ def
+    docks $ ewmh $ def
         { terminal = "exec urxvt"
         , workspaces = ["irc", "web"] ++ map show [3 .. 9 :: Int]
         , mouseBindings = \(XConfig {modMask = modm}) -> M.fromList $
@@ -35,7 +35,7 @@ sjanssenConfig =
                                     | (x, w) <- [ ("Firefox", "web")
                                                 , ("Ktorrent", "7")
                                                 , ("Amarokapp", "7")]]
-                        <+> manageHook def <+> manageDocks <+> manageSpawn
+                        <+> manageHook def <+> manageSpawn
                         <+> (isFullscreen --> doFullFloat)
         , startupHook = mapM_ spawnOnce spawns
         }

XMonad/Hooks/DynamicLog.hs

@@ -199,12 +199,11 @@ statusBar :: LayoutClass l Window
           -> IO (XConfig (ModifiedLayout AvoidStruts l))
 statusBar cmd pp k conf = do
     h <- spawnPipe cmd
-    return $ conf
+    return $ docks $ conf
         { layoutHook = avoidStruts (layoutHook conf)
         , logHook = do
                         logHook conf
                         dynamicLogWithPP pp { ppOutput = hPutStrLn h }
-        , manageHook = manageHook conf <+> manageDocks
         , keys       = liftM2 M.union keys' (keys conf)
         }
  where

XMonad/Hooks/EwmhDesktops.hs

@@ -47,7 +47,7 @@ import XMonad.Util.WindowProperties (getProp32)
 -- > main = xmonad $ ewmh def{ handleEventHook =
 -- >            handleEventHook def <+> fullscreenEventHook }
 --
--- You may also be interested in 'avoidStruts' from "XMonad.Hooks.ManageDocks".
+-- You may also be interested in 'docks' from "XMonad.Hooks.ManageDocks".
 
 
 -- | Add EWMH functionality to the given config.  See above for an example.

XMonad/Hooks/ManageDocks.hs

@@ -15,7 +15,7 @@
 module XMonad.Hooks.ManageDocks (
     -- * Usage
     -- $usage
-    manageDocks, checkDock, AvoidStruts, avoidStruts, avoidStrutsOn,
+    docks, manageDocks, checkDock, AvoidStruts, avoidStruts, avoidStrutsOn,
     docksEventHook, docksStartupHook,
     ToggleStruts(..),
     SetStruts(..),
@@ -28,7 +28,7 @@ module XMonad.Hooks.ManageDocks (
 #endif
 
     -- for XMonad.Actions.FloatSnap
-    calcGap, calcGapForAll
+    calcGap
     ) where
 
 
@@ -39,12 +39,12 @@ import XMonad.Layout.LayoutModifier
 import XMonad.Util.Types
 import XMonad.Util.WindowProperties (getProp32s)
 import XMonad.Util.XUtils (fi)
+import qualified XMonad.Util.ExtensibleState as XS
 import Data.Monoid (All(..), mempty)
 import Data.Functor((<$>))
 
 import qualified Data.Set as S
 import qualified Data.Map as M
-import Data.Maybe (fromMaybe)
 import Control.Monad (when, forM_, filterM)
 
 -- $usage
@@ -52,25 +52,16 @@ import Control.Monad (when, forM_, filterM)
 --
 -- > import XMonad.Hooks.ManageDocks
 --
--- The first component is a 'ManageHook' which recognizes these
+-- Wrap your xmonad config with a call to 'docks', like so:
--- windows and de-manages them, so that xmonad does not try to tile
--- them.  To enable it:
 --
--- > manageHook = ... <+> manageDocks
+-- > main = xmonad $ docks def
 --
--- The second component is a layout modifier that prevents windows
+-- Then add 'avoidStruts' or 'avoidStrutsOn' layout modifier to your layout
--- from overlapping these dock windows.  It is intended to replace
+-- to prevent windows from overlapping these windows.
--- xmonad's so-called \"gap\" support.  First, you must add it to your
--- list of layouts:
 --
 -- > layoutHook = avoidStruts (tall ||| mirror tall ||| ...)
 -- >                   where  tall = Tall 1 (3/100) (1/2)
 --
--- The third component is an event hook that causes new docks to appear
--- immediately, instead of waiting for the next focus change.
---
--- > handleEventHook = ... <+> docksEventHook
---
 -- 'AvoidStruts' also supports toggling the dock gaps; add a keybinding
 -- similar to:
 --
@@ -90,17 +81,36 @@ import Control.Monad (when, forM_, filterM)
 --
 -- > layoutHook = avoidStrutsOn [U,L] (tall ||| mirror tall ||| ...)
 --
--- /Important note/: if you are switching from manual gaps
--- (defaultGaps in your config) to avoidStruts (recommended, since
--- manual gaps will probably be phased out soon), be sure to switch
--- off all your gaps (with mod-b) /before/ reloading your config with
--- avoidStruts!  Toggling struts with a 'ToggleStruts' message will
--- not work unless your gaps are set to zero.
---
 -- For detailed instructions on editing your key bindings, see
 -- "XMonad.Doc.Extending#Editing_key_bindings".
 --
 
+-- | Add docks functionality to the given config.  See above for an example.
+docks :: XConfig a -> XConfig a
+docks c = c { startupHook     = docksStartupHook <+> startupHook c
+            , handleEventHook = docksEventHook <+> handleEventHook c
+            , manageHook      = manageDocks <+> manageHook c }
+
+newtype StrutCache = StrutCache { fromStrutCache :: M.Map Window [Strut] }
+    deriving (Eq, Typeable)
+
+data UpdateDocks = UpdateDocks deriving Typeable
+instance Message UpdateDocks
+
+refreshDocks :: X ()
+refreshDocks = sendMessage UpdateDocks
+
+instance ExtensionClass StrutCache where
+  initialValue = StrutCache M.empty
+
+updateStrutCache :: Window -> [Strut] -> X Bool
+updateStrutCache w strut = do
+  XS.modified $ StrutCache . M.insert w strut . fromStrutCache
+
+deleteFromStructCache :: Window -> X Bool
+deleteFromStructCache w = do
+  XS.modified $ StrutCache . M.delete w . fromStrutCache
+
 -- | Detects if the given window is of type DOCK and if so, reveals
 --   it, but does not manage it.
 manageDocks :: ManageHook
@@ -125,9 +135,8 @@ checkDock = ask >>= \w -> liftX $ do
 docksEventHook :: Event -> X All
 docksEventHook (MapNotifyEvent { ev_window = w }) = do
     whenX (runQuery checkDock w <&&> (not <$> isClient w)) $ do
-        strut <- getRawStrut w
+        strut <- getStrut w
-        sendMessage $ UpdateDock w strut
+        whenX (updateStrutCache w strut) refreshDocks
-        broadcastMessage $ UpdateDock w strut
     return (All True)
 docksEventHook (PropertyEvent { ev_window = w
                               , ev_atom = a }) = do
@@ -135,13 +144,11 @@ docksEventHook (PropertyEvent { ev_window = w
         nws <- getAtom "_NET_WM_STRUT"
         nwsp <- getAtom "_NET_WM_STRUT_PARTIAL"
         when (a == nws || a == nwsp) $ do
-            strut <- getRawStrut w
+            strut <- getStrut w
-            broadcastMessage $ UpdateDock w strut
+            whenX (updateStrutCache w strut) refreshDocks
-            refresh
     return (All True)
 docksEventHook (DestroyWindowEvent {ev_window = w}) = do
-    sendMessage (RemoveDock w)
+    whenX (deleteFromStructCache w) refreshDocks
-    broadcastMessage (RemoveDock w)
     return (All True)
 docksEventHook _ = return (All True)
 
@@ -151,23 +158,9 @@ docksStartupHook = withDisplay $ \dpy -> do
     (_,_,wins) <- io $ queryTree dpy rootw
     docks <- filterM (runQuery checkDock) wins
     forM_ docks $ \win -> do
-        strut <- getRawStrut win
+        strut <- getStrut win
-        broadcastMessage (UpdateDock win strut)
+        updateStrutCache win strut
-    refresh
+    refreshDocks
-
-getRawStrut :: Window -> X (Maybe (Either [CLong] [CLong]))
-getRawStrut w = do
-    msp <- fromMaybe [] <$> getProp32s "_NET_WM_STRUT_PARTIAL" w
-    if null msp
-        then do
-            mp <- fromMaybe [] <$> getProp32s "_NET_WM_STRUT" w
-            if null mp then return Nothing
-                       else return $ Just (Left mp)
-        else return $ Just (Right msp)
-
-getRawStruts :: [Window] -> X (M.Map Window (Maybe (Either [CLong] [CLong])))
-getRawStruts wins = M.fromList <$> zip wins <$> mapM getRawStrut wins
-
 
 -- | Gets the STRUT config, if present, in xmonad gap order
 getStrut :: Window -> X [Strut]
@@ -185,18 +178,12 @@ getStrut w = do
         [(L, l, ly1, ly2), (R, r, ry1, ry2), (U, t, tx1, tx2), (D, b, bx1, bx2)]
     parseStrutPartial _ = []
 
-calcGapForAll :: S.Set Direction2D -> X (Rectangle -> Rectangle)
-calcGapForAll ss = withDisplay $ \dpy -> do
-    rootw <- asks theRoot
-    (_,_,wins) <- io $ queryTree dpy rootw
-    calcGap wins ss
-
 -- | Goes through the list of windows and find the gap so that all
 --   STRUT settings are satisfied.
-calcGap :: [Window] -> S.Set Direction2D -> X (Rectangle -> Rectangle)
+calcGap :: S.Set Direction2D -> X (Rectangle -> Rectangle)
-calcGap wins ss = withDisplay $ \dpy -> do
+calcGap ss = withDisplay $ \dpy -> do
     rootw <- asks theRoot
-    struts <- (filter careAbout . concat) `fmap` mapM getStrut wins
+    struts <- (filter careAbout . concat) `fmap` XS.gets (M.elems . fromStrutCache)
 
     -- we grab the window attributes of the root window rather than checking
     -- the width of the screen because xlib caches this info and it tends to
@@ -218,13 +205,9 @@ avoidStrutsOn :: LayoutClass l a =>
                  [Direction2D]
               -> l a
               -> ModifiedLayout AvoidStruts l a
-avoidStrutsOn ss = ModifiedLayout $ AvoidStruts (S.fromList ss) Nothing M.empty
+avoidStrutsOn ss = ModifiedLayout $ AvoidStruts (S.fromList ss)
 
-data AvoidStruts a = AvoidStruts {
+data AvoidStruts a = AvoidStruts (S.Set Direction2D) deriving ( Read, Show )
-    avoidStrutsDirection :: S.Set Direction2D,
-    avoidStrutsRectCache :: Maybe (S.Set Direction2D, Rectangle, Rectangle),
-    strutMap :: M.Map Window (Maybe (Either [CLong] [CLong]))
-}  deriving ( Read, Show )
 
 -- | Message type which can be sent to an 'AvoidStruts' layout
 --   modifier to alter its behavior.
@@ -234,15 +217,6 @@ data ToggleStruts = ToggleStruts
 
 instance Message ToggleStruts
 
-
--- | message sent to ensure that caching the gaps won't give a wrong result
--- because a new dock has been added
-data DockMessage = UpdateDock Window (Maybe (Either [CLong] [CLong]))
-                 | RemoveDock Window
-  deriving (Read,Show,Typeable)
-instance Message DockMessage
-
-
 -- | SetStruts is a message constructor used to set or unset specific struts,
 -- regardless of whether or not the struts were originally set. Here are some
 -- example bindings:
@@ -270,44 +244,18 @@ data SetStruts = SetStruts { addedStruts   :: [Direction2D]
 instance Message SetStruts
 
 instance LayoutModifier AvoidStruts a where
-    modifyLayoutWithUpdate as@(AvoidStruts ss cache smap) w r = do
+    modifyLayout (AvoidStruts ss) w r = do
-        let dockWins = M.keys smap
+        srect <- fmap ($ r) (calcGap ss)
-        (nr, nsmap) <- case cache of
+        setWorkarea srect
-            Just (ss', r', nr) | ss' == ss, r' == r -> do
+        runLayout w srect
-                nsmap <- getRawStruts dockWins
-                if nsmap /= smap
-                  then do
-                    wnr <- fmap ($ r) (calcGap dockWins ss)
-                    setWorkarea wnr
-                    return (wnr, nsmap)
-                  else do
-                    return (nr, smap)
-            _ -> do
-                nsset <- getRawStruts dockWins
-                nr <- fmap ($ r) (calcGap dockWins ss)
-                setWorkarea nr
-                return (nr, nsset)
-        arranged <- runLayout w nr
-        let newCache = Just (ss, r, nr)
-        return (arranged, if newCache == cache && smap == nsmap
-                    then Nothing
-                    else Just as { avoidStrutsRectCache = newCache
-                                 , strutMap = nsmap })
 
-    pureMess as@(AvoidStruts { avoidStrutsDirection = ss, strutMap = sm }) m
+    pureMess as@(AvoidStruts ss) m
-        | Just ToggleStruts    <- fromMessage m = Just $ as { avoidStrutsDirection = toggleAll ss }
+        | Just ToggleStruts    <- fromMessage m = Just $ AvoidStruts (toggleAll ss)
-        | Just (ToggleStrut s) <- fromMessage m = Just $ as { avoidStrutsDirection = toggleOne s ss }
+        | Just (ToggleStrut s) <- fromMessage m = Just $ AvoidStruts (toggleOne s ss)
         | Just (SetStruts n k) <- fromMessage m
         , let newSS = S.fromList n `S.union` (ss S.\\ S.fromList k)
-        , newSS /= ss = Just $ as { avoidStrutsDirection = newSS }
+        , newSS /= ss = Just $ AvoidStruts newSS
-        | Just (UpdateDock dock strut) <- fromMessage m = if maybe True (/= strut) (M.lookup dock sm)
+        | Just UpdateDocks <- fromMessage m = Just as
-                                            then Just $ as { avoidStrutsRectCache = Nothing
-                                                           , strutMap = M.insert dock strut sm }
-                                            else Nothing
-        | Just (RemoveDock dock) <- fromMessage m = if M.member dock sm
-                                            then Just $ as { avoidStrutsRectCache = Nothing
-                                                           , strutMap = M.delete dock sm }
-                                            else Nothing
         | otherwise = Nothing
       where toggleAll x | S.null x = S.fromList [minBound .. maxBound]
                         | otherwise = S.empty

XMonad/Hooks/PositionStoreHooks.hs

@@ -88,7 +88,7 @@ positionStoreInit mDecoTheme w  = withDisplay $ \d -> do
             else do
                 sc <- fromMaybe (W.current ws) <$> pointScreen (fi $ wa_x wa) (fi $ wa_y wa)
                 let sr = screenRect . W.screenDetail $ sc
-                sr' <- fmap ($ sr) (calcGapForAll $ S.fromList [minBound .. maxBound]) -- take docks into account, accepting
+                sr' <- fmap ($ sr) (calcGap $ S.fromList [minBound .. maxBound]) -- take docks into account, accepting
                                                                                        -- a somewhat unfortunate inter-dependency
                                                                                        -- with 'XMonad.Hooks.ManageDocks'
                 modifyPosStore (\ps -> posStoreInsert ps w

XMonad/Layout/DecorationAddons.hs

@@ -106,8 +106,8 @@ handleScreenCrossing w decoWin = withDisplay $ \d -> do
                         {-- somewhat ugly hack to get proper ScreenRect,
                             creates unwanted inter-dependencies
                             TODO: get ScreenRects in a proper way --}
-                        oldScreenRect' <- fmap ($ oldScreenRect) (calcGapForAll $ S.fromList [minBound .. maxBound])
+                        oldScreenRect' <- fmap ($ oldScreenRect) (calcGap $ S.fromList [minBound .. maxBound])
-                        newScreenRect' <- fmap ($ newScreenRect) (calcGapForAll $ S.fromList [minBound .. maxBound])
+                        newScreenRect' <- fmap ($ newScreenRect) (calcGap $ S.fromList [minBound .. maxBound])
                         wa <- io $ getWindowAttributes d decoWin
                         modifyPosStore (\ps ->
                             posStoreMove ps w (fi $ wa_x wa) (fi $ wa_y wa)

XMonad/Util/ExtensibleState.hs

@@ -21,6 +21,7 @@ module XMonad.Util.ExtensibleState (
                               , remove
                               , get
                               , gets
+                              , modified
                               ) where
 
 import Data.Typeable (typeOf,cast)
@@ -115,3 +116,10 @@ gets = flip fmap get
 -- | Remove the value from the extensible state field that has the same type as the supplied argument
 remove :: ExtensionClass a => a -> X ()
 remove wit = modifyStateExts $ M.delete (show . typeOf $ wit)
+
+modified :: (ExtensionClass a, Eq a) => (a -> a) -> X Bool
+modified f = do
+    v <- get
+    case f v of
+        v' | v' == v   -> return False
+           | otherwise -> put v' >> return True