X.H.ManageDocks: Refactor strut cache

This is primarily a cleanup to make it easier to use `setDocksMask` from
the on-demand cache init (see further commits), but it makes the code
nicer:

- the logic to refresh and cache a strut is now concentrated in
  `updateStrut` instead of being spread over `updateStrutCache` and
  `docksEventHook`

- the logic to initialize the cache if not yet initialized is now
  concentrated in `maybeInitStrutCache` instead of being spread over
  `initStrutCache` and `getStrutCache`, so the dual-purpose return type
  of `getStrutCache` is no more

- the logic to detect changes and refresh is now always handled by
  `XS.modifiedM` instead of an additional `||`

Related: xmonad#406

XMonad/Hooks/ManageDocks.hs

@@ -45,7 +45,8 @@ import Data.Monoid (All(..))
 
 import qualified Data.Set as S
 import qualified Data.Map as M
-import Control.Monad (when, filterM, void)
+import Control.Monad (when, filterM, void, (<=<))
+import Data.Foldable (foldlM)
 
 -- $usage
 -- To use this module, add the following import to @~\/.xmonad\/xmonad.hs@:
@@ -93,46 +94,44 @@ docks c = c { startupHook     = docksStartupHook <+> startupHook c
 
 type WindowStruts = M.Map Window [Strut]
 
--- Nothing means cache hasn't been initialized yet
-newtype StrutCache = StrutCache { fromStrutCache :: Maybe WindowStruts }
-    deriving (Eq, Typeable)
-
 data UpdateDocks = UpdateDocks deriving Typeable
 instance Message UpdateDocks
 
 refreshDocks :: X ()
 refreshDocks = sendMessage UpdateDocks
 
+-- Nothing means cache hasn't been initialized yet
+newtype StrutCache = StrutCache { fromStrutCache :: Maybe WindowStruts }
+    deriving (Eq, Typeable)
+
 instance ExtensionClass StrutCache where
     initialValue = StrutCache Nothing
 
-initStrutCache :: X WindowStruts
-initStrutCache = withDisplay $ \dpy -> do
-    rootw <- asks theRoot
-    (_,_,wins) <- io $ queryTree dpy rootw
-    dockws <- filterM (runQuery checkDock) wins
-    M.fromList . zip dockws <$> mapM getStrut dockws
-
-getStrutCache :: X (Bool, WindowStruts)
-getStrutCache = XS.gets fromStrutCache >>= \case
-    Just cache ->
-        return (False, cache)
-    Nothing -> do
-        cache <- initStrutCache
-        XS.put $ StrutCache $ Just cache
-        return (True, cache)
-
-updateStrutCache :: Window -> [Strut] -> X Bool
-updateStrutCache w strut = do
-    ch1 <- fst <$> getStrutCache
-    ch2 <- XS.modified $ StrutCache . fmap (M.insert w strut) . fromStrutCache
-    return $ ch1 || ch2
-
-deleteFromStructCache :: Window -> X Bool
-deleteFromStructCache w = do
-    ch1 <- fst <$> getStrutCache
-    ch2 <- XS.modified $ StrutCache . fmap (M.delete w) . fromStrutCache
-    return $ ch1 || ch2
+modifiedStrutCache :: (Maybe WindowStruts -> X WindowStruts) -> X Bool
+modifiedStrutCache f = XS.modifiedM $ fmap (StrutCache . Just) . f . fromStrutCache
+
+getStrutCache :: X WindowStruts
+getStrutCache = do
+    cache <- maybeInitStrutCache =<< XS.gets fromStrutCache
+    cache <$ XS.put (StrutCache (Just cache))
+
+updateStrutCache :: Window -> X Bool
+updateStrutCache w = modifiedStrutCache $ updateStrut w <=< maybeInitStrutCache
+
+deleteFromStrutCache :: Window -> X Bool
+deleteFromStrutCache w = modifiedStrutCache $ fmap (M.delete w) . maybeInitStrutCache
+
+maybeInitStrutCache :: Maybe WindowStruts -> X WindowStruts
+maybeInitStrutCache = maybe (queryDocks >>= foldlM (flip updateStrut) M.empty) pure
+  where
+    queryDocks = withDisplay $ \dpy -> do
+        (_, _, wins) <- io . queryTree dpy =<< asks theRoot
+        filterM (runQuery checkDock) wins
+
+updateStrut :: Window -> WindowStruts -> X WindowStruts
+updateStrut w cache = do
+    strut <- getStrut w
+    pure $ M.insert w strut cache
 
 -- | Detects if the given window is of type DOCK and if so, reveals
 --   it, but does not manage it.
@@ -157,20 +156,18 @@ checkDock = ask >>= \w -> liftX $ do
 -- new dock.
 docksEventHook :: Event -> X All
 docksEventHook (MapNotifyEvent { ev_window = w }) = do
-    whenX (runQuery checkDock w <&&> (not <$> isClient w)) $ do
-        strut <- getStrut w
-        whenX (updateStrutCache w strut) refreshDocks
+    whenX (runQuery checkDock w <&&> (not <$> isClient w)) $
+        whenX (updateStrutCache w) refreshDocks
     return (All True)
 docksEventHook (PropertyEvent { ev_window = w
                               , ev_atom = a }) = do
     nws <- getAtom "_NET_WM_STRUT"
     nwsp <- getAtom "_NET_WM_STRUT_PARTIAL"
-    when (a == nws || a == nwsp) $ do
-        strut <- getStrut w
-        whenX (updateStrutCache w strut) refreshDocks
+    when (a == nws || a == nwsp) $
+        whenX (updateStrutCache w) refreshDocks
     return (All True)
 docksEventHook (DestroyWindowEvent {ev_window = w}) = do
-    whenX (deleteFromStructCache w) refreshDocks
+    whenX (deleteFromStrutCache w) refreshDocks
     return (All True)
 docksEventHook _ = return (All True)
 
@@ -198,7 +195,7 @@ getStrut w = do
 calcGap :: S.Set Direction2D -> X (Rectangle -> Rectangle)
 calcGap ss = withDisplay $ \dpy -> do
     rootw <- asks theRoot
-    struts <- filter careAbout . concat . M.elems . snd <$> getStrutCache
+    struts <- filter careAbout . concat . M.elems <$> getStrutCache
 
     -- 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

XMonad/Util/ExtensibleState.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternGuards #-}
 -----------------------------------------------------------------------------
 -- |
@@ -22,6 +23,7 @@ module XMonad.Util.ExtensibleState (
                               , get
                               , gets
                               , modified
+                              , modifiedM
                               ) where
 
 import Data.Typeable (typeOf,cast)
@@ -121,8 +123,11 @@ remove :: (ExtensionClass a, XLike m) => a -> m ()
 remove wit = modifyStateExts $ M.delete (show . typeOf $ wit)
 
 modified :: (ExtensionClass a, Eq a, XLike m) => (a -> a) -> m Bool
-modified f = do
+modified = modifiedM . (pure .)
+
+modifiedM :: (ExtensionClass a, Eq a, XLike m) => (a -> m a) -> m Bool
+modifiedM f = do
     v <- get
-    case f v of
+    f v >>= \case
         v' | v' == v   -> return False
            | otherwise -> put v' >> return True