75 lines
2.5 KiB
Haskell
75 lines
2.5 KiB
Haskell
module WorkspaceMon (fromList, runWorkspaceMon) where
|
|
|
|
import SendXMsg
|
|
|
|
import Data.Map as M
|
|
|
|
import Control.Concurrent
|
|
import Control.Monad
|
|
|
|
import Graphics.X11.Types
|
|
|
|
import Graphics.X11.Xlib.Atom
|
|
import Graphics.X11.Xlib.Display
|
|
import Graphics.X11.Xlib.Event
|
|
import Graphics.X11.Xlib.Extras
|
|
import Graphics.X11.Xlib.Misc
|
|
import Graphics.X11.Xlib.Types
|
|
|
|
import System.Directory
|
|
import System.Process (Pid)
|
|
|
|
-- TODO yes yes I could use a reader monad here...
|
|
type MatchTags = Map String String
|
|
|
|
runWorkspaceMon :: MatchTags -> IO ()
|
|
runWorkspaceMon mts = do
|
|
dpy <- openDisplay ""
|
|
root <- rootWindow dpy $ defaultScreen dpy
|
|
-- listen only for substructure change events (which includes MapNotify)
|
|
allocaSetWindowAttributes $ \a -> do
|
|
set_event_mask a substructureNotifyMask
|
|
changeWindowAttributes dpy root cWEventMask a
|
|
_ <- allocaXEvent $ \e ->
|
|
forever $ handle dpy mts =<< (nextEvent dpy e >> getEvent e)
|
|
return ()
|
|
|
|
handle :: Display -> MatchTags -> Event -> IO ()
|
|
|
|
-- | assume this fires at least once when a new window is created (also could
|
|
-- use CreateNotify but that is really noisy)
|
|
handle dpy mts MapNotifyEvent { ev_window = w } = do
|
|
hint <- getClassHint dpy w
|
|
-- this will need to eventually accept a conditional argument that
|
|
-- we can change upon initialization
|
|
let tag = M.lookup (resClass hint) mts
|
|
case tag of
|
|
Just t -> do
|
|
a <- internAtom dpy "_NET_WM_PID" False
|
|
pid <- getWindowProperty32 dpy a w
|
|
case pid of
|
|
-- ASSUMPTION windows will only have one PID at one time
|
|
Just [p] -> waitAndKill t $ fromIntegral p
|
|
_ -> return ()
|
|
Nothing -> return ()
|
|
|
|
handle _ _ _ = return ()
|
|
|
|
waitAndKill :: String -> Pid -> IO ()
|
|
waitAndKill tag pid = waitUntilExit pidDir
|
|
where
|
|
pidDir = "/proc/" ++ show pid
|
|
waitUntilExit d = do
|
|
-- TODO this will not work if the process is a zombie (maybe I care...)
|
|
-- ASSUMPTION on linux PIDs will always increase until they overflow, in
|
|
-- which case they will start to recycle. Barring any fork bombs, this
|
|
-- code should work because we can reasonably expect that no processes
|
|
-- will spawn with the same PID within the delay limit
|
|
res <- doesDirectoryExist d
|
|
if res then do
|
|
threadDelay 100000
|
|
waitUntilExit d
|
|
else do
|
|
print "sending"
|
|
sendXMsg "%%%%%" tag
|