ADD workspace monitor

bin/xmonad.hs

@@ -8,6 +8,7 @@ import           DBus.Client                      (Client)
 import           Notify
 import           SendXMsg
 import           Shell
+import           WorkspaceMon
 
 import           DBus.Common
 import           DBus.IntelBacklight
@@ -81,6 +82,7 @@ main = do
   dbClient <- startXMonadService
   (barPID, h) <- spawnPipe' "xmobar"
   _ <- forkIO runPowermon
+  _ <- forkIO runWorkspaceMon
   launch
     $ ewmh
     $ addDescrKeys' ((myModMask, xK_F1), showKeybindings) (myKeys [barPID] dbClient)

lib/WorkspaceMon.hs

@@ -0,0 +1,61 @@
+module WorkspaceMon (runWorkspaceMon) where
+
+import           Control.Concurrent
+import           Control.Monad
+
+import           Graphics.X11.Types
+
+import           Graphics.X11.Xlib.Atom
+import           Graphics.X11.Xlib.Display
+import           Graphics.X11.Xlib.Event
+import           Graphics.X11.Xlib.Extras
+import           Graphics.X11.Xlib.Misc
+import           Graphics.X11.Xlib.Types
+
+import           System.Directory
+import           System.Process            (Pid)
+
+runWorkspaceMon :: IO ()
+runWorkspaceMon = do
+  dpy <- openDisplay ""
+  root <- rootWindow dpy $ defaultScreen dpy
+  -- listen only for substructure change events (which includes MapNotify)
+  allocaSetWindowAttributes $ \a -> do
+    set_event_mask a substructureNotifyMask
+    changeWindowAttributes dpy root cWEventMask a
+  _ <- allocaXEvent $ \e ->
+    forever $ handle dpy =<< (nextEvent dpy e >> getEvent e)
+  return ()
+
+handle :: Display -> 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
+  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 ()
+
+handle _ _ = return ()
+
+waitAndKill :: Pid -> IO ()
+waitAndKill pid = waitUntilExit pidDir
+  where
+    pidDir = "/proc/" ++ show pid
+    waitUntilExit d = do
+      -- TODO this will not work if the process is a zombie (maybe I care...)
+      -- ASSUMPTION on linux PIDs will always increase until they overflow, in
+      -- which case they will start to recycle. Barring any fork bombs, this
+      -- 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

my-xmonad.cabal

@@ -10,6 +10,7 @@ library
                    , Theme
                    , Notify
                    , Shell
+                   , WorkspaceMon
                    , DBus.Common
                    , DBus.IntelBacklight
                    , DBus.Internal
@@ -18,45 +19,48 @@ library
                    , Xmobar.Plugins.IntelBacklight
                    , Xmobar.Plugins.Screensaver
                    , Xmobar.Plugins.VPN
-    build-depends: base
-                 , X11 >= 1.9.1
+    build-depends: X11 >= 1.9.1
+                 , base
+                 , bytestring >= 0.10.8.2
                  , colour >= 2.3.5
+                 , containers >= 0.6.0.1
+                 , dbus >= 1.2.7
+                 , fdo-notify
+                 , io-streams >= 1.5.1.0
+                 , mtl >= 2.2.2
+                 , tcp-streams >= 1.0.1.1
+                 , text >= 1.2.3.1
+                 , directory >= 1.3.3.0
+                 , process >= 1.6.5.0
+                 , xmobar
                  , xmonad >= 0.13
                  , xmonad-contrib >= 0.13
-                 , fdo-notify
-                 , dbus >= 1.2.7
-                 , text >= 1.2.3.1
-                 , containers >= 0.6.0.1
-                 , tcp-streams >= 1.0.1.1
-                 , io-streams >= 1.5.1.0
-                 , bytestring >= 0.10.8.2
-                 , xmobar
     ghc-options: -Wall -Werror -fno-warn-missing-signatures
     default-language: Haskell2010
 
 executable xmonad
     main-is: bin/xmonad.hs
-    build-depends: base
+    build-depends: X11 >= 1.9.1
+                 , base
+                 , containers >= 0.6.0.1
+                 , dbus >= 1.2.7
+                 , directory >= 1.3.3.0
+                 , my-xmonad
+                 , process >= 1.6.5.0
+                 , unix >= 2.7.2.2
                  , xmonad >= 0.13
                  , xmonad-contrib >= 0.13
                  , xmonad-extras >= 0.15.2
-                 , X11 >= 1.9.1
-                 , unix >= 2.7.2.2
-                 , process >= 1.6.5.0
-                 , directory >= 1.3.3.0
-                 , containers >= 0.6.0.1
-                 , dbus >= 1.2.7
-                 , my-xmonad
     default-language: Haskell2010
     ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded
 
 executable xmobar
     main-is: bin/xmobar.hs
     build-depends: base
-                 , xmonad >= 0.13
                  , dbus >= 1.2.7
-                 , xmobar
                  , my-xmonad
+                 , xmobar
+                 , xmonad >= 0.13
     default-language: Haskell2010
     ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded