{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
-- |
-- Module      :  XMonad.Hooks.Rescreen
-- Description :  Custom hooks for screen (xrandr) configuration changes.
-- 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
    addAfterRescreenHook,
    addRandrChangeHook,
    setRescreenWorkspacesHook,
    setRescreenDelay,
    RescreenConfig(..),
    rescreenHook,
    ) where

import Control.Concurrent (threadDelay)
import Graphics.X11.Xrandr
import XMonad
import XMonad.Prelude
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
-- ('XMonad.Hooks.StatusBar.dynamicSBs' uses this module internally), as well
-- as to actually invoke xrandr or autorandr when an output is (dis)connected.
--
-- To use this, include the following in your @xmonad.hs@:
--
-- > import XMonad.Hooks.Rescreen
--
-- define your custom hooks:
--
-- > myAfterRescreenHook :: X ()
-- > myAfterRescreenHook = spawn "fbsetroot -solid red"
--
-- > myRandrChangeHook :: X ()
-- > myRandrChangeHook = spawn "autorandr --change"
--
-- and hook them into your 'xmonad' config:
--
-- > main = xmonad $ …
-- >               . addAfterRescreenHook myAfterRescreenHook
-- >               . addRandrChangeHook myRandrChangeHook
-- >               . …
-- >               $ def{…}
--
-- See documentation of 'rescreenHook' for details about when these hooks are
-- called.

-- | Hook configuration for 'rescreenHook'.
data RescreenConfig = RescreenConfig
    { RescreenConfig -> X ()
afterRescreenHook :: X () -- ^ hook to invoke after 'rescreen'
    , RescreenConfig -> X ()
randrChangeHook :: X () -- ^ hook for other randr changes, e.g. (dis)connects
    , RescreenConfig -> Last (X ())
rescreenWorkspacesHook :: Last (X ()) -- ^ hook to invoke instead of 'rescreen'
    , RescreenConfig -> Last Int
rescreenDelay :: Last Int -- ^ delay (in microseconds) to wait for events to settle
    }

instance Default RescreenConfig where
    def :: RescreenConfig
def = RescreenConfig
        { afterRescreenHook :: X ()
afterRescreenHook = X ()
forall a. Monoid a => a
mempty
        , randrChangeHook :: X ()
randrChangeHook = X ()
forall a. Monoid a => a
mempty
        , rescreenWorkspacesHook :: Last (X ())
rescreenWorkspacesHook = Last (X ())
forall a. Monoid a => a
mempty
        , rescreenDelay :: Last Int
rescreenDelay = Last Int
forall a. Monoid a => a
mempty
        }

instance Semigroup RescreenConfig where
    RescreenConfig X ()
arh X ()
rch Last (X ())
rwh Last Int
rd <> :: RescreenConfig -> RescreenConfig -> RescreenConfig
<> RescreenConfig X ()
arh' X ()
rch' Last (X ())
rwh' Last Int
rd' =
        X () -> X () -> Last (X ()) -> Last Int -> RescreenConfig
RescreenConfig (X ()
arh X () -> X () -> X ()
forall a. Semigroup a => a -> a -> a
<> X ()
arh') (X ()
rch X () -> X () -> X ()
forall a. Semigroup a => a -> a -> a
<> X ()
rch') (Last (X ())
rwh Last (X ()) -> Last (X ()) -> Last (X ())
forall a. Semigroup a => a -> a -> a
<> Last (X ())
rwh') (Last Int
rd Last Int -> Last Int -> Last Int
forall a. Semigroup a => a -> a -> a
<> Last Int
rd')

instance Monoid RescreenConfig where
    mempty :: RescreenConfig
mempty = RescreenConfig
forall a. Default a => a
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.
--
-- 'rescreenWorkspacesHook' allows tweaking the 'rescreen' implementation,
-- to change the order workspaces are assigned to physical screens for
-- example.
--
-- 'rescreenDelay' makes xmonad wait a bit for events to settle (after the
-- first event is received) — useful when multiple @xrandr@ invocations are
-- being used to change the screen layout.
--
-- Note that 'rescreenHook' is safe to use several times, 'rescreen' is still
-- done just once and hooks are invoked in sequence (except
-- 'rescreenWorkspacesHook', which has a replace rather than sequence
-- semantics), also just once.
rescreenHook :: RescreenConfig -> XConfig l -> XConfig l
rescreenHook :: forall (l :: * -> *). RescreenConfig -> XConfig l -> XConfig l
rescreenHook = (XConfig l -> XConfig l)
-> RescreenConfig -> XConfig l -> XConfig l
forall a (l :: * -> *).
(Semigroup a, Typeable a) =>
(XConfig l -> XConfig l) -> a -> XConfig l -> XConfig l
XC.once XConfig l -> XConfig l
forall {l :: * -> *}. XConfig l -> XConfig l
hook (RescreenConfig -> XConfig l -> XConfig l)
-> (RescreenConfig -> RescreenConfig)
-> RescreenConfig
-> XConfig l
-> XConfig l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RescreenConfig -> RescreenConfig
catchUserCode
  where
    hook :: XConfig l -> XConfig l
hook XConfig l
c = XConfig l
c
        { startupHook = startupHook c <> rescreenStartupHook
        , handleEventHook = handleEventHook c <> rescreenEventHook }
    catchUserCode :: RescreenConfig -> RescreenConfig
catchUserCode rc :: RescreenConfig
rc@RescreenConfig{Last Int
Last (X ())
X ()
afterRescreenHook :: RescreenConfig -> X ()
randrChangeHook :: RescreenConfig -> X ()
rescreenWorkspacesHook :: RescreenConfig -> Last (X ())
rescreenDelay :: RescreenConfig -> Last Int
afterRescreenHook :: X ()
randrChangeHook :: X ()
rescreenWorkspacesHook :: Last (X ())
rescreenDelay :: Last Int
..} = RescreenConfig
rc
        { afterRescreenHook = userCodeDef () afterRescreenHook
        , randrChangeHook = userCodeDef () randrChangeHook
        , rescreenWorkspacesHook = flip catchX rescreen <$> rescreenWorkspacesHook
        }

-- | Shortcut for 'rescreenHook'.
addAfterRescreenHook :: X () -> XConfig l -> XConfig l
addAfterRescreenHook :: forall (l :: * -> *). X () -> XConfig l -> XConfig l
addAfterRescreenHook X ()
h = RescreenConfig -> XConfig l -> XConfig l
forall (l :: * -> *). RescreenConfig -> XConfig l -> XConfig l
rescreenHook RescreenConfig
forall a. Default a => a
def{ afterRescreenHook = h }

-- | Shortcut for 'rescreenHook'.
addRandrChangeHook :: X () -> XConfig l -> XConfig l
addRandrChangeHook :: forall (l :: * -> *). X () -> XConfig l -> XConfig l
addRandrChangeHook X ()
h = RescreenConfig -> XConfig l -> XConfig l
forall (l :: * -> *). RescreenConfig -> XConfig l -> XConfig l
rescreenHook RescreenConfig
forall a. Default a => a
def{ randrChangeHook = h }

-- | Shortcut for 'rescreenHook'.
setRescreenWorkspacesHook :: X () -> XConfig l -> XConfig l
setRescreenWorkspacesHook :: forall (l :: * -> *). X () -> XConfig l -> XConfig l
setRescreenWorkspacesHook X ()
h = RescreenConfig -> XConfig l -> XConfig l
forall (l :: * -> *). RescreenConfig -> XConfig l -> XConfig l
rescreenHook RescreenConfig
forall a. Default a => a
def{ rescreenWorkspacesHook = pure h }

-- | Shortcut for 'rescreenHook'.
setRescreenDelay :: Int -> XConfig l -> XConfig l
setRescreenDelay :: forall (l :: * -> *). Int -> XConfig l -> XConfig l
setRescreenDelay Int
d = RescreenConfig -> XConfig l -> XConfig l
forall (l :: * -> *). RescreenConfig -> XConfig l -> XConfig l
rescreenHook RescreenConfig
forall a. Default a => a
def{ rescreenDelay = pure d }

-- | Startup hook to listen for @RRScreenChangeNotify@ events.
rescreenStartupHook :: X ()
rescreenStartupHook :: X ()
rescreenStartupHook = do
    dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
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 :: Event -> X All
rescreenEventHook Event
e = do
    shouldHandle <- case Event
e of
        ConfigureEvent{ ev_window :: Event -> Window
ev_window = Window
w } -> Window -> X Bool
isRoot Window
w
        RRScreenChangeNotifyEvent{ ev_window :: Event -> Window
ev_window = Window
w } -> Window -> X Bool
isRoot Window
w
        Event
_ -> Bool -> X Bool
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    if shouldHandle
        then All False <$ handleEvent e
        else mempty

handleEvent :: Event -> X ()
handleEvent :: Event -> X ()
handleEvent Event
e = (RescreenConfig -> X ()) -> X ()
forall (m :: * -> *) a b.
(MonadReader XConf m, Typeable a, Monoid b) =>
(a -> m b) -> m b
XC.with ((RescreenConfig -> X ()) -> X ())
-> (RescreenConfig -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \RescreenConfig{Last Int
Last (X ())
X ()
afterRescreenHook :: RescreenConfig -> X ()
randrChangeHook :: RescreenConfig -> X ()
rescreenWorkspacesHook :: RescreenConfig -> Last (X ())
rescreenDelay :: RescreenConfig -> Last Int
afterRescreenHook :: X ()
randrChangeHook :: X ()
rescreenWorkspacesHook :: Last (X ())
rescreenDelay :: Last Int
..} -> do
    -- Xorg emits several events after every change, clear them to prevent
    -- triggering the hook multiple times.
    Maybe Int -> (Int -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (Last Int -> Maybe Int
forall a. Last a -> Maybe a
getLast Last Int
rescreenDelay) (IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> (Int -> IO ()) -> Int -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
threadDelay)
    moreConfigureEvents <- Window -> EventType -> X Bool
clearTypedWindowEvents (Event -> Window
ev_window Event
e) EventType
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 fromMaybe rescreen (getLast rescreenWorkspacesHook) >> 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 :: Window -> EventType -> X Bool
clearTypedWindowEvents Window
w EventType
t = (Display -> X Bool) -> X Bool
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X Bool) -> X Bool) -> (Display -> X Bool) -> X Bool
forall a b. (a -> b) -> a -> b
$ \Display
d -> IO Bool -> X Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Bool -> X Bool) -> IO Bool -> X Bool
forall a b. (a -> b) -> a -> b
$ (XEventPtr -> IO Bool) -> IO Bool
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent (Display -> XEventPtr -> IO Bool
go Display
d)
  where
    go :: Display -> XEventPtr -> IO Bool
go Display
d XEventPtr
e' = do
        Display -> Bool -> IO ()
sync Display
d Bool
False
        gotEvent <- Display -> Window -> EventType -> XEventPtr -> IO Bool
checkTypedWindowEvent Display
d Window
w EventType
t XEventPtr
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 :: Window -> EventType -> X Bool
clearTypedWindowRREvents Window
w EventType
t =
    X (Maybe EventType)
rrEventBase X (Maybe EventType) -> (Maybe EventType -> X Bool) -> X Bool
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just EventType
base -> Window -> EventType -> X Bool
clearTypedWindowEvents Window
w (EventType
base EventType -> EventType -> EventType
forall a. Num a => a -> a -> a
+ EventType
t)
        Maybe EventType
Nothing -> Bool -> X Bool
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

rrEventBase :: X (Maybe EventType)
rrEventBase :: X (Maybe EventType)
rrEventBase = (Display -> X (Maybe EventType)) -> X (Maybe EventType)
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X (Maybe EventType)) -> X (Maybe EventType))
-> (Display -> X (Maybe EventType)) -> X (Maybe EventType)
forall a b. (a -> b) -> a -> b
$ \Display
d ->
    ((CInt, CInt) -> EventType)
-> Maybe (CInt, CInt) -> Maybe EventType
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CInt -> EventType
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> EventType)
-> ((CInt, CInt) -> CInt) -> (CInt, CInt) -> EventType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CInt, CInt) -> CInt
forall a b. (a, b) -> a
fst) (Maybe (CInt, CInt) -> Maybe EventType)
-> X (Maybe (CInt, CInt)) -> X (Maybe EventType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (CInt, CInt)) -> X (Maybe (CInt, CInt))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> IO (Maybe (CInt, CInt))
xrrQueryExtension Display
d)