{-# LANGUAGE NamedFieldPuns #-}
module XMonad.Hooks.WindowSwallowing
(
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 )
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 =
(Window -> X ()) -> X ()
withFocused forall a b. (a -> b) -> a -> b
$ \Window
parentWindow -> do
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
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
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 ()
swallowEventHookSub
:: Query Bool
-> Query Bool
-> Event
-> 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 ()
swallowEventHook
:: Query Bool
-> Query Bool
-> Event
-> 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
(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)
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
DestroyWindowEvent { ev_event :: Event -> Window
ev_event = Window
eventId, ev_window :: Event -> Window
ev_window = Window
childWindow } ->
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
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
(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
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 })
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
moveFloatingState
:: Ord a
=> a
-> a
-> 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))
}
isChildOf
:: ProcessID
-> ProcessID
-> 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
, SwallowingState -> Maybe (Stack Window)
stackBeforeWindowClosing :: Maybe (W.Stack Window)
, SwallowingState -> Map Window RationalRect
floatingBeforeClosing :: M.Map Window W.RationalRect
} 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
}