REF remove xit-event program and refactor workspacemon code
This commit is contained in:
parent
579f124e7b
commit
81227c1296
|
@ -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
|
|
|
@ -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" []
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -63,11 +63,3 @@ executable xmobar
|
||||||
, xmonad >= 0.13
|
, xmonad >= 0.13
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded
|
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
|
|
Loading…
Reference in New Issue