X.H.Rescreen: Merge the two hooks together and improve their behaviour

Now that randrChangeHook is only invoked for changes that don't result
in rescreen, it can actually be used for autorandr.

XMonad/Hooks/Rescreen.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
 -- |
 -- Module      :  XMonad.Hooks.Rescreen
 -- Copyright   :  (c) 2021 Tomáš Janoušek <tomi@nomi.cz>
@@ -9,15 +12,13 @@
 module XMonad.Hooks.Rescreen (
     -- * Usage
     -- $usage
+    RescreenConfig(..),
     rescreenHook,
+    rescreenStartupHook,
     rescreenEventHook,
-    randrHook,
-    randrEventHook,
-    randrStartupHook,
     ) where
 
-import Control.Monad.Fix (fix)
+import Control.Monad (void)
-import Control.Monad (when)
 import Data.Monoid (All(..))
 
 import Graphics.X11.Xrandr
@@ -25,90 +26,118 @@ import XMonad
 
 -- $usage
 -- This module provides a replacement for the screen configuration change
--- handling in core that enables attaching a custom hook that can
+-- handling in core that enables attaching custom hooks to screen (xrandr)
--- restart/reposition status bars or systray.
+-- 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 rescreen hook:
+-- defining your custom hooks:
 --
--- > myRescreenHook :: X ()
+-- > myAfterRescreenHook :: X ()
--- > myRescreenHook = …
+-- > myAfterRescreenHook = …
+--
+-- > myRandrChangeHook :: X ()
+-- > myRandrChangeHook = …
+--
+-- > rescreenCfg = def{
+-- >     afterRescreenHook = myAfterRescreenHook,
+-- >     randrChangeHook = myRandrChangeHook
+-- > }
 --
 -- and adding 'rescreenHook' to your 'xmonad' config:
 --
--- > main = xmonad $ … . rescreenHook myRescreenHook . … $ def{…}
+-- > main = xmonad $ … . rescreenHook rescreenCfg . … $ def{…}
---
--- There is also 'randrHook' which listens for @RRScreenChangeNotify@ events
--- and is useful for reacting to outputs being connected/disconnected.
 
--- | Attach a custom hook when the screen configuration changes (due to
+-- | Hook configuration for 'rescreenEventHook'.
--- xrandr). Replaces the built-in rescreen handling of xmonad core with:
+data RescreenConfig = RescreenConfig
---
+    { afterRescreenHook :: X () -- ^ hook to invoke after 'rescreen'
--- 1. suppress duplicate change events
+    , randrChangeHook :: X () -- ^ hook for other randr changes, e.g. (dis)connects
--- 2. 'rescreen'
+    }
--- 3. invoke specified hook
---
--- Useful for restarting/repositioning status bars and systray.
-rescreenHook :: X () -> XConfig a -> XConfig a
-rescreenHook hook xConfig =
-    xConfig{ handleEventHook = handleEventHook xConfig <> rescreenEventHook hook }
 
--- | Event hook with custom rescreen hook. See 'rescreenHook' for more.
+instance Default RescreenConfig where
-rescreenEventHook :: X () -> Event -> X All
+    def = RescreenConfig
-rescreenEventHook hook ConfigureEvent{ev_event_type = t, ev_window = w} = do
+        { afterRescreenHook = mempty
-    isRescreen <- isRoot w
+        , randrChangeHook = mempty
-    if isRescreen
+        }
-        then do
-            -- Xorg emits several ConfigureEvents after every change,
-            -- clear them to prevent triggering the hook multiple times
-            clearTypedWindowEvents w t
-            rescreen
-            hook
-            return (All False)
-        else mempty
-rescreenEventHook _ _ = mempty
 
--- | Attach a hook to an @RRScreenChangeNotify@ event which is generated not
+-- | Attach custom hooks to screen (xrandr) configuration change events.
--- only when the configuration is changed via xrandr but also when outputs are
+-- Replaces the built-in rescreen handling of xmonad core with:
--- connected or disconnected.
 --
--- This may be used to automatically trigger xrandr (or perhaps autorandr)
+-- 1. listen to 'RRScreenChangeNotifyEvent' in addition to 'ConfigureEvent' on
--- when outputs are (dis)connected. Beware: the hook will also run after
+--    the root window
--- xrandr makes changes, so care must be taken to not invoke it again.
+-- 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
 --
--- TODO: merge with rescreenHook, do clearTypedWindowEvents for both event
+-- 'afterRescreenHook' is useful for restarting/repositioning status bars and
--- types and if there are any ConfigureEvents, do not invoke the randr hook
+-- systray.
-randrHook :: X () -> XConfig a -> XConfig a
+--
-randrHook hook xConfig =
+-- 'randrChangeHook' may be used to automatically trigger xrandr (or perhaps
-    xConfig{ handleEventHook = handleEventHook xConfig <> randrEventHook hook
+-- autorandr) when outputs are (dis)connected.
-           , startupHook = startupHook xConfig <> randrStartupHook }
+rescreenHook :: RescreenConfig -> XConfig a -> XConfig a
-
+rescreenHook cfg xConfig =
--- | Event hook with custom @RRScreenChangeNotify@ hook. See 'randrHook'
+    xConfig{ startupHook = startupHook xConfig <> rescreenStartupHook
--- for details.
+           , handleEventHook = handleEventHook xConfig <> rescreenEventHook cfg
-randrEventHook :: X () -> Event -> X All
+           }
-randrEventHook hook RRScreenChangeNotifyEvent{ev_event_type = t, ev_window = w} = do
-    whenX (isRoot w) $ do
-        -- Xorg emits several RRScreenChangeNotifyEvents after every change,
-        -- clear them to prevent triggering the hook multiple times
-        clearTypedWindowEvents w t
-        hook
-    mempty
-randrEventHook _ _ = mempty
 
 -- | Startup hook to listen for @RRScreenChangeNotify@ events.
-randrStartupHook :: X ()
+rescreenStartupHook :: X ()
-randrStartupHook = do
+rescreenStartupHook = do
     dpy <- asks display
     root <- asks theRoot
     io $ xrrSelectInput dpy root rrScreenChangeNotifyMask
 
--- | Remove all X events of a given window and type from the event queue.
+-- | Event hook with custom rescreen/randr hooks. See 'rescreenHook' for more.
-clearTypedWindowEvents :: Window -> EventType -> X ()
+rescreenEventHook :: RescreenConfig -> Event -> X All
-clearTypedWindowEvents w t = withDisplay $ \d -> io $ do
+rescreenEventHook cfg e = do
-    sync d False
+    shouldHandle <- case e of
-    allocaXEvent $ \e -> fix $ \again -> do
+        ConfigureEvent{ ev_window = w } -> isRoot w
-        more <- checkTypedWindowEvent d w t e
+        RRScreenChangeNotifyEvent{ ev_window = w } -> isRoot w
-        when more again
+        _ -> pure False
+    if shouldHandle
+        then All False <$ handleEvent cfg e
+        else mempty
+
+handleEvent :: RescreenConfig -> Event -> X ()
+handleEvent RescreenConfig{..} e = 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)