94 lines
2.7 KiB
Haskell
94 lines
2.7 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
module WorkspaceMon (M.fromList, runWorkspaceMon) where
|
|
|
|
import Process
|
|
import SendXMsg
|
|
|
|
import qualified Data.Map as M
|
|
|
|
import Control.Concurrent
|
|
import Control.Monad
|
|
import Control.Monad.Reader
|
|
|
|
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.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 = M.Map String String
|
|
|
|
type WatchedPIDs = MVar [Pid]
|
|
|
|
data WConf = WConf
|
|
{ display :: Display
|
|
, matchTags :: MatchTags
|
|
}
|
|
|
|
newtype W a = W (ReaderT WConf IO a)
|
|
deriving (Functor, Monad, MonadIO, MonadReader WConf)
|
|
|
|
instance Applicative W where
|
|
pure = return
|
|
(<*>) = ap
|
|
|
|
runW :: WConf -> W a -> IO a
|
|
runW c (W a) = runReaderT a c
|
|
|
|
io :: MonadIO m => IO a -> m a
|
|
io = liftIO
|
|
|
|
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 curPIDs =<< io (nextEvent dpy e >> getEvent e)
|
|
return ()
|
|
|
|
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 curPIDs MapNotifyEvent { ev_window = w } = do
|
|
dpy <- asks display
|
|
hint <- io $ getClassHint dpy w
|
|
mts <- asks matchTags
|
|
let tag = M.lookup (resClass hint) mts
|
|
io $ forM_ tag $ \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] -> let p' = fromIntegral p
|
|
in void $ forkIO $ withUniquePid curPIDs p' $ waitAndKill t p'
|
|
_ -> return ()
|
|
|
|
handle _ _ = return ()
|
|
|
|
waitAndKill :: String -> Pid -> IO ()
|
|
waitAndKill tag pid = waitUntilExit pid >> sendXMsg Workspace tag
|
|
|
|
|
|
withUniquePid :: WatchedPIDs -> Pid -> IO () -> IO ()
|
|
withUniquePid curPIDs pid f = do
|
|
pids <- readMVar curPIDs
|
|
unless (pid `elem` pids) $ do
|
|
modifyMVar_ curPIDs (return . (pid:))
|
|
f
|
|
modifyMVar_ curPIDs (return . filter (/=pid))
|