ENH use logging in dynamic workspace thread
This commit is contained in:
parent
1b4480ac3a
commit
76011dc6d6
|
@ -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 ()
|
||||||
|
|
|
@ -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 $
|
||||||
|
|
Loading…
Reference in New Issue