    {-# 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,
        RescreenConfig(..),
        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
    -- ('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\/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
        }

    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
            }

    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 :: 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)
     -> 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 :: 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 :: X ()
    afterRescreenHook = () -> X () -> X ()
    forall a. a -> X a -> X a
    userCodeDef () X ()
    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 :: X ()
    randrChangeHook = () -> X () -> X ()
    forall a. a -> X a -> X a
    userCodeDef () 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 a. a -> X a
    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 a b. a -> X b -> X a
    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 ()
    afterRescreenHook :: RescreenConfig -> X ()
    randrChangeHook :: RescreenConfig -> X ()
    afterRescreenHook :: X ()
    randrChangeHook :: 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 a b. X a -> X b -> X b
    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 a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Maybe Event
    forall a. Maybe a
    Nothing
            Bool
    gotEvent Bool -> IO () -> IO Bool
    forall a b. a -> IO b -> IO a
    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 a b. IO a -> IO b -> IO b
    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 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)