{-# 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