    {-# LANGUAGE LambdaCase #-}
    -- |
    -- Module      :  XMonad.Hooks.FloatConfigureReq
    -- Description :  Customize handling of floating windows' move\/resize\/restack requests (ConfigureRequest).
    -- Copyright   :  (c) 2024 Tomáš Janoušek <tomi@nomi.cz>
    -- License     :  BSD3
    -- Maintainer  :  Tomáš Janoušek <tomi@nomi.cz>
    --
    -- xmonad normally honours those requests by doing exactly what the client
    -- application asked, and refreshing. There are some misbehaving clients,
    -- however, that:
    --
    -- * try to move their window to the last known absolute position regardless
    --   of the current xrandr/xinerama layout
    --
    -- * move their window to 0, 0 for no particular reason (e.g. rxvt-unicode)
    --
    -- * issue lots of no-op requests causing flickering (e.g. Steam)
    --
    -- This module provides a replacement handler for 'ConfigureRequestEvent' to
    -- work around such misbehaviours.
    --
    module XMonad.Hooks.FloatConfigureReq (
        -- * Usage
        -- $usage
        MaybeMaybeManageHook,
        floatConfReqHook,

        -- * Known workarounds
        fixSteamFlicker,
        fixSteamFlickerMMMH,
        ) where

    import qualified Data.Map.Strict as M
    import XMonad
    import XMonad.Hooks.ManageHelpers
    import XMonad.Prelude
    import qualified XMonad.StackSet as W

    -- $usage
    -- To use this, include the following in your @xmonad.hs@:
    --
    -- > import XMonad.Hooks.FloatConfigureReq
    -- > import XMonad.Hooks.ManageHelpers
    --
    -- > myFloatConfReqHook :: MaybeMaybeManageHook
    -- > myFloatConfReqHook = composeAll
    -- >     [ … ]
    --
    -- > myEventHook :: Event -> X All
    -- > myEventHook = mconcat
    -- >     [ …
    -- >     , floatConfReqHook myFloatConfReqHook
    -- >     , … ]
    --
    -- > main = xmonad $ …
    -- >               $ def{ handleEventHook = myEventHook
    -- >                    , … }
    --
    -- Then fill the @myFloatConfReqHook@ with whatever custom rules you need.
    --
    -- As an example, the following will prevent rxvt-unicode from moving its
    -- (floating) window to 0, 0 after a font change but still ensure its size
    -- increment hints are respected:
    --
    -- > className =? "URxvt" -?> pure <$> doFloat
    --
    -- Another example that avoids flickering and xmonad slowdowns caused by the
    -- Steam client (completely ignore all its requests, none of which are
    -- meaningful in the context of a tiling WM):
    --
    -- > map toLower `fmap` className =? "steam" -?> mempty
    --
    -- (this example is also available as 'fixSteamFlickerMMMH' to be added to
    -- one's @myFloatConfReqHook@ and also 'fixSteamFlicker' to be added directly
    -- to one's 'handleEventHook')

    -- | A variant of 'MaybeManageHook' that additionally may or may not make
    -- changes to the 'WindowSet'.
    type MaybeMaybeManageHook = Query (Maybe (Maybe (Endo WindowSet)))

    -- | Customizable handler for a 'ConfigureRequestEvent'. If the event's
    -- 'ev_window' is a managed floating window, the provided
    -- 'MaybeMaybeManageHook' is consulted and its result interpreted as follows:
    --
    --  * @Nothing@ - no match, fall back to the default handler
    --
    --  * @Just Nothing@ - match but ignore, no refresh, just send ConfigureNotify
    --
    --  * @Just (Just a)@ - match, modify 'WindowSet', refresh, send ConfigureNotify
    floatConfReqHook :: MaybeMaybeManageHook -> Event -> X All
    floatConfReqHook :: MaybeMaybeManageHook -> Event -> X All
    floatConfReqHook MaybeMaybeManageHook
    mh ConfigureRequestEvent{ev_window :: Event -> Window
    ev_window = Window
    w} =
        MaybeMaybeManageHook
    -> Window -> X (Maybe (Maybe (Endo WindowSet)))
    forall a. Query a -> Window -> X a
    runQuery (Maybe (Maybe (Maybe (Endo WindowSet)))
    -> Maybe (Maybe (Endo WindowSet))
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
    join (Maybe (Maybe (Maybe (Endo WindowSet)))
     -> Maybe (Maybe (Endo WindowSet)))
    -> Query (Maybe (Maybe (Maybe (Endo WindowSet))))
    -> MaybeMaybeManageHook
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Query Bool
    isFloatQ Query Bool
    -> MaybeMaybeManageHook
    -> Query (Maybe (Maybe (Maybe (Endo WindowSet))))
    forall (m :: * -> *) a.
    (Functor m, Monad m) =>
    m Bool -> m a -> m (Maybe a)
    -?> MaybeMaybeManageHook
    mh)) Window
    w X (Maybe (Maybe (Endo WindowSet)))
    -> (Maybe (Maybe (Endo WindowSet)) -> X All) -> X All
    forall a b. X a -> (a -> X b) -> X b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
            Maybe (Maybe (Endo WindowSet))
    Nothing -> X All
    forall a. Monoid a => a
    mempty
            Just Maybe (Endo WindowSet)
    e -> do
                Maybe (Endo WindowSet) -> (Endo WindowSet -> X ()) -> X ()
    forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
    whenJust Maybe (Endo WindowSet)
    e ((WindowSet -> WindowSet) -> X ()
    windows ((WindowSet -> WindowSet) -> X ())
    -> (Endo WindowSet -> WindowSet -> WindowSet)
    -> Endo WindowSet
    -> X ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Endo WindowSet -> WindowSet -> WindowSet
    forall a. Endo a -> a -> a
    appEndo)
                X ()
    sendConfEvent
                All -> X All
    forall a. a -> X a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Bool -> All
    All Bool
    False)
      where
        sendConfEvent :: X ()
    sendConfEvent = (Display -> X ()) -> X ()
    forall a. (Display -> X a) -> X a
    withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
    forall a b. (a -> b) -> a -> b
    $ \Display
    dpy ->
            Display -> Window -> (WindowAttributes -> X ()) -> X ()
    withWindowAttributes Display
    dpy Window
    w ((WindowAttributes -> X ()) -> X ())
    -> (WindowAttributes -> X ()) -> X ()
    forall a b. (a -> b) -> a -> b
    $ \WindowAttributes
    wa -> do
                IO () -> X ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    io (IO () -> X ())
    -> ((XEventPtr -> IO ()) -> IO ()) -> (XEventPtr -> IO ()) -> X ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (XEventPtr -> IO ()) -> IO ()
    forall a. (XEventPtr -> IO a) -> IO a
    allocaXEvent ((XEventPtr -> IO ()) -> X ()) -> (XEventPtr -> IO ()) -> X ()
    forall a b. (a -> b) -> a -> b
    $ \XEventPtr
    ev -> do
                    -- We may have made no changes to the window size/position
                    -- and thus the X server didn't emit any ConfigureNotify,
                    -- so we need to send the ConfigureNotify ourselves to make
                    -- sure there is a reply to this ConfigureRequestEvent and the
                    -- window knows we (possibly) ignored its request.
                    XEventPtr -> EventType -> IO ()
    setEventType XEventPtr
    ev EventType
    configureNotify
                    XEventPtr
    -> Window
    -> Window
    -> CInt
    -> CInt
    -> CInt
    -> CInt
    -> CInt
    -> Window
    -> Bool
    -> IO ()
    setConfigureEvent XEventPtr
    ev Window
    w Window
    w
                        (WindowAttributes -> CInt
    wa_x WindowAttributes
    wa) (WindowAttributes -> CInt
    wa_y WindowAttributes
    wa) (WindowAttributes -> CInt
    wa_width WindowAttributes
    wa)
                        (WindowAttributes -> CInt
    wa_height WindowAttributes
    wa) (WindowAttributes -> CInt
    wa_border_width WindowAttributes
    wa) Window
    none (WindowAttributes -> Bool
    wa_override_redirect WindowAttributes
    wa)
                    Display -> Window -> Bool -> Window -> XEventPtr -> IO ()
    sendEvent Display
    dpy Window
    w Bool
    False Window
    0 XEventPtr
    ev
    floatConfReqHook MaybeMaybeManageHook
    _ Event
    _ = X All
    forall a. Monoid a => a
    mempty

    -- | A 'Query' to determine if a window is floating.
    isFloatQ :: Query Bool
    isFloatQ :: Query Bool
    isFloatQ = Query Window
    forall r (m :: * -> *). MonadReader r m => m r
    ask Query Window -> (Window -> Query Bool) -> Query Bool
    forall a b. Query a -> (a -> Query b) -> Query b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Window
    w -> X Bool -> Query Bool
    forall a. X a -> Query a
    liftX (X Bool -> Query Bool)
    -> ((XState -> Bool) -> X Bool) -> (XState -> Bool) -> Query Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (XState -> Bool) -> X Bool
    forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
    gets ((XState -> Bool) -> Query Bool) -> (XState -> Bool) -> Query Bool
    forall a b. (a -> b) -> a -> b
    $ Window -> Map Window RationalRect -> Bool
    forall k a. Ord k => k -> Map k a -> Bool
    M.member Window
    w (Map Window RationalRect -> Bool)
    -> (XState -> Map Window RationalRect) -> XState -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . WindowSet -> Map Window RationalRect
    forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect
    W.floating (WindowSet -> Map Window RationalRect)
    -> (XState -> WindowSet) -> XState -> Map Window RationalRect
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XState -> WindowSet
    windowset

    -- | A pre-packaged 'floatConfReqHook' that fixes flickering of the Steam client by ignoring 'ConfigureRequestEvent's on any of its floating windows.
    --
    -- To use this, add 'fixSteamFlicker' to your 'handleEventHook'.
    fixSteamFlicker :: Event -> X All
    fixSteamFlicker :: Event -> X All
    fixSteamFlicker = MaybeMaybeManageHook -> Event -> X All
    floatConfReqHook MaybeMaybeManageHook
    fixSteamFlickerMMMH

    fixSteamFlickerMMMH :: MaybeMaybeManageHook
    fixSteamFlickerMMMH :: MaybeMaybeManageHook
    fixSteamFlickerMMMH = (Char -> Char) -> [Char] -> [Char]
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Char
    toLower ([Char] -> [Char]) -> Query [Char] -> Query [Char]
    forall a b. (a -> b) -> Query a -> Query b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` Query [Char]
    className Query [Char] -> [Char] -> Query Bool
    forall a. Eq a => Query a -> a -> Query Bool
    =? [Char]
    "steam" Query Bool
    -> Query (Maybe (Endo WindowSet)) -> MaybeMaybeManageHook
    forall (m :: * -> *) a.
    (Functor m, Monad m) =>
    m Bool -> m a -> m (Maybe a)
    -?> Query (Maybe (Endo WindowSet))
    forall a. Monoid a => a
    mempty