{-# 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 = forall a. Monoid a => a
mempty
        , randrChangeHook :: X ()
randrChangeHook = forall a. Monoid a => a
mempty
        , rescreenWorkspacesHook :: Last (X ())
rescreenWorkspacesHook = forall a. Monoid a => a
mempty
        , rescreenDelay :: Last Int
rescreenDelay = 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 forall a. Semigroup a => a -> a -> a
<> X ()
arh') (X ()
rch forall a. Semigroup a => a -> a -> a
<> X ()
rch') (Last (X ())
rwh forall a. Semigroup a => a -> a -> a
<> Last (X ())
rwh') (Last Int
rd forall a. Semigroup a => a -> a -> a
<> Last Int
rd')

instance Monoid RescreenConfig where
    mempty :: RescreenConfig
mempty = 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 = forall a (l :: * -> *).
(Semigroup a, Typeable a) =>
(XConfig l -> XConfig l) -> a -> XConfig l -> XConfig l
XC.once forall {l :: * -> *}. XConfig l -> XConfig l
hook 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 :: X ()
startupHook = forall (l :: * -> *). XConfig l -> X ()
startupHook XConfig l
c forall a. Semigroup a => a -> a -> a
<> X ()
rescreenStartupHook
        , handleEventHook :: Event -> X All
handleEventHook = forall (l :: * -> *). XConfig l -> Event -> X All
handleEventHook XConfig l
c forall a. Semigroup a => a -> a -> a
<> Event -> X All
rescreenEventHook }
    catchUserCode :: RescreenConfig -> RescreenConfig
catchUserCode rc :: RescreenConfig
rc@RescreenConfig{Last Int
Last (X ())
X ()
rescreenDelay :: Last Int
rescreenWorkspacesHook :: Last (X ())
randrChangeHook :: X ()
afterRescreenHook :: X ()
rescreenDelay :: RescreenConfig -> Last Int
rescreenWorkspacesHook :: RescreenConfig -> Last (X ())
randrChangeHook :: RescreenConfig -> X ()
afterRescreenHook :: RescreenConfig -> X ()
..} = RescreenConfig
rc
        { afterRescreenHook :: X ()
afterRescreenHook = forall a. a -> X a -> X a
userCodeDef () X ()
afterRescreenHook
        , randrChangeHook :: X ()
randrChangeHook = forall a. a -> X a -> X a
userCodeDef () X ()
randrChangeHook
        , rescreenWorkspacesHook :: Last (X ())
rescreenWorkspacesHook = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. X a -> X a -> X a
catchX X ()
rescreen forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Last (X ())
rescreenWorkspacesHook
        }

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

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

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

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

-- | Startup hook to listen for @RRScreenChangeNotify@ events.
rescreenStartupHook :: X ()
rescreenStartupHook :: X ()
rescreenStartupHook = do
    Display
dpy <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
    Window
root <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Window -> Window -> IO ()
xrrSelectInput Display
dpy Window
root Window
rrScreenChangeNotifyMask

-- | Event hook with custom rescreen/randr hooks. See 'rescreenHook' for more.
rescreenEventHook :: Event -> X All
rescreenEventHook :: Event -> X All
rescreenEventHook Event
e = do
    Bool
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
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    if Bool
shouldHandle
        then Bool -> All
All Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event -> X ()
handleEvent Event
e
        else forall a. Monoid a => a
mempty

handleEvent :: Event -> X ()
handleEvent :: Event -> X ()
handleEvent Event
e = forall (m :: * -> *) a b.
(MonadReader XConf m, Typeable a, Monoid b) =>
(a -> m b) -> m b
XC.with forall a b. (a -> b) -> a -> b
$ \RescreenConfig{Last Int
Last (X ())
X ()
rescreenDelay :: Last Int
rescreenWorkspacesHook :: Last (X ())
randrChangeHook :: X ()
afterRescreenHook :: X ()
rescreenDelay :: RescreenConfig -> Last Int
rescreenWorkspacesHook :: RescreenConfig -> Last (X ())
randrChangeHook :: RescreenConfig -> X ()
afterRescreenHook :: RescreenConfig -> X ()
..} -> do
    -- Xorg emits several events after every change, clear them to prevent
    -- triggering the hook multiple times.
    forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (forall a. Last a -> Maybe a
getLast Last Int
rescreenDelay) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
threadDelay)
    Bool
moreConfigureEvents <- Window -> EventType -> X Bool
clearTypedWindowEvents (Event -> Window
ev_window Event
e) EventType
configureNotify
    Bool
_ <- Window -> EventType -> X Bool
clearTypedWindowRREvents (Event -> Window
ev_window Event
e) EventType
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 Event -> EventType
ev_event_type Event
e forall a. Eq a => a -> a -> Bool
== EventType
configureNotify Bool -> Bool -> Bool
|| Bool
moreConfigureEvents
        then forall a. a -> Maybe a -> a
fromMaybe X ()
rescreen (forall a. Last a -> Maybe a
getLast Last (X ())
rescreenWorkspacesHook) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X ()
afterRescreenHook
        else X ()
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 = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ 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
        Bool
gotEvent <- Display -> Window -> EventType -> XEventPtr -> IO Bool
checkTypedWindowEvent Display
d Window
w EventType
t XEventPtr
e'
        Maybe Event
e <- if Bool
gotEvent then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XEventPtr -> IO Event
getEvent XEventPtr
e' else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Bool
gotEvent forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ if
            | Bool -> Bool
not Bool
gotEvent -> forall a. Monoid a => a
mempty
            | (Event -> Window
ev_window forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Event
e) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Window
w -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Display -> XEventPtr -> IO Bool
go Display
d XEventPtr
e'
            -- checkTypedWindowEvent checks ev_event instead of ev_window, so
            -- we may need to put some events back
            | Bool
otherwise -> forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent (Display -> XEventPtr -> IO Bool
go Display
d) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> XEventPtr -> IO ()
putBackEvent Display
d XEventPtr
e')

clearTypedWindowRREvents :: Window -> EventType -> X Bool
clearTypedWindowRREvents :: Window -> EventType -> X Bool
clearTypedWindowRREvents Window
w EventType
t =
    X (Maybe EventType)
rrEventBase 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 forall a. Num a => a -> a -> a
+ EventType
t)
        Maybe EventType
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

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