This commit is contained in:
Leon Kowarschick 2020-06-13 14:30:57 +02:00
parent 3494c7c18a
commit de8881498a
2 changed files with 26 additions and 30 deletions

View file

@ -12,32 +12,26 @@ import Data.Semigroup ( All(..) )
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.List ( isInfixOf ) import Data.List ( isInfixOf )
import Control.Monad ( when ) import Control.Monad ( when )
import Control.Concurrent ( threadDelay )
swallowEventHook :: [Query Bool] -> [Query Bool] -> Event -> X All swallowEventHook :: [Query Bool] -> [Query Bool] -> Event -> X All
swallowEventHook parentQueries childQueries event = do swallowEventHook parentQueries childQueries event = do
case event of case event of
ConfigureEvent{} -> do ConfigureEvent{} -> withWindowSet $ \ws -> do
withWindowSet XS.modify . setStackBeforeWindowClosing . currentStack $ ws
( XS.modify XS.modify . setFloatingBeforeWindowClosing . W.floating $ ws
. setStackBeforeWindowClosing
. W.stack DestroyWindowEvent { ev_event = eventId, ev_window = childWindow } ->
. W.workspace
. W.current
)
withWindowSet (XS.modify . setFloatingBeforeWindowClosing . W.floating)
(DestroyWindowEvent _ _ _ _ eventId childWindow) ->
when (eventId == childWindow) $ do when (eventId == childWindow) $ do
maybeSwallowedParent <- XS.gets (getSwallowedParent childWindow) maybeSwallowedParent <- XS.gets (getSwallowedParent childWindow)
maybeOldStack <- XS.gets stackBeforeWindowClosing maybeOldStack <- XS.gets stackBeforeWindowClosing
oldFloating <- XS.gets floatingBeforeClosing oldFloating <- XS.gets floatingBeforeClosing
case (maybeSwallowedParent, maybeOldStack) of case (maybeSwallowedParent, maybeOldStack) of
(Just parent, Just oldStack) -> do (Just parent, Just oldStack) -> do
--liftIO $ threadDelay 100000
windows windows
(\ws -> (\ws ->
updateStack (const $ Just $ oldStack { W.focus = parent }) updateCurrentStack
(const $ Just $ oldStack { W.focus = parent })
$ onWorkspace "NSP" (W.delete' parent) $ onWorkspace "NSP" (W.delete' parent)
$ copyFloatingState childWindow parent $ copyFloatingState childWindow parent
$ ws { W.floating = oldFloating } $ ws { W.floating = oldFloating }
@ -48,8 +42,8 @@ swallowEventHook parentQueries childQueries event = do
_ -> return () _ -> return ()
return () return ()
(MapRequestEvent _ _ _ _ _ childWindow) -> withFocused $ \parentWindow -> MapRequestEvent { ev_window = childWindow } ->
do withFocused $ \parentWindow -> do
parentMatches <- mapM (`runQuery` parentWindow) parentQueries parentMatches <- mapM (`runQuery` parentWindow) parentQueries
childMatches <- mapM (`runQuery` childWindow) childQueries childMatches <- mapM (`runQuery` childWindow) childQueries
when (or parentMatches && or childMatches) $ do when (or parentMatches && or childMatches) $ do
@ -61,7 +55,7 @@ swallowEventHook parentQueries childQueries event = do
when isChild $ do when isChild $ do
-- TODO use https://hackage.haskell.org/package/xmonad-contrib-0.16/docs/XMonad-Layout-Hidden.html -- TODO use https://hackage.haskell.org/package/xmonad-contrib-0.16/docs/XMonad-Layout-Hidden.html
windows windows
( updateStack (fmap (\x -> x { W.focus = childWindow })) (updateCurrentStack (fmap (\x -> x { W.focus = childWindow }))
. onWorkspace "NSP" (W.insertUp parentWindow) . onWorkspace "NSP" (W.insertUp parentWindow)
. copyFloatingState parentWindow childWindow . copyFloatingState parentWindow childWindow
) )
@ -70,20 +64,22 @@ swallowEventHook parentQueries childQueries event = do
return () return ()
_ -> return () _ -> return ()
return $ All True return $ All True
where
updateStack f ws = ws
{ W.current = (W.current ws)
{ W.workspace = (W.workspace $ W.current ws)
{ W.stack = f
. W.stack
. W.workspace
. W.current
$ ws
}
}
}
updateCurrentStack
:: (Maybe (W.Stack a) -> Maybe (W.Stack a))
-> W.StackSet i l a sid sd
-> W.StackSet i l a sid sd
updateCurrentStack f ws = ws
{ W.current = (W.current ws)
{ W.workspace = currentWsp { W.stack = f $ currentStack ws }
}
}
where currentWsp = W.workspace $ W.current ws
currentStack :: W.StackSet i l a sid sd -> Maybe (W.Stack a)
currentStack = W.stack . W.workspace . W.current
copyFloatingState copyFloatingState
:: Ord a => a -> a -> W.StackSet i l a s sd -> W.StackSet i l a s sd :: Ord a => a -> a -> W.StackSet i l a s sd -> W.StackSet i l a s sd
copyFloatingState from to ws = ws copyFloatingState from to ws = ws
@ -100,7 +96,7 @@ onWorkspace
onWorkspace n f s = W.view (W.currentTag s) . f . W.view n $ s onWorkspace n f s = W.view (W.currentTag s) . f . W.view n $ s
-- | check if a given process is a child of another process. -- | 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. -- NOTE: this does not work if the child process does any kind of process-sharing.
isChildOf isChildOf
:: Int -- ^ child PID :: Int -- ^ child PID
@ -145,5 +141,5 @@ instance ExtensionClass SwallowingState where
} }
fi :: (Integral a, Num b) => a -> b
fi = fromIntegral fi = fromIntegral