diff --git a/bin/xmonad.hs b/bin/xmonad.hs index fa47a89..1c801e3 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -82,7 +82,9 @@ main = do dbClient <- startXMonadService (barPID, h) <- spawnPipe' "xmobar" _ <- forkIO runPowermon - _ <- forkIO runWorkspaceMon + _ <- forkIO $ runWorkspaceMon $ fromList [ ("Gimp", myGimpWorkspace) + , ("VirtualBoxVM", myVMWorkspace) + ] launch $ ewmh $ 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 } | t == bITMAP = do let (magic, tag) = splitXMsg d + io $ print $ magic ++ "; " ++ tag if | magic == magicStringWS -> removeEmptyWorkspaceByTag' tag | magic == acpiMagic -> do 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 | otherwise -> return () return (All True) - | otherwise = return (All True) -- myEventHook DestroyWindowEvent { ev_window = w } = do -- io $ print w -- return (All True) @@ -343,10 +345,10 @@ runOptimusPrompt = do magicStringWS :: String magicStringWS = "%%%%%" -spawnCmdOwnWS :: String -> [String] -> String -> X () -spawnCmdOwnWS cmd args ws = spawn - $ fmtCmd cmd args - #!&& fmtCmd "xit-event" [magicStringWS, ws] +-- spawnCmdOwnWS :: String -> [String] -> String -> X () +-- spawnCmdOwnWS cmd args ws = spawn +-- $ fmtCmd cmd args +-- #!&& fmtCmd "xit-event" [magicStringWS, ws] myTerm :: String myTerm = "urxvt" @@ -467,10 +469,10 @@ runDesktopCapture :: X () runDesktopCapture = runFlameshot "full" runVBox :: X () -runVBox = spawnCmdOwnWS "vbox-start win8raw" [] myVMWorkspace +runVBox = spawnCmd "vbox-start win8raw" [] runGimp :: X () -runGimp = spawnCmdOwnWS "gimp" [] myGimpWorkspace +runGimp = spawnCmd "gimp" [] runCleanup :: [ProcessID] -> Client -> X () runCleanup ps client = io $ do diff --git a/lib/WorkspaceMon.hs b/lib/WorkspaceMon.hs index a5b74bd..4ecf0be 100644 --- a/lib/WorkspaceMon.hs +++ b/lib/WorkspaceMon.hs @@ -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.Monad @@ -15,8 +19,11 @@ import Graphics.X11.Xlib.Types import System.Directory import System.Process (Pid) -runWorkspaceMon :: IO () -runWorkspaceMon = do +-- TODO yes yes I could use a reader monad here... +type MatchTags = Map String String + +runWorkspaceMon :: MatchTags -> IO () +runWorkspaceMon mts = do dpy <- openDisplay "" root <- rootWindow dpy $ defaultScreen dpy -- listen only for substructure change events (which includes MapNotify) @@ -24,29 +31,32 @@ runWorkspaceMon = do set_event_mask a substructureNotifyMask changeWindowAttributes dpy root cWEventMask a _ <- allocaXEvent $ \e -> - forever $ handle dpy =<< (nextEvent dpy e >> getEvent e) + forever $ handle dpy mts =<< (nextEvent dpy e >> getEvent e) return () -handle :: Display -> Event -> IO () +handle :: Display -> MatchTags -> Event -> IO () -- | assume this fires at least once when a new window is created (also could -- 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 -- this will need to eventually accept a conditional argument that -- we can change upon initialization - when (resName hint == "gimp") $ do - a <- internAtom dpy "_NET_WM_PID" False - pid <- getWindowProperty32 dpy a w - case pid of - -- ASSUMPTION windows will only have one PID at one time - Just [p] -> waitAndKill $ fromIntegral p - _ -> return () + let tag = M.lookup (resClass hint) mts + case tag of + Just t -> do + a <- internAtom dpy "_NET_WM_PID" False + pid <- getWindowProperty32 dpy a w + case pid of + -- ASSUMPTION windows will only have one PID at one time + Just [p] -> waitAndKill t $ fromIntegral p + _ -> return () + Nothing -> return () -handle _ _ = return () +handle _ _ _ = return () -waitAndKill :: Pid -> IO () -waitAndKill pid = waitUntilExit pidDir +waitAndKill :: String -> Pid -> IO () +waitAndKill tag pid = waitUntilExit pidDir where pidDir = "/proc/" ++ show pid waitUntilExit d = do @@ -56,6 +66,9 @@ waitAndKill pid = waitUntilExit pidDir -- code should work because we can reasonably expect that no processes -- will spawn with the same PID within the delay limit res <- doesDirectoryExist d - when res $ do - threadDelay 100000 - waitUntilExit d + if res then do + threadDelay 100000 + waitUntilExit d + else do + print "sending" + sendXMsg "%%%%%" tag