{-# 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
    RescreenConfig(..),
    addAfterRescreenHook,
    addRandrChangeHook,
    rescreenHook,
    ) where

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, 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 '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
    }

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

instance Semigroup RescreenConfig where
    RescreenConfig X ()
arh X ()
rch <> :: RescreenConfig -> RescreenConfig -> RescreenConfig
<> RescreenConfig X ()
arh' X ()
rch' = X () -> X () -> 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')

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.
--
-- 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 l -> XConfig l
rescreenHook :: 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)
 -> RescreenConfig -> XConfig l -> XConfig l)
-> (XConfig l -> XConfig l)
-> RescreenConfig
-> XConfig l
-> XConfig l
forall a b. (a -> b) -> a -> b
$ \XConfig l
c -> XConfig l
c
    { startupHook :: X ()
startupHook = XConfig l -> X ()
forall (l :: * -> *). XConfig l -> X ()
startupHook XConfig l
c X () -> X () -> X ()
forall a. Semigroup a => a -> a -> a
<> X ()
rescreenStartupHook
    , handleEventHook :: Event -> X All
handleEventHook = XConfig l -> Event -> X All
forall (l :: * -> *). XConfig l -> Event -> X All
handleEventHook XConfig l
c (Event -> X All) -> (Event -> X All) -> Event -> X All
forall a. Semigroup a => a -> a -> a
<> Event -> X All
rescreenEventHook }

-- | Shortcut for 'rescreenHook'.
addAfterRescreenHook :: X () -> XConfig l -> XConfig l
addAfterRescreenHook :: 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 :: X ()
afterRescreenHook = X ()
h }

-- | Shortcut for 'rescreenHook'.
addRandrChangeHook :: X () -> XConfig l -> XConfig l
addRandrChangeHook :: 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 :: X ()
randrChangeHook = X ()
h }

-- | Startup hook to listen for @RRScreenChangeNotify@ events.
rescreenStartupHook :: X ()
rescreenStartupHook :: X ()
rescreenStartupHook = do
    Display
dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
    Window
root <- (XConf -> Window) -> X Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
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
_ -> Bool -> X Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    if Bool
shouldHandle
        then Bool -> All
All Bool
False All -> X () -> X All
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event -> X ()
handleEvent Event
e
        else X All
forall a. Monoid a => a
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{X ()
randrChangeHook :: X ()
afterRescreenHook :: X ()
randrChangeHook :: RescreenConfig -> X ()
afterRescreenHook :: RescreenConfig -> X ()
..} -> do
    -- Xorg emits several events after every change, clear them to prevent
    -- triggering the hook multiple times.
    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 EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
configureNotify Bool -> Bool -> Bool
|| Bool
moreConfigureEvents
        then X ()
rescreen X () -> X () -> X ()
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 = (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
        Bool
gotEvent <- Display -> Window -> EventType -> XEventPtr -> IO Bool
checkTypedWindowEvent Display
d Window
w EventType
t XEventPtr
e'
        Maybe Event
e <- if Bool
gotEvent then Event -> Maybe Event
forall a. a -> Maybe a
Just (Event -> Maybe Event) -> IO Event -> IO (Maybe Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XEventPtr -> IO Event
getEvent XEventPtr
e' else Maybe Event -> IO (Maybe Event)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Event
forall a. Maybe a
Nothing
        Bool
gotEvent Bool -> IO () -> IO Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ if
            | Bool -> Bool
not Bool
gotEvent -> IO ()
forall a. Monoid a => a
mempty
            | (Event -> Window
ev_window (Event -> Window) -> Maybe Event -> Maybe Window
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Event
e) Maybe Window -> Maybe Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window -> Maybe Window
forall a. a -> Maybe a
Just Window
w -> IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
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 -> (XEventPtr -> IO Bool) -> IO Bool
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent (Display -> XEventPtr -> IO Bool
go Display
d) IO Bool -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> IO ()
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 X (Maybe EventType) -> (Maybe EventType -> X Bool) -> X Bool
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 (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 (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)