ENH use rio for dyn workspace monitor

This commit is contained in:
Nathan Dwarshuis 2022-12-28 16:22:09 -05:00
parent f3b0fb6ec5
commit e3e89c2754
2 changed files with 38 additions and 41 deletions

View File

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

View File

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