Merge branch 'pr/rescreen'

CHANGES.md

@@ -250,6 +250,13 @@
     This lets them create custom hooks, ensure they hook into xmonad core only
     once, and possibly more.
 
+  * `XMonad.Hooks.Rescreen`
+
+    Custom hooks for screen (xrandr) configuration changes. These can be used
+    to restart/reposition status bars or systrays automatically after xrandr,
+    as well as to actually invoke xrandr or autorandr when an output is
+    (dis)connected.
+
 ### Bug Fixes and Minor Changes
 
   * Add support for GHC 9.0.1.

XMonad/Doc/Extending.hs

@@ -543,6 +543,12 @@ Here is a list of the modules found in @XMonad.Hooks@:
     even if it was opened in a tiled layout initially. The EventHook makes sure
     that windows are deleted from the PositionStore when they are closed.
 
+* "XMonad.Hooks.Rescreen":
+    Custom hooks for screen (xrandr) configuration changes. These can be used
+    to restart/reposition status bars or systrays automatically after xrandr,
+    as well as to actually invoke xrandr or autorandr when an output is
+    (dis)connected.
+
 * "XMonad.Hooks.RestoreMinimized":
     (Deprecated: Use XMonad.Hooks.Minimize) Lets you restore minimized
     windows (see "XMonad.Layout.Minimize") by selecting them on a

XMonad/Hooks/Rescreen.hs

@@ -0,0 +1,160 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+-- |
+-- Module      :  XMonad.Hooks.Rescreen
+-- Copyright   :  (c) 2021 Tomáš Janoušek <tomi@nomi.cz>
+-- License     :  BSD3
+-- Maintainer  :  Tomáš Janoušek <tomi@nomi.cz>
+--
+-- Custom hooks for screen (xrandr) configuration changes.
+--
+module XMonad.Hooks.Rescreen (
+    -- * Usage
+    -- $usage
+    RescreenConfig(..),
+    addAfterRescreenHook,
+    addRandrChangeHook,
+    rescreenHook,
+    ) where
+
+import Control.Monad (void)
+import Data.Monoid (All(..))
+
+import Graphics.X11.Xrandr
+import XMonad
+import qualified XMonad.Util.ExtensibleConf as XC
+
+-- $usage
+-- This module provides a replacement for the screen configuration change
+-- handling in core that enables attaching custom hooks to screen (xrandr)
+-- configuration change events. These can be used to restart/reposition status
+-- bars or systrays automatically after xrandr, as well as to actually invoke
+-- xrandr or autorandr when an output is (dis)connected.
+--
+-- You can use it by including the following in your @~\/.xmonad\/xmonad.hs@:
+--
+-- > import XMonad.Hooks.RescreenHook
+--
+-- defining your custom hooks:
+--
+-- > myAfterRescreenHook :: X ()
+-- > myAfterRescreenHook = …
+--
+-- > myRandrChangeHook :: X ()
+-- > myRandrChangeHook = …
+--
+-- > rescreenCfg = def{
+-- >     afterRescreenHook = myAfterRescreenHook,
+-- >     randrChangeHook = myRandrChangeHook
+-- > }
+--
+-- and adding 'rescreenHook' to your 'xmonad' config:
+--
+-- > main = xmonad $ … . rescreenHook rescreenCfg . … $ def{…}
+
+-- | Hook configuration for 'rescreenEventHook'.
+data RescreenConfig = RescreenConfig
+    { afterRescreenHook :: X () -- ^ hook to invoke after 'rescreen'
+    , randrChangeHook :: X () -- ^ hook for other randr changes, e.g. (dis)connects
+    }
+
+instance Default RescreenConfig where
+    def = RescreenConfig
+        { afterRescreenHook = mempty
+        , randrChangeHook = mempty
+        }
+
+instance Semigroup RescreenConfig where
+    RescreenConfig arh rch <> RescreenConfig arh' rch' = RescreenConfig (arh <> arh') (rch <> rch')
+
+instance Monoid RescreenConfig where
+    mempty = def
+
+-- | Attach custom hooks to screen (xrandr) configuration change events.
+-- Replaces the built-in rescreen handling of xmonad core with:
+--
+-- 1. listen to 'RRScreenChangeNotifyEvent' in addition to 'ConfigureEvent' on
+--    the root window
+-- 2. whenever such event is received:
+-- 3. clear any other similar events (Xorg server emits them in bunches)
+-- 4. if any event was 'ConfigureEvent', 'rescreen' and invoke 'afterRescreenHook'
+-- 5. if there was no 'ConfigureEvent', invoke 'randrChangeHook' only
+--
+-- 'afterRescreenHook' is useful for restarting/repositioning status bars and
+-- systray.
+--
+-- 'randrChangeHook' may be used to automatically trigger xrandr (or perhaps
+-- autorandr) when outputs are (dis)connected.
+--
+-- Note that 'rescreenHook' is safe to use several times, 'rescreen' is still
+-- done just once and hooks are invoked in sequence, also just once.
+rescreenHook :: RescreenConfig -> XConfig a -> XConfig a
+rescreenHook = XC.once $ \c -> c
+    { startupHook = startupHook c <> rescreenStartupHook
+    , handleEventHook = handleEventHook c <> rescreenEventHook }
+
+-- | Shortcut for 'rescreenHook'.
+addAfterRescreenHook :: X () -> XConfig a -> XConfig a
+addAfterRescreenHook h = rescreenHook def{ afterRescreenHook = h }
+
+-- | Shortcut for 'rescreenHook'.
+addRandrChangeHook :: X () -> XConfig a -> XConfig a
+addRandrChangeHook h = rescreenHook def{ randrChangeHook = h }
+
+-- | Startup hook to listen for @RRScreenChangeNotify@ events.
+rescreenStartupHook :: X ()
+rescreenStartupHook = do
+    dpy <- asks display
+    root <- asks theRoot
+    io $ xrrSelectInput dpy root rrScreenChangeNotifyMask
+
+-- | Event hook with custom rescreen/randr hooks. See 'rescreenHook' for more.
+rescreenEventHook :: Event -> X All
+rescreenEventHook e = do
+    shouldHandle <- case e of
+        ConfigureEvent{ ev_window = w } -> isRoot w
+        RRScreenChangeNotifyEvent{ ev_window = w } -> isRoot w
+        _ -> pure False
+    if shouldHandle
+        then All False <$ handleEvent e
+        else mempty
+
+handleEvent :: Event -> X ()
+handleEvent e = XC.with $ \RescreenConfig{..} -> do
+    -- Xorg emits several events after every change, clear them to prevent
+    -- triggering the hook multiple times.
+    moreConfigureEvents <- clearTypedWindowEvents (ev_window e) configureNotify
+    _ <- clearTypedWindowRREvents (ev_window e) rrScreenChangeNotify
+    -- If there were any ConfigureEvents, this is an actual screen
+    -- configuration change, so rescreen and fire rescreenHook. Otherwise,
+    -- this is just a connect/disconnect, fire randrChangeHook.
+    if ev_event_type e == configureNotify || moreConfigureEvents
+        then rescreen >> afterRescreenHook
+        else randrChangeHook
+
+-- | Remove all X events of a given window and type from the event queue,
+-- return whether there were any.
+clearTypedWindowEvents :: Window -> EventType -> X Bool
+clearTypedWindowEvents w t = withDisplay $ \d -> io $ allocaXEvent (go d)
+  where
+    go d e' = do
+        sync d False
+        gotEvent <- checkTypedWindowEvent d w t e'
+        e <- if gotEvent then Just <$> getEvent e' else pure Nothing
+        gotEvent <$ if
+            | not gotEvent -> mempty
+            | (ev_window <$> e) == Just w -> void $ go d e'
+            -- checkTypedWindowEvent checks ev_event instead of ev_window, so
+            -- we may need to put some events back
+            | otherwise -> allocaXEvent (go d) >> io (putBackEvent d e')
+
+clearTypedWindowRREvents :: Window -> EventType -> X Bool
+clearTypedWindowRREvents w t =
+    rrEventBase >>= \case
+        Just base -> clearTypedWindowEvents w (base + t)
+        Nothing -> pure False
+
+rrEventBase :: X (Maybe EventType)
+rrEventBase = withDisplay $ \d ->
+    fmap (fromIntegral . fst) <$> io (xrrQueryExtension d)

XMonad/Hooks/StatusBar.hs

@@ -75,11 +75,10 @@ import qualified XMonad.Util.ExtensibleState as XS
 
 import XMonad.Layout.LayoutModifier
 import XMonad.Hooks.ManageDocks
+import XMonad.Hooks.Rescreen
 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@:
 --
@@ -440,13 +439,9 @@ instance ExtensionClass ActiveSBs where
 --
 -- Heavily inspired by "XMonad.Hooks.DynamicBars"
 dynamicSBs :: (ScreenId -> IO StatusBarConfig) -> XConfig l -> XConfig l
-dynamicSBs f conf = conf
+dynamicSBs f conf = addAfterRescreenHook (updateSBs f) $ conf
-  { startupHook     = startupHook conf
+  { startupHook = startupHook conf >> killAllStatusBars >> updateSBs f
-                      >> setupEventHandler
-                      >> killAllStatusBars
-                      >> updateSBs f
   , logHook     = logHook conf >> logSBs
-  , handleEventHook = eventHookSBs f <> handleEventHook conf
   }
 
 -- | Like 'dynamicSBs', but applies 'docks' to the
@@ -475,23 +470,10 @@ updateSBs f = do
   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 ()

XMonad/Util/ExtensibleConf.hs

@@ -113,16 +113,16 @@ add x = alter (<> Just x)
 -- This can be used to implement a composable interface for modules that must
 -- only hook into xmonad core once.
 once :: forall a l. (Semigroup a, Typeable a)
-     => a -- ^ configuration to add
+     => (XConfig l -> XConfig l) -- ^ 'XConfig' modification done only once
-     -> (XConfig l -> XConfig l) -- ^ 'XConfig' modification done only once
+     -> a -- ^ configuration to add
      -> XConfig l -> XConfig l
-once x f c = add x $ maybe f (const id) (lookup @a c) c
+once f x c = add x $ maybe f (const id) (lookup @a c) c
 
 -- | Config-time: Applicative (monadic) variant of 'once', useful if the
 -- 'XConfig' modification needs to do some 'IO' (e.g. create an
 -- 'Data.IORef.IORef').
 onceM :: forall a l m. (Applicative m, Semigroup a, Typeable a)
-      => a -- ^ configuration to add
+      => (XConfig l -> m (XConfig l)) -- ^ 'XConfig' modification done only once
-      -> (XConfig l -> m (XConfig l)) -- ^ 'XConfig' modification done only once
+      -> a -- ^ configuration to add
       -> XConfig l -> m (XConfig l)
-onceM x f c = add x <$> maybe f (const pure) (lookup @a c) c
+onceM f x c = add x <$> maybe f (const pure) (lookup @a c) c

tests/ExtensibleConf.hs

@@ -22,9 +22,9 @@ spec = do
         XC.lookup (XC.add "a" (XC.add [1 :: Int] def)) `shouldBe` (Nothing :: Maybe ())
 
     specify "once" $
-        borderWidth (XC.once "a" incBorderWidth def) `shouldBe` succ (borderWidth def)
+        borderWidth (XC.once incBorderWidth "a" def) `shouldBe` succ (borderWidth def)
     specify "once . once" $
-        borderWidth (XC.once "b" incBorderWidth (XC.once "a" incBorderWidth def))
+        borderWidth (XC.once incBorderWidth "b" (XC.once incBorderWidth "a" def))
             `shouldBe` succ (borderWidth def)
 
 incBorderWidth :: XConfig l -> XConfig l

xmonad-contrib.cabal

@@ -184,6 +184,7 @@ library
                         XMonad.Hooks.Place
                         XMonad.Hooks.PositionStoreHooks
                         XMonad.Hooks.RefocusLast
+                        XMonad.Hooks.Rescreen
                         XMonad.Hooks.RestoreMinimized
                         XMonad.Hooks.ScreenCorners
                         XMonad.Hooks.Script