2020-03-31 23:15:43 -04:00
|
|
|
{-# LANGUAGE DeriveFunctor #-}
|
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
|
2020-04-01 12:57:39 -04:00
|
|
|
--------------------------------------------------------------------------------
|
2020-04-01 12:59:35 -04:00
|
|
|
-- | Xcape MANager (XMan) - a wrapper for managing xcape
|
2020-04-01 12:57:39 -04:00
|
|
|
--
|
2020-04-01 12:59:35 -04:00
|
|
|
-- xcape is a program to map keyrelease events to keysyms, and is very useful
|
|
|
|
-- for making custom keymaps. However, it is not always 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.
|
2020-04-01 12:57:39 -04:00
|
|
|
--
|
|
|
|
-- 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
|
2020-04-01 12:59:35 -04:00
|
|
|
-- 4) If active window matches a certain criteria, turn off xcape (vice versa)
|
2020-04-01 12:57:39 -04:00
|
|
|
--
|
|
|
|
-- The matching criteria in (4) are POSIX regular expressions.
|
2020-04-01 13:02:17 -04:00
|
|
|
--
|
|
|
|
-- Known limitations:
|
|
|
|
-- this is agnostic to any keymap changes, so if the keymap is changed, xcape
|
|
|
|
-- will not be updated or restarted. Furthermore, it is outside the scope of
|
|
|
|
-- this program to bind multiple xcape mappings with multiple keymaps
|
2020-04-01 12:57:39 -04:00
|
|
|
|
2020-03-31 23:15:43 -04:00
|
|
|
module Main where
|
|
|
|
|
|
|
|
import Control.Monad (forM_, forever, void, when)
|
|
|
|
import Control.Monad.Reader
|
|
|
|
import Control.Monad.State
|
|
|
|
|
|
|
|
import Data.List (any)
|
|
|
|
import Data.Maybe (isJust)
|
|
|
|
|
|
|
|
import Foreign.C.String (castCCharToChar)
|
|
|
|
import Foreign.C.Types (CLong)
|
|
|
|
|
|
|
|
import Graphics.X11.Types
|
|
|
|
import Graphics.X11.Xlib.Atom
|
|
|
|
import Graphics.X11.Xlib.Display
|
|
|
|
import Graphics.X11.Xlib.Event
|
|
|
|
import Graphics.X11.Xlib.Extras
|
|
|
|
import Graphics.X11.Xlib.Misc
|
|
|
|
import Graphics.X11.Xlib.Types
|
|
|
|
|
|
|
|
import Text.Regex.TDFA
|
|
|
|
|
|
|
|
import System.Environment
|
|
|
|
import System.Posix.IO
|
|
|
|
import System.Posix.Signals
|
|
|
|
import System.Process
|
|
|
|
|
|
|
|
type WindowTitle = String
|
|
|
|
|
2020-04-01 12:57:39 -04:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- | Central State+Reader+IO Monad (I wonder where this idea came from...)
|
|
|
|
--
|
2020-04-01 12:59:35 -04:00
|
|
|
-- 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.
|
2020-04-01 12:57:39 -04:00
|
|
|
--
|
2020-04-01 12:59:35 -04:00
|
|
|
-- The State portion holds the xcape process handle (so we can kill it later)
|
2020-04-01 12:57:39 -04:00
|
|
|
-- and the current window title.
|
2020-03-31 23:15:43 -04:00
|
|
|
newtype XMan a = XMan (ReaderT XMConf (StateT XMState IO) a) deriving
|
|
|
|
(Functor, Monad, MonadIO, MonadState XMState, MonadReader XMConf)
|
|
|
|
|
|
|
|
instance Applicative XMan where
|
|
|
|
pure = return
|
|
|
|
(<*>) = ap
|
|
|
|
|
|
|
|
data XMState = XMState
|
|
|
|
{ currentTitle :: Maybe WindowTitle
|
|
|
|
, xcapeProcess :: Maybe ProcessHandle
|
|
|
|
}
|
|
|
|
|
|
|
|
data XMConf = XMConf
|
|
|
|
{ display :: Display
|
|
|
|
, theRoot :: Window
|
|
|
|
, netActiveWindow :: Atom
|
|
|
|
, netWMName :: Atom
|
|
|
|
, regexps :: [String]
|
|
|
|
, xcapeKeys :: String
|
|
|
|
}
|
|
|
|
|
2020-04-01 13:02:17 -04:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
|
2020-04-01 12:57:39 -04:00
|
|
|
main :: IO ()
|
|
|
|
main = getArgs >>= parse
|
2020-03-31 23:15:43 -04:00
|
|
|
|
2020-04-01 12:57:39 -04:00
|
|
|
-- | Given a list of arguments, either start the program or print the usage
|
2020-03-31 23:15:43 -04:00
|
|
|
parse :: [String] -> IO ()
|
|
|
|
parse [_] = usage
|
|
|
|
parse (x:rs) = initXMan x rs
|
|
|
|
parse _ = usage
|
|
|
|
|
2020-04-01 12:57:39 -04:00
|
|
|
-- | Print the usage and exit
|
2020-03-31 23:15:43 -04:00
|
|
|
usage :: IO ()
|
2020-04-01 12:57:39 -04:00
|
|
|
-- TODO produce relevant exit codes here
|
2020-03-31 23:15:43 -04:00
|
|
|
usage = putStrLn "xman XCAPE_KEYS REGEXP [[REGEXP]...]"
|
|
|
|
|
2020-04-01 12:57:39 -04:00
|
|
|
-- | Given a string of keys for xcape and a list of regular expressions to match
|
|
|
|
-- the window titles we care about, initialize the XMan monad and run the main
|
|
|
|
-- event loop.
|
2020-03-31 23:15:43 -04:00
|
|
|
initXMan :: String -> [String] -> IO ()
|
|
|
|
initXMan x r = do
|
2020-04-01 12:57:39 -04:00
|
|
|
-- ignore SIGCHLD so we don't produce zombie processes
|
2020-03-31 23:15:43 -04:00
|
|
|
void $ installHandler sigCHLD Ignore Nothing
|
|
|
|
dpy <- openDisplay ""
|
|
|
|
root <- rootWindow dpy $ defaultScreen dpy
|
|
|
|
naw <- internAtom dpy "_NET_ACTIVE_WINDOW" False
|
|
|
|
nwn <- internAtom dpy "_NET_WM_NAME" False
|
|
|
|
let cf = XMConf
|
|
|
|
{ display = dpy
|
|
|
|
, theRoot = root
|
|
|
|
, netActiveWindow = naw
|
|
|
|
, netWMName = nwn
|
|
|
|
, regexps = r
|
|
|
|
, xcapeKeys = x
|
|
|
|
}
|
|
|
|
st = XMState { currentTitle = Nothing, xcapeProcess = Nothing }
|
2020-04-01 12:57:39 -04:00
|
|
|
-- listen only for PropertyNotify events on the root window
|
2020-03-31 23:15:43 -04:00
|
|
|
allocaSetWindowAttributes $ \a -> do
|
|
|
|
set_event_mask a propertyChangeMask
|
|
|
|
changeWindowAttributes dpy root cWEventMask a
|
|
|
|
void $ allocaXEvent $ \e ->
|
|
|
|
runXMan cf st $ do
|
2020-04-01 12:57:39 -04:00
|
|
|
updateXCape -- set the initial state before entering main loop
|
2020-03-31 23:15:43 -04:00
|
|
|
forever $ handle =<< io (nextEvent dpy e >> getEvent e)
|
|
|
|
|
2020-04-01 12:57:39 -04:00
|
|
|
-- | 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
|
2020-03-31 23:15:43 -04:00
|
|
|
updateXCape :: XMan ()
|
|
|
|
updateXCape = do
|
|
|
|
dpy <- asks display
|
|
|
|
atom <- asks netActiveWindow
|
|
|
|
root <- asks theRoot
|
|
|
|
prop <- io $ getWindowProperty32 dpy atom root
|
|
|
|
case prop of
|
|
|
|
Just [aw] -> getTitle aw >>= updateTitle >> startOrKillXCape
|
|
|
|
_ -> return ()
|
|
|
|
|
2020-04-01 12:57:39 -04:00
|
|
|
-- | 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.
|
2020-03-31 23:15:43 -04:00
|
|
|
handle :: Event -> XMan ()
|
|
|
|
handle PropertyEvent { ev_atom = a } = do
|
|
|
|
atom <- asks netActiveWindow
|
|
|
|
when (a == atom) updateXCape
|
|
|
|
handle _ = return ()
|
|
|
|
|
2020-04-01 12:57:39 -04:00
|
|
|
-- | 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)
|
2020-03-31 23:15:43 -04:00
|
|
|
getTitle :: CLong -> XMan (Maybe WindowTitle)
|
|
|
|
getTitle winID = do
|
|
|
|
nwn <- asks netWMName
|
|
|
|
doMaybe [nwn, wM_NAME] $ getTitle' winID
|
|
|
|
where
|
|
|
|
doMaybe (x:xs) f = f x >>= (\r -> if isJust r then return r else doMaybe xs f)
|
|
|
|
doMaybe [] _ = return Nothing
|
|
|
|
|
2020-04-01 12:57:39 -04:00
|
|
|
-- | Get the title of a window given a window ID and an atom that may contain
|
|
|
|
-- the title
|
2020-03-31 23:15:43 -04:00
|
|
|
getTitle' :: CLong -> Atom -> XMan (Maybe WindowTitle)
|
|
|
|
getTitle' winID atom = do
|
|
|
|
dpy <- asks display
|
|
|
|
title' <- io $ permitBadWindow $ getWindowProperty8 dpy atom
|
|
|
|
$ fromIntegral winID
|
|
|
|
return $ fmap (fmap castCCharToChar) title'
|
|
|
|
|
2020-04-01 12:57:39 -04:00
|
|
|
-- | 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)
|
2020-03-31 23:15:43 -04:00
|
|
|
permitBadWindow :: IO a -> IO a
|
|
|
|
permitBadWindow action = do
|
|
|
|
handler <- mkXErrorHandler $ \_ e ->
|
|
|
|
getErrorEvent e >>= handleError >> return 0
|
|
|
|
original <- _xSetErrorHandler handler
|
|
|
|
res <- action
|
|
|
|
void $ _xSetErrorHandler original
|
|
|
|
return res
|
|
|
|
where
|
|
|
|
-- TODO also ignore badvalue errors?
|
|
|
|
handleError ErrorEvent { ev_error_code = t }
|
|
|
|
| fromIntegral t == badWindow = return ()
|
|
|
|
handleError _ = print "actual error"
|
|
|
|
|
2020-04-01 12:57:39 -04:00
|
|
|
-- | Given a window title that may exist, update the window title in XMan's
|
|
|
|
-- state
|
2020-03-31 23:15:43 -04:00
|
|
|
updateTitle :: Maybe WindowTitle -> XMan ()
|
|
|
|
updateTitle newTitle = modify (\s -> s { currentTitle = newTitle } )
|
|
|
|
|
2020-04-01 12:57:39 -04:00
|
|
|
-- | Start or stop xcape given the state in XMan
|
2020-03-31 23:15:43 -04:00
|
|
|
startOrKillXCape :: XMan ()
|
|
|
|
startOrKillXCape = do
|
2020-04-01 12:57:39 -04:00
|
|
|
-- TODO this is redundant
|
2020-03-31 23:15:43 -04:00
|
|
|
title <- gets currentTitle
|
|
|
|
case title of
|
|
|
|
Just t -> asks regexps >>= \r ->
|
|
|
|
if any (t =~) r then stopXCape else startXCape
|
|
|
|
Nothing -> startXCape
|
|
|
|
|
2020-04-01 12:59:35 -04:00
|
|
|
-- | Start xcape if it is not already running
|
2020-03-31 23:15:43 -04:00
|
|
|
startXCape :: XMan ()
|
|
|
|
startXCape = do
|
|
|
|
pID <- gets xcapeProcess
|
|
|
|
unless (isJust pID) $ do
|
|
|
|
x <- asks xcapeKeys
|
|
|
|
h <- io $ runXcape x
|
|
|
|
modify $ \s -> s { xcapeProcess = Just h }
|
|
|
|
io $ print "started xcape"
|
|
|
|
|
2020-04-01 12:59:35 -04:00
|
|
|
-- | Stop xcape if it is running
|
2020-03-31 23:15:43 -04:00
|
|
|
stopXCape :: XMan ()
|
|
|
|
stopXCape = do
|
|
|
|
pID <- gets xcapeProcess
|
|
|
|
forM_ pID $ \p -> do
|
|
|
|
io $ terminateProcess p
|
|
|
|
modify $ \s -> s { xcapeProcess = Nothing }
|
|
|
|
io $ print "stopped xcape"
|
|
|
|
|
2020-04-01 12:57:39 -04:00
|
|
|
-- | 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).
|
2020-03-31 23:15:43 -04:00
|
|
|
runXcape :: String -> IO ProcessHandle
|
|
|
|
runXcape keys = do
|
|
|
|
dn <- fmap UseHandle $ fdToHandle
|
|
|
|
=<< openFd "/dev/null" ReadOnly Nothing defaultFileFlags
|
2020-04-01 12:57:39 -04:00
|
|
|
-- TODO pass more arguments here? this hardcodes the timeout
|
2020-03-31 23:15:43 -04:00
|
|
|
let cp = proc "xcape" $ ["-d", "-t", "500", "-e"] ++ [keys]
|
|
|
|
(_, _, _, h) <- createProcess $ cp { std_err = dn, std_out = dn }
|
|
|
|
return h
|