ENH pass timeout to xcape
This commit is contained in:
parent
4ef3f2d654
commit
c4a7104469
66
app/Main.hs
66
app/Main.hs
|
@ -62,22 +62,25 @@ instance Applicative XMan where
|
||||||
pure = return
|
pure = return
|
||||||
(<*>) = ap
|
(<*>) = ap
|
||||||
|
|
||||||
newtype XMState = XMState { xcapeProcess :: Maybe ProcessHandle }
|
newtype XMState = XMState { xcapeHandle :: Maybe ProcessHandle }
|
||||||
|
|
||||||
data XMConf = XMConf
|
data XMConf = XMConf
|
||||||
{ display :: Display
|
{ display :: Display
|
||||||
, theRoot :: Window
|
, theRoot :: Window
|
||||||
, netActiveWindow :: Atom
|
, netActiveWindow :: Atom
|
||||||
, regexps :: Patterns
|
, regexps :: Patterns
|
||||||
, xcapeKeys :: Bindings
|
, xcapeProcess :: CreateProcess
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | regular expression patterns
|
-- | timeout for xcape
|
||||||
type Patterns = [String]
|
type Timeout = Maybe String
|
||||||
|
|
||||||
-- | bindings for xcape
|
-- | bindings for xcape
|
||||||
type Bindings = String
|
type Bindings = String
|
||||||
|
|
||||||
|
-- | regular expression patterns
|
||||||
|
type Patterns = [String]
|
||||||
|
|
||||||
-- | window app name
|
-- | window app name
|
||||||
type AppName = String
|
type AppName = String
|
||||||
|
|
||||||
|
@ -88,18 +91,26 @@ main = getArgs >>= parse
|
||||||
|
|
||||||
-- | Given a list of arguments, either start the program or print the usage
|
-- | Given a list of arguments, either start the program or print the usage
|
||||||
parse :: [String] -> IO ()
|
parse :: [String] -> IO ()
|
||||||
parse [_] = usage
|
parse [_] = usage
|
||||||
parse (x:rs) = initXMan x rs
|
parse ("-t":t:b:rs) = initXMan rs $ mkXcapeProcess (Just t) b
|
||||||
parse _ = usage
|
parse (b:rs) = initXMan rs $ mkXcapeProcess Nothing b
|
||||||
|
parse _ = usage
|
||||||
|
|
||||||
|
-- | Given a timeout and bindings for xcape, return a process record. This will
|
||||||
|
-- run xcape in debug mode (which will make it run as a foreground process,
|
||||||
|
-- otherwise it will fork unnecessarily).
|
||||||
|
mkXcapeProcess :: Timeout -> Bindings -> CreateProcess
|
||||||
|
mkXcapeProcess (Just t) b = proc "xcape" $ ["-t", t, "-d", "-e"] ++ [b]
|
||||||
|
mkXcapeProcess Nothing b = proc "xcape" $ ["-d", "-e"] ++ [b]
|
||||||
|
|
||||||
-- | Print the usage and exit
|
-- | Print the usage and exit
|
||||||
usage :: IO ()
|
usage :: IO ()
|
||||||
usage = putStrLn "xman BINDINGS REGEXP [[REGEXP] ...]"
|
usage = putStrLn "xman [-t TIMEOUT] BINDINGS REGEXP [[REGEXP] ...]"
|
||||||
|
|
||||||
-- | Given xcape bindings and regular expression patterns to match the window
|
-- | Given xcape bindings and regular expression patterns to match the window
|
||||||
-- titles we care about, initialize the XMan monad and run the main event loop
|
-- titles we care about, initialize the XMan monad and run the main event loop
|
||||||
initXMan :: Bindings -> Patterns -> IO ()
|
initXMan :: Patterns -> CreateProcess -> IO ()
|
||||||
initXMan x r = do
|
initXMan rs cp = do
|
||||||
-- ignore SIGCHLD so we don't produce zombie processes
|
-- ignore SIGCHLD so we don't produce zombie processes
|
||||||
void $ installHandler sigCHLD Ignore Nothing
|
void $ installHandler sigCHLD Ignore Nothing
|
||||||
dpy <- openDisplay ""
|
dpy <- openDisplay ""
|
||||||
|
@ -109,10 +120,10 @@ initXMan x r = do
|
||||||
{ display = dpy
|
{ display = dpy
|
||||||
, theRoot = root
|
, theRoot = root
|
||||||
, netActiveWindow = naw
|
, netActiveWindow = naw
|
||||||
, regexps = r
|
, regexps = rs
|
||||||
, xcapeKeys = x
|
, xcapeProcess = cp
|
||||||
}
|
}
|
||||||
st = XMState { xcapeProcess = Nothing }
|
st = XMState { xcapeHandle = Nothing }
|
||||||
-- listen only for PropertyNotify events on the root window
|
-- listen only for PropertyNotify events on the root window
|
||||||
allocaSetWindowAttributes $ \a -> do
|
allocaSetWindowAttributes $ \a -> do
|
||||||
set_event_mask a propertyChangeMask
|
set_event_mask a propertyChangeMask
|
||||||
|
@ -122,6 +133,7 @@ initXMan x r = do
|
||||||
updateXCape -- set the initial state before entering main loop
|
updateXCape -- set the initial state before entering main loop
|
||||||
forever $ handle =<< io (nextEvent dpy e >> getEvent e)
|
forever $ handle =<< io (nextEvent dpy e >> getEvent e)
|
||||||
|
|
||||||
|
|
||||||
-- | Lift an IO monad into the XMan context
|
-- | Lift an IO monad into the XMan context
|
||||||
io :: MonadIO m => IO a -> m a
|
io :: MonadIO m => IO a -> m a
|
||||||
io = liftIO
|
io = liftIO
|
||||||
|
@ -183,34 +195,30 @@ startOrKillXCape name = do
|
||||||
-- | Start xcape if it is not already running
|
-- | Start xcape if it is not already running
|
||||||
startXCape :: XMan ()
|
startXCape :: XMan ()
|
||||||
startXCape = do
|
startXCape = do
|
||||||
pID <- gets xcapeProcess
|
pID <- gets xcapeHandle
|
||||||
unless (isJust pID) $ do
|
unless (isJust pID) $ do
|
||||||
x <- asks xcapeKeys
|
cp <- asks xcapeProcess
|
||||||
h <- io $ runXcape x
|
h <- io $ createProcessNull cp
|
||||||
modify $ \s -> s { xcapeProcess = Just h }
|
modify $ \s -> s { xcapeHandle = Just h }
|
||||||
io $ print "started xcape"
|
io $ print "started xcape"
|
||||||
|
|
||||||
-- | Stop xcape if it is running
|
-- | Stop xcape if it is running
|
||||||
stopXCape :: XMan ()
|
stopXCape :: XMan ()
|
||||||
stopXCape = do
|
stopXCape = do
|
||||||
pID <- gets xcapeProcess
|
pID <- gets xcapeHandle
|
||||||
forM_ pID $ \p -> do
|
forM_ pID $ \p -> do
|
||||||
io $ terminateProcess p
|
io $ terminateProcess p
|
||||||
modify $ \s -> s { xcapeProcess = Nothing }
|
modify $ \s -> s { xcapeHandle = Nothing }
|
||||||
io $ print "stopped xcape"
|
io $ print "stopped xcape"
|
||||||
|
|
||||||
-- | Given xcape bindings, run xcape with the bindings argument and return the
|
-- | Given a createProcess record, start the process with stderr and stdout
|
||||||
-- process handle. Run xcape in debug mode (this will make it run as a
|
-- redirected to the null device
|
||||||
-- foreground process, otherwise it will fork unnecessarily) and pipe the output
|
|
||||||
-- and error streams to the null device
|
|
||||||
-- NOTE: use the process module here rather than the unix module. The latter has
|
-- NOTE: use the process module here rather than the unix module. The latter has
|
||||||
-- the 'forkProcess' function which may fail if multiple instances of xcape are
|
-- the 'forkProcess' function which may fail if multiple instances of xcape are
|
||||||
-- started and killed in quick succession (Resource unavailable error).
|
-- started and killed in quick succession (Resource unavailable error).
|
||||||
runXcape :: Bindings -> IO ProcessHandle
|
createProcessNull :: CreateProcess -> IO ProcessHandle
|
||||||
runXcape keys = do
|
createProcessNull cp = do
|
||||||
dn <- fmap UseHandle $ fdToHandle
|
fd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
|
||||||
=<< openFd "/dev/null" ReadOnly Nothing defaultFileFlags
|
dn <- UseHandle <$> fdToHandle fd
|
||||||
-- TODO pass more arguments here? this hardcodes the timeout
|
|
||||||
let cp = proc "xcape" $ ["-d", "-t", "500", "-e"] ++ [keys]
|
|
||||||
(_, _, _, h) <- createProcess $ cp { std_err = dn, std_out = dn }
|
(_, _, _, h) <- createProcess $ cp { std_err = dn, std_out = dn }
|
||||||
return h
|
return h
|
||||||
|
|
Loading…
Reference in New Issue