REF add documentation

This commit is contained in:
Nathan Dwarshuis 2020-04-01 12:57:39 -04:00
parent 89e23e186b
commit 840f96c76b
1 changed files with 73 additions and 13 deletions

View File

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