Fix caching issues in ManageDocks

Commits d638dc8b and a5e87e38 introduced a per-AvoidStruts-instance
strut cache that

a) didn't get initialized at startup,
b) didn't get reinitialized after layout reset and
c) didn't get updates if it wasn't the active layout, for example when
   layoutHook = avoidStruts tall ||| avoidStruts (mirror tall)

a) + b) could be fixed by using the docksStartupHook introduced in
28e9f8bc, although this wasn't documented and having to call
docksStartupHook after setLayout is far from obvious.

By moving the strut cache from AvoidStruts instances to a global state,
b) and c) are fixed. One still has to invoke the docksStartupHook for
a), and this will be addressed in the next commit.

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/Hooks/ManageDocks.hs

@@ -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
@@ -101,6 +101,33 @@ import Control.Monad (when, forM_, filterM)
 -- "XMonad.Doc.Extending#Editing_key_bindings".
 --
 
+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
+
+modifyXS :: (ExtensionClass a, Eq a) => (a -> a) -> X Bool
+modifyXS f = do
+    v <- XS.get
+    case f v of
+        v' | v' == v   -> return False
+           | otherwise -> XS.put v' >> return True
+
+updateStrutCache :: Window -> [Strut] -> X Bool
+updateStrutCache w strut = do
+  modifyXS $ StrutCache . M.insert w strut . fromStrutCache
+
+deleteFromStructCache :: Window -> X Bool
+deleteFromStructCache w = do
+  modifyXS $ 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 +152,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 +161,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 +175,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 +195,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 +222,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 +234,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 +261,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)