ADD guard to ensure only one thread per PID spawns

lib/WorkspaceMon.hs

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