ENH use rio for dyn workspace monitor
This commit is contained in:
parent
f3b0fb6ec5
commit
e3e89c2754
|
@ -32,7 +32,6 @@ import System.Process
|
||||||
( getPid
|
( getPid
|
||||||
, getProcessExitCode
|
, getProcessExitCode
|
||||||
)
|
)
|
||||||
import System.Process.Typed (nullStream)
|
|
||||||
|
|
||||||
import XMonad
|
import XMonad
|
||||||
import XMonad.Actions.CopyWindow
|
import XMonad.Actions.CopyWindow
|
||||||
|
|
|
@ -1,5 +1,3 @@
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Automatically Manage Dynamic Workspaces
|
-- | Automatically Manage Dynamic Workspaces
|
||||||
-- This is a somewhat convoluted wrapper for the Dymamic Workspaces module
|
-- This is a somewhat convoluted wrapper for the Dymamic Workspaces module
|
||||||
|
@ -39,10 +37,16 @@ import Data.List (deleteBy, find)
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
|
||||||
import Control.Concurrent
|
-- import Control.Concurrent
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
|
|
||||||
|
import RIO hiding
|
||||||
|
( Display
|
||||||
|
, display
|
||||||
|
)
|
||||||
|
import qualified RIO.Set as S
|
||||||
|
|
||||||
import Graphics.X11.Types
|
import Graphics.X11.Types
|
||||||
|
|
||||||
import Graphics.X11.Xlib.Atom
|
import Graphics.X11.Xlib.Atom
|
||||||
|
@ -91,68 +95,62 @@ data DynWorkspace = DynWorkspace
|
||||||
-- the same as that in XMonad itself (eg with Query types)
|
-- the same as that in XMonad itself (eg with Query types)
|
||||||
-- type MatchTags = M.Map String String
|
-- type MatchTags = M.Map String String
|
||||||
|
|
||||||
type WatchedPIDs = MVar [Pid]
|
|
||||||
|
|
||||||
data WConf = WConf
|
data WConf = WConf
|
||||||
{ display :: Display
|
{ display :: Display
|
||||||
, dynWorkspaces :: [DynWorkspace]
|
, dynWorkspaces :: [DynWorkspace]
|
||||||
|
, curPIDs :: MVar (S.Set Pid)
|
||||||
}
|
}
|
||||||
|
|
||||||
newtype W a = W (ReaderT WConf IO a)
|
type W a = RIO WConf ()
|
||||||
deriving (Functor, Monad, MonadIO, MonadReader WConf)
|
|
||||||
|
|
||||||
instance Applicative W where
|
withDisplay :: (Display -> IO a) -> IO a
|
||||||
pure = return
|
withDisplay = bracket (openDisplay "") closeDisplay
|
||||||
(<*>) = ap
|
|
||||||
|
|
||||||
runW :: WConf -> W a -> IO a
|
|
||||||
runW c (W a) = runReaderT a c
|
|
||||||
|
|
||||||
runWorkspaceMon :: [DynWorkspace] -> IO ()
|
runWorkspaceMon :: [DynWorkspace] -> IO ()
|
||||||
runWorkspaceMon dws = do
|
runWorkspaceMon dws = withDisplay $ \dpy -> do
|
||||||
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, dynWorkspaces = dws }
|
void $ allocaXEvent $ withEvents dpy
|
||||||
_ <- allocaXEvent $ \e ->
|
where
|
||||||
runW c $ forever $ handle curPIDs =<< io (nextEvent dpy e >> getEvent e)
|
withEvents dpy e = do
|
||||||
return ()
|
ps <- newMVar S.empty
|
||||||
|
let c = WConf { display = dpy, dynWorkspaces = dws, curPIDs = ps }
|
||||||
|
runRIO c
|
||||||
|
$ forever
|
||||||
|
$ handleEvent =<< io (nextEvent dpy e >> getEvent e)
|
||||||
|
|
||||||
handle :: WatchedPIDs -> Event -> W ()
|
handleEvent :: 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 curPIDs MapNotifyEvent { ev_window = w } = do
|
handleEvent MapNotifyEvent { ev_window = w } = do
|
||||||
dpy <- asks display
|
dpy <- asks display
|
||||||
hint <- io $ getClassHint dpy w
|
hint <- io $ getClassHint dpy w
|
||||||
dws <- asks dynWorkspaces
|
dws <- asks dynWorkspaces
|
||||||
let m = M.fromList $ fmap (\DynWorkspace { dwTag = t, dwClass = c } -> (c, t)) dws
|
let tag = M.lookup (resClass hint)
|
||||||
let tag = M.lookup (resClass hint) m
|
$ M.fromList
|
||||||
io $ forM_ tag $ \t -> do
|
$ fmap (\DynWorkspace { dwTag = t, dwClass = c } -> (c, t)) dws
|
||||||
a <- internAtom dpy "_NET_WM_PID" False
|
forM_ tag $ \t -> do
|
||||||
pid <- getWindowProperty32 dpy a w
|
a <- io $ internAtom dpy "_NET_WM_PID" False
|
||||||
|
pid <- io $ 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] -> let p' = fromIntegral p
|
Just [p] -> let p' = fromIntegral p in void $ async $ withUniquePid p' t
|
||||||
in void $ forkIO $ withUniquePid curPIDs p' $ waitAndKill t p'
|
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
|
|
||||||
handle _ _ = return ()
|
handleEvent _ = return ()
|
||||||
|
|
||||||
waitAndKill :: String -> Pid -> IO ()
|
withUniquePid :: Pid -> String -> W ()
|
||||||
waitAndKill tag pid = waitUntilExit pid >> sendXMsg Workspace tag
|
withUniquePid pid tag = do
|
||||||
|
ps <- asks curPIDs
|
||||||
withUniquePid :: WatchedPIDs -> Pid -> IO () -> IO ()
|
pids <- readMVar ps
|
||||||
withUniquePid curPIDs pid f = do
|
io $ unless (pid `elem` pids) $ bracket_
|
||||||
pids <- readMVar curPIDs
|
(modifyMVar_ ps (return . S.insert pid))
|
||||||
unless (pid `elem` pids) $ do
|
(modifyMVar_ ps (return . S.delete pid))
|
||||||
modifyMVar_ curPIDs (return . (pid:))
|
$ waitUntilExit pid >> sendXMsg Workspace tag
|
||||||
f
|
|
||||||
modifyMVar_ curPIDs (return . filter (/=pid))
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Launching apps
|
-- | Launching apps
|
||||||
|
|
Loading…
Reference in New Issue