REF remove xit-event program and refactor workspacemon code

This commit is contained in:
Nathan Dwarshuis 2020-03-25 14:09:07 -04:00
parent 579f124e7b
commit 81227c1296
4 changed files with 51 additions and 63 deletions

View File

@ -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

View File

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

View File

@ -1,3 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module WorkspaceMon (fromList, runWorkspaceMon) where module WorkspaceMon (fromList, runWorkspaceMon) where
import SendXMsg import SendXMsg
@ -6,6 +8,7 @@ import Data.Map as M
import Control.Concurrent import Control.Concurrent
import Control.Monad import Control.Monad
import Control.Monad.Reader
import Graphics.X11.Types import Graphics.X11.Types
@ -19,9 +22,28 @@ import Graphics.X11.Xlib.Types
import System.Directory import System.Directory
import System.Process (Pid) 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 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 :: MatchTags -> IO ()
runWorkspaceMon mts = do runWorkspaceMon mts = do
dpy <- openDisplay "" dpy <- openDisplay ""
@ -30,30 +52,29 @@ runWorkspaceMon mts = do
allocaSetWindowAttributes $ \a -> do allocaSetWindowAttributes $ \a -> do
set_event_mask a substructureNotifyMask set_event_mask a substructureNotifyMask
changeWindowAttributes dpy root cWEventMask a changeWindowAttributes dpy root cWEventMask a
let c = WConf { display = dpy, matchTags = mts }
_ <- allocaXEvent $ \e -> _ <- allocaXEvent $ \e ->
forever $ handle dpy mts =<< (nextEvent dpy e >> getEvent e) runW c $ forever $ handle =<< io (nextEvent dpy e >> getEvent e)
return () return ()
handle :: Display -> MatchTags -> Event -> IO () handle :: Event -> W ()
-- | assume this fires at least once when a new window is created (also could -- | assume this fires at least once when a new window is created (also could
-- use CreateNotify but that is really noisy) -- use CreateNotify but that is really noisy)
handle dpy mts MapNotifyEvent { ev_window = w } = do handle MapNotifyEvent { ev_window = w } = do
hint <- getClassHint dpy w dpy <- asks display
-- this will need to eventually accept a conditional argument that hint <- io $ getClassHint dpy w
-- we can change upon initialization mts <- asks matchTags
let tag = M.lookup (resClass hint) mts let tag = M.lookup (resClass hint) mts
case tag of io $ forM_ tag $ \t -> do
Just t -> do a <- internAtom dpy "_NET_WM_PID" False
a <- internAtom dpy "_NET_WM_PID" False pid <- getWindowProperty32 dpy a w
pid <- getWindowProperty32 dpy a w case pid of
case pid of -- ASSUMPTION windows will only have one PID at one time
-- ASSUMPTION windows will only have one PID at one time Just [p] -> waitAndKill t $ fromIntegral p
Just [p] -> waitAndKill t $ fromIntegral p _ -> return ()
_ -> return ()
Nothing -> return ()
handle _ _ _ = return () handle _ = return ()
waitAndKill :: String -> Pid -> IO () waitAndKill :: String -> Pid -> IO ()
waitAndKill tag pid = waitUntilExit pidDir 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 -- code should work because we can reasonably expect that no processes
-- will spawn with the same PID within the delay limit -- will spawn with the same PID within the delay limit
res <- doesDirectoryExist d res <- doesDirectoryExist d
if res then do if res then threadDelay 100000 >> waitUntilExit d
threadDelay 100000 else sendXMsg "%%%%%" tag
waitUntilExit d
else do
print "sending"
sendXMsg "%%%%%" tag

View File

@ -62,12 +62,4 @@ executable xmobar
, xmobar , xmobar
, xmonad >= 0.13 , xmonad >= 0.13
default-language: Haskell2010 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 ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded