{-# 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 ((Window -> X ()) -> X ()) -> (Window -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Window
parentWindow -> do
    -- First verify that both windows match the given queries
    Bool
parentMatches <- Query Bool -> Window -> X Bool
forall a. Query a -> Window -> X a
runQuery Query Bool
parentQ Window
parentWindow
    Bool
childMatches  <- Query Bool -> Window -> X Bool
forall a. Query a -> Window -> X a
runQuery Query Bool
childQ Window
childWindow
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
parentMatches Bool -> Bool -> Bool
&& Bool
childMatches) (X () -> X ()) -> X () -> X ()
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 <- IO Bool -> X Bool
forall a. IO a -> X a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> X Bool) -> IO Bool -> X Bool
forall a b. (a -> b) -> a -> b
$ CLong -> ProcessID
forall a b. (Integral a, Num b) => a -> b
fi CLong
childPid ProcessID -> ProcessID -> IO Bool
`isChildOf` CLong -> ProcessID
forall a b. (Integral a, Num b) => a -> b
fi CLong
parentPid
          Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isChild (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
            Window -> X ()
action Window
parentWindow
        (Maybe [CLong], Maybe [CLong])
_ -> () -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      () -> X ()
forall a. a -> X a
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 All -> X () -> X All
forall a b. a -> X b -> X a
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 ((Window -> X ()) -> X ()) -> (Window -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Window
parentWindow -> do
        Window -> X ()
manage Window
childWindow
        GroupMsg Window -> X ()
forall a. Message a => a -> X ()
sendMessage (Window -> Window -> GroupMsg Window
forall a. a -> a -> GroupMsg a
Merge Window
parentWindow Window
childWindow)
    Event
_ -> () -> X ()
forall a. a -> X a
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 ((Window -> X ()) -> X ()) -> (Window -> X ()) -> X ()
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
          ( (Stack Window -> Stack Window) -> WindowSet -> WindowSet
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 { W.focus = childWindow })
          (WindowSet -> WindowSet)
-> (WindowSet -> WindowSet) -> WindowSet -> WindowSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> Window -> WindowSet -> WindowSet
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
          )
        (SwallowingState -> SwallowingState) -> X ()
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{} -> (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
ws -> do
      (SwallowingState -> SwallowingState) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((SwallowingState -> SwallowingState) -> X ())
-> (WindowSet -> SwallowingState -> SwallowingState)
-> WindowSet
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Stack Window) -> SwallowingState -> SwallowingState
setStackBeforeWindowClosing (Maybe (Stack Window) -> SwallowingState -> SwallowingState)
-> (WindowSet -> Maybe (Stack Window))
-> WindowSet
-> SwallowingState
-> SwallowingState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet -> Maybe (Stack Window)
forall i l a sid sd. StackSet i l a sid sd -> Maybe (Stack a)
currentStack (WindowSet -> X ()) -> WindowSet -> X ()
forall a b. (a -> b) -> a -> b
$ WindowSet
ws
      (SwallowingState -> SwallowingState) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((SwallowingState -> SwallowingState) -> X ())
-> (WindowSet -> SwallowingState -> SwallowingState)
-> WindowSet
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Window RationalRect -> SwallowingState -> SwallowingState
setFloatingBeforeWindowClosing (Map Window RationalRect -> SwallowingState -> SwallowingState)
-> (WindowSet -> Map Window RationalRect)
-> WindowSet
-> SwallowingState
-> SwallowingState
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 -> X ()) -> WindowSet -> X ()
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.
      Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Window
eventId Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
childWindow) (X () -> X ()) -> X () -> X ()
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 <- (SwallowingState -> Maybe Window) -> X (Maybe Window)
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        <- (SwallowingState -> Maybe (Stack Window))
-> X (Maybe (Stack Window))
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets SwallowingState -> Maybe (Stack Window)
stackBeforeWindowClosing
        Map Window RationalRect
oldFloating          <- (SwallowingState -> Map Window RationalRect)
-> X (Map Window RationalRect)
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 (Window -> WindowSet -> WindowSet
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 <- (WindowSet -> X (Maybe (Stack Window))) -> X (Maybe (Stack Window))
forall a. (WindowSet -> X a) -> X a
withWindowSet (Maybe (Stack Window) -> X (Maybe (Stack Window))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Stack Window) -> X (Maybe (Stack Window)))
-> (WindowSet -> Maybe (Stack Window))
-> WindowSet
-> X (Maybe (Stack Window))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet -> Maybe (Stack Window)
forall i l a sid sd. StackSet i l a sid sd -> Maybe (Stack a)
currentStack)
              let oldLen :: Int
oldLen = [Window] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Stack Window -> [Window]
forall a. Stack a -> [a]
W.integrate Stack Window
oldStack)
              let curLen :: Int
curLen = [Window] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Maybe (Stack Window) -> [Window]
forall a. Maybe (Stack a) -> [a]
W.integrate' Maybe (Stack Window)
curStack)
              Bool -> X Bool
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
oldLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
curLen Bool -> Bool -> Bool
&& Window
childWindow Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Stack Window -> Window
forall a. Stack a -> a
W.focus Stack Window
oldStack)

            if Bool
stackStoredCorrectly
              then (WindowSet -> WindowSet) -> X ()
windows
                (\WindowSet
ws ->
                  (Maybe (Stack Window) -> Maybe (Stack Window))
-> WindowSet -> WindowSet
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 Window)
-> Maybe (Stack Window) -> Maybe (Stack Window)
forall a b. a -> b -> a
const (Maybe (Stack Window)
 -> Maybe (Stack Window) -> Maybe (Stack Window))
-> Maybe (Stack Window)
-> Maybe (Stack Window)
-> Maybe (Stack Window)
forall a b. (a -> b) -> a -> b
$ Stack Window -> Maybe (Stack Window)
forall a. a -> Maybe a
Just (Stack Window -> Maybe (Stack Window))
-> Stack Window -> Maybe (Stack Window)
forall a b. (a -> b) -> a -> b
$ Stack Window
oldStack { W.focus = parent })
                    (WindowSet -> WindowSet) -> WindowSet -> WindowSet
forall a b. (a -> b) -> a -> b
$ Window -> Window -> WindowSet -> WindowSet
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
                    (WindowSet -> WindowSet) -> WindowSet -> WindowSet
forall a b. (a -> b) -> a -> b
$ WindowSet
ws { W.floating = oldFloating }
                )
              else (WindowSet -> WindowSet) -> X ()
windows (Window -> WindowSet -> WindowSet
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))
_ -> () -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Event
_ -> () -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  All -> X All
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (All -> X All) -> All -> X All
forall a b. (a -> b) -> a -> b
$ Bool -> All
All Bool
True
 where
  deleteState :: Window -> X ()
  deleteState :: Window -> X ()
deleteState Window
childWindow = do
    (SwallowingState -> SwallowingState) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((SwallowingState -> SwallowingState) -> X ())
-> (SwallowingState -> SwallowingState) -> X ()
forall a b. (a -> b) -> a -> b
$ Window -> SwallowingState -> SwallowingState
removeSwallowed Window
childWindow
    (SwallowingState -> SwallowingState) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((SwallowingState -> SwallowingState) -> X ())
-> (SwallowingState -> SwallowingState) -> X ()
forall a b. (a -> b) -> a -> b
$ Maybe (Stack Window) -> SwallowingState -> SwallowingState
setStackBeforeWindowClosing Maybe (Stack Window)
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 = Maybe (Stack a)
-> (Stack a -> Maybe (Stack a))
-> StackSet i l a sid sd
-> StackSet i l a sid sd
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
  (Stack a -> Maybe (Stack a)
forall a. a -> Maybe a
Just (Stack a -> Maybe (Stack a)) -> Stack a -> Maybe (Stack a)
forall a b. (a -> b) -> a -> b
$ a -> [a] -> [a] -> Stack a
forall a. a -> [a] -> [a] -> Stack a
W.Stack a
win [] [])
  (\Stack a
s -> Stack a -> Maybe (Stack a)
forall a. a -> Maybe a
Just (Stack a -> Maybe (Stack a)) -> Stack a -> Maybe (Stack a)
forall a b. (a -> b) -> a -> b
$ Stack a
s { W.focus = win, W.down = W.focus s : W.down 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 = Maybe (Stack a)
-> (Stack a -> Maybe (Stack a))
-> StackSet i l a sid sd
-> StackSet i l a sid sd
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 Maybe (Stack a)
forall a. Maybe a
Nothing) (Maybe (Stack a) -> Maybe (Stack a)
f (Maybe (Stack a) -> Maybe (Stack a))
-> (Stack a -> Maybe (Stack a)) -> Stack a -> Maybe (Stack a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack a -> Maybe (Stack a)
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 = Workspace i l a -> Maybe (Stack a)
forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack (Workspace i l a -> Maybe (Stack a))
-> (StackSet i l a sid sd -> Workspace i l a)
-> StackSet i l a sid sd
-> Maybe (Stack a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen i l a sid sd -> Workspace i l a
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen i l a sid sd -> Workspace i l a)
-> (StackSet i l a sid sd -> Screen i l a sid sd)
-> StackSet i l a sid sd
-> Workspace i l a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet i l a sid sd -> Screen i l a sid sd
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
  { W.floating = M.delete from $ maybe (M.delete to (W.floating ws))
                                       (\RationalRect
r -> a -> RationalRect -> Map a RationalRect -> Map a RationalRect
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert a
to RationalRect
r (StackSet i l a s sd -> Map a RationalRect
forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect
W.floating StackSet i l a s sd
ws))
                                       (M.lookup from (W.floating 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 ProcessID -> [ProcessID] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) ([ProcessID] -> Bool) -> IO [ProcessID] -> IO Bool
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
(Int -> SwallowingState -> ShowS)
-> (SwallowingState -> String)
-> ([SwallowingState] -> ShowS)
-> Show SwallowingState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SwallowingState -> ShowS
showsPrec :: Int -> SwallowingState -> ShowS
$cshow :: SwallowingState -> String
show :: SwallowingState -> String
$cshowList :: [SwallowingState] -> ShowS
showList :: [SwallowingState] -> ShowS
Show)

getSwallowedParent :: Window -> SwallowingState -> Maybe Window
getSwallowedParent :: Window -> SwallowingState -> Maybe Window
getSwallowedParent Window
win SwallowingState { Map Window Window
currentlySwallowed :: SwallowingState -> Map Window Window
currentlySwallowed :: Map Window Window
currentlySwallowed } =
  Window -> Map Window Window -> Maybe Window
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 :: SwallowingState -> Map Window Window
currentlySwallowed :: Map Window Window
currentlySwallowed } =
  SwallowingState
s { currentlySwallowed = M.insert child parent currentlySwallowed }

removeSwallowed :: Window -> SwallowingState -> SwallowingState
removeSwallowed :: Window -> SwallowingState -> SwallowingState
removeSwallowed Window
child s :: SwallowingState
s@SwallowingState { Map Window Window
currentlySwallowed :: SwallowingState -> Map Window Window
currentlySwallowed :: Map Window Window
currentlySwallowed } =
  SwallowingState
s { currentlySwallowed = M.delete child currentlySwallowed }

setStackBeforeWindowClosing
  :: Maybe (W.Stack Window) -> SwallowingState -> SwallowingState
setStackBeforeWindowClosing :: Maybe (Stack Window) -> SwallowingState -> SwallowingState
setStackBeforeWindowClosing Maybe (Stack Window)
stack SwallowingState
s = SwallowingState
s { stackBeforeWindowClosing = 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 = x }

instance ExtensionClass SwallowingState where
  initialValue :: SwallowingState
initialValue = SwallowingState { currentlySwallowed :: Map Window Window
currentlySwallowed       = Map Window Window
forall a. Monoid a => a
mempty
                                 , stackBeforeWindowClosing :: Maybe (Stack Window)
stackBeforeWindowClosing = Maybe (Stack Window)
forall a. Maybe a
Nothing
                                 , floatingBeforeClosing :: Map Window RationalRect
floatingBeforeClosing    = Map Window RationalRect
forall a. Monoid a => a
mempty
                                 }