From 9ff68d97e908af64c587803931568d4698026a24 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 28 Mar 2020 17:29:43 -0400 Subject: [PATCH] REF move dynamic workspace code to workspace mon module --- bin/xmonad.hs | 165 ++++++++++++++++++++------------------------ lib/WorkspaceMon.hs | 126 +++++++++++++++++++++++++++++---- 2 files changed, 188 insertions(+), 103 deletions(-) diff --git a/bin/xmonad.hs b/bin/xmonad.hs index d916f3f..41d29b8 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -18,13 +18,7 @@ import WorkspaceMon import Control.Arrow (first) import Control.Concurrent -import Control.Monad - ( forM_ - , liftM2 - , mapM_ - , void - , when - ) +import Control.Monad (forM_, mapM_, void, when) import Data.List (isPrefixOf, sortBy, sortOn) import qualified Data.Map.Lazy as M @@ -35,7 +29,6 @@ import Graphics.X11.Types import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Extras - import System.Directory import System.Exit import System.IO @@ -48,7 +41,6 @@ import Xmobar.Common import XMonad import XMonad.Actions.CopyWindow import XMonad.Actions.CycleWS -import XMonad.Actions.DynamicWorkspaces import XMonad.Actions.PhysicalScreens import XMonad.Actions.Volume import XMonad.Actions.Warp @@ -66,13 +58,12 @@ import qualified XMonad.StackSet as W import XMonad.Util.EZConfig import XMonad.Util.NamedActions - main :: IO () main = do cl <- startXMonadService (p, h) <- spawnPipe' "xmobar" _ <- forkIO runPowermon - _ <- forkIO $ runWorkspaceMon matchPatterns + _ <- forkIO $ runWorkspaceMon allDWs let ts = ThreadState { client = cl , childPIDs = [p] @@ -95,27 +86,75 @@ main = do , focusedBorderColor = T.selectedBordersColor } -myStartupHook :: X () -myStartupHook = docksStartupHook <+> startupHook def - +-- Data structure to hold the dbus client, threadIDs, and process IDs started +-- outside the main Xmonad thread. Maybe I could use a ReaderT here but I'm lazy data ThreadState = ThreadState { client :: Client , childPIDs :: [Pid] , childHandles :: [Handle] } -matchPatterns :: M.Map String String -matchPatterns = fromList - [ (myGimpClass, myGimpWorkspace) - , (myVMClass, myVMWorkspace) - , (myXSaneClass, myXSaneWorkspace) - ] +-- | Startuphook configuration -myWorkspaces :: [String] +myStartupHook :: X () +myStartupHook = docksStartupHook <+> startupHook def + +-- | Workspace configuration + +myWorkspaces :: [WorkspaceId] myWorkspaces = map show [1..10 :: Int] -myLayouts = onWorkspace myVMWorkspace vmLayout - $ onWorkspace myGimpWorkspace gimpLayout +gimpDynamicWorkspace :: DynWorkspace +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 where addTopBar = noFrillsDeco shrinkText T.tabbedTheme @@ -138,7 +177,7 @@ myLayouts = onWorkspace myVMWorkspace vmLayout $ addTopBar $ 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 -- is the workspace and LAYOUT is the current layout. Each workspace -- 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 x1 _ _ _) = getScreenIdAndRectangle s1 -viewShift = doF . liftM2 (.) W.view W.shift - -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) [] +-- | Managehook configuration myManageHook :: ManageHook myManageHook = manageApps <+> manageDocks <+> manageHook def manageApps :: ManageHook -manageApps = composeOne +manageApps = composeOne $ concatMap dwHook allDWs ++ [ 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 , className =? "Seafile Client" -?> doFloat -- gnucash @@ -221,6 +239,8 @@ manageApps = composeOne , (className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat ] +-- | Eventhook configuration + myEventHook :: Event -> X All myEventHook = monitorEventHook <+> docksEventHook <+> handleEventHook def @@ -229,7 +249,7 @@ monitorEventHook ClientMessageEvent { ev_message_type = t, ev_data = d } | t == bITMAP = do let (xtype, tag) = splitXMsg d case xtype of - Workspace -> removeEmptyWorkspaceByTag tag + Workspace -> removeDynamicWorkspace tag ACPI -> do let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent forM_ acpiTag $ \case @@ -432,46 +452,7 @@ runMaxBacklight = io $ void callMaxBrightness runToggleDPMS :: X () runToggleDPMS = io $ void callToggle --- keybindings - -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" [] +-- | Keymap configuration myModMask :: KeyMask myModMask = mod4Mask @@ -513,6 +494,11 @@ mkKeys ts c = , ("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" [ ("M-l", "move up screen", nextScreen) , ("M-h", "move down screen", prevScreen) @@ -543,9 +529,6 @@ mkKeys ts c = , ("M-C-t", "launch terminal", runTerm) , ("M-C-q", "launch calc", runCalc) , ("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" diff --git a/lib/WorkspaceMon.hs b/lib/WorkspaceMon.hs index 55e87f2..e60ae4d 100644 --- a/lib/WorkspaceMon.hs +++ b/lib/WorkspaceMon.hs @@ -1,11 +1,45 @@ {-# 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 SendXMsg -import qualified Data.Map as M +import qualified Data.Map as M +import Data.Maybe +import Data.Semigroup import Control.Concurrent import Control.Monad @@ -20,17 +54,49 @@ import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Misc 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 -- 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] data WConf = WConf - { display :: Display - , matchTags :: MatchTags + { display :: Display + , dynWorkspaces :: [DynWorkspace] } 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 = liftIO -runWorkspaceMon :: MatchTags -> IO () -runWorkspaceMon mts = do +runWorkspaceMon :: [DynWorkspace] -> IO () +runWorkspaceMon dws = do dpy <- openDisplay "" root <- rootWindow dpy $ defaultScreen dpy curPIDs <- newMVar [] -- TODO this is ugly, use a mutable state monad @@ -55,7 +121,7 @@ runWorkspaceMon mts = do allocaSetWindowAttributes $ \a -> do set_event_mask a substructureNotifyMask changeWindowAttributes dpy root cWEventMask a - let c = WConf { display = dpy, matchTags = mts } + let c = WConf { display = dpy, dynWorkspaces = dws } _ <- allocaXEvent $ \e -> runW c $ forever $ handle curPIDs =<< io (nextEvent dpy e >> getEvent e) return () @@ -67,8 +133,9 @@ handle :: WatchedPIDs -> Event -> W () handle curPIDs MapNotifyEvent { ev_window = w } = do dpy <- asks display hint <- io $ getClassHint dpy w - mts <- asks matchTags - let tag = M.lookup (resClass hint) mts + dws <- asks dynWorkspaces + 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 a <- internAtom dpy "_NET_WM_PID" False pid <- getWindowProperty32 dpy a w @@ -83,7 +150,6 @@ handle _ _ = return () waitAndKill :: String -> Pid -> IO () waitAndKill tag pid = waitUntilExit pid >> sendXMsg Workspace tag - withUniquePid :: WatchedPIDs -> Pid -> IO () -> IO () withUniquePid curPIDs pid f = do pids <- readMVar curPIDs @@ -91,3 +157,39 @@ withUniquePid curPIDs pid f = do modifyMVar_ curPIDs (return . (pid:)) f 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