REF move dynamic workspace code to workspace mon module
This commit is contained in:
parent
68d83d859f
commit
9ff68d97e9
165
bin/xmonad.hs
165
bin/xmonad.hs
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue