diff --git a/bin/xit-event.hs b/bin/xit-event.hs deleted file mode 100644 index 77b6f86..0000000 --- a/bin/xit-event.hs +++ /dev/null @@ -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 diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 1c801e3..c359470 100644 --- a/bin/xmonad.hs +++ b/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" [] diff --git a/lib/WorkspaceMon.hs b/lib/WorkspaceMon.hs index 4ecf0be..0203b5a 100644 --- a/lib/WorkspaceMon.hs +++ b/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 - 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 () + 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 () -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 diff --git a/my-xmonad.cabal b/my-xmonad.cabal index 5eeb13d..fd0efe7 100644 --- a/my-xmonad.cabal +++ b/my-xmonad.cabal @@ -62,12 +62,4 @@ executable xmobar , 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 \ No newline at end of file