ENH use logging in dynamic workspace thread

This commit is contained in:
Nathan Dwarshuis 2023-01-01 19:23:31 -05:00
parent 1b4480ac3a
commit 76011dc6d6
2 changed files with 32 additions and 11 deletions

View File

@ -149,7 +149,7 @@ run = do
where where
startDynWorkspaces fs = do startDynWorkspaces fs = do
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs) dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
void $ io $ async $ runWorkspaceMon dws void $ async $ runWorkspaceMon dws
return dws return dws
runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO () runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()

View File

@ -1,3 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- 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
@ -34,6 +36,8 @@ module XMonad.Internal.Concurrent.DynamicWorkspaces
) )
where where
import qualified Data.ByteString.Char8 as BC
import Data.Internal.XIO
import Graphics.X11.Types import Graphics.X11.Types
import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display import Graphics.X11.Xlib.Display
@ -92,24 +96,34 @@ data WEnv = WEnv
{ wDisplay :: !Display { wDisplay :: !Display
, wDynWorkspaces :: ![DynWorkspace] , wDynWorkspaces :: ![DynWorkspace]
, wCurPIDs :: !(MVar (S.Set Pid)) , wCurPIDs :: !(MVar (S.Set Pid))
-- , wXEnv :: !XEnv , wXEnv :: !XEnv
} }
instance HasLogFunc WEnv where
logFuncL = lens wXEnv (\x y -> x {wXEnv = y}) . logFuncL
type WIO a = RIO WEnv a type WIO a = RIO WEnv a
runWorkspaceMon :: [DynWorkspace] -> IO () runWorkspaceMon :: [DynWorkspace] -> XIO ()
runWorkspaceMon dws = withOpenDisplay $ \dpy -> do runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
root <- rootWindow dpy $ defaultScreen dpy root <- liftIO $ rootWindow dpy $ defaultScreen dpy
-- listen only for substructure change events (which includes MapNotify) -- listen only for substructure change events (which includes MapNotify)
allocaSetWindowAttributes $ \a -> do liftIO $ allocaSetWindowAttributes $ \a -> do
set_event_mask a substructureNotifyMask set_event_mask a substructureNotifyMask
changeWindowAttributes dpy root cWEventMask a changeWindowAttributes dpy root cWEventMask a
void $ allocaXEvent $ withEvents dpy withRunInIO $ \runIO -> do
void $ allocaXEvent $ runIO . withEvents dpy
where where
wrapEnv dpy ps x =
WEnv
{ wDisplay = dpy
, wDynWorkspaces = dws
, wCurPIDs = ps
, wXEnv = x
}
withEvents dpy e = do withEvents dpy e = do
ps <- newMVar S.empty ps <- newMVar S.empty
let c = WEnv {wDisplay = dpy, wDynWorkspaces = dws, wCurPIDs = ps} mapRIO (wrapEnv dpy ps) $ do
runRIO c $
forever $ forever $
handleEvent =<< io (nextEvent dpy e >> getEvent e) handleEvent =<< io (nextEvent dpy e >> getEvent e)
@ -138,17 +152,24 @@ withUniquePid :: Pid -> String -> WIO ()
withUniquePid pid tag = do withUniquePid pid tag = do
ps <- asks wCurPIDs ps <- asks wCurPIDs
pids <- readMVar ps pids <- readMVar ps
io unless (pid `elem` pids)
$ unless (pid `elem` pids)
$ bracket_ $ bracket_
(modifyMVar_ ps (return . S.insert pid)) (modifyMVar_ ps (return . S.insert pid))
(modifyMVar_ ps (return . S.delete pid)) (modifyMVar_ ps (return . S.delete pid))
$ waitUntilExit pid >> sendXMsg Workspace tag $ do
logInfo $ "waiting for pid " <> pid_ <> " to exit on workspace " <> tag_
waitUntilExit pid
logInfo $ "pid " <> pid_ <> " exited on workspace " <> tag_
liftIO $ sendXMsg Workspace tag
where
pid_ = "'" <> displayShow pid <> "'"
tag_ = "'" <> displayBytesUtf8 (BC.pack tag) <> "'"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Launching apps -- Launching apps
-- When launching apps on dymamic workspaces, first check if they are running -- When launching apps on dymamic workspaces, first check if they are running
-- and launch if not, then switch to their workspace -- and launch if not, then switch to their workspace
wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
wsOccupied tag ws = wsOccupied tag ws =
elem tag $ elem tag $