packages feed

wild-bind-x11 (empty) → 0.1.0.1

raw patch · 14 files changed

+828/−0 lines, 14 filesdep +QuickCheckdep +X11dep +basesetup-changed

Dependencies added: QuickCheck, X11, base, containers, fold-debounce, hspec, stm, text, time, transformers, wild-bind, wild-bind-x11

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for wild-bind-x11++## 0.1.0.1  -- 2016-09-22++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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 <debug.ito@gmail.com>
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/WildBind/X11.hs view
@@ -0,0 +1,156 @@+-- |+-- Module: WildBind.X11+-- Description: X11-specific implementation for WildBind+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+-- +-- 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+                          }
+ src/WildBind/X11/Internal/Key.hs view
@@ -0,0 +1,168 @@+-- |+-- Module: WildBind.X11.Internal.Key+-- Description: types and functions related to key symbols and their conversion+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- __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
+ src/WildBind/X11/Internal/NotificationDebouncer.hs view
@@ -0,0 +1,94 @@+-- |+-- Module: WildBind.X11.Internal.NotificationDebouncer+-- Description: debouce X11 notification events+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- __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
+ src/WildBind/X11/Internal/Window.hs view
@@ -0,0 +1,106 @@+-- |+-- Module: WildBind.X11.Internal.Window+-- Description: types and functions related to X11 windows+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- __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"
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/WildBind/X11/Internal/KeySpec.hs view
@@ -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+
+ test/WildBind/X11/Internal/NotificationDebouncerSpec.hs view
@@ -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)+
+ test/WildBind/X11/TestUtil.hs view
@@ -0,0 +1,24 @@+-- |+-- Module: WildBind.X11.TestUtil+-- Description:  +-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- +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."
+ test/WildBind/X11Spec.hs view
@@ -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+
+ wild-bind-x11.cabal view
@@ -0,0 +1,69 @@+name:                   wild-bind-x11+version:                0.1.0.1+author:                 Toshio Ito <debug.ito@gmail.com>+maintainer:             Toshio Ito <debug.ito@gmail.com>+license:                BSD3+license-file:           LICENSE+synopsis:               X11-specific implementation for WildBind+description:            X11-specific implementation for WildBind. See <https://github.com/debug-ito/wild-bind>+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