REF add documentation
This commit is contained in:
parent
89e23e186b
commit
840f96c76b
86
app/Main.hs
86
app/Main.hs
|
@ -1,6 +1,23 @@
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- | Xcape MANager (XMan) - a wrapper for managing Xcape
|
||||||
|
--
|
||||||
|
-- Xcape is a program to map keyrease events to keysyms, and is very useful
|
||||||
|
-- for making custom keymaps. However, it is not alwasys desirable to have this
|
||||||
|
-- running all the time; for example, VirtualBox will blend the XKB keymap with
|
||||||
|
-- that if the Guest OS, so Xcape may end up producing an extra keypress. The
|
||||||
|
-- solution is to turn off Xcape when certain windows are in focus.
|
||||||
|
--
|
||||||
|
-- The process for doing this using Xlib:
|
||||||
|
-- 1) Listen for PropertyNotify events from the root window
|
||||||
|
-- 2) Of those events, filter those where the _NET_ACTIVE_WINDOW atom has changed
|
||||||
|
-- 3) Using the value of _NET_ACTIVE_WINDOW, get the title of the active window
|
||||||
|
-- 4) If active window matches a certain criteria, turn off Xcape (vice versa)
|
||||||
|
--
|
||||||
|
-- The matching criteria in (4) are POSIX regular expressions.
|
||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Control.Monad (forM_, forever, void, when)
|
import Control.Monad (forM_, forever, void, when)
|
||||||
|
@ -30,7 +47,15 @@ import System.Process
|
||||||
|
|
||||||
type WindowTitle = String
|
type WindowTitle = String
|
||||||
|
|
||||||
-- I wonder where this idea came from...
|
--------------------------------------------------------------------------------
|
||||||
|
-- | Central State+Reader+IO Monad (I wonder where this idea came from...)
|
||||||
|
--
|
||||||
|
-- The Reader portion holds some of the key data structures from
|
||||||
|
-- X that we care about as well as the regular expression patterns to match and
|
||||||
|
-- the keys to pass the Xcape command.
|
||||||
|
--
|
||||||
|
-- The State portion holds the Xcape process handle (so we can kill it later)
|
||||||
|
-- and the current window title.
|
||||||
newtype XMan a = XMan (ReaderT XMConf (StateT XMState IO) a) deriving
|
newtype XMan a = XMan (ReaderT XMConf (StateT XMState IO) a) deriving
|
||||||
(Functor, Monad, MonadIO, MonadState XMState, MonadReader XMConf)
|
(Functor, Monad, MonadIO, MonadState XMState, MonadReader XMConf)
|
||||||
|
|
||||||
|
@ -52,25 +77,26 @@ data XMConf = XMConf
|
||||||
, xcapeKeys :: String
|
, xcapeKeys :: String
|
||||||
}
|
}
|
||||||
|
|
||||||
io :: MonadIO m => IO a -> m a
|
main :: IO ()
|
||||||
io = liftIO
|
main = getArgs >>= parse
|
||||||
|
|
||||||
runXMan :: XMConf -> XMState -> XMan a -> IO (a, XMState)
|
|
||||||
runXMan c s (XMan a) = runStateT (runReaderT a c) s
|
|
||||||
|
|
||||||
|
-- | 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 (x:rs) = initXMan x rs
|
||||||
parse _ = usage
|
parse _ = usage
|
||||||
|
|
||||||
|
-- | Print the usage and exit
|
||||||
usage :: IO ()
|
usage :: IO ()
|
||||||
|
-- TODO produce relevant exit codes here
|
||||||
usage = putStrLn "xman XCAPE_KEYS REGEXP [[REGEXP]...]"
|
usage = putStrLn "xman XCAPE_KEYS REGEXP [[REGEXP]...]"
|
||||||
|
|
||||||
main :: IO ()
|
-- | Given a string of keys for xcape and a list of regular expressions to match
|
||||||
main = getArgs >>= parse
|
-- the window titles we care about, initialize the XMan monad and run the main
|
||||||
|
-- event loop.
|
||||||
initXMan :: String -> [String] -> IO ()
|
initXMan :: String -> [String] -> IO ()
|
||||||
initXMan x r = do
|
initXMan x r = do
|
||||||
|
-- ignore SIGCHLD so we don't produce zombie processes
|
||||||
void $ installHandler sigCHLD Ignore Nothing
|
void $ installHandler sigCHLD Ignore Nothing
|
||||||
dpy <- openDisplay ""
|
dpy <- openDisplay ""
|
||||||
root <- rootWindow dpy $ defaultScreen dpy
|
root <- rootWindow dpy $ defaultScreen dpy
|
||||||
|
@ -85,14 +111,24 @@ initXMan x r = do
|
||||||
, xcapeKeys = x
|
, xcapeKeys = x
|
||||||
}
|
}
|
||||||
st = XMState { currentTitle = Nothing, xcapeProcess = Nothing }
|
st = XMState { currentTitle = Nothing, xcapeProcess = Nothing }
|
||||||
|
-- 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
|
||||||
changeWindowAttributes dpy root cWEventMask a
|
changeWindowAttributes dpy root cWEventMask a
|
||||||
void $ allocaXEvent $ \e ->
|
void $ allocaXEvent $ \e ->
|
||||||
runXMan cf st $ do
|
runXMan cf st $ do
|
||||||
updateXCape
|
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
|
||||||
|
io :: MonadIO m => IO a -> m a
|
||||||
|
io = liftIO
|
||||||
|
|
||||||
|
-- | Given an initial state and configuration, run the XMan monad
|
||||||
|
runXMan :: XMConf -> XMState -> XMan a -> IO (a, XMState)
|
||||||
|
runXMan c s (XMan a) = runStateT (runReaderT a c) s
|
||||||
|
|
||||||
|
-- | Update the xcape status given the state of XMan
|
||||||
updateXCape :: XMan ()
|
updateXCape :: XMan ()
|
||||||
updateXCape = do
|
updateXCape = do
|
||||||
dpy <- asks display
|
dpy <- asks display
|
||||||
|
@ -103,21 +139,28 @@ updateXCape = do
|
||||||
Just [aw] -> getTitle aw >>= updateTitle >> startOrKillXCape
|
Just [aw] -> getTitle aw >>= updateTitle >> startOrKillXCape
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
|
|
||||||
|
-- | Given an event, call a handler. In this case the only thing we care about
|
||||||
|
-- are PropertyNotify events where the atom is _NET_ACTIVE_WINDOW, which will
|
||||||
|
-- initiated the xcape update logic.
|
||||||
handle :: Event -> XMan ()
|
handle :: Event -> XMan ()
|
||||||
handle PropertyEvent { ev_atom = a } = do
|
handle PropertyEvent { ev_atom = a } = do
|
||||||
atom <- asks netActiveWindow
|
atom <- asks netActiveWindow
|
||||||
when (a == atom) updateXCape
|
when (a == atom) updateXCape
|
||||||
handle _ = return ()
|
handle _ = return ()
|
||||||
|
|
||||||
|
-- | Get the title of a window given a window ID
|
||||||
|
-- The window title could be in two atoms. This will try _NET_WM_NAME first
|
||||||
|
-- before trying WM_NAME (legacy)
|
||||||
getTitle :: CLong -> XMan (Maybe WindowTitle)
|
getTitle :: CLong -> XMan (Maybe WindowTitle)
|
||||||
getTitle winID = do
|
getTitle winID = do
|
||||||
nwn <- asks netWMName
|
nwn <- asks netWMName
|
||||||
-- try getting _NET_WM_NAME first before trying legacy WM_NAME
|
|
||||||
doMaybe [nwn, wM_NAME] $ getTitle' winID
|
doMaybe [nwn, wM_NAME] $ getTitle' winID
|
||||||
where
|
where
|
||||||
doMaybe (x:xs) f = f x >>= (\r -> if isJust r then return r else doMaybe xs f)
|
doMaybe (x:xs) f = f x >>= (\r -> if isJust r then return r else doMaybe xs f)
|
||||||
doMaybe [] _ = return Nothing
|
doMaybe [] _ = return Nothing
|
||||||
|
|
||||||
|
-- | Get the title of a window given a window ID and an atom that may contain
|
||||||
|
-- the title
|
||||||
getTitle' :: CLong -> Atom -> XMan (Maybe WindowTitle)
|
getTitle' :: CLong -> Atom -> XMan (Maybe WindowTitle)
|
||||||
getTitle' winID atom = do
|
getTitle' winID atom = do
|
||||||
dpy <- asks display
|
dpy <- asks display
|
||||||
|
@ -125,6 +168,11 @@ getTitle' winID atom = do
|
||||||
$ fromIntegral winID
|
$ fromIntegral winID
|
||||||
return $ fmap (fmap castCCharToChar) title'
|
return $ fmap (fmap castCCharToChar) title'
|
||||||
|
|
||||||
|
-- | Given an IO action (which is assumed to call an XLib function that may
|
||||||
|
-- throw an error), attach an error handler before performing the action and
|
||||||
|
-- remove it after it completes. The error handler will ignore BadWindow errors
|
||||||
|
-- (which in this case are assumed to be benign since the _NET_ACTIVE_WINDOW
|
||||||
|
-- atom may refer to a non-existent window)
|
||||||
permitBadWindow :: IO a -> IO a
|
permitBadWindow :: IO a -> IO a
|
||||||
permitBadWindow action = do
|
permitBadWindow action = do
|
||||||
handler <- mkXErrorHandler $ \_ e ->
|
handler <- mkXErrorHandler $ \_ e ->
|
||||||
|
@ -134,24 +182,27 @@ permitBadWindow action = do
|
||||||
void $ _xSetErrorHandler original
|
void $ _xSetErrorHandler original
|
||||||
return res
|
return res
|
||||||
where
|
where
|
||||||
-- totally ignore BadWindow errors
|
|
||||||
-- TODO also ignore badvalue errors?
|
-- TODO also ignore badvalue errors?
|
||||||
handleError ErrorEvent { ev_error_code = t }
|
handleError ErrorEvent { ev_error_code = t }
|
||||||
| fromIntegral t == badWindow = return ()
|
| fromIntegral t == badWindow = return ()
|
||||||
-- anything not a BadWindow is an unexpected error
|
|
||||||
handleError _ = print "actual error"
|
handleError _ = print "actual error"
|
||||||
|
|
||||||
|
-- | Given a window title that may exist, update the window title in XMan's
|
||||||
|
-- state
|
||||||
updateTitle :: Maybe WindowTitle -> XMan ()
|
updateTitle :: Maybe WindowTitle -> XMan ()
|
||||||
updateTitle newTitle = modify (\s -> s { currentTitle = newTitle } )
|
updateTitle newTitle = modify (\s -> s { currentTitle = newTitle } )
|
||||||
|
|
||||||
|
-- | Start or stop xcape given the state in XMan
|
||||||
startOrKillXCape :: XMan ()
|
startOrKillXCape :: XMan ()
|
||||||
startOrKillXCape = do
|
startOrKillXCape = do
|
||||||
|
-- TODO this is redundant
|
||||||
title <- gets currentTitle
|
title <- gets currentTitle
|
||||||
case title of
|
case title of
|
||||||
Just t -> asks regexps >>= \r ->
|
Just t -> asks regexps >>= \r ->
|
||||||
if any (t =~) r then stopXCape else startXCape
|
if any (t =~) r then stopXCape else startXCape
|
||||||
Nothing -> startXCape
|
Nothing -> startXCape
|
||||||
|
|
||||||
|
-- | Start Xcape if it is not already running
|
||||||
startXCape :: XMan ()
|
startXCape :: XMan ()
|
||||||
startXCape = do
|
startXCape = do
|
||||||
pID <- gets xcapeProcess
|
pID <- gets xcapeProcess
|
||||||
|
@ -161,6 +212,7 @@ startXCape = do
|
||||||
modify $ \s -> s { xcapeProcess = Just h }
|
modify $ \s -> s { xcapeProcess = Just h }
|
||||||
io $ print "started xcape"
|
io $ print "started xcape"
|
||||||
|
|
||||||
|
-- | Stop Xcape if it is running
|
||||||
stopXCape :: XMan ()
|
stopXCape :: XMan ()
|
||||||
stopXCape = do
|
stopXCape = do
|
||||||
pID <- gets xcapeProcess
|
pID <- gets xcapeProcess
|
||||||
|
@ -169,10 +221,18 @@ stopXCape = do
|
||||||
modify $ \s -> s { xcapeProcess = Nothing }
|
modify $ \s -> s { xcapeProcess = Nothing }
|
||||||
io $ print "stopped xcape"
|
io $ print "stopped xcape"
|
||||||
|
|
||||||
|
-- | Given the keys argument for xcape, run xcape with the keys argument and
|
||||||
|
-- return the process handle. Run xcape in debug mode (this will make it run as
|
||||||
|
-- a 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 the 'forkProcess' function which may fail if multiple instances of xcape
|
||||||
|
-- are started and killed in quick succession (Resource unavailable error).
|
||||||
runXcape :: String -> IO ProcessHandle
|
runXcape :: String -> IO ProcessHandle
|
||||||
runXcape keys = do
|
runXcape keys = do
|
||||||
dn <- fmap UseHandle $ fdToHandle
|
dn <- fmap UseHandle $ fdToHandle
|
||||||
=<< openFd "/dev/null" ReadOnly Nothing defaultFileFlags
|
=<< openFd "/dev/null" ReadOnly Nothing defaultFileFlags
|
||||||
|
-- TODO pass more arguments here? this hardcodes the timeout
|
||||||
let cp = proc "xcape" $ ["-d", "-t", "500", "-e"] ++ [keys]
|
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