REF remove xit-event program and refactor workspacemon code

bin/xit-event.hs

@@ -1,22 +0,0 @@
--- | Send a special event as a signal to the window manager
--- Specifically, this is meant to be run after applications exit which
--- will allow xmonad to react to processes closing. It takes two
--- arguments: a string called the "magic string" up to 5 characters
--- and a string up to 15 characters called the "tag." These will be
--- concatenated and sent to xmonad in a ClientRequest event of type
--- BITMAP (which hopefully will never do anything) to the root window.
--- Operationally, the magic string is meant to be used to
--- differentiate this event and the tag is meant to be a signal to be
--- read by xmonad.
-
-import SendXMsg
-
-import System.Environment
-import System.Exit
-
-main :: IO ()
-main = getArgs >>= parse
-
-parse :: [String] -> IO ()
-parse [magic, tag] = sendXMsg magic tag >> exitSuccess
-parse _            = exitFailure

bin/xmonad.hs

@@ -82,8 +82,8 @@ main = do
   dbClient <- startXMonadService
   (barPID, h) <- spawnPipe' "xmobar"
   _ <- forkIO runPowermon
-  _ <- forkIO $ runWorkspaceMon $ fromList [ ("Gimp", myGimpWorkspace)
-                                           , ("VirtualBoxVM", myVMWorkspace)
+  _ <- forkIO $ runWorkspaceMon $ fromList [ (myGimpClass, myGimpWorkspace)
+                                           , (myVMClass, myVMWorkspace)
                                            ]
   launch
     $ ewmh
@@ -120,9 +120,15 @@ myWorkspaces = map show [1..10 :: Int]
 myVMWorkspace :: String
 myVMWorkspace = "VM"
 
+myVMClass :: String
+myVMClass = "VirtualBoxVM"
+
 myGimpWorkspace :: String
 myGimpWorkspace = "GIMP"
 
+myGimpClass :: String
+myGimpClass = "Gimp"
+
 myLayouts = onWorkspace myVMWorkspace (noBorders Full)
   -- $ onWorkspace myGimpWorkspace gimpLayout
   $ tall ||| single ||| full
@@ -193,7 +199,7 @@ myManageHook = composeOne
   -- assume virtualbox is not run with the toolbar in fullscreen mode
   -- as this makes a new window that confusingly must go over the
   -- actual VM window
-  [ className =? "VirtualBoxVM" -?> doShift myVMWorkspace
+  [ className =? myVMClass -?> doShift myVMWorkspace
   -- the seafile applet
   , className =? "Seafile Client" -?> doFloat
   -- gnucash
@@ -201,7 +207,7 @@ myManageHook = composeOne
   -- xsane
   , className =? "Xsane" -?> doFloat
   -- all of GIMP
-  , className =? "Gimp" -?> doFloat >> doShift myGimpWorkspace
+  , className =? myGimpClass -?> doFloat >> doShift myGimpWorkspace
   -- , title =? "GIMP Startup" -?> doIgnore
   -- plots and graphics created by R
   , className =? "R_x11" -?> doFloat
@@ -345,11 +351,6 @@ runOptimusPrompt = do
 magicStringWS :: String
 magicStringWS = "%%%%%"
 
--- spawnCmdOwnWS :: String -> [String] -> String -> X ()
--- spawnCmdOwnWS cmd args ws = spawn
---   $ fmtCmd cmd args
---   #!&& fmtCmd "xit-event" [magicStringWS, ws]
-
 myTerm :: String
 myTerm = "urxvt"
 
@@ -469,7 +470,7 @@ runDesktopCapture :: X ()
 runDesktopCapture = runFlameshot "full"
 
 runVBox :: X ()
-runVBox = spawnCmd "vbox-start win8raw" []
+runVBox = spawnCmd "vbox-start" ["win8raw"]
 
 runGimp :: X ()
 runGimp = spawnCmd "gimp" []

lib/WorkspaceMon.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 module WorkspaceMon (fromList, runWorkspaceMon) where
 
 import           SendXMsg
@@ -6,6 +8,7 @@ import           Data.Map                  as M
 
 import           Control.Concurrent
 import           Control.Monad
+import           Control.Monad.Reader
 
 import           Graphics.X11.Types
 
@@ -19,9 +22,28 @@ import           Graphics.X11.Xlib.Types
 import           System.Directory
 import           System.Process            (Pid)
 
--- TODO yes yes I could use a reader monad here...
+-- TOOD it would be really nice if the manner we used to match windows was
+-- the same as that in XMonad itself (eg with Query types)
 type MatchTags = Map String String
 
+data WConf = WConf
+    { display   :: Display
+    , matchTags :: MatchTags
+    }
+
+newtype W a = W (ReaderT WConf IO a)
+  deriving (Functor, Monad, MonadIO, MonadReader WConf)
+
+instance Applicative W where
+  pure = return
+  (<*>) = ap
+
+runW :: WConf -> W a -> IO a
+runW c (W a) = runReaderT a c
+
+io :: MonadIO m => IO a -> m a
+io = liftIO
+
 runWorkspaceMon :: MatchTags -> IO ()
 runWorkspaceMon mts = do
   dpy <- openDisplay ""
@@ -30,30 +52,29 @@ runWorkspaceMon mts = do
   allocaSetWindowAttributes $ \a -> do
     set_event_mask a substructureNotifyMask
     changeWindowAttributes dpy root cWEventMask a
+  let c = WConf { display = dpy, matchTags = mts }
   _ <- allocaXEvent $ \e ->
-    forever $ handle dpy mts =<< (nextEvent dpy e >> getEvent e)
+    runW c $ forever $ handle =<< io (nextEvent dpy e >> getEvent e)
   return ()
 
-handle :: Display -> MatchTags -> Event -> IO ()
+handle :: Event -> W ()
 
 -- | assume this fires at least once when a new window is created (also could
 -- use CreateNotify but that is really noisy)
-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
+handle MapNotifyEvent { ev_window = w } = do
+  dpy <- asks display
+  hint <- io $ getClassHint dpy w
+  mts <- asks matchTags
   let tag = M.lookup (resClass hint) mts
-  case tag of
-    Just t -> do
+  io $ forM_ tag $ \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 :: String -> Pid -> IO ()
 waitAndKill tag pid = waitUntilExit pidDir
@@ -66,9 +87,5 @@ waitAndKill tag 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
-      if res then do
-        threadDelay 100000
-        waitUntilExit d
-      else do
-        print "sending"
-        sendXMsg "%%%%%" tag
+      if res then threadDelay 100000 >> waitUntilExit d
+      else sendXMsg "%%%%%" tag

my-xmonad.cabal

@@ -63,11 +63,3 @@ executable xmobar
                  , xmonad >= 0.13
     default-language: Haskell2010
     ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded
-
-executable xit-event
-    main-is: bin/xit-event.hs
-    build-depends: base
-                 , X11 >= 1.9.1
-                 , my-xmonad
-    default-language: Haskell2010
-    ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded