xmonad-config/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs

225 lines
7.8 KiB
Haskell
Raw Normal View History

--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Automatically Manage Dynamic Workspaces
-- This is a somewhat convoluted wrapper for the Dymamic Workspaces module
-- in the contrib library. The general behavior this allows:
-- 1) launch app
-- 2) move app to its own dynamic workspace
-- 3) close app and remove dynamic workspace
--
-- The only sane way to do this is to monitor the lifetime of a PID on a dynamic
-- workspace (effectively tying each dynamic workspace to a single PID). Xmonad
-- is single threaded and thus cannot "wait" for PIDs to exit, so this spawns
-- a separate thread outside XMonad that will in turn spawn monitor threads
-- for each dynamic workspace. When these monitor threads detect that the app
-- has closed, they will send an event to X which can be caught by Xmonad so
-- the workspace can be removed.
--
-- What is the motivation? Some apps suck and don't play nice with others on
-- normal workspaces, so I would rather have them go in their own little
-- environment and misbehave.
--
-- Examples:
-- 1) Gimp (lots of trays and floating windows)
-- 2) Xsane (see Gimp)
-- 3) Virtualbox (should always be by itself anyways)
2020-04-01 20:17:47 -04:00
module XMonad.Internal.Concurrent.DynamicWorkspaces
2022-12-30 14:58:23 -05:00
( DynWorkspace (..)
, appendShift
, appendViewShift
, removeDynamicWorkspace
, runWorkspaceMon
, spawnOrSwitch
2020-03-28 23:15:41 -04:00
, doSink
2022-12-30 14:58:23 -05:00
)
where
-- import Control.Concurrent
2022-12-30 14:58:23 -05:00
import Control.Monad
import Control.Monad.Reader
import Data.List (deleteBy, find)
import qualified Data.Map as M
import Data.Maybe
import Graphics.X11.Types
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Extras
import Graphics.X11.Xlib.Misc
import Graphics.X11.Xlib.Types
import RIO hiding
( Display
, display
)
import qualified RIO.Set as S
import System.Process
import XMonad.Actions.DynamicWorkspaces
import XMonad.Core
( ManageHook
, WorkspaceId
, X
, io
, withWindowSet
)
import XMonad.Hooks.ManageHelpers (MaybeManageHook)
import XMonad.Internal.Concurrent.ClientMessage
import XMonad.Internal.IO
import XMonad.ManageHook
import XMonad.Operations
import qualified XMonad.StackSet as W
2020-04-01 20:17:47 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Dynamic Workspace datatype
-- This holds all the data needed to tie an app to a particular dynamic workspace
data DynWorkspace = DynWorkspace
2022-12-30 14:58:23 -05:00
{ dwName :: String
, dwTag :: WorkspaceId
, dwClass :: String
, dwHook :: [MaybeManageHook]
, dwKey :: Char
, dwCmd :: Maybe (X ())
-- TODO this should also have the layout for this workspace
}
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Manager thread
-- The main thread that watches for new windows. When a match is found, this
-- thread spawns a new thread the waits for the PID of the window to exit. When
-- the PID exits, it sends a ClientMessage event to X
2020-03-25 12:24:40 -04:00
-- TOOD it would be really nice if the manner we used to match windows was
-- the same as that in XMonad itself (eg with Query types)
-- type MatchTags = M.Map String String
data WConf = WConf
2022-12-30 14:58:23 -05:00
{ display :: Display
, dynWorkspaces :: [DynWorkspace]
, curPIDs :: MVar (S.Set Pid)
}
2022-12-28 16:22:09 -05:00
type W a = RIO WConf ()
withOpenDisplay :: (Display -> IO a) -> IO a
withOpenDisplay = bracket (openDisplay "") closeDisplay
runWorkspaceMon :: [DynWorkspace] -> IO ()
2022-12-28 20:11:06 -05:00
runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
2020-03-25 12:24:40 -04:00
root <- rootWindow dpy $ defaultScreen dpy
-- listen only for substructure change events (which includes MapNotify)
allocaSetWindowAttributes $ \a -> do
set_event_mask a substructureNotifyMask
changeWindowAttributes dpy root cWEventMask a
2022-12-28 16:22:09 -05:00
void $ allocaXEvent $ withEvents dpy
where
withEvents dpy e = do
ps <- newMVar S.empty
2022-12-30 14:58:23 -05:00
let c = WConf {display = dpy, dynWorkspaces = dws, curPIDs = ps}
runRIO c $
forever $
handleEvent =<< io (nextEvent dpy e >> getEvent e)
2020-03-25 12:24:40 -04:00
2022-12-28 16:22:09 -05:00
handleEvent :: Event -> W ()
2020-03-25 12:24:40 -04:00
-- | assume this fires at least once when a new window is created (also could
-- use CreateNotify but that is really noisy)
2022-12-30 14:58:23 -05:00
handleEvent MapNotifyEvent {ev_window = w} = do
dpy <- asks display
hint <- io $ getClassHint dpy w
dws <- asks dynWorkspaces
2022-12-30 14:58:23 -05:00
let tag =
M.lookup (resClass hint) $
M.fromList $
fmap (\DynWorkspace {dwTag = t, dwClass = c} -> (c, t)) dws
2022-12-28 16:22:09 -05:00
forM_ tag $ \t -> do
a <- io $ internAtom dpy "_NET_WM_PID" False
pid <- io $ getWindowProperty32 dpy a w
case pid of
-- ASSUMPTION windows will only have one PID at one time
2022-12-28 16:22:09 -05:00
Just [p] -> let p' = fromIntegral p in void $ async $ withUniquePid p' t
2022-12-30 14:58:23 -05:00
_ -> return ()
2022-12-28 16:22:09 -05:00
handleEvent _ = return ()
2022-12-28 16:22:09 -05:00
withUniquePid :: Pid -> String -> W ()
withUniquePid pid tag = do
ps <- asks curPIDs
pids <- readMVar ps
2022-12-30 14:58:23 -05:00
io
$ unless (pid `elem` pids)
$ bracket_
(modifyMVar_ ps (return . S.insert pid))
(modifyMVar_ ps (return . S.delete pid))
2022-12-28 16:22:09 -05:00
$ waitUntilExit pid >> sendXMsg Workspace tag
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Launching apps
-- When launching apps on dymamic workspaces, first check if they are running
-- and launch if not, then switch to their workspace
wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
2022-12-30 14:58:23 -05:00
wsOccupied tag ws =
elem tag $
map W.tag $
filter (isJust . W.stack)
-- list of all workspaces with windows on them
-- TODO is there not a better way to do this?
$
W.workspace (W.current ws) : W.hidden ws ++ map W.workspace (W.visible ws)
spawnOrSwitch :: WorkspaceId -> X () -> X ()
spawnOrSwitch tag cmd = do
occupied <- withWindowSet $ return . wsOccupied tag
if occupied then windows $ W.view tag else cmd
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Managehook
-- Move windows to new workspace if they are part of a dynamic workspace
-- shamelessly ripped off from appendWorkspace (this analogue doesn't exist)
appendHiddenWorkspace :: String -> X ()
appendHiddenWorkspace = addHiddenWorkspaceAt (flip (++) . return)
2020-04-01 22:06:00 -04:00
viewShift :: WorkspaceId -> ManageHook
viewShift = doF . liftM2 (.) W.view W.shift
-- NOTE: need to appendHidden because the regular append function will shift
-- to the new workspace, which I don't want for this one
appendShift :: String -> ManageHook
appendShift tag = liftX (appendHiddenWorkspace tag) >> doF (W.shift tag)
2020-04-01 22:06:00 -04:00
appendViewShift :: String -> ManageHook
appendViewShift tag = liftX (appendWorkspace tag) >> viewShift tag
2020-04-01 22:06:00 -04:00
-- TODO surprisingly this doesn't exist? We shouldn't need to TBH
2020-03-28 23:15:41 -04:00
doSink :: ManageHook
doSink = doF $ \s -> case W.stack $ W.workspace $ W.current s of
2022-12-30 14:58:23 -05:00
Just s' -> W.sink (W.focus s') s
Nothing -> s
2020-03-28 23:15:41 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Eventhook
-- When an app is closed, this will respond the event that is sent in the main
-- XMonad thread
removeDynamicWorkspace :: WorkspaceId -> X ()
removeDynamicWorkspace target = windows removeIfEmpty
where
-- remove workspace if it is empty and if there are hidden workspaces
2022-12-30 14:58:23 -05:00
removeIfEmpty s@W.StackSet {W.visible = vis, W.hidden = hall@(h : hs)}
-- if hidden, delete from hidden
2022-12-30 14:58:23 -05:00
| Just x <- find isEmptyTarget hall =
s {W.hidden = deleteBy (eq W.tag) x hall}
-- if visible, delete from visible and move first hidden to its place
2022-12-30 14:58:23 -05:00
| Just x <- find (isEmptyTarget . W.workspace) vis =
s
{ W.visible = x {W.workspace = h} : deleteBy (eq W.screen) x vis
, W.hidden = hs
}
-- if current, move the first hidden workspace to the current
2022-12-30 14:58:23 -05:00
| isEmptyTarget $ W.workspace $ W.current s =
s {W.current = (W.current s) {W.workspace = h}, W.hidden = hs}
-- otherwise do nothing
| otherwise = s
removeIfEmpty s = s
isEmptyTarget ws = isNothing (W.stack ws) && W.tag ws == target
eq f x y = f x == f y