diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for wild-bind-x11 + +## 0.1.0.1 -- 2016-09-22 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Toshio Ito + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Toshio Ito nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +# wild-bind-x11 + +X11 FrontEnd for WildBind. + +See https://github.com/debug-ito/wild-bind for WildBind in general. + +## Author + +Toshio Ito diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/WildBind/X11.hs b/src/WildBind/X11.hs new file mode 100644 --- /dev/null +++ b/src/WildBind/X11.hs @@ -0,0 +1,156 @@ +-- | +-- Module: WildBind.X11 +-- Description: X11-specific implementation for WildBind +-- Maintainer: Toshio Ito +-- +-- This module exports a 'FrontEnd' for X11 environments. +module WildBind.X11 + ( -- * X11 front-end + withFrontEnd, + -- * Windows in X11 + Window, + ActiveWindow, + -- ** Accessor functions for Window + winInstance, + winClass, + winName + ) where + +import Control.Applicative ((<$>), empty) +import Control.Concurrent (rtsSupportsBoundThreads) +import Control.Concurrent.STM (atomically, TChan, newTChanIO, tryReadTChan, writeTChan) +import Control.Exception (bracket, throwIO) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Cont (ContT(ContT), runContT) +import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) +import Control.Monad.Trans.List (ListT(ListT), runListT) +import Control.Monad.Trans.Writer (WriterT, execWriterT, tell) +import Data.Bits ((.|.)) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Graphics.X11.Xlib as Xlib + +import WildBind + ( FrontEnd(FrontEnd, frontDefaultDescription, frontSetGrab, frontUnsetGrab, frontNextEvent), + FrontEvent(FEInput,FEChange) + ) +import qualified WildBind.Description as WBD + +import WildBind.X11.Internal.Key (KeySymLike, ModifierLike, xEventToKeySymLike, xGrabKey, xUngrabKey) +import WildBind.X11.Internal.Window (ActiveWindow,getActiveWindow, Window, winInstance, winClass, winName, emptyWindow) +import qualified WildBind.X11.Internal.NotificationDebouncer as Ndeb + +-- | The X11 front-end +data X11Front k = + X11Front { x11Display :: Xlib.Display, + x11Debouncer :: Ndeb.Debouncer, + x11PrevActiveWindow :: IORef (Maybe ActiveWindow), + x11PendingEvents :: TChan (FrontEvent ActiveWindow k) + } + +x11RootWindow :: X11Front k -> Xlib.Window +x11RootWindow = Xlib.defaultRootWindow . x11Display + +x11PopPendingEvent :: X11Front k -> IO (Maybe (FrontEvent ActiveWindow k)) +x11PopPendingEvent f = atomically $ tryReadTChan $ x11PendingEvents f + +x11UnshiftPendingEvents :: X11Front k -> [FrontEvent ActiveWindow k] -> IO () +x11UnshiftPendingEvents f = atomically . mapM_ (writeTChan $ x11PendingEvents f) + +openMyDisplay :: IO Xlib.Display +openMyDisplay = Xlib.openDisplay "" + +-- | Initialize and obtain 'FrontEnd' for X11, and run the given +-- action. +-- +-- The X11 'FrontEnd' watches and provides 'ActiveWindow' as the +-- front-end state. 'ActiveWindow' keeps information about the window +-- currently active. As for the input type @i@, +-- 'WildBind.Input.NumPad.NumPadUnlocked' and +-- 'WildBind.Input.NumPad.NumPadLocked' are currently supported. +-- +-- Code using this function must be compiled __with @-threaded@ option enabled__ +-- in @ghc@. Otherwise, it aborts. +-- +-- Note that bound actions are executed when the key is released. That +-- way, you can deliver events to the window that originally has the +-- keyboard focus. +-- +withFrontEnd :: (KeySymLike i, ModifierLike i, WBD.Describable i) => (FrontEnd ActiveWindow i -> IO a) -> IO a +withFrontEnd = if rtsSupportsBoundThreads then impl else error_impl where + impl = runContT $ do + disp <- ContT $ bracket openMyDisplay Xlib.closeDisplay + notif_disp <- ContT $ bracket openMyDisplay Xlib.closeDisplay + debouncer <- ContT $ Ndeb.withDebouncer notif_disp + liftIO $ Xlib.selectInput disp (Xlib.defaultRootWindow disp) + (Xlib.substructureNotifyMask .|. Ndeb.xEventMask) + awin_ref <- liftIO $ newIORef Nothing + pending_events <- liftIO $ newTChanIO + liftIO $ Ndeb.notify debouncer + return $ makeFrontEnd $ X11Front disp debouncer awin_ref pending_events + error_impl _ = throwIO $ userError "You need to build with -threaded option when you use WildBind.X11.withFrontEnd function." + +tellElem :: Monad m => a -> WriterT [a] m () +tellElem a = tell [a] + +convertEvent :: (KeySymLike k) => Xlib.Display -> Ndeb.Debouncer -> Xlib.XEventPtr -> ListT IO (FrontEvent ActiveWindow k) +convertEvent disp deb xev = ListT $ execWriterT $ convertEventWriter where + convertEventWriter :: KeySymLike k => WriterT [FrontEvent ActiveWindow k] IO () + convertEventWriter = do + xtype <- liftIO $ Xlib.get_EventType xev + let is_key_event = xtype == Xlib.keyRelease + is_awin_event = xtype == Xlib.configureNotify || xtype == Xlib.destroyNotify + tellChangeEvent = (tellElem . FEChange) =<< (liftIO $ getActiveWindow disp) + is_deb_event <- liftIO $ Ndeb.isDebouncedEvent deb xev + if is_key_event + then do + tellChangeEvent + (maybe (return ()) tellElem) =<< (liftIO $ runMaybeT (FEInput <$> xEventToKeySymLike xev)) + else if is_deb_event + then tellChangeEvent + else if is_awin_event + then liftIO (Ndeb.notify deb) >> return () + else return () + +filterUnchangedEvent :: X11Front k -> FrontEvent ActiveWindow k -> ListT IO () +filterUnchangedEvent front (FEChange new_state) = do + m_old_state <- liftIO $ readIORef $ x11PrevActiveWindow front + case m_old_state of + Nothing -> return () + Just old_state -> if new_state == old_state then empty else return () +filterUnchangedEvent _ _ = return () + +updateState :: X11Front k -> FrontEvent ActiveWindow k -> IO () +updateState front fev = case fev of + (FEInput _) -> return () + (FEChange s) -> writeIORef (x11PrevActiveWindow front) (Just s) + +grabDef :: (KeySymLike k, ModifierLike k) => (Xlib.Display -> Xlib.Window -> k -> IO ()) -> X11Front k -> k -> IO () +grabDef func front key = func (x11Display front) (x11RootWindow front) key + +nextEvent :: (KeySymLike k) => X11Front k -> IO (FrontEvent ActiveWindow k) +nextEvent handle = loop where + loop = do + mpending <- x11PopPendingEvent handle + case mpending of + Just eve -> return eve + Nothing -> nextEventFromX11 + nextEventFromX11 = Xlib.allocaXEvent $ \xev -> do + Xlib.nextEvent (x11Display handle) xev + got_events <- processEvents xev + case got_events of + [] -> loop + (eve : rest) -> do + x11UnshiftPendingEvents handle rest + return eve + processEvents xev = runListT $ do + fevent <- convertEvent (x11Display handle) (x11Debouncer handle) xev + filterUnchangedEvent handle fevent + liftIO $ updateState handle fevent + return fevent + +makeFrontEnd :: (KeySymLike k, ModifierLike k, WBD.Describable k) => X11Front k -> FrontEnd ActiveWindow k +makeFrontEnd f = FrontEnd { frontDefaultDescription = WBD.describe, + frontSetGrab = grabDef xGrabKey f, + frontUnsetGrab = grabDef xUngrabKey f, + frontNextEvent = nextEvent f + } diff --git a/src/WildBind/X11/Internal/Key.hs b/src/WildBind/X11/Internal/Key.hs new file mode 100644 --- /dev/null +++ b/src/WildBind/X11/Internal/Key.hs @@ -0,0 +1,168 @@ +-- | +-- Module: WildBind.X11.Internal.Key +-- Description: types and functions related to key symbols and their conversion +-- Maintainer: Toshio Ito +-- +-- __This is an internal module. Package users should not rely on this.__ +module WildBind.X11.Internal.Key + ( -- * Conversion between key types + KeySymLike(..), + xEventToKeySymLike, + -- * Key grabs + ModifierLike, + xGrabKey, xUngrabKey + ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad.Trans.Maybe (MaybeT(MaybeT)) +import Data.Bits ((.|.)) +import qualified Data.Bits as Bits +import qualified Data.Map as M +import Data.Maybe (mapMaybe, listToMaybe) +import qualified Graphics.X11.Xlib as Xlib +import qualified Graphics.X11.Xlib.Extras as XlibE + +import qualified WildBind.Input.NumPad as NumPad + +-- | Convertible to/from Xlib's 'KeySym' +-- +-- prop> fromKeySym . toKeySym == Just +class KeySymLike k where + fromKeySym :: Xlib.KeySym -> Maybe k + toKeySym :: k -> Xlib.KeySym + +instance KeySymLike Xlib.KeySym where + fromKeySym = Just + toKeySym = id + +fromKeySymDef :: (Bounded k, Enum k) => (k -> Xlib.KeySym) -> Xlib.KeySym -> Maybe k +fromKeySymDef to_conv ks = M.lookup ks $ M.fromList $ map (\n -> (to_conv n, n)) $ enumFromTo minBound maxBound + +instance KeySymLike NumPad.NumPadUnlocked where + fromKeySym = fromKeySymDef toKeySym + toKeySym n = case n of + NumPad.NumUp -> Xlib.xK_KP_Up + NumPad.NumDown -> Xlib.xK_KP_Down + NumPad.NumLeft -> Xlib.xK_KP_Left + NumPad.NumRight -> Xlib.xK_KP_Right + NumPad.NumHome -> Xlib.xK_KP_Home + NumPad.NumPageUp -> Xlib.xK_KP_Page_Up + NumPad.NumPageDown -> Xlib.xK_KP_Page_Down + NumPad.NumEnd -> Xlib.xK_KP_End + NumPad.NumCenter -> Xlib.xK_KP_Begin + NumPad.NumInsert -> Xlib.xK_KP_Insert + NumPad.NumDelete -> Xlib.xK_KP_Delete + NumPad.NumEnter -> Xlib.xK_KP_Enter + NumPad.NumDivide -> Xlib.xK_KP_Divide + NumPad.NumMulti -> Xlib.xK_KP_Multiply + NumPad.NumMinus -> Xlib.xK_KP_Subtract + NumPad.NumPlus -> Xlib.xK_KP_Add + +instance KeySymLike NumPad.NumPadLocked where + -- Xlib handles the [(.) (Delete)] key in a weird way. In the input + -- event, it brings XK_KP_Decimal when NumLock enabled, XK_KP_Delete + -- when NumLock disabled. However, XKeysymToKeycode() function won't + -- return the correct keycode for XK_KP_Decimal. (I'm not sure how + -- much this behavior depends on user's environment...) As a + -- workaround in this instance, we map NumLPeriod -> XK_KP_Delete, + -- but in the reverse map, we also respond to XK_KP_Decimal. + fromKeySym ks | ks == Xlib.xK_KP_Decimal = Just NumPad.NumLPeriod + | otherwise = (fromKeySymDef toKeySym) ks + toKeySym n = case n of + NumPad.NumL0 -> Xlib.xK_KP_0 + NumPad.NumL1 -> Xlib.xK_KP_1 + NumPad.NumL2 -> Xlib.xK_KP_2 + NumPad.NumL3 -> Xlib.xK_KP_3 + NumPad.NumL4 -> Xlib.xK_KP_4 + NumPad.NumL5 -> Xlib.xK_KP_5 + NumPad.NumL6 -> Xlib.xK_KP_6 + NumPad.NumL7 -> Xlib.xK_KP_7 + NumPad.NumL8 -> Xlib.xK_KP_8 + NumPad.NumL9 -> Xlib.xK_KP_9 + NumPad.NumLDivide -> Xlib.xK_KP_Divide + NumPad.NumLMulti -> Xlib.xK_KP_Multiply + NumPad.NumLMinus -> Xlib.xK_KP_Subtract + NumPad.NumLPlus -> Xlib.xK_KP_Add + NumPad.NumLEnter -> Xlib.xK_KP_Enter + NumPad.NumLPeriod -> Xlib.xK_KP_Delete + -- XKeysymToKeycode() didn't return the correct keycode for XK_KP_Decimal in numpaar code... + + +-- | Extract the KeySym associated with the XEvent. +xEventToKeySym :: Xlib.XEventPtr -> MaybeT IO Xlib.KeySym +xEventToKeySym xev = MaybeT (fst <$> (Xlib.lookupString $ Xlib.asKeyEvent xev)) + +-- | Extract the 'KeySymLike' associated with the XEvent. +xEventToKeySymLike :: KeySymLike k => Xlib.XEventPtr -> MaybeT IO k +xEventToKeySymLike xev = (MaybeT . return . fromKeySym) =<< xEventToKeySym xev + +-- | Internal abstract of key modifiers +data ModifierKey = ModNumLock deriving (Eq,Ord,Show,Bounded,Enum) + +-- | Convertible into a set of Modifiers. +class ModifierLike k where + toModifiers :: k -> [ModifierKey] + +instance ModifierLike NumPad.NumPadUnlocked where + toModifiers _ = [] + +instance ModifierLike NumPad.NumPadLocked where + toModifiers _ = [ModNumLock] + +-- | Convert a 'KeySymLike' into a KeyCode and ButtonMask for grabbing. +xKeyCode :: (KeySymLike k, ModifierLike k) => Xlib.Display -> k -> IO (Xlib.KeyCode, Xlib.ButtonMask) +xKeyCode disp key = (,) <$> Xlib.keysymToKeycode disp (toKeySym key) <*> createMask disp (toModifiers key) + +createMask :: Xlib.Display -> [ModifierKey] -> IO Xlib.ButtonMask +createMask _ [] = return 0 +createMask disp (modkey:rest) = do + modifier_index <- fromIntegral <$> getXModifier disp modkey + (Bits.shift 1 modifier_index .|.) <$> createMask disp rest + +type XModifierMap = [(Xlib.Modifier, [Xlib.KeyCode])] + +getXModifierMap :: Xlib.Display -> IO XModifierMap +getXModifierMap = XlibE.getModifierMapping + +-- | Look up modifier for the given 'ModifierKey'. This is necessary +-- especially for NumLock modifier, because it is highly dynamic in +-- KeyCode realm. If no modifier is associated with the 'ModifierKey', +-- it returns 0. +-- +-- c.f: +-- +-- * grab_key.c of xbindkey package +-- * http://tronche.com/gui/x/xlib/input/keyboard-grabbing.html +-- * http://tronche.com/gui/x/xlib/input/keyboard-encoding.html +lookupXModifier :: Xlib.Display -> XModifierMap -> ModifierKey -> IO Xlib.Modifier +lookupXModifier disp xmmap ModNumLock = do + numlock_code <- Xlib.keysymToKeycode disp Xlib.xK_Num_Lock + return $ maybe 0 id $ listToMaybe $ mapMaybe (lookupXMod' numlock_code) xmmap + where + lookupXMod' key_code (xmod, codes) = if key_code `elem` codes + then Just xmod + else Nothing + +getXModifier :: Xlib.Display -> ModifierKey -> IO Xlib.Modifier +getXModifier disp key = do + xmmap <- getXModifierMap disp + lookupXModifier disp xmmap key + +----- + +-- | Grab the specified key on the specified window. The key is +-- captured from now on, so the window won't get that. +xGrabKey :: (KeySymLike k, ModifierLike k) => Xlib.Display -> Xlib.Window -> k -> IO () +xGrabKey disp win key = do + (code, mask) <- xKeyCode disp key + Xlib.grabKey disp code mask win False Xlib.grabModeAsync Xlib.grabModeAsync + +-- grabKey throws an exception if that key for the window is already +-- grabbed by another X client. For now, we don't handle that +-- exception. + +-- | Release the grab on the specified key. +xUngrabKey :: (KeySymLike k, ModifierLike k) => Xlib.Display -> Xlib.Window -> k -> IO () +xUngrabKey disp win key = do + (code, mask) <- xKeyCode disp key + Xlib.ungrabKey disp code mask win diff --git a/src/WildBind/X11/Internal/NotificationDebouncer.hs b/src/WildBind/X11/Internal/NotificationDebouncer.hs new file mode 100644 --- /dev/null +++ b/src/WildBind/X11/Internal/NotificationDebouncer.hs @@ -0,0 +1,94 @@ +-- | +-- Module: WildBind.X11.Internal.NotificationDebouncer +-- Description: debouce X11 notification events +-- Maintainer: Toshio Ito +-- +-- __This is an internal module. End-users should not rely on it.__ +-- +-- WildBind.X11 module receives some notification events to update the +-- current state of the desktop (usually it is the active +-- window). However, there are some problems in updating the state +-- every time it receives a notification event. +-- +-- * Notification events can come too fast. It can make siginificant +-- overhead to the system. +-- +-- * The active window obtained at the very moment a notification +-- arrives is often unstable. It can become invalid soon. In +-- addition, Xlib is notorious for being bad at handling that kind +-- of exceptions (it just crashes the entire process and it's +-- practically impossible to catch the exceptions). +-- +-- Personally, I have experienced even weirder behaviors when I did +-- some X11 operations at arrivals of notification events. +-- +-- * Sometimes I could not obtain the current active window. Instead, +-- I ended up with getting the previous active window. +-- +-- * Sometimes GetWindowProperty blocked forever. +-- +-- So, as a workaround, we debounce the raw notification events and +-- generate a ClientMessage X11 event. When we get the ClientMessage, +-- we update the state. + +-- Toshio's personal note: 2015/05/06, 2010/12/05 - 19 + +module WildBind.X11.Internal.NotificationDebouncer + ( Debouncer, + withDebouncer, + notify, + xEventMask, + isDebouncedEvent + ) where + +import Control.Exception (bracket) +import qualified Control.FoldDebounce as Fdeb +import qualified Graphics.X11.Xlib as Xlib +import qualified Graphics.X11.Xlib.Extras as XlibE + +data Debouncer = Debouncer + { ndTrigger :: Fdeb.Trigger () (), + ndMessageType :: Xlib.Atom + } + +-- | Create a Debouncer and run the specified action. +withDebouncer :: Xlib.Display -> (Debouncer -> IO a) -> IO a +withDebouncer disp action = do + mtype <- Xlib.internAtom disp "_WILDBIND_NOTIFY_CHANGE" False + bracket (newTrigger disp mtype) (Fdeb.close) $ \trigger -> action (Debouncer trigger mtype) + +-- | Notify the 'Debouncer' that a notification event arrives. After a +-- while, the 'Debouncer' emits a ClientMessage X11 event. +notify :: Debouncer -> IO () +notify deb = Fdeb.send (ndTrigger deb) () + +debounceDelay :: Int +debounceDelay = 200000 + +newTrigger :: Xlib.Display -> Xlib.Atom -> IO (Fdeb.Trigger () ()) +newTrigger disp mtype = Fdeb.new (Fdeb.forVoid $ sendClientMessage disp mtype) + Fdeb.def { Fdeb.delay = debounceDelay, Fdeb.alwaysResetTimer = True } + +-- | The Xlib EventMask for sending the ClientMessage. You have to +-- select this mask by 'selectInput' function to receive the +-- ClientMessage. +xEventMask :: Xlib.EventMask +xEventMask = Xlib.substructureNotifyMask + +sendClientMessage :: Xlib.Display -> Xlib.Atom -> IO () +sendClientMessage disp mtype = Xlib.allocaXEvent $ \xev -> do + let root_win = Xlib.defaultRootWindow disp + XlibE.setEventType xev Xlib.clientMessage + XlibE.setClientMessageEvent xev root_win mtype 8 0 0 + Xlib.sendEvent disp root_win False xEventMask xev + Xlib.flush disp + +-- | Check if the given event is the debounced ClientMessage X11 +-- event. +isDebouncedEvent :: Debouncer -> Xlib.XEventPtr -> IO Bool +isDebouncedEvent deb xev = do + ev <- XlibE.getEvent xev + let exp_type = ndMessageType deb + case ev of + XlibE.ClientMessageEvent _ _ _ _ _ got_type _ -> return (got_type == exp_type) + _ -> return False diff --git a/src/WildBind/X11/Internal/Window.hs b/src/WildBind/X11/Internal/Window.hs new file mode 100644 --- /dev/null +++ b/src/WildBind/X11/Internal/Window.hs @@ -0,0 +1,106 @@ +-- | +-- Module: WildBind.X11.Internal.Window +-- Description: types and functions related to X11 windows +-- Maintainer: Toshio Ito +-- +-- __This is an internal module. Package users should not rely on this.__ +module WildBind.X11.Internal.Window + ( -- * The 'Window' data type + Window, + ActiveWindow, + emptyWindow, + -- * Accessor functions for 'Window' + winInstance, + winClass, + winName, + -- * Functions + getActiveWindow + ) where + +import Control.Applicative ((<$>),(<|>),empty) +import Control.Monad (guard) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe (MaybeT(MaybeT),runMaybeT) +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Graphics.X11.Xlib as Xlib +import qualified Graphics.X11.Xlib.Extras as XlibE + +-- | Information about window. You can inspect properties 'winInstance' +-- and 'winClass' by @wmctrl@ command. +-- +-- > $ wmctrl -lx +-- > 0x01400004 -1 xfce4-panel.Xfce4-panel mydesktop xfce4-panel +-- > 0x01800003 -1 xfdesktop.Xfdesktop mydesktop desktop +-- > 0x03800004 0 xfce4-terminal.Xfce4-terminal mydesktop Terminal - toshio@mydesktop - byobu +-- > 0x03a000a7 0 emacs.Emacs23 mydesktop emacs@mydesktop +-- > 0x03e010fc 0 Navigator.Firefox mydesktop debug-ito (Toshio Ito) - Mozilla Firefox +-- > 0x02600003 0 totem.Totem mydesktop Movie Player +-- +-- In the above example, the third column shows @winInstance.winClass@. +data Window = + Window + { winInstance :: Text, -- ^ name of the application instance (part of @WM_CLASS@ property) + winClass :: Text, -- ^ name of the application class (part of @WM_CLASS@ property) + winName :: Text -- ^ what's shown in the title bar + } deriving (Eq,Ord,Show) + +-- | Use this type especially when the 'Window' is active. +type ActiveWindow = Window + +-- | An empty Window instance used for fallback and/or default value. +emptyWindow :: Window +emptyWindow = Window "" "" "" + +-- | Get currently active 'Window'. +getActiveWindow :: Xlib.Display -> IO ActiveWindow +getActiveWindow disp = maybe emptyWindow id <$> runMaybeT getActiveWindowM where + getActiveWindowM = do + awin <- xGetActiveWindow disp + guard (awin /= 0) -- sometimes X11 returns 0 (NULL) as a window ID, which I think is always invalid + name <- xGetWindowName disp awin + class_hint <- liftIO $ xGetClassHint disp awin + return $ (uncurry Window) class_hint name + +-- | Check whether specified feature is supported by the window +-- manager(?) Port of libxdo's @_xdo_ewmh_is_supported()@ function. +ewmhIsSupported :: Xlib.Display -> String -> IO Bool +ewmhIsSupported disp feature_str = do + req <- Xlib.internAtom disp "_NET_SUPPORTED" False + feature <- Xlib.internAtom disp feature_str False + result <- XlibE.getWindowProperty32 disp req (Xlib.defaultRootWindow disp) + case result of + Nothing -> return False + Just atoms -> return $ any ((feature ==) . fromIntegral) atoms + +-- | Get X11 Window handle for the active window. Port of libxdo's +-- @xdo_window_get_active()@ function. +xGetActiveWindow :: Xlib.Display -> MaybeT IO Xlib.Window +xGetActiveWindow disp = do + let req_str = "_NET_ACTIVE_WINDOW" + supported <- liftIO $ ewmhIsSupported disp req_str + if not supported + then empty + else do + req <- liftIO $ Xlib.internAtom disp req_str False + result <- MaybeT $ XlibE.getWindowProperty32 disp req (Xlib.defaultRootWindow disp) + case result of + [] -> empty + (val:_) -> return $ fromIntegral val + + +xGetClassHint :: Xlib.Display -> Xlib.Window -> IO (Text, Text) +xGetClassHint disp win = do + hint <- XlibE.getClassHint disp win + return (Text.pack $ XlibE.resName hint, Text.pack $ XlibE.resClass hint) + +xGetTextProperty :: Xlib.Display -> Xlib.Window -> String -> MaybeT IO Text +xGetTextProperty disp win prop_name = do + req <- liftIO $ Xlib.internAtom disp prop_name False + Text.pack <$> MaybeT (listToMaybe <$> (XlibE.wcTextPropertyToTextList disp =<< XlibE.getTextProperty disp win req)) + +-- | Get the window name for the X11 window. The window name refers to +-- @_NET_WM_NAME@ or @WM_NAME@. +xGetWindowName :: Xlib.Display -> Xlib.Window -> MaybeT IO Text +xGetWindowName disp win = xGetTextProperty disp win "_NET_WM_NAME" <|> xGetTextProperty disp win "WM_NAME" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/WildBind/X11/Internal/KeySpec.hs b/test/WildBind/X11/Internal/KeySpec.hs new file mode 100644 --- /dev/null +++ b/test/WildBind/X11/Internal/KeySpec.hs @@ -0,0 +1,34 @@ +module WildBind.X11.Internal.KeySpec (spec) where + +import Test.Hspec +import Test.QuickCheck (Arbitrary(arbitrary), arbitraryBoundedEnum, property) + +import WildBind.Input.NumPad (NumPadUnlocked, NumPadLocked) +import WildBind.X11.Internal.Key (KeySymLike(fromKeySym,toKeySym)) + +newtype NumPadUnlocked' = + NumPadUnlocked' { unwrapNumPadUnlocked :: NumPadUnlocked } + deriving Show + +instance Arbitrary NumPadUnlocked' where + arbitrary = fmap NumPadUnlocked' arbitraryBoundedEnum + +newtype NumPadLocked' = + NumPadLocked' { unwrapNumPadLocked :: NumPadLocked } + deriving Show + +instance Arbitrary NumPadLocked' where + arbitrary = fmap NumPadLocked' arbitraryBoundedEnum + +spec :: Spec +spec = do + spec_keySymLike "NumPadUnlocked" unwrapNumPadUnlocked + spec_keySymLike "NumPadLocked" unwrapNumPadLocked + +spec_keySymLike :: (Arbitrary k', Show k', KeySymLike k, Eq k) => String -> (k' -> k) -> Spec +spec_keySymLike label unwrapper = describe label $ do + it "is a KeySymLike" $ property $ (prop_keySymLike . unwrapper) + +prop_keySymLike :: (KeySymLike k, Eq k) => k -> Bool +prop_keySymLike key = (fromKeySym . toKeySym) key == Just key + diff --git a/test/WildBind/X11/Internal/NotificationDebouncerSpec.hs b/test/WildBind/X11/Internal/NotificationDebouncerSpec.hs new file mode 100644 --- /dev/null +++ b/test/WildBind/X11/Internal/NotificationDebouncerSpec.hs @@ -0,0 +1,50 @@ +module WildBind.X11.Internal.NotificationDebouncerSpec (spec) where + +import Test.Hspec + +import qualified Graphics.X11.Xlib as Xlib +import qualified Graphics.X11.Xlib.Extras as XlibE +import qualified WildBind.X11.Internal.NotificationDebouncer as Deb + +import WildBind.X11.TestUtil (checkIfX11Available) + +spec :: Spec +spec = checkIfX11Available $ do + describe "notify" $ do + it "should create an X event that passes isDebouncedEvent" $ do + disp <- Xlib.openDisplay "" + Xlib.selectInput disp (Xlib.defaultRootWindow disp) Deb.xEventMask + deb_disp <- Xlib.openDisplay "" + Deb.withDebouncer deb_disp $ \deb -> do + Deb.notify deb + (Xlib.allocaXEvent $ waitForDebouncedEvent deb disp) `shouldReturn` True + +-- showDisplay :: Xlib.Display -> String +-- showDisplay disp = show disp ++ "(conn number = "++ show (Xlib.connectionNumber disp) ++")" + +waitForDebouncedEvent :: Deb.Debouncer -> Xlib.Display -> Xlib.XEventPtr -> IO Bool +waitForDebouncedEvent deb disp xev = doit 0 where + doit :: Int -> IO Bool + doit count = do + Xlib.nextEvent disp xev + ret <- Deb.isDebouncedEvent deb xev + showXEvent disp xev >>= \xev_str -> putStrLn ("Got event: " ++ xev_str) + if ret || (count > 20) + then return ret + else doit (count + 1) + + +showAtom :: Xlib.Display -> Xlib.Atom -> IO String +showAtom disp atom = do + name <- Xlib.getAtomName disp atom + return (show atom ++ " ("++ show name ++")") + +showXEvent :: Xlib.Display -> Xlib.XEventPtr -> IO String +showXEvent disp xev = do + ev <- XlibE.getEvent xev + case ev of + XlibE.ClientMessageEvent _ _ _ _ _ got_type _ -> do + got_name <- showAtom disp got_type + return (show ev ++ ", message type = " ++ got_name) + _ -> return (show ev) + diff --git a/test/WildBind/X11/TestUtil.hs b/test/WildBind/X11/TestUtil.hs new file mode 100644 --- /dev/null +++ b/test/WildBind/X11/TestUtil.hs @@ -0,0 +1,24 @@ +-- | +-- Module: WildBind.X11.TestUtil +-- Description: +-- Maintainer: Toshio Ito +-- +-- +module WildBind.X11.TestUtil + ( checkIfX11Available + ) where + +import Control.Monad (when) +import Control.Applicative ((<$>)) +import System.Environment (lookupEnv) +import Test.Hspec + +isDisplaySet :: IO Bool +isDisplaySet = exists <$> lookupEnv "DISPLAY" where + exists (Just v) = v /= "" + exists _ = False + +checkIfX11Available :: Spec -> Spec +checkIfX11Available = before $ do + available <- isDisplaySet + when (not available) $ pendingWith "DISPLAY env is not set. Skipped." diff --git a/test/WildBind/X11Spec.hs b/test/WildBind/X11Spec.hs new file mode 100644 --- /dev/null +++ b/test/WildBind/X11Spec.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, CPP #-} +module WildBind.X11Spec (main, spec) where + +import Control.Applicative ((<$>)) +import Control.Exception (finally) +import Data.Time.Clock (getCurrentTime, diffUTCTime) +import System.IO (hPutStrLn,stderr) +import Test.Hspec + +import WildBind + ( FrontEnd(frontSetGrab, frontUnsetGrab, frontNextEvent), + FrontEvent(FEChange,FEInput) + ) +import qualified WildBind.Input.NumPad as NumPad +import WildBind.X11 (withFrontEnd, ActiveWindow) + +import WildBind.X11.TestUtil (checkIfX11Available) + +main :: IO () +main = hspec spec + +maybeRun :: Expectation -> Expectation +#ifdef TEST_NUMPAD_INTERACTIVE +maybeRun = id +#else +maybeRun _ = pendingWith ("You need to set test_numpad_interactive flag to run the test.") +#endif + + +p :: String -> IO () +p = hPutStrLn stderr . ("--- " ++) + +grabExp :: forall i + . (Bounded i, Enum i, Show i, Eq i) + => FrontEnd ActiveWindow i -> i -> Expectation +grabExp front grab_input = grabExpMain `finally` releaseAll where + grabExpMain = do + frontSetGrab front grab_input + p ("Press some numpad keys (grab="++ show grab_input ++")..") + ev <- frontNextEvent front :: IO (FrontEvent ActiveWindow i) + p ("Got event: " ++ show ev) + case ev of + FEChange _ -> expectationFailure "FEChange is caught. not expected" + FEInput got -> do + got `shouldBe` grab_input + releaseAll = mapM_ (frontUnsetGrab front) (enumFromTo minBound maxBound :: [i]) + +grabCase :: forall i . (Bounded i, Enum i, Show i, Eq i) => FrontEnd ActiveWindow i -> Expectation +grabCase front = do + _ <- frontNextEvent front :: IO (FrontEvent ActiveWindow i) -- discard the first FEChange event. + mapM_ (grabExp front) (enumFromTo minBound maxBound :: [i]) + +stopWatchMsec :: IO a -> IO (a, Int) +stopWatchMsec act = do + start <- getCurrentTime + ret <- act + end <- getCurrentTime + return (ret, floor ((diffUTCTime end start) * 1000)) + +spec :: Spec +spec = checkIfX11Available $ do + describe "X11Front" $ do + it "should first emit FEChange event when initialized" $ withFrontEnd $ \f -> do + p "try to get the first event..." + (ev, time) <- stopWatchMsec $ frontNextEvent f :: IO (FrontEvent ActiveWindow NumPad.NumPadUnlocked, Int) + time `shouldSatisfy` (< 500) + case ev of + FEChange _ -> return () + _ -> expectationFailure ("FEChange is expected, but got " ++ show ev) + it "should NOT throw exception when it tries to double-grab in the same process" $ withFrontEnd $ \f1 -> + withFrontEnd $ \f2 -> do + frontSetGrab f1 NumPad.NumLeft `shouldReturn` () + frontSetGrab f2 NumPad.NumLeft `shouldReturn` () + describe "X11Front - NumPadUnlocked" $ do + it "should grab/ungrab keys" $ maybeRun $ withFrontEnd $ \(f :: FrontEnd ActiveWindow NumPad.NumPadUnlocked) -> do + grabCase f + describe "X11Front - NumPadLocked" $ do + it "should grab/ungrab keys" $ maybeRun $ withFrontEnd $ \(f :: FrontEnd ActiveWindow NumPad.NumPadLocked) -> do + grabCase f + diff --git a/wild-bind-x11.cabal b/wild-bind-x11.cabal new file mode 100644 --- /dev/null +++ b/wild-bind-x11.cabal @@ -0,0 +1,69 @@ +name: wild-bind-x11 +version: 0.1.0.1 +author: Toshio Ito +maintainer: Toshio Ito +license: BSD3 +license-file: LICENSE +synopsis: X11-specific implementation for WildBind +description: X11-specific implementation for WildBind. See +category: UserInterface +cabal-version: >= 1.10 +build-type: Simple +extra-source-files: README.md, ChangeLog.md +homepage: https://github.com/debug-ito/wild-bind +bug-reports: https://github.com/debug-ito/wild-bind/issues + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall -fno-warn-unused-imports + default-extensions: TypeSynonymInstances, OverloadedStrings, MultiParamTypeClasses, FlexibleInstances + exposed-modules: WildBind.X11, + WildBind.X11.Internal.Key, + WildBind.X11.Internal.Window, + WildBind.X11.Internal.NotificationDebouncer +-- other-modules: + build-depends: base >=4.6 && <5.0, + wild-bind >=0.1.0 && <0.2, + text >=1.2.0 && <1.3, + X11 >=1.6.1 && <1.7, + containers >=0.5.0 && <0.6, + transformers >=0.3.0 && <0.6, + fold-debounce >=0.2.0 && <0.3, + stm >=2.4.2 && <2.5 + +-- executable wild-bind-x11 +-- default-language: Haskell2010 +-- hs-source-dirs: src +-- main-is: Main.hs +-- ghc-options: -Wall -fno-warn-unused-imports +-- -- other-modules: +-- -- other-extensions: +-- build-depends: base >=4 && <5 + +flag test-numpad-interactive + description: Run tests that require the user to interact with the test script via a numpad. + default: False + +test-suite spec + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + ghc-options: -Wall -fno-warn-unused-imports -threaded "-with-rtsopts=-M512m -N" + if flag(test-numpad-interactive) + cpp-options: -DTEST_NUMPAD_INTERACTIVE + main-is: Spec.hs + other-extensions: FlexibleContexts, ScopedTypeVariables, CPP + other-modules: WildBind.X11Spec, + WildBind.X11.Internal.KeySpec, + WildBind.X11.Internal.NotificationDebouncerSpec, + WildBind.X11.TestUtil + build-depends: base, wild-bind-x11, + wild-bind, X11, + hspec >=2.1.7 && <2.3, + QuickCheck >=2.6 && <3.0, + time >=1.5.0 && <1.7 + +source-repository head + type: git + location: https://github.com/debug-ito/wild-bind.git