ADD guard to ensure only one thread per PID spawns
This commit is contained in:
parent
7d92a35e39
commit
9e381abfd2
|
@ -1,10 +1,10 @@
|
|||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module WorkspaceMon (fromList, runWorkspaceMon) where
|
||||
module WorkspaceMon (M.fromList, runWorkspaceMon) where
|
||||
|
||||
import SendXMsg
|
||||
|
||||
import Data.Map as M
|
||||
import qualified Data.Map as M
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Monad
|
||||
|
@ -24,7 +24,9 @@ import System.Process (Pid)
|
|||
|
||||
-- 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 = Map String String
|
||||
type MatchTags = M.Map String String
|
||||
|
||||
type WatchedPIDs = MVar [Pid]
|
||||
|
||||
data WConf = WConf
|
||||
{ display :: Display
|
||||
|
@ -48,20 +50,21 @@ runWorkspaceMon :: MatchTags -> IO ()
|
|||
runWorkspaceMon mts = do
|
||||
dpy <- openDisplay ""
|
||||
root <- rootWindow dpy $ defaultScreen dpy
|
||||
curPIDs <- newMVar [] -- TODO this is ugly, use a mutable state monad
|
||||
-- listen only for substructure change events (which includes MapNotify)
|
||||
allocaSetWindowAttributes $ \a -> do
|
||||
set_event_mask a substructureNotifyMask
|
||||
changeWindowAttributes dpy root cWEventMask a
|
||||
let c = WConf { display = dpy, matchTags = mts }
|
||||
_ <- allocaXEvent $ \e ->
|
||||
runW c $ forever $ handle =<< io (nextEvent dpy e >> getEvent e)
|
||||
runW c $ forever $ handle curPIDs =<< io (nextEvent dpy e >> getEvent e)
|
||||
return ()
|
||||
|
||||
handle :: Event -> W ()
|
||||
handle :: WatchedPIDs -> Event -> W ()
|
||||
|
||||
-- | assume this fires at least once when a new window is created (also could
|
||||
-- use CreateNotify but that is really noisy)
|
||||
handle MapNotifyEvent { ev_window = w } = do
|
||||
handle curPIDs MapNotifyEvent { ev_window = w } = do
|
||||
dpy <- asks display
|
||||
hint <- io $ getClassHint dpy w
|
||||
mts <- asks matchTags
|
||||
|
@ -71,10 +74,11 @@ handle MapNotifyEvent { ev_window = w } = do
|
|||
pid <- getWindowProperty32 dpy a w
|
||||
case pid of
|
||||
-- ASSUMPTION windows will only have one PID at one time
|
||||
Just [p] -> waitAndKill t $ fromIntegral p
|
||||
Just [p] -> let p' = fromIntegral p
|
||||
in withUniquePid curPIDs p' $ waitAndKill t p'
|
||||
_ -> return ()
|
||||
|
||||
handle _ = return ()
|
||||
handle _ _ = return ()
|
||||
|
||||
waitAndKill :: String -> Pid -> IO ()
|
||||
waitAndKill tag pid = waitUntilExit pidDir
|
||||
|
@ -89,3 +93,13 @@ waitAndKill tag pid = waitUntilExit pidDir
|
|||
res <- doesDirectoryExist d
|
||||
if res then threadDelay 100000 >> waitUntilExit d
|
||||
else sendXMsg Workspace tag
|
||||
|
||||
withUniquePid :: WatchedPIDs -> Pid -> IO () -> IO ()
|
||||
withUniquePid curPIDs pid f = do
|
||||
pids <- readMVar curPIDs
|
||||
if pid `elem` pids
|
||||
then return ()
|
||||
else do
|
||||
modifyMVar_ curPIDs (return . (pid:))
|
||||
f
|
||||
modifyMVar_ curPIDs (return . filter (/=pid))
|
||||
|
|
Loading…
Reference in New Issue