ENH make pattern matcher general for any window class

This commit is contained in:
Nathan Dwarshuis 2020-03-25 13:38:41 -04:00
parent c82f73c380
commit 579f124e7b
2 changed files with 42 additions and 27 deletions

View File

@ -82,7 +82,9 @@ main = do
dbClient <- startXMonadService dbClient <- startXMonadService
(barPID, h) <- spawnPipe' "xmobar" (barPID, h) <- spawnPipe' "xmobar"
_ <- forkIO runPowermon _ <- forkIO runPowermon
_ <- forkIO runWorkspaceMon _ <- forkIO $ runWorkspaceMon $ fromList [ ("Gimp", myGimpWorkspace)
, ("VirtualBoxVM", myVMWorkspace)
]
launch launch
$ ewmh $ ewmh
$ addDescrKeys' ((myModMask, xK_F1), showKeybindings) (myKeys [barPID] dbClient) $ addDescrKeys' ((myModMask, xK_F1), showKeybindings) (myKeys [barPID] dbClient)
@ -231,6 +233,7 @@ myEventHook :: Event -> X All
myEventHook ClientMessageEvent { ev_message_type = t, ev_data = d } myEventHook ClientMessageEvent { ev_message_type = t, ev_data = d }
| t == bITMAP = do | t == bITMAP = do
let (magic, tag) = splitXMsg d let (magic, tag) = splitXMsg d
io $ print $ magic ++ "; " ++ tag
if | magic == magicStringWS -> removeEmptyWorkspaceByTag' tag if | magic == magicStringWS -> removeEmptyWorkspaceByTag' tag
| magic == acpiMagic -> do | magic == acpiMagic -> do
let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent
@ -242,7 +245,6 @@ myEventHook ClientMessageEvent { ev_message_type = t, ev_data = d }
forM_ status $ \s -> runScreenLock >> when s runSuspend forM_ status $ \s -> runScreenLock >> when s runSuspend
| otherwise -> return () | otherwise -> return ()
return (All True) return (All True)
| otherwise = return (All True)
-- myEventHook DestroyWindowEvent { ev_window = w } = do -- myEventHook DestroyWindowEvent { ev_window = w } = do
-- io $ print w -- io $ print w
-- return (All True) -- return (All True)
@ -343,10 +345,10 @@ runOptimusPrompt = do
magicStringWS :: String magicStringWS :: String
magicStringWS = "%%%%%" magicStringWS = "%%%%%"
spawnCmdOwnWS :: String -> [String] -> String -> X () -- spawnCmdOwnWS :: String -> [String] -> String -> X ()
spawnCmdOwnWS cmd args ws = spawn -- spawnCmdOwnWS cmd args ws = spawn
$ fmtCmd cmd args -- $ fmtCmd cmd args
#!&& fmtCmd "xit-event" [magicStringWS, ws] -- #!&& fmtCmd "xit-event" [magicStringWS, ws]
myTerm :: String myTerm :: String
myTerm = "urxvt" myTerm = "urxvt"
@ -467,10 +469,10 @@ runDesktopCapture :: X ()
runDesktopCapture = runFlameshot "full" runDesktopCapture = runFlameshot "full"
runVBox :: X () runVBox :: X ()
runVBox = spawnCmdOwnWS "vbox-start win8raw" [] myVMWorkspace runVBox = spawnCmd "vbox-start win8raw" []
runGimp :: X () runGimp :: X ()
runGimp = spawnCmdOwnWS "gimp" [] myGimpWorkspace runGimp = spawnCmd "gimp" []
runCleanup :: [ProcessID] -> Client -> X () runCleanup :: [ProcessID] -> Client -> X ()
runCleanup ps client = io $ do runCleanup ps client = io $ do

View File

@ -1,4 +1,8 @@
module WorkspaceMon (runWorkspaceMon) where module WorkspaceMon (fromList, runWorkspaceMon) where
import SendXMsg
import Data.Map as M
import Control.Concurrent import Control.Concurrent
import Control.Monad import Control.Monad
@ -15,8 +19,11 @@ import Graphics.X11.Xlib.Types
import System.Directory import System.Directory
import System.Process (Pid) import System.Process (Pid)
runWorkspaceMon :: IO () -- TODO yes yes I could use a reader monad here...
runWorkspaceMon = do type MatchTags = Map String String
runWorkspaceMon :: MatchTags -> IO ()
runWorkspaceMon mts = do
dpy <- openDisplay "" dpy <- openDisplay ""
root <- rootWindow dpy $ defaultScreen dpy root <- rootWindow dpy $ defaultScreen dpy
-- listen only for substructure change events (which includes MapNotify) -- listen only for substructure change events (which includes MapNotify)
@ -24,29 +31,32 @@ runWorkspaceMon = do
set_event_mask a substructureNotifyMask set_event_mask a substructureNotifyMask
changeWindowAttributes dpy root cWEventMask a changeWindowAttributes dpy root cWEventMask a
_ <- allocaXEvent $ \e -> _ <- allocaXEvent $ \e ->
forever $ handle dpy =<< (nextEvent dpy e >> getEvent e) forever $ handle dpy mts =<< (nextEvent dpy e >> getEvent e)
return () return ()
handle :: Display -> Event -> IO () handle :: Display -> MatchTags -> Event -> IO ()
-- | 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 dpy MapNotifyEvent { ev_window = w } = do handle dpy mts MapNotifyEvent { ev_window = w } = do
hint <- getClassHint dpy w hint <- getClassHint dpy w
-- this will need to eventually accept a conditional argument that -- this will need to eventually accept a conditional argument that
-- we can change upon initialization -- we can change upon initialization
when (resName hint == "gimp") $ do let tag = M.lookup (resClass hint) mts
case tag of
Just t -> do
a <- internAtom dpy "_NET_WM_PID" False a <- internAtom dpy "_NET_WM_PID" False
pid <- getWindowProperty32 dpy a w pid <- 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] -> waitAndKill $ fromIntegral p Just [p] -> waitAndKill t $ fromIntegral p
_ -> return () _ -> return ()
Nothing -> return ()
handle _ _ = return () handle _ _ _ = return ()
waitAndKill :: Pid -> IO () waitAndKill :: String -> Pid -> IO ()
waitAndKill pid = waitUntilExit pidDir waitAndKill tag pid = waitUntilExit pidDir
where where
pidDir = "/proc/" ++ show pid pidDir = "/proc/" ++ show pid
waitUntilExit d = do waitUntilExit d = do
@ -56,6 +66,9 @@ waitAndKill pid = waitUntilExit pidDir
-- code should work because we can reasonably expect that no processes -- code should work because we can reasonably expect that no processes
-- will spawn with the same PID within the delay limit -- will spawn with the same PID within the delay limit
res <- doesDirectoryExist d res <- doesDirectoryExist d
when res $ do if res then do
threadDelay 100000 threadDelay 100000
waitUntilExit d waitUntilExit d
else do
print "sending"
sendXMsg "%%%%%" tag