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 #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
|
||||||
module WorkspaceMon (fromList, runWorkspaceMon) where
|
module WorkspaceMon (M.fromList, runWorkspaceMon) where
|
||||||
|
|
||||||
import SendXMsg
|
import SendXMsg
|
||||||
|
|
||||||
import Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Monad
|
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
|
-- 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 = Map String String
|
type MatchTags = M.Map String String
|
||||||
|
|
||||||
|
type WatchedPIDs = MVar [Pid]
|
||||||
|
|
||||||
data WConf = WConf
|
data WConf = WConf
|
||||||
{ display :: Display
|
{ display :: Display
|
||||||
|
@ -48,20 +50,21 @@ runWorkspaceMon :: MatchTags -> IO ()
|
||||||
runWorkspaceMon mts = do
|
runWorkspaceMon mts = 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
|
||||||
-- listen only for substructure change events (which includes MapNotify)
|
-- listen only for substructure change events (which includes MapNotify)
|
||||||
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, matchTags = mts }
|
||||||
_ <- allocaXEvent $ \e ->
|
_ <- allocaXEvent $ \e ->
|
||||||
runW c $ forever $ handle =<< io (nextEvent dpy e >> getEvent e)
|
runW c $ forever $ handle curPIDs =<< io (nextEvent dpy e >> getEvent e)
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
handle :: Event -> W ()
|
handle :: WatchedPIDs -> Event -> W ()
|
||||||
|
|
||||||
-- | assume this fires at least once when a new window is created (also could
|
-- | assume this fires at least once when a new window is created (also could
|
||||||
-- use CreateNotify but that is really noisy)
|
-- use CreateNotify but that is really noisy)
|
||||||
handle 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
|
mts <- asks matchTags
|
||||||
|
@ -71,10 +74,11 @@ handle MapNotifyEvent { ev_window = w } = do
|
||||||
pid <- getWindowProperty32 dpy a w
|
pid <- getWindowProperty32 dpy a w
|
||||||
case pid of
|
case pid of
|
||||||
-- ASSUMPTION windows will only have one PID at one time
|
-- 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 ()
|
_ -> return ()
|
||||||
|
|
||||||
handle _ = return ()
|
handle _ _ = return ()
|
||||||
|
|
||||||
waitAndKill :: String -> Pid -> IO ()
|
waitAndKill :: String -> Pid -> IO ()
|
||||||
waitAndKill tag pid = waitUntilExit pidDir
|
waitAndKill tag pid = waitUntilExit pidDir
|
||||||
|
@ -89,3 +93,13 @@ waitAndKill tag pid = waitUntilExit pidDir
|
||||||
res <- doesDirectoryExist d
|
res <- doesDirectoryExist d
|
||||||
if res then threadDelay 100000 >> waitUntilExit d
|
if res then threadDelay 100000 >> waitUntilExit d
|
||||||
else sendXMsg Workspace tag
|
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