Merge pull request #463 from TheMC47/dynamic-status-bar-configs

Dynamic Status Bars support for XMonad.Hooks.StatusBar

XMonad/Hooks/StatusBar.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, TypeApplications #-}
+{-# LANGUAGE FlexibleContexts, TypeApplications, TupleSections  #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Hooks.StatusBar
@@ -39,30 +39,33 @@ module XMonad.Hooks.StatusBar (
   -- * Multiple Status Bars
   -- $multiple
 
+  -- * Dynamic Status Bars
+  -- $dynamic
+  dynamicSBs,
+  dynamicEasySBs,
+
   -- * Property Logging utilities
   xmonadPropLog,
   xmonadPropLog',
   xmonadDefProp,
 
-  -- * Managing Status Bar Processes
-  spawnStatusBarAndRemember,
-  cleanupStatusBars,
-
-  -- * Manual Plumbing
-  -- $plumbing
+  -- * Managing status bar Processes
+  -- $sbprocess
+  spawnStatusBar,
+  killStatusBar,
+  killAllStatusBars,
   ) where
 
 import Control.Exception (SomeException, try)
 import qualified Codec.Binary.UTF8.String as UTF8 (encode)
+import qualified Data.Map as M
 import System.Posix.Signals (sigTERM, signalProcessGroup)
 import System.Posix.Types (ProcessID)
 
-import qualified Data.Map        as M
-
 import Foreign.C (CChar)
 
 import XMonad
-import XMonad.Prelude (void)
+import XMonad.Prelude
 
 import XMonad.Util.Run
 import qualified XMonad.Util.ExtensibleState as XS
@@ -70,6 +73,9 @@ import qualified XMonad.Util.ExtensibleState as XS
 import XMonad.Layout.LayoutModifier
 import XMonad.Hooks.ManageDocks
 import XMonad.Hooks.StatusBar.PP
+import qualified XMonad.StackSet as W
+
+import Graphics.X11.Xrandr (xrrSelectInput)
 
 -- $usage
 -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
@@ -189,7 +195,7 @@ import XMonad.Hooks.StatusBar.PP
 -- chosen status bar from spawning again). Using 'statusBarProp', however, takes
 -- care of the necessary plumbing /and/ keeps track of the started status bars, so
 -- they can be correctly restarted with xmonad. This is achieved using
--- 'spawnStatusBarAndRemember' to start them and 'cleanupStatusBars' to kill
+-- 'spawnStatusBar' to start them and 'killStatusBar' to kill
 -- previously started bars.
 --
 -- Even if you don't use a status bar, you can still use 'dynamicLogString' to
@@ -297,8 +303,8 @@ statusBarPropTo :: String -- ^ Property to write the string to
                 -> StatusBarConfig
 statusBarPropTo prop cmd pp = def
     { sbLogHook     = xmonadPropLog' prop =<< dynamicLogString =<< pp
-    , sbStartupHook = spawnStatusBarAndRemember cmd
-    , sbCleanupHook = cleanupStatusBars
+    , sbStartupHook = spawnStatusBar cmd
+    , sbCleanupHook = killStatusBar cmd
     }
 
 -- | Like 'statusBarProp', but uses pipe-based logging instead.
@@ -317,7 +323,7 @@ statusBarPipe cmd xpp  = do
 -- Here's an example of what such declarative configuration of multiple status
 -- bars may look like:
 --
--- > -- Make sure to setup the xmobar config accordingly
+-- > -- Make sure to setup the xmobar configs accordingly
 -- > xmobarTop    = statusBarPropTo "_XMONAD_LOG_1" "xmobar -x 0 ~/.config/xmobar/xmobarrc_top"    (pure ppTop)
 -- > xmobarBottom = statusBarPropTo "_XMONAD_LOG_2" "xmobar -x 0 ~/.config/xmobar/xmobarrc_bottom" (pure ppBottom)
 -- > xmobar1      = statusBarPropTo "_XMONAD_LOG_3" "xmobar -x 1 ~/.config/xmobar/xmobarrc1"       (pure pp1)
@@ -361,6 +367,105 @@ statusBarPipe cmd xpp  = do
 --
 -- By using the new interface, the config becomes more declarative and there's
 -- less room for errors.
+--
+-- The only *problem* now is that the status bars will not be updated when your screen
+-- configuration changes (by plugging in a monitor, for example). Check the section
+-- on dynamic status bars for how to do that.
+
+-- $dynamic
+-- Using multiple status bars by just combining them with '<>' works well
+-- as long as the screen configuration does not change often. If it does,
+-- you should use 'dynamicSBs': by providing a function that creates
+-- status bars, it takes care of setting up the event hook, the log hook
+-- and the startup hook necessary to make the status bars, well, dynamic.
+--
+-- > xmobarTop    = statusBarPropTo "_XMONAD_LOG_1" "xmobar -x 0 ~/.config/xmobar/xmobarrc_top"    (pure ppTop)
+-- > xmobarBottom = statusBarPropTo "_XMONAD_LOG_2" "xmobar -x 0 ~/.config/xmobar/xmobarrc_bottom" (pure ppBottom)
+-- > xmobar1      = statusBarPropTo "_XMONAD_LOG_3" "xmobar -x 1 ~/.config/xmobar/xmobarrc1"       (pure pp1)
+-- >
+-- > barSpawner :: ScreenId -> IO StatusBarConfig
+-- > barSpawner 0 = pure $ xmobarTop <> xmobarBottom -- two bars on the main screen
+-- > barSpawner 1 = pure $ xmobar1
+-- > barSpawner _ = mempty -- nothing on the rest of the screens
+-- >
+-- > main = xmonad $ dynamicSBs barSpawner (def { ... })
+--
+-- Make sure you specify which screen to place the status bar on (in xmobar,
+-- this is achieved by the @-x@ argument). In addition to making sure that your
+-- status bar lands where you intended it to land, the commands are used
+-- internally to keep track of the status bars.
+--
+-- Note also that this interface can be used with one screen, or if
+-- the screen configuration doesn't change.
+
+newtype ActiveSBs = ASB {getASBs :: [(ScreenId,  StatusBarConfig)]}
+
+instance ExtensionClass ActiveSBs where
+  initialValue = ASB []
+
+-- | Given a function to create status bars, 'dynamicSBs'
+-- adds the dynamic status bar capabilities to the config.
+-- For a version of this function that applies 'docks' and
+-- 'avoidStruts', check 'dynamicEasySBs'.
+--
+-- Heavily inspired by "XMonad.Hooks.DynamicBars"
+dynamicSBs :: (ScreenId -> IO StatusBarConfig) -> XConfig l -> XConfig l
+dynamicSBs f conf = conf
+  { startupHook     = startupHook conf
+                      >> setupEventHandler
+                      >> killAllStatusBars
+                      >> updateSBs f
+  , logHook         = logHook conf >> logSBs
+  , handleEventHook = eventHookSBs f <> handleEventHook conf
+  }
+
+-- | Like 'dynamicSBs', but applies 'docks' to the
+-- resulting config and adds 'avoidStruts' to the
+-- layout.
+dynamicEasySBs :: LayoutClass l Window
+               => (ScreenId -> IO StatusBarConfig)
+               -> XConfig l
+               -> XConfig (ModifiedLayout AvoidStruts l)
+dynamicEasySBs f conf =
+  docks . dynamicSBs f $ conf { layoutHook = avoidStruts (layoutHook conf) }
+
+-- | Given the function to create status bars, update
+-- the status bars by killing those that shouldn't be
+-- visible anymore and creates any missing status bars
+updateSBs :: (ScreenId -> IO StatusBarConfig) -> X ()
+updateSBs f = do
+  actualScreens    <- withWindowSet $ return . map W.screen . W.screens
+  (toKeep, toKill) <-
+    partition ((`elem` actualScreens) . fst) . getASBs <$> XS.get
+  -- Kill the status bars
+  cleanSBs (map snd toKill)
+  -- Create new status bars if needed
+  let missing = actualScreens \\ map fst toKeep
+  added <- io $ traverse (\s -> (s,) <$> f s) missing
+  traverse_ (sbStartupHook . snd) added
+  XS.put (ASB (toKeep ++ added))
+
+-- | Handles 'RRScreenChangeNotifyEvent' by updating the
+-- status bars.
+eventHookSBs :: (ScreenId -> IO StatusBarConfig) -> Event -> X All
+eventHookSBs f RRScreenChangeNotifyEvent{} = updateSBs f >> return (All True)
+eventHookSBs _ _                           = return (All True)
+
+-- | Run 'sbLogHook' for the saved 'StatusBarConfig's
+logSBs :: X ()
+logSBs = XS.get >>= traverse_ (sbLogHook . snd) . getASBs
+
+-- | Subscribe to the 'RRScreenChangeNotifyEvent'
+setupEventHandler :: X ()
+setupEventHandler = do
+  dpy  <- asks display
+  root <- asks theRoot
+  io $ xrrSelectInput dpy root rrScreenChangeNotifyMask
+
+-- | Kill the given 'StatusBarConfig's from the given
+-- list
+cleanSBs :: [StatusBarConfig] -> X ()
+cleanSBs = traverse_ sbCleanupHook
 
 -- | The default property xmonad writes to. (@_XMONAD_LOG@).
 xmonadDefProp :: String
@@ -389,41 +494,49 @@ xmonadPropLog' prop msg = do
 
 -- This newtype wrapper, together with the ExtensionClass instance make use of
 -- the extensible state to save the PIDs bewteen xmonad restarts.
-newtype StatusBarPIDs = StatusBarPIDs { getPIDs :: [ProcessID] }
+newtype StatusBarPIDs = StatusBarPIDs { getPIDs :: M.Map String ProcessID }
   deriving (Show, Read)
 
 instance ExtensionClass StatusBarPIDs where
-  initialValue = StatusBarPIDs []
+  initialValue = StatusBarPIDs mempty
   extensionType = PersistentExtension
 
--- | Kills the status bars started with 'spawnStatusBarAndRemember', and resets
--- the state. This could go for example at the beginning of the startupHook.
+-- | Kills the status bar started with 'spawnStatusBar' using the given command
+-- and resets the state. This could go for example at the beginning of the
+-- startupHook, to kill the status bars that need to be restarted.
 --
 -- Concretely, this function sends a 'sigTERM' to the saved PIDs using
 -- 'signalProcessGroup' to effectively terminate all processes, regardless
--- of how many were started by using  'spawnStatusBarAndRemember'.
+-- of how many were started by using  'spawnStatusBar'.
 --
 -- There is one caveat to keep in mind: to keep the implementation simple;
 -- no checks are executed before terminating the processes. This means: if the
 -- started process dies for some reason, and enough time passes for the PIDs
 -- to wrap around, this function might terminate another process that happens
 -- to have the same PID. However, this isn't a typical usage scenario.
-cleanupStatusBars :: X ()
-cleanupStatusBars =
-    getPIDs <$> XS.get
-    >>= (io . mapM_ killPid)
-    >> XS.put (StatusBarPIDs [])
-   where
+killStatusBar :: String -- ^ The command used to start the status bar
+                 -> X ()
+killStatusBar cmd = do
+    XS.gets (M.lookup cmd . getPIDs) >>= flip whenJust (io . killPid)
+    XS.modify (StatusBarPIDs . M.delete cmd . getPIDs)
+
 killPid :: ProcessID -> IO ()
 killPid pidToKill = void $ try @SomeException (signalProcessGroup sigTERM pidToKill)
 
--- | Spawns a status bar and saves its PID. This is useful when the status bars
--- should be restarted with xmonad. Use this in combination with 'cleanupStatusBars'.
+-- | Spawns a status bar and saves its PID together with the commands that was
+-- used to start it. This is useful when the status bars should be restarted
+-- with xmonad. Use this in combination with 'killStatusBar'.
 --
 -- Note: in some systems, multiple processes might start, even though one command is
 -- provided. This means the first PID, of the group leader, is saved.
-spawnStatusBarAndRemember :: String -- ^ The command used to spawn the status bar
+spawnStatusBar :: String -- ^ The command used to spawn the status bar
                -> X ()
-spawnStatusBarAndRemember cmd = do
+spawnStatusBar cmd = do
   newPid <- spawnPID cmd
-  XS.modify (StatusBarPIDs . (newPid :) . getPIDs)
+  XS.modify (StatusBarPIDs . M.insert cmd newPid . getPIDs)
+
+-- | Kill all status bars started with 'spawnStatusBar'. Note the
+-- caveats in 'cleanupStatusBar'
+killAllStatusBars :: X ()
+killAllStatusBars =
+  XS.gets (M.elems . getPIDs) >>= io . traverse_ killPid >> XS.put (StatusBarPIDs mempty)