ENH make pattern matcher general for any window class

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 :: 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 = "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

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 ()
+-- 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 ""
   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
+  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 $ fromIntegral p
+        Just [p] -> waitAndKill t $ fromIntegral p
         _        -> return ()
+    Nothing -> return ()
 
-handle _ _ = return ()
+handle _ _ _ = return ()
 
-waitAndKill :: Pid -> IO ()
+waitAndKill :: String -> Pid -> IO ()
-waitAndKill pid = waitUntilExit pidDir
+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
+      if res then do
         threadDelay 100000
         waitUntilExit d
+      else do
+        print "sending"
+        sendXMsg "%%%%%" tag