ADD guard to ensure only one thread per PID spawns

This commit is contained in:
Nathan Dwarshuis 2020-03-25 16:18:30 -04:00
parent 7d92a35e39
commit 9e381abfd2
1 changed files with 22 additions and 8 deletions

View File

@ -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))