REF move dynamic workspace code to workspace mon module

This commit is contained in:
Nathan Dwarshuis 2020-03-28 17:29:43 -04:00
parent 68d83d859f
commit 9ff68d97e9
2 changed files with 188 additions and 103 deletions

View File

@ -18,13 +18,7 @@ import WorkspaceMon
import Control.Arrow (first) import Control.Arrow (first)
import Control.Concurrent import Control.Concurrent
import Control.Monad import Control.Monad (forM_, mapM_, void, when)
( forM_
, liftM2
, mapM_
, void
, when
)
import Data.List (isPrefixOf, sortBy, sortOn) import Data.List (isPrefixOf, sortBy, sortOn)
import qualified Data.Map.Lazy as M import qualified Data.Map.Lazy as M
@ -35,7 +29,6 @@ import Graphics.X11.Types
import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Extras
import System.Directory import System.Directory
import System.Exit import System.Exit
import System.IO import System.IO
@ -48,7 +41,6 @@ import Xmobar.Common
import XMonad import XMonad
import XMonad.Actions.CopyWindow import XMonad.Actions.CopyWindow
import XMonad.Actions.CycleWS import XMonad.Actions.CycleWS
import XMonad.Actions.DynamicWorkspaces
import XMonad.Actions.PhysicalScreens import XMonad.Actions.PhysicalScreens
import XMonad.Actions.Volume import XMonad.Actions.Volume
import XMonad.Actions.Warp import XMonad.Actions.Warp
@ -66,13 +58,12 @@ import qualified XMonad.StackSet as W
import XMonad.Util.EZConfig import XMonad.Util.EZConfig
import XMonad.Util.NamedActions import XMonad.Util.NamedActions
main :: IO () main :: IO ()
main = do main = do
cl <- startXMonadService cl <- startXMonadService
(p, h) <- spawnPipe' "xmobar" (p, h) <- spawnPipe' "xmobar"
_ <- forkIO runPowermon _ <- forkIO runPowermon
_ <- forkIO $ runWorkspaceMon matchPatterns _ <- forkIO $ runWorkspaceMon allDWs
let ts = ThreadState let ts = ThreadState
{ client = cl { client = cl
, childPIDs = [p] , childPIDs = [p]
@ -95,27 +86,75 @@ main = do
, focusedBorderColor = T.selectedBordersColor , focusedBorderColor = T.selectedBordersColor
} }
myStartupHook :: X () -- Data structure to hold the dbus client, threadIDs, and process IDs started
myStartupHook = docksStartupHook <+> startupHook def -- outside the main Xmonad thread. Maybe I could use a ReaderT here but I'm lazy
data ThreadState = ThreadState data ThreadState = ThreadState
{ client :: Client { client :: Client
, childPIDs :: [Pid] , childPIDs :: [Pid]
, childHandles :: [Handle] , childHandles :: [Handle]
} }
matchPatterns :: M.Map String String -- | Startuphook configuration
matchPatterns = fromList
[ (myGimpClass, myGimpWorkspace)
, (myVMClass, myVMWorkspace)
, (myXSaneClass, myXSaneWorkspace)
]
myWorkspaces :: [String] myStartupHook :: X ()
myStartupHook = docksStartupHook <+> startupHook def
-- | Workspace configuration
myWorkspaces :: [WorkspaceId]
myWorkspaces = map show [1..10 :: Int] myWorkspaces = map show [1..10 :: Int]
myLayouts = onWorkspace myVMWorkspace vmLayout gimpDynamicWorkspace :: DynWorkspace
$ onWorkspace myGimpWorkspace gimpLayout gimpDynamicWorkspace = DynWorkspace
{ dwName = "Gimp"
, dwTag = t
, dwClass = c
, dwHook =
[ matchGimpRole "gimp-image-window" -?> appendViewShift t
, matchGimpRole "gimp-dock" -?> doF (toBottom . W.focusMaster)
, matchGimpRole "gimp-toolbox" -?> doF (toBottom . W.focusMaster)
, className =? c -?> appendViewShift t
]
, dwCmd = Just ("g", spawnCmd "gimp-2.10" [])
}
where
matchGimpRole role = isPrefixOf role <$> stringProperty "WM_WINDOW_ROLE"
<&&> className =? c
toBottom = W.modify' $ \(W.Stack f tp bt) -> W.Stack f (reverse bt ++ tp) []
t = "GIMP"
c = "Gimp-2.10" -- TODO I don't feel like changing the version long term
wmDynamicWorkspace :: DynWorkspace
wmDynamicWorkspace = DynWorkspace
{ dwName = "Windows VirtualBox"
, dwTag = t
, dwClass = c
, dwHook = [ className =? c -?> appendViewShift t ]
, dwCmd = Just ("v", spawnCmd "vbox-start" ["win8raw"])
}
where
t = "VM"
c = "VirtualBoxVM"
xsaneDynamicWorkspace :: DynWorkspace
xsaneDynamicWorkspace = DynWorkspace
{ dwName = "XSane"
, dwTag = t
, dwClass = c
, dwHook = [ className =? c -?> appendViewShift t >> doFloat ]
, dwCmd = Just ("x", spawnCmd "xsane" [])
}
where
t = "XSANE"
c = "Xsane"
allDWs :: [DynWorkspace]
allDWs = [xsaneDynamicWorkspace, wmDynamicWorkspace, gimpDynamicWorkspace]
-- | Layout configuration
myLayouts = onWorkspace (dwTag wmDynamicWorkspace) vmLayout
$ onWorkspace (dwTag gimpDynamicWorkspace) gimpLayout
$ tall ||| single ||| full $ tall ||| single ||| full
where where
addTopBar = noFrillsDeco shrinkText T.tabbedTheme addTopBar = noFrillsDeco shrinkText T.tabbedTheme
@ -138,7 +177,7 @@ myLayouts = onWorkspace myVMWorkspace vmLayout
$ addTopBar $ addTopBar
$ Tall 1 0.025 0.8 $ Tall 1 0.025 0.8
-- | Format workspace and layout in loghook -- | Loghook configuration
-- The format will be like "[<1> 2 3] 4 5 | LAYOUT" where each digit -- The format will be like "[<1> 2 3] 4 5 | LAYOUT" where each digit
-- is the workspace and LAYOUT is the current layout. Each workspace -- is the workspace and LAYOUT is the current layout. Each workspace
-- in the brackets is currently visible and the order reflects the -- in the brackets is currently visible and the order reflects the
@ -177,35 +216,14 @@ myWindowSetXinerama ws = wsString ++ sep ++ layout
(_, Rectangle x0 _ _ _) = getScreenIdAndRectangle s0 (_, Rectangle x0 _ _ _) = getScreenIdAndRectangle s0
(_, Rectangle x1 _ _ _) = getScreenIdAndRectangle s1 (_, Rectangle x1 _ _ _) = getScreenIdAndRectangle s1
viewShift = doF . liftM2 (.) W.view W.shift -- | Managehook configuration
appendViewShift tag = liftX (appendWorkspace tag) >> viewShift tag
($?) :: Query a -> (a -> Bool) -> Query Bool
($?) q f = f <$> q
matchGimpRole :: String -> Query Bool
matchGimpRole role = stringProperty "WM_WINDOW_ROLE" $? isPrefixOf role
<&&> className =? myGimpClass
moveBottom :: W.StackSet i l a s sd -> W.StackSet i l a s sd
moveBottom = W.modify' $ \(W.Stack f t b) -> W.Stack f (reverse b ++ t) []
myManageHook :: ManageHook myManageHook :: ManageHook
myManageHook = manageApps <+> manageDocks <+> manageHook def myManageHook = manageApps <+> manageDocks <+> manageHook def
manageApps :: ManageHook manageApps :: ManageHook
manageApps = composeOne manageApps = composeOne $ concatMap dwHook allDWs ++
[ isDialog -?> doCenterFloat [ isDialog -?> doCenterFloat
-- VM window
, className =? myVMClass -?> appendViewShift myVMWorkspace
-- GIMP
, matchGimpRole "gimp-image-window" -?> appendViewShift myGimpWorkspace
, matchGimpRole "gimp-dock" -?> doF (moveBottom . W.focusMaster)
, matchGimpRole "gimp-toolbox" -?> doF (moveBottom . W.focusMaster)
, className =? myGimpClass -?> appendViewShift myGimpWorkspace
-- XSane
, className =? myXSaneClass -?> appendViewShift myXSaneWorkspace >> doFloat
-- the seafile applet -- the seafile applet
, className =? "Seafile Client" -?> doFloat , className =? "Seafile Client" -?> doFloat
-- gnucash -- gnucash
@ -221,6 +239,8 @@ manageApps = composeOne
, (className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat , (className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat
] ]
-- | Eventhook configuration
myEventHook :: Event -> X All myEventHook :: Event -> X All
myEventHook = monitorEventHook <+> docksEventHook <+> handleEventHook def myEventHook = monitorEventHook <+> docksEventHook <+> handleEventHook def
@ -229,7 +249,7 @@ monitorEventHook ClientMessageEvent { ev_message_type = t, ev_data = d }
| t == bITMAP = do | t == bITMAP = do
let (xtype, tag) = splitXMsg d let (xtype, tag) = splitXMsg d
case xtype of case xtype of
Workspace -> removeEmptyWorkspaceByTag tag Workspace -> removeDynamicWorkspace tag
ACPI -> do ACPI -> do
let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent
forM_ acpiTag $ \case forM_ acpiTag $ \case
@ -432,46 +452,7 @@ runMaxBacklight = io $ void callMaxBrightness
runToggleDPMS :: X () runToggleDPMS :: X ()
runToggleDPMS = io $ void callToggle runToggleDPMS = io $ void callToggle
-- keybindings -- | Keymap configuration
myVMWorkspace :: String
myVMWorkspace = "VM"
myVMClass :: String
myVMClass = "VirtualBoxVM"
myGimpWorkspace :: String
myGimpWorkspace = "GIMP"
-- TODO I don't feel like changing the version long term
myGimpClass :: String
myGimpClass = "Gimp-2.10"
myXSaneWorkspace :: String
myXSaneWorkspace = "XSANE"
myXSaneClass :: String
myXSaneClass = "Xsane"
wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
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
runVBox :: X ()
runVBox = spawnOrSwitch myVMWorkspace $ spawnCmd "vbox-start" ["win8raw"]
runGimp :: X ()
runGimp = spawnOrSwitch myGimpWorkspace $ spawnCmd "gimp-2.10" []
runXSane :: X ()
runXSane = spawnOrSwitch myXSaneWorkspace $ spawnCmd "xsane" []
myModMask :: KeyMask myModMask :: KeyMask
myModMask = mod4Mask myModMask = mod4Mask
@ -513,6 +494,11 @@ mkKeys ts c =
, ("M-M1-h", "move down workspace", moveTo Prev HiddenNonEmptyWS) , ("M-M1-h", "move down workspace", moveTo Prev HiddenNonEmptyWS)
]) ++ ]) ++
mkNamedSubmap "Dynamic Workspaces"
[ ("M-C-" ++ k, "launch/switch to " ++ n, spawnOrSwitch t a)
| DynWorkspace { dwTag = t, dwCmd = Just (k, a), dwName = n } <- allDWs
] ++
mkNamedSubmap "Screens" mkNamedSubmap "Screens"
[ ("M-l", "move up screen", nextScreen) [ ("M-l", "move up screen", nextScreen)
, ("M-h", "move down screen", prevScreen) , ("M-h", "move down screen", prevScreen)
@ -543,9 +529,6 @@ mkKeys ts c =
, ("M-C-t", "launch terminal", runTerm) , ("M-C-t", "launch terminal", runTerm)
, ("M-C-q", "launch calc", runCalc) , ("M-C-q", "launch calc", runCalc)
, ("M-C-f", "launch file manager", runFileManager) , ("M-C-f", "launch file manager", runFileManager)
, ("M-C-v", "launch windows VM", runVBox)
, ("M-C-g", "launch GIMP", runGimp)
, ("M-C-x", "launch XSane", runXSane)
] ++ ] ++
mkNamedSubmap "Multimedia" mkNamedSubmap "Multimedia"

View File

@ -1,11 +1,45 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
module WorkspaceMon (M.fromList, runWorkspaceMon) where --------------------------------------------------------------------------------
-- | 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)
module WorkspaceMon
( DynWorkspace(..)
, appendViewShift
, removeDynamicWorkspace
, runWorkspaceMon
, spawnOrSwitch
)
where
import Process import Process
import SendXMsg import SendXMsg
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe
import Data.Semigroup
import Control.Concurrent import Control.Concurrent
import Control.Monad import Control.Monad
@ -22,15 +56,47 @@ import Graphics.X11.Xlib.Types
import System.Process (Pid) import System.Process (Pid)
import XMonad.Actions.DynamicWorkspaces
import XMonad.Core
( Query
, ScreenId
, WorkspaceId
, X
, withWindowSet
)
import XMonad.Hooks.ManageHelpers (MaybeManageHook)
import XMonad.ManageHook
import XMonad.Operations
import qualified XMonad.StackSet as W
--------------------------------------------------------------------------------
-- | Dynamic Workspace datatype
-- This hold all the data needed to tie an app to a particular dynamic workspace
data DynWorkspace = DynWorkspace
{ dwName :: String
, dwTag :: WorkspaceId
, dwClass :: String
, dwHook :: [MaybeManageHook]
, dwCmd :: Maybe (String, X ())
-- TODO this should also have the layout for this workspace
}
--------------------------------------------------------------------------------
-- | 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
-- TOOD it would be really nice if the manner we used to match windows was -- 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) -- the same as that in XMonad itself (eg with Query types)
type MatchTags = M.Map String String -- type MatchTags = M.Map String String
type WatchedPIDs = MVar [Pid] type WatchedPIDs = MVar [Pid]
data WConf = WConf data WConf = WConf
{ display :: Display { display :: Display
, matchTags :: MatchTags , dynWorkspaces :: [DynWorkspace]
} }
newtype W a = W (ReaderT WConf IO a) newtype W a = W (ReaderT WConf IO a)
@ -46,8 +112,8 @@ runW c (W a) = runReaderT a c
io :: MonadIO m => IO a -> m a io :: MonadIO m => IO a -> m a
io = liftIO io = liftIO
runWorkspaceMon :: MatchTags -> IO () runWorkspaceMon :: [DynWorkspace] -> IO ()
runWorkspaceMon mts = do runWorkspaceMon dws = do
dpy <- openDisplay "" dpy <- openDisplay ""
root <- rootWindow dpy $ defaultScreen dpy root <- rootWindow dpy $ defaultScreen dpy
curPIDs <- newMVar [] -- TODO this is ugly, use a mutable state monad curPIDs <- newMVar [] -- TODO this is ugly, use a mutable state monad
@ -55,7 +121,7 @@ runWorkspaceMon mts = do
allocaSetWindowAttributes $ \a -> do allocaSetWindowAttributes $ \a -> do
set_event_mask a substructureNotifyMask set_event_mask a substructureNotifyMask
changeWindowAttributes dpy root cWEventMask a changeWindowAttributes dpy root cWEventMask a
let c = WConf { display = dpy, matchTags = mts } let c = WConf { display = dpy, dynWorkspaces = dws }
_ <- allocaXEvent $ \e -> _ <- allocaXEvent $ \e ->
runW c $ forever $ handle curPIDs =<< io (nextEvent dpy e >> getEvent e) runW c $ forever $ handle curPIDs =<< io (nextEvent dpy e >> getEvent e)
return () return ()
@ -67,8 +133,9 @@ handle :: WatchedPIDs -> Event -> W ()
handle curPIDs MapNotifyEvent { ev_window = w } = do handle curPIDs MapNotifyEvent { ev_window = w } = do
dpy <- asks display dpy <- asks display
hint <- io $ getClassHint dpy w hint <- io $ getClassHint dpy w
mts <- asks matchTags dws <- asks dynWorkspaces
let tag = M.lookup (resClass hint) mts let m = M.fromList $ fmap (\DynWorkspace { dwTag = t, dwClass = c } -> (c, t)) dws
let tag = M.lookup (resClass hint) m
io $ forM_ tag $ \t -> do io $ forM_ tag $ \t -> do
a <- internAtom dpy "_NET_WM_PID" False a <- internAtom dpy "_NET_WM_PID" False
pid <- getWindowProperty32 dpy a w pid <- getWindowProperty32 dpy a w
@ -83,7 +150,6 @@ handle _ _ = return ()
waitAndKill :: String -> Pid -> IO () waitAndKill :: String -> Pid -> IO ()
waitAndKill tag pid = waitUntilExit pid >> sendXMsg Workspace tag waitAndKill tag pid = waitUntilExit pid >> sendXMsg Workspace tag
withUniquePid :: WatchedPIDs -> Pid -> IO () -> IO () withUniquePid :: WatchedPIDs -> Pid -> IO () -> IO ()
withUniquePid curPIDs pid f = do withUniquePid curPIDs pid f = do
pids <- readMVar curPIDs pids <- readMVar curPIDs
@ -91,3 +157,39 @@ withUniquePid curPIDs pid f = do
modifyMVar_ curPIDs (return . (pid:)) modifyMVar_ curPIDs (return . (pid:))
f f
modifyMVar_ curPIDs (return . filter (/=pid)) modifyMVar_ curPIDs (return . filter (/=pid))
--------------------------------------------------------------------------------
-- | 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
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
--------------------------------------------------------------------------------
-- | Managehook
-- Move windows to new workspace if they are part of a dynamic workspace
viewShift
:: WorkspaceId -> Query (Endo (W.StackSet WorkspaceId l Window ScreenId sd))
viewShift = doF . liftM2 (.) W.view W.shift
appendViewShift
:: String -> Query (Endo (W.StackSet WorkspaceId l Window ScreenId sd))
appendViewShift tag = liftX (appendWorkspace tag) >> viewShift tag
--------------------------------------------------------------------------------
-- | Eventhook
-- When an app is closed, this will respond the event that is sent in the main
-- XMonad thread
removeDynamicWorkspace :: WorkspaceId -> X ()
removeDynamicWorkspace = removeEmptyWorkspaceByTag