{-# LANGUAGE NamedFieldPuns #-} ----------------------------------------------------------------------------- -- | -- Module : XMonad.Hooks.WindowSwallowing -- Description : Temporarily hide parent windows when opening other programs. -- Copyright : (c) 2020 Leon Kowarschick -- License : BSD3-style (see LICENSE) -- -- Maintainer : Leon Kowarschick. <thereal.elkowar@gmail.com> -- Stability : unstable -- Portability : unportable -- -- Provides a handleEventHook that implements window swallowing. -- -- If you open a GUI-window (i.e. feh) from the terminal, -- the terminal will normally still be shown on screen, unnecessarily -- taking up space on the screen. -- With window swallowing, can detect that you opened a window from within another -- window, and allows you "swallow" that parent window for the time the new -- window is running. -- -- __NOTE__ that this does not always work perfectly: -- -- - Because window swallowing needs to check the process hierarchy, it requires -- both the child and the parent to be distinct processes. This means that -- applications which implement instance sharing cannot be supported by window swallowing. -- Most notably, this excludes some terminal emulators as well as tmux -- from functioning as the parent process. It also excludes a good amount of -- child programs, because many graphical applications do implement instance sharing. -- For example, window swallowing will probably not work with your browser. -- -- - To check the process hierarchy, we need to be able to get the process ID -- by looking at the window. This requires the @_NET_WM_PID@ X-property to be set. -- If any application you want to use this with does not provide the @_NET_WM_PID@, -- there is not much you can do except for reaching out to the author of that -- application and asking them to set that property. Additionally, -- applications running in their own PID namespace, such as those in -- Flatpak, can't set a correct @_NET_WM_PID@ even if they wanted to. ----------------------------------------------------------------------------- module XMonad.Hooks.WindowSwallowing ( -- * Usage -- $usage swallowEventHook, swallowEventHookSub ) where import XMonad import XMonad.Prelude import qualified XMonad.StackSet as W import XMonad.Layout.SubLayouts import qualified XMonad.Util.ExtensibleState as XS import XMonad.Util.WindowProperties import XMonad.Util.Process ( getPPIDChain ) import qualified Data.Map.Strict as M import System.Posix.Types ( ProcessID ) -- $usage -- You can use this module by including the following in your @xmonad.hs@: -- -- > import XMonad.Hooks.WindowSwallowing -- -- and using 'swallowEventHook' somewhere in your 'handleEventHook', for example: -- -- > myHandleEventHook = swallowEventHook (className =? "Alacritty" <||> className =? "Termite") (return True) -- -- The variant 'swallowEventHookSub' can be used if a layout from "XMonad.Layout.SubLayouts" is used; -- instead of swallowing the window it will merge the child window with the parent. (this does not work with floating windows) -- -- For more information on editing your handleEventHook and key bindings, -- see <https://xmonad.org/TUTORIAL.html the tutorial> and "XMonad.Doc.Extending". -- | Run @action@ iff both parent- and child queries match and the child -- is a child by PID. -- -- A 'MapRequestEvent' is called right before a window gets opened. We -- intercept that call to possibly open the window ourselves, swapping -- out it's parent processes window for the new window in the stack. handleMapRequestEvent :: Query Bool -> Query Bool -> Window -> (Window -> X ()) -> X () handleMapRequestEvent :: Query Bool -> Query Bool -> Window -> (Window -> X ()) -> X () handleMapRequestEvent Query Bool parentQ Query Bool childQ Window childWindow Window -> X () action = -- For a window to be opened from within another window, that other window -- must be focused. Thus the parent window that would be swallowed has to be -- the currently focused window. (Window -> X ()) -> X () withFocused forall a b. (a -> b) -> a -> b $ \Window parentWindow -> do -- First verify that both windows match the given queries Bool parentMatches <- forall a. Query a -> Window -> X a runQuery Query Bool parentQ Window parentWindow Bool childMatches <- forall a. Query a -> Window -> X a runQuery Query Bool childQ Window childWindow forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Bool parentMatches Bool -> Bool -> Bool && Bool childMatches) forall a b. (a -> b) -> a -> b $ do -- read the windows _NET_WM_PID properties Maybe [CLong] childWindowPid <- String -> Window -> X (Maybe [CLong]) getProp32s String "_NET_WM_PID" Window childWindow Maybe [CLong] parentWindowPid <- String -> Window -> X (Maybe [CLong]) getProp32s String "_NET_WM_PID" Window parentWindow case (Maybe [CLong] parentWindowPid, Maybe [CLong] childWindowPid) of (Just (CLong parentPid : [CLong] _), Just (CLong childPid : [CLong] _)) -> do -- check if the new window is a child process of the last focused window -- using the process ids. Bool isChild <- forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ forall a b. (Integral a, Num b) => a -> b fi CLong childPid ProcessID -> ProcessID -> IO Bool `isChildOf` forall a b. (Integral a, Num b) => a -> b fi CLong parentPid forall (f :: * -> *). Applicative f => Bool -> f () -> f () when Bool isChild forall a b. (a -> b) -> a -> b $ do Window -> X () action Window parentWindow (Maybe [CLong], Maybe [CLong]) _ -> forall (m :: * -> *) a. Monad m => a -> m a return () forall (m :: * -> *) a. Monad m => a -> m a return () -- | handleEventHook that will merge child windows via -- "XMonad.Layout.SubLayouts" when they are opened from another window. swallowEventHookSub :: Query Bool -- ^ query the parent window has to match for window swallowing to occur. -- Set this to @return True@ to run swallowing for every parent. -> Query Bool -- ^ query the child window has to match for window swallowing to occur. -- Set this to @return True@ to run swallowing for every child -> Event -- ^ The event to handle. -> X All swallowEventHookSub :: Query Bool -> Query Bool -> Event -> X All swallowEventHookSub Query Bool parentQ Query Bool childQ Event event = Bool -> All All Bool True forall (f :: * -> *) a b. Functor f => a -> f b -> f a <$ case Event event of MapRequestEvent{ev_window :: Event -> Window ev_window=Window childWindow} -> Query Bool -> Query Bool -> Window -> (Window -> X ()) -> X () handleMapRequestEvent Query Bool parentQ Query Bool childQ Window childWindow forall a b. (a -> b) -> a -> b $ \Window parentWindow -> do Window -> X () manage Window childWindow forall a. Message a => a -> X () sendMessage (forall a. a -> a -> GroupMsg a Merge Window parentWindow Window childWindow) Event _ -> forall (f :: * -> *) a. Applicative f => a -> f a pure () -- | handleEventHook that will swallow child windows when they are -- opened from another window. swallowEventHook :: Query Bool -- ^ query the parent window has to match for window swallowing to occur. -- Set this to @return True@ to run swallowing for every parent. -> Query Bool -- ^ query the child window has to match for window swallowing to occur. -- Set this to @return True@ to run swallowing for every child -> Event -- ^ The event to handle. -> X All swallowEventHook :: Query Bool -> Query Bool -> Event -> X All swallowEventHook Query Bool parentQ Query Bool childQ Event event = do case Event event of MapRequestEvent{ev_window :: Event -> Window ev_window=Window childWindow} -> Query Bool -> Query Bool -> Window -> (Window -> X ()) -> X () handleMapRequestEvent Query Bool parentQ Query Bool childQ Window childWindow forall a b. (a -> b) -> a -> b $ \Window parentWindow -> do -- We set the newly opened window as the focused window, replacing the parent window. -- If the parent window was floating, we transfer that data to the child, -- such that it shows up at the same position, with the same dimensions. (WindowSet -> WindowSet) -> X () windows ( forall a i l s sd. (Stack a -> Stack a) -> StackSet i l a s sd -> StackSet i l a s sd W.modify' (\Stack Window x -> Stack Window x { focus :: Window W.focus = Window childWindow }) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a i l s sd. Ord a => a -> a -> StackSet i l a s sd -> StackSet i l a s sd moveFloatingState Window parentWindow Window childWindow ) forall a (m :: * -> *). (ExtensionClass a, XLike m) => (a -> a) -> m () XS.modify (Window -> Window -> SwallowingState -> SwallowingState addSwallowedParent Window parentWindow Window childWindow) -- This is called in many circumstances, most notably for us: -- right before a window gets closed. We store the current -- state of the window stack here, such that we know where the -- child window was on the screen when restoring the swallowed parent process. ConfigureEvent{} -> forall a. (WindowSet -> X a) -> X a withWindowSet forall a b. (a -> b) -> a -> b $ \WindowSet ws -> do forall a (m :: * -> *). (ExtensionClass a, XLike m) => (a -> a) -> m () XS.modify forall b c a. (b -> c) -> (a -> b) -> a -> c . Maybe (Stack Window) -> SwallowingState -> SwallowingState setStackBeforeWindowClosing forall b c a. (b -> c) -> (a -> b) -> a -> c . forall i l a sid sd. StackSet i l a sid sd -> Maybe (Stack a) currentStack forall a b. (a -> b) -> a -> b $ WindowSet ws forall a (m :: * -> *). (ExtensionClass a, XLike m) => (a -> a) -> m () XS.modify forall b c a. (b -> c) -> (a -> b) -> a -> c . Map Window RationalRect -> SwallowingState -> SwallowingState setFloatingBeforeWindowClosing forall b c a. (b -> c) -> (a -> b) -> a -> c . forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect W.floating forall a b. (a -> b) -> a -> b $ WindowSet ws -- This is called right after any window closes. DestroyWindowEvent { ev_event :: Event -> Window ev_event = Window eventId, ev_window :: Event -> Window ev_window = Window childWindow } -> -- Because DestroyWindowEvent is emitted a lot more often then you think, -- this check verifies that the event is /actually/ about closing a window. forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Window eventId forall a. Eq a => a -> a -> Bool == Window childWindow) forall a b. (a -> b) -> a -> b $ do -- we get some data from the extensible state, most notably we ask for -- the \"parent\" window of the now closed window. Maybe Window maybeSwallowedParent <- forall a (m :: * -> *) b. (ExtensionClass a, XLike m) => (a -> b) -> m b XS.gets (Window -> SwallowingState -> Maybe Window getSwallowedParent Window childWindow) Maybe (Stack Window) maybeOldStack <- forall a (m :: * -> *) b. (ExtensionClass a, XLike m) => (a -> b) -> m b XS.gets SwallowingState -> Maybe (Stack Window) stackBeforeWindowClosing Map Window RationalRect oldFloating <- forall a (m :: * -> *) b. (ExtensionClass a, XLike m) => (a -> b) -> m b XS.gets SwallowingState -> Map Window RationalRect floatingBeforeClosing case (Maybe Window maybeSwallowedParent, Maybe (Stack Window) maybeOldStack) of -- If there actually is a corresponding swallowed parent window for this window, -- we will try to restore it. -- Because there are some cases where the stack-state is not stored correctly in the ConfigureEvent hook, -- we have to first check if the stack-state is valid. -- If it is, we can restore the parent exactly where the child window was before being closed. -- If the stored stack-state is invalid however, we still restore the window -- by just inserting it as the focused window in the stack. -- -- After restoring, we remove the information about the swallowing from the state. (Just Window parent, Maybe (Stack Window) Nothing) -> do (WindowSet -> WindowSet) -> X () windows (forall a i l sid sd. a -> StackSet i l a sid sd -> StackSet i l a sid sd insertIntoStack Window parent) Window -> X () deleteState Window childWindow (Just Window parent, Just Stack Window oldStack) -> do Bool stackStoredCorrectly <- do Maybe (Stack Window) curStack <- forall a. (WindowSet -> X a) -> X a withWindowSet (forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . forall i l a sid sd. StackSet i l a sid sd -> Maybe (Stack a) currentStack) let oldLen :: Int oldLen = forall (t :: * -> *) a. Foldable t => t a -> Int length (forall a. Stack a -> [a] W.integrate Stack Window oldStack) let curLen :: Int curLen = forall (t :: * -> *) a. Foldable t => t a -> Int length (forall a. Maybe (Stack a) -> [a] W.integrate' Maybe (Stack Window) curStack) forall (m :: * -> *) a. Monad m => a -> m a return (Int oldLen forall a. Num a => a -> a -> a - Int 1 forall a. Eq a => a -> a -> Bool == Int curLen Bool -> Bool -> Bool && Window childWindow forall a. Eq a => a -> a -> Bool == forall a. Stack a -> a W.focus Stack Window oldStack) if Bool stackStoredCorrectly then (WindowSet -> WindowSet) -> X () windows (\WindowSet ws -> forall a i l sid sd. (Maybe (Stack a) -> Maybe (Stack a)) -> StackSet i l a sid sd -> StackSet i l a sid sd updateCurrentStack (forall a b. a -> b -> a const forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ Stack Window oldStack { focus :: Window W.focus = Window parent }) forall a b. (a -> b) -> a -> b $ forall a i l s sd. Ord a => a -> a -> StackSet i l a s sd -> StackSet i l a s sd moveFloatingState Window childWindow Window parent forall a b. (a -> b) -> a -> b $ WindowSet ws { floating :: Map Window RationalRect W.floating = Map Window RationalRect oldFloating } ) else (WindowSet -> WindowSet) -> X () windows (forall a i l sid sd. a -> StackSet i l a sid sd -> StackSet i l a sid sd insertIntoStack Window parent) Window -> X () deleteState Window childWindow (Maybe Window, Maybe (Stack Window)) _ -> forall (m :: * -> *) a. Monad m => a -> m a return () Event _ -> forall (m :: * -> *) a. Monad m => a -> m a return () forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Bool -> All All Bool True where deleteState :: Window -> X () deleteState :: Window -> X () deleteState Window childWindow = do forall a (m :: * -> *). (ExtensionClass a, XLike m) => (a -> a) -> m () XS.modify forall a b. (a -> b) -> a -> b $ Window -> SwallowingState -> SwallowingState removeSwallowed Window childWindow forall a (m :: * -> *). (ExtensionClass a, XLike m) => (a -> a) -> m () XS.modify forall a b. (a -> b) -> a -> b $ Maybe (Stack Window) -> SwallowingState -> SwallowingState setStackBeforeWindowClosing forall a. Maybe a Nothing -- | insert a window as focused into the current stack, moving the previously focused window down the stack insertIntoStack :: a -> W.StackSet i l a sid sd -> W.StackSet i l a sid sd insertIntoStack :: forall a i l sid sd. a -> StackSet i l a sid sd -> StackSet i l a sid sd insertIntoStack a win = forall a i l s sd. Maybe (Stack a) -> (Stack a -> Maybe (Stack a)) -> StackSet i l a s sd -> StackSet i l a s sd W.modify (forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ forall a. a -> [a] -> [a] -> Stack a W.Stack a win [] []) (\Stack a s -> forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ Stack a s { focus :: a W.focus = a win, down :: [a] W.down = forall a. Stack a -> a W.focus Stack a s forall a. a -> [a] -> [a] : forall a. Stack a -> [a] W.down Stack a s }) -- | run a pure transformation on the Stack of the currently focused workspace. updateCurrentStack :: (Maybe (W.Stack a) -> Maybe (W.Stack a)) -> W.StackSet i l a sid sd -> W.StackSet i l a sid sd updateCurrentStack :: forall a i l sid sd. (Maybe (Stack a) -> Maybe (Stack a)) -> StackSet i l a sid sd -> StackSet i l a sid sd updateCurrentStack Maybe (Stack a) -> Maybe (Stack a) f = forall a i l s sd. Maybe (Stack a) -> (Stack a -> Maybe (Stack a)) -> StackSet i l a s sd -> StackSet i l a s sd W.modify (Maybe (Stack a) -> Maybe (Stack a) f forall a. Maybe a Nothing) (Maybe (Stack a) -> Maybe (Stack a) f forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. a -> Maybe a Just) currentStack :: W.StackSet i l a sid sd -> Maybe (W.Stack a) currentStack :: forall i l a sid sd. StackSet i l a sid sd -> Maybe (Stack a) currentStack = forall i l a. Workspace i l a -> Maybe (Stack a) W.stack forall b c a. (b -> c) -> (a -> b) -> a -> c . forall i l a sid sd. Screen i l a sid sd -> Workspace i l a W.workspace forall b c a. (b -> c) -> (a -> b) -> a -> c . forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd W.current -- | move the floating state from one window to another, sinking the original window moveFloatingState :: Ord a => a -- ^ window to move from -> a -- ^ window to move to -> W.StackSet i l a s sd -> W.StackSet i l a s sd moveFloatingState :: forall a i l s sd. Ord a => a -> a -> StackSet i l a s sd -> StackSet i l a s sd moveFloatingState a from a to StackSet i l a s sd ws = StackSet i l a s sd ws { floating :: Map a RationalRect W.floating = forall k a. Ord k => k -> Map k a -> Map k a M.delete a from forall a b. (a -> b) -> a -> b $ forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall k a. Ord k => k -> Map k a -> Map k a M.delete a to (forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect W.floating StackSet i l a s sd ws)) (\RationalRect r -> forall k a. Ord k => k -> a -> Map k a -> Map k a M.insert a to RationalRect r (forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect W.floating StackSet i l a s sd ws)) (forall k a. Ord k => k -> Map k a -> Maybe a M.lookup a from (forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect W.floating StackSet i l a s sd ws)) } -- | check if a given process is a child of another process. This depends on "pstree" being in the PATH -- NOTE: this does not work if the child process does any kind of process-sharing. isChildOf :: ProcessID -- ^ child PID -> ProcessID -- ^ parent PID -> IO Bool isChildOf :: ProcessID -> ProcessID -> IO Bool isChildOf ProcessID child ProcessID parent = (ProcessID parent forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem`) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ProcessID -> IO [ProcessID] getPPIDChain ProcessID child data SwallowingState = SwallowingState { SwallowingState -> Map Window Window currentlySwallowed :: M.Map Window Window -- ^ mapping from child window window to the currently swallowed parent window , SwallowingState -> Maybe (Stack Window) stackBeforeWindowClosing :: Maybe (W.Stack Window) -- ^ current stack state right before DestroyWindowEvent is sent , SwallowingState -> Map Window RationalRect floatingBeforeClosing :: M.Map Window W.RationalRect -- ^ floating map of the stackset right before DestroyWindowEvent is sent } deriving (Int -> SwallowingState -> ShowS [SwallowingState] -> ShowS SwallowingState -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [SwallowingState] -> ShowS $cshowList :: [SwallowingState] -> ShowS show :: SwallowingState -> String $cshow :: SwallowingState -> String showsPrec :: Int -> SwallowingState -> ShowS $cshowsPrec :: Int -> SwallowingState -> ShowS Show) getSwallowedParent :: Window -> SwallowingState -> Maybe Window getSwallowedParent :: Window -> SwallowingState -> Maybe Window getSwallowedParent Window win SwallowingState { Map Window Window currentlySwallowed :: Map Window Window currentlySwallowed :: SwallowingState -> Map Window Window currentlySwallowed } = forall k a. Ord k => k -> Map k a -> Maybe a M.lookup Window win Map Window Window currentlySwallowed addSwallowedParent :: Window -> Window -> SwallowingState -> SwallowingState addSwallowedParent :: Window -> Window -> SwallowingState -> SwallowingState addSwallowedParent Window parent Window child s :: SwallowingState s@SwallowingState { Map Window Window currentlySwallowed :: Map Window Window currentlySwallowed :: SwallowingState -> Map Window Window currentlySwallowed } = SwallowingState s { currentlySwallowed :: Map Window Window currentlySwallowed = forall k a. Ord k => k -> a -> Map k a -> Map k a M.insert Window child Window parent Map Window Window currentlySwallowed } removeSwallowed :: Window -> SwallowingState -> SwallowingState removeSwallowed :: Window -> SwallowingState -> SwallowingState removeSwallowed Window child s :: SwallowingState s@SwallowingState { Map Window Window currentlySwallowed :: Map Window Window currentlySwallowed :: SwallowingState -> Map Window Window currentlySwallowed } = SwallowingState s { currentlySwallowed :: Map Window Window currentlySwallowed = forall k a. Ord k => k -> Map k a -> Map k a M.delete Window child Map Window Window currentlySwallowed } setStackBeforeWindowClosing :: Maybe (W.Stack Window) -> SwallowingState -> SwallowingState setStackBeforeWindowClosing :: Maybe (Stack Window) -> SwallowingState -> SwallowingState setStackBeforeWindowClosing Maybe (Stack Window) stack SwallowingState s = SwallowingState s { stackBeforeWindowClosing :: Maybe (Stack Window) stackBeforeWindowClosing = Maybe (Stack Window) stack } setFloatingBeforeWindowClosing :: M.Map Window W.RationalRect -> SwallowingState -> SwallowingState setFloatingBeforeWindowClosing :: Map Window RationalRect -> SwallowingState -> SwallowingState setFloatingBeforeWindowClosing Map Window RationalRect x SwallowingState s = SwallowingState s { floatingBeforeClosing :: Map Window RationalRect floatingBeforeClosing = Map Window RationalRect x } instance ExtensionClass SwallowingState where initialValue :: SwallowingState initialValue = SwallowingState { currentlySwallowed :: Map Window Window currentlySwallowed = forall a. Monoid a => a mempty , stackBeforeWindowClosing :: Maybe (Stack Window) stackBeforeWindowClosing = forall a. Maybe a Nothing , floatingBeforeClosing :: Map Window RationalRect floatingBeforeClosing = forall a. Monoid a => a mempty }