wild-bind-x11 0.1.0.7 → 0.2.0.0

raw patch · 14 files changed

+1523/−294 lines, 14 filesdep +asyncdep +mtldep +semigroupsdep −QuickCheckdep ~textdep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: async, mtl, semigroups

Dependencies removed: QuickCheck

Dependency ranges changed: text, transformers

API changes (from Hackage documentation)

Files

• ChangeLog.md +14/−0
• src/WildBind/X11.hs +40/−137
• src/WildBind/X11/Emulate.hs +100/−0
• src/WildBind/X11/Emulate/Example.hs +35/−0
• src/WildBind/X11/Internal/FrontEnd.hs +220/−0
• src/WildBind/X11/Internal/GrabMan.hs +128/−0
• src/WildBind/X11/Internal/Key.hs +329/−77
• src/WildBind/X11/Internal/Window.hs +32/−6
• src/WildBind/X11/KeySym.hs +371/−0
• test/WildBind/X11/EmulateSpec.hs +106/−0
• test/WildBind/X11/Internal/KeySpec.hs +0/−34
• test/WildBind/X11/TestUtil.hs +12/−1
• test/WildBind/X11Spec.hs +116/−26
• wild-bind-x11.cabal +20/−13

@@ -1,6 +1,20 @@ # Revision history for wild-bind-x11 +## 0.2.0.0  -- 2018-01-01++* Fix crash when some kind of window (e.g. xdvi) is active. +* Remove `KeySymLike` and `ModifierLike` classes.+* Add `XMod`, `KeyEventType`, `XKeyEvent`, `X11Front`  types.+* Add `XKeyInput`, `ToXKeyEvent` classes.+* Add `withX11Front`, `makeFrontEnd`, `press`, `release`,+  `addXMod`, `shift`, `alt`, `ctrl`, `super`, `defaultRootWindow` functions.+* Add `WildBind.X11.Emulate`, `WildBind.X11.Emulate.Example` and `WildBind.X11.KeySym` modules.+* Changed signature of `xGrabKey` and `xUngrabKey` functions.++ ## 0.1.0.7  -- 2017-07-21++* Confirmed build with `time-1.8`.  ## 0.1.0.6  -- 2017-02-10 

@@ -7,150 +7,53 @@ module WildBind.X11        ( -- * X11 front-end          withFrontEnd,+         XKeyInput(..),          -- * Windows in X11          Window,          ActiveWindow,-         -- ** Accessor functions for Window+         -- ** Getters          winInstance,          winClass,-         winName+         winName,+         -- * Keys in X11+         XKeyEvent(..),+         XMod(..),+         KeyEventType(..),+         ToXKeyEvent(..),+         -- ** Setters+         press,+         release,+         shift,+         ctrl,+         alt,+         super,+         addXMod,+         -- * X11Front+         X11Front,+         withX11Front,+         makeFrontEnd,+         defaultRootWindow        ) 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 WildBind (FrontEnd) 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+import WildBind.X11.Internal.FrontEnd+  ( X11Front,+    withFrontEnd,+    withX11Front,+    makeFrontEnd,+    defaultRootWindow+  )+import WildBind.X11.Internal.Key+  ( XKeyInput(..),+    XKeyEvent(..),+    XMod(..),+    ToXKeyEvent(..),+    KeyEventType(..),+    press, release,+    addXMod,+    shift, ctrl, alt, super+  )+import WildBind.X11.Internal.Window (ActiveWindow, Window, winInstance, winClass, winName) -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-                          }

@@ -0,0 +1,100 @@+{-# LANGUAGE FlexibleContexts #-}+-- |+-- Module: WildBind.X11.Emulate+-- Description: X11 event emulation functions+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- This module defines functions to emulate key inputs.+--+-- See "WildBind.X11.Emulate.Example" for an example.+--+-- @since 0.2.0.0+module WildBind.X11.Emulate+       ( -- * Create key inputs+         sendKeyTo,+         sendKey,+         pushTo,+         push,+         -- * Key remap binding+         remap,+         remapR+       ) where++import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Reader.Class (MonadReader(ask))+import WildBind.Binding (Binding', bindsF, on, run)++import WildBind.X11.Internal.FrontEnd+  ( X11Front(..)+  )+import WildBind.X11.Internal.Key+  ( ToXKeyEvent(..), KeyEventType(..), XKeyEvent,+    xSendKeyEvent, press, release+  )+import WildBind.X11.Internal.Window+  ( Window, ActiveWindow, winID+  )++-- | Send a X11 key event to a 'Window'.+sendKeyTo :: (ToXKeyEvent k, MonadIO m)+          => X11Front i+          -> Window -- ^ target window+          -> k -- ^ Key event to send+          -> m ()+sendKeyTo front win key = liftIO $ xSendKeyEvent kmmap disp win_id key_event+  where+    kmmap = x11KeyMaskMap front+    disp = x11Display front+    win_id = winID win+    key_event = toXKeyEvent key++-- | Same as 'sendKeyTo', but the target window is obtained from+-- 'MonadReader'.+sendKey :: (ToXKeyEvent k, MonadIO m, MonadReader Window m) => X11Front i -> k -> m ()+sendKey front key = do+  win <- ask+  sendKeyTo front win key++-- | Send a \"key push\" event to a 'Window', that is, send 'KeyPress'+-- and 'KeyRelease' events.+pushTo :: (ToXKeyEvent k, MonadIO m) => X11Front i -> Window -> k -> m ()+pushTo front win key = do+  send $ press key+  send $ release key+  where+    send = sendKeyTo front win++-- | Same as 'pushTo', but the target window is obtained from+-- 'MonadReader'.+push :: (ToXKeyEvent k, MonadIO m, MonadReader Window m) => X11Front i -> k -> m ()+push front key = do+  win <- ask+  pushTo front win key++-- | Create a binding that remaps key event \"@from@\" to+-- \"@to@\".+--+-- This binding captures 'KeyPress' and 'KeyRelease' events of+-- \"@from@\", and sends respective events of \"@to@\" to the active+-- window.+--+-- Sometimes 'remap' doesn't work as you expect, because the+-- 'KeyPress' event is sent to the window while it doesn't have+-- keyboard focus. In that case, try using 'remapR'.+remap :: (ToXKeyEvent from, ToXKeyEvent to) => X11Front i -> from -> to -> Binding' bs ActiveWindow XKeyEvent+remap front from to = bindsF $ do+  on (press from) `run` sendKey' (press to)+  on (release from) `run` sendKey' (release to)+  where+    sendKey' = sendKey front++-- | remap on Release. Like 'remap', but this binding captures only+-- 'KeyRelease' event and sends a pair of 'KeyPress' and 'KeyRelease'+-- events.+--+-- Because the original 'KeyRelease' event occurs after the focus+-- returns to the window, the emulated events are sent to the window+-- with focus.+remapR :: (ToXKeyEvent from, ToXKeyEvent to) => X11Front i -> from -> to -> Binding' bs ActiveWindow XKeyEvent+remapR front from to = bindsF $ do+  on (release from) `run` push front to

@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module: WildBind.X11.Emulate.Example+-- Description: Example of WildBind.X11.Emulate+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- This is an example of using "WildBind.X11.Emulate". See the source.+--+-- @since 0.2.0.0+module WildBind.X11.Emulate.Example+       where++import WildBind+  ( Binding,+    wildBind, bindsF, on, as, run+  )+import WildBind.X11+  ( X11Front, XKeyEvent, ActiveWindow,+    withX11Front, makeFrontEnd,+    alt, ctrl, press, release+  )+import WildBind.X11.KeySym (xK_c, xK_w)+import WildBind.X11.Emulate (sendKey)++main :: IO ()+main = withX11Front $ \x11 -> wildBind (myBinding x11) (makeFrontEnd x11)++-- | To use emulation functions, you need to obtain an 'X11Front'+-- object by 'withX11Front', and call emulation functions on it.+--+-- 'bindsF' function is useful to send keyboard events to the current+-- 'ActiveWindow'.+myBinding :: X11Front XKeyEvent -> Binding ActiveWindow XKeyEvent+myBinding x11 = bindsF $ do+  on (alt xK_w) `as` "Copy" `run` sendKey x11 (ctrl xK_c)

@@ -0,0 +1,220 @@+-- |+-- Module: WildBind.X11.Internal.FrontEnd+-- Description: WildBind FrontEnd implementation for X11+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- __This is an internal module. Package users should not rely on this.__+module WildBind.X11.Internal.FrontEnd+       ( -- * X11Front+         X11Front(..),+         withFrontEnd,+         withX11Front,+         makeFrontEnd,+         defaultRootWindow+       ) 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 (when)+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+  ( xKeyEventToXKeyInput,+    xGrabKey, xUngrabKey,+    XKeyInput(..), KeyMaskMap, getKeyMaskMap,+    KeyEventType(..)+  )+import WildBind.X11.Internal.Window+  ( ActiveWindow,getActiveWindow, Window,+    winInstance, winClass, winName, emptyWindow,+    defaultRootWindowForDisplay+  )+import qualified WildBind.X11.Internal.NotificationDebouncer as Ndeb+import qualified WildBind.X11.Internal.GrabMan as GM++-- | The X11 front-end. @k@ is the input key type.+--+-- This is the implementation of the 'FrontEnd' given by+-- 'withFrontEnd' function. With this object, you can do more advanced+-- actions. See "WildBind.X11.Emulate".+--+-- 'X11Front' is relatively low-level interface, so it's more likely+-- for this API to change in the future than 'FrontEnd'.+--+-- @since 0.2.0.0+data X11Front k =+  X11Front { x11Display :: Xlib.Display,+             x11Debouncer :: Ndeb.Debouncer,+             x11PrevActiveWindow :: IORef (Maybe ActiveWindow),+             x11PendingEvents :: TChan (FrontEvent ActiveWindow k),+             x11KeyMaskMap :: KeyMaskMap,+             x11GrabMan :: IORef (GM.GrabMan k)+           }++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@, this 'FrontEnd' gets+-- keyboard events from the X server.+-- +-- CAVEATS+--+-- Code using this function must be compiled+-- __with @-threaded@ option enabled__ in @ghc@. Otherwise, it aborts.+--+-- Because this 'FrontEnd' currently uses @XGrabKey(3)@ to get the+-- input, it may cause some weird behavior such as:+--+-- - Every input event makes the active window lose focus+--   temporarily. This may result in flickering cursor, for example. See+--   also: https://stackoverflow.com/questions/15270420/+--+-- - Key input is captured only while the first grabbed key is+--   pressed. For example, if @(release xK_a)@ and @(release xK_b)@+--   are bound, and you input @(press xK_a)@, @(press xK_b)@, @(release xK_a)@,+--   @(release xK_b)@, the last @(release xK_b)@ is NOT captured+--   because key grab ends with @(release xK_a)@.+withFrontEnd :: (XKeyInput i, WBD.Describable i, Ord i) => (FrontEnd ActiveWindow i -> IO a) -> IO a+withFrontEnd action = withX11Front' "WildBind.X11.withFrontEnd" $ \x11front -> action (makeFrontEnd x11front)++-- | Same as 'withFrontEnd', but it creates 'X11Front'. To create+-- 'FrontEnd', use 'makeFrontEnd'.+--+-- @since 0.2.0.0+withX11Front :: (X11Front k -> IO a) -> IO a+withX11Front = withX11Front' "WildBind.X11.withX11Front"++withX11Front' :: String -- ^ function name used in the error message.+              -> (X11Front k -> IO a)+              -> IO a+withX11Front' func_name = if rtsSupportsBoundThreads then impl else error_impl where+  impl = runContT $ do+    disp <- ContT $ bracket openMyDisplay Xlib.closeDisplay+    keymask_map <- liftIO $ getKeyMaskMap disp+    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+    grab_man <- liftIO $ GM.new keymask_map disp (Xlib.defaultRootWindow disp)+    liftIO $ Ndeb.notify debouncer+    return $ X11Front disp debouncer awin_ref pending_events keymask_map grab_man+  error_impl _ = throwIO $ userError ("You need to build with -threaded option when you use " ++ func_name ++ " function.")+++tellElem :: Monad m => a -> WriterT [a] m ()+tellElem a = tell [a]++data InternalEvent = IEKey KeyEventType+                   | IEDebounced+                   | IEActiveWindow+                   | IEUnknown++identifyEvent :: Ndeb.Debouncer -> Xlib.XEventPtr -> IO InternalEvent+identifyEvent deb xev = do+  xtype <- Xlib.get_EventType xev+  identify xtype+  where+    identify xtype | xtype == Xlib.keyPress = return $ IEKey KeyPress+                   | xtype == Xlib.keyRelease = return $ IEKey KeyRelease+                   | xtype == Xlib.configureNotify || xtype == Xlib.destroyNotify = return $ IEActiveWindow+                   | otherwise = do+                       is_deb_event <- Ndeb.isDebouncedEvent deb xev+                       if is_deb_event+                         then return IEDebounced+                         else return IEUnknown++convertEvent :: (XKeyInput k) => KeyMaskMap -> Xlib.Display -> Ndeb.Debouncer -> Xlib.XEventPtr -> ListT IO (FrontEvent ActiveWindow k)+convertEvent kmmap disp deb xev = ListT $ execWriterT $ convertEventWriter where+  tellChangeEvent = (tellElem . FEChange) =<< (liftIO $ getActiveWindow disp)+  convertEventWriter :: XKeyInput k => WriterT [FrontEvent ActiveWindow k] IO ()+  convertEventWriter = do+    in_event <- liftIO $ identifyEvent deb xev+    case in_event of+     IEKey ev_type -> do+       let key_ev = Xlib.asKeyEvent xev+       tellChangeEvent+       (maybe (return ()) tellElem) =<< (liftIO $ runMaybeT (FEInput <$> xKeyEventToXKeyInput kmmap ev_type key_ev))+     IEDebounced -> tellChangeEvent+     IEActiveWindow -> liftIO (Ndeb.notify deb) >> return ()+     IEUnknown -> 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)++nextEvent :: (XKeyInput 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 (x11KeyMaskMap handle) (x11Display handle) (x11Debouncer handle) xev+    filterUnchangedEvent handle fevent+    liftIO $ updateState handle fevent+    return fevent++-- | Create 'FrontEnd' from 'X11Front' object.+--+-- @since 0.2.0.0+makeFrontEnd :: (XKeyInput k, WBD.Describable k, Ord k) => X11Front k -> FrontEnd ActiveWindow k+makeFrontEnd f = FrontEnd { frontDefaultDescription = WBD.describe,+                            frontSetGrab = runGrab GM.DoSetGrab,+                            frontUnsetGrab = runGrab GM.DoUnsetGrab,+                            frontNextEvent = nextEvent f+                          }+  where+    runGrab = GM.modify (x11GrabMan f)++-- | Get the default root window.+--+-- @since 0.2.0.0+defaultRootWindow :: X11Front k -> Window+defaultRootWindow = defaultRootWindowForDisplay . x11Display

@@ -0,0 +1,128 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+-- Module: WildBind.X11.Internal.GrabMan+-- Description: internal key grab manager+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- __This is an internal module. Package users should not rely on this.__+--+-- 'GrabMan' is a \"grab manager\". It manages the state of key grabs.+--+-- Of course X11 server itself manages key grabs. The reason why we+-- need 'GrabMan' is that the input symbols for X11 FrontEnd do not+-- map one-to-one to X11 'GrabField's. For example, @(press $ ctrl xK_x)@+-- actually corresponds to multiple 'GrabField's, each with a different+-- 'Xlib.KeyMask'. In addition, @(release $ ctrl xK_x)@ has exactly the+-- same set of 'GrabField's as @(press $ ctrl xK_x)@. For each possible+-- 'GrabField', we need to grab it if and only if there is at least+-- one grabbed input symbol for the 'GrabField'.+module WildBind.X11.Internal.GrabMan+       ( GrabMan,+         GrabOp(..),+         new,+         modify+       ) where++import Control.Monad (forM_)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Foldable (foldr)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Map.Strict as M+import Data.Monoid (Monoid(..), (<>))+import qualified Data.Set as S+import qualified Graphics.X11.Xlib as Xlib++import WildBind.X11.Internal.Key+  ( XKeyEvent(..), press, KeyEventType(..),+    KeyMaskMap, XKeyInput(..),+    xGrabKey, xUngrabKey+  )++-- | Unit of key grabs in X11. X server manages state of key grabs+-- independently for each 'GrabField'.+type GrabField = (Xlib.KeySym, Xlib.KeyMask)++-- | High-level grab state. For each 'GrabField', the 'M.Map' value is+-- non-empty set of input symbols (type @k@) currently grabbed.+type GrabbedInputs k = M.Map GrabField (S.Set k)++insertG :: Ord k => GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)+insertG field key inputs = (new_inputs, is_new_entry)+  where+    is_new_entry = not $ M.member field inputs+    new_inputs = M.insertWith S.union field (S.singleton key) inputs++deleteG :: Ord k => GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)+deleteG field key inputs = (new_inputs, is_entry_deleted)+  where+    (new_inputs, is_entry_deleted) = case M.lookup field inputs of+      Nothing -> (inputs, False)+      Just cur_grabbed -> let new_grabbed = S.delete key cur_grabbed+                              removed = new_grabbed == mempty+                          in ( if removed+                               then M.delete field inputs+                               else M.insert field new_grabbed inputs,+                               +                               removed+                             )++-- | Grab operation. Either \"set grab\" or \"unset grab\".+data GrabOp = DoSetGrab | DoUnsetGrab deriving (Show,Eq,Ord)++modifyG :: Ord k => GrabOp -> GrabField -> k -> GrabbedInputs k -> (GrabbedInputs k, Bool)+modifyG op = case op of+  DoSetGrab -> insertG+  DoUnsetGrab -> deleteG++-- | The key grab manager.+data GrabMan k =+  GrabMan+  { gmKeyMaskMap :: KeyMaskMap,+    gmDisplay :: Xlib.Display,+    gmRootWindow :: Xlib.Window,+    gmGrabbedInputs :: GrabbedInputs k+  }+  deriving (Show,Eq,Ord)++-- | Create a new 'GrabMan'.+new :: KeyMaskMap -> Xlib.Display -> Xlib.Window -> IO (IORef (GrabMan k))+new kmm disp win = newIORef $ GrabMan { gmKeyMaskMap = kmm,+                                        gmDisplay = disp,+                                        gmRootWindow = win,+                                        gmGrabbedInputs = mempty+                                      }++grabFieldsFor :: XKeyInput k => KeyMaskMap -> k -> NonEmpty GrabField+grabFieldsFor kmmap k = do+  sym <- return $ toKeySym k+  modmask <- toModifierMasks kmmap k+  return (sym, modmask)++-- | Pure version of 'modify'.+modifyGM :: (XKeyInput k, Ord k) => GrabOp -> k -> GrabMan k+         -> (GrabMan k, [GrabField])+         -- ^ the next state of 'GrabMan', and the list of+         -- 'GrabField's which needs modifying with the X server.+modifyGM op input gm = foldr modifySingle (gm, []) fields+  where+    fields = grabFieldsFor (gmKeyMaskMap gm) input+    modifySingle field (cur_gm, cur_changed) = (new_gm, new_changed)+      where+        (new_gi, modified) = modifyG op field input $ gmGrabbedInputs cur_gm+        new_gm = cur_gm { gmGrabbedInputs = new_gi }+        new_changed = if modified then (field : cur_changed) else cur_changed++-- | Modify the grab state. The modification operation is specified by+-- 'GrabOp'. It controls grabs of the X server if necessary.+modify :: (XKeyInput k, Ord k) => IORef (GrabMan k) -> GrabOp -> k -> IO ()+modify gm_ref op input = do+  cur_gm <- readIORef gm_ref+  let (new_gm, changed_fields) = modifyGM op input cur_gm+      disp = gmDisplay cur_gm+      rwin = gmRootWindow cur_gm+  writeIORef gm_ref new_gm+  forM_ changed_fields $ \(keysym, mask) -> do+    case op of+     DoSetGrab -> xGrabKey disp rwin keysym mask+     DoUnsetGrab -> xUngrabKey disp rwin keysym mask+

@@ -1,3 +1,4 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, OverloadedStrings #-} -- | -- Module: WildBind.X11.Internal.Key -- Description: types and functions related to key symbols and their conversion@@ -5,41 +6,105 @@ -- -- __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+       ( -- * Key+         XKeyInput(..),+         xKeyEventToXKeyInput,+         KeyEventType(..),+         -- * Modifiers+         KeyMaskMap(..),+         getKeyMaskMap,+         -- * XKeyEvent+         XKeyEvent(..),+         XMod(..),+         ToXKeyEvent(..),+         addXMod,+         press,+         release,+         shift,+         ctrl,+         alt,+         super,+         -- * Grabs+         xGrabKey,+         xUngrabKey,+         -- * Event generation+         xSendKeyEvent        ) where -import Control.Applicative ((<$>), (<*>))+import Control.Applicative ((<$>), (<*>), (<|>))+import Control.Monad (forM_)+import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Maybe (MaybeT(MaybeT))-import Data.Bits ((.|.))+import Data.Bits ((.|.), (.&.)) import qualified Data.Bits as Bits+import Data.Foldable (foldr, fold)+import Data.List (nub)+import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as M import Data.Maybe (mapMaybe, listToMaybe)+import Data.Monoid ((<>))+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Foreign import qualified Graphics.X11.Xlib as Xlib import qualified Graphics.X11.Xlib.Extras as XlibE +import WildBind.Description (Describable(..)) import qualified WildBind.Input.NumPad as NumPad --- | Convertible to/from Xlib's 'KeySym'+-- | Whether the key is pressed or released. ----- prop> fromKeySym . toKeySym == Just-class KeySymLike k where-  fromKeySym :: Xlib.KeySym -> Maybe k-  toKeySym :: k -> Xlib.KeySym+-- @since 0.2.0.0+data KeyEventType = KeyPress+                  | KeyRelease+                  deriving (Show,Eq,Ord,Bounded,Enum) -instance KeySymLike Xlib.KeySym where-  fromKeySym = Just-  toKeySym = id+-- | 'Xlib.KeyMask' values assigned to each modifier keys/states. If+-- the modifier doesn't exist, the mask is 0.+--+-- @since 0.2.0.0+data KeyMaskMap =+  KeyMaskMap+  { maskShift :: Xlib.KeyMask,+    maskControl :: Xlib.KeyMask,+    maskAlt :: Xlib.KeyMask,+    maskSuper :: Xlib.KeyMask,+    maskNumLock :: Xlib.KeyMask,+    maskCapsLock :: Xlib.KeyMask,+    maskShiftLock :: Xlib.KeyMask,+    maskScrollLock :: Xlib.KeyMask+  }+  deriving (Show,Eq,Ord) +isMasked :: KeyMaskMap -> (KeyMaskMap -> Xlib.KeyMask) -> Xlib.KeyMask -> Bool+isMasked kmmap accessor target = if (target .&. accessor kmmap) == 0+                                 then False+                                 else True++-- | Class of data types that can be handled by X11. The data type can+-- tell X11 to grab key with optional modifiers, and it can be+-- extracted from a X11 Event object.+--+-- @since 0.2.0.0+class XKeyInput k where+  toKeySym :: k -> Xlib.KeySym+  -- ^ Get the X11 keysym for this input.+  toModifierMasks :: KeyMaskMap -> k -> NonEmpty Xlib.KeyMask+  -- ^ Get modifer masks to grab the keysym. The grab action is+  -- repeated for all modifier masks. By default, it just returns 0.+  toModifierMasks _ _ = return 0+  fromKeyEvent :: KeyMaskMap -> KeyEventType -> Xlib.KeySym -> Xlib.KeyMask -> Maybe k+  -- ^ Create the input object from a key event type, a keysym and a+  -- modifier (got from XEvent.)++-- | Partial inverse of 'toKeySym'. 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+-- | This input event captures the 'KeyRelease' event only. That way,+-- you can deliver events to the window that originally has the+-- keyboard focus.+instance XKeyInput NumPad.NumPadUnlocked where   toKeySym n = case n of     NumPad.NumUp -> Xlib.xK_KP_Up     NumPad.NumDown -> Xlib.xK_KP_Down@@ -57,17 +122,17 @@     NumPad.NumMulti -> Xlib.xK_KP_Multiply     NumPad.NumMinus -> Xlib.xK_KP_Subtract     NumPad.NumPlus -> Xlib.xK_KP_Add+  fromKeyEvent _ KeyPress _ _ = Nothing+  fromKeyEvent kmmask KeyRelease keysym mask = if is_numlocked+                                               then Nothing+                                               else fromKeySymDef toKeySym keysym+    where+      is_numlocked = isMasked kmmask maskNumLock mask -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+-- | This input event captures the 'KeyRelease' event only. That way,+-- you can deliver events to the window that originally has the+-- keyboard focus.+instance XKeyInput NumPad.NumPadLocked where   toKeySym n = case n of     NumPad.NumL0 -> Xlib.xK_KP_0     NumPad.NumL1 -> Xlib.xK_KP_1@@ -86,75 +151,100 @@     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 _ = []+    +  toModifierMasks kmmap _ = return $ maskNumLock kmmap -instance ModifierLike NumPad.NumPadLocked where-  toModifiers _ = [ModNumLock]+  -- 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.+  fromKeyEvent _ KeyPress _ _ = Nothing+  fromKeyEvent kmmap KeyRelease keysym mask =+    if not $ is_num_locked+    then Nothing+    else if keysym == Xlib.xK_KP_Decimal+         then Just NumPad.NumLPeriod+         else fromKeySymDef toKeySym keysym+    where+      is_num_locked = isMasked kmmap maskNumLock mask --- | 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)+-- | 'fromKeyEvent' first tries to create 'Left' (type @a@). If it+-- fails, then it tries to create 'Right' (type @b@).+instance (XKeyInput a, XKeyInput b) => XKeyInput (Either a b) where+  toKeySym = either toKeySym toKeySym+  toModifierMasks kmmap = either (toModifierMasks kmmap) (toModifierMasks kmmap)+  fromKeyEvent kmmap ev_type keysym mask =+    (fmap Left $ fromKeyEvent kmmap ev_type keysym mask) <|> (fmap Right $ fromKeyEvent kmmap ev_type keysym mask) -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+-- | Extract the 'XKeyInput' from the XKeyEvent.+--+-- @since 0.2.0.0+xKeyEventToXKeyInput :: XKeyInput k => KeyMaskMap -> KeyEventType -> Xlib.XKeyEventPtr -> MaybeT IO k+xKeyEventToXKeyInput kmmap ev_type kev = do+  keysym <- MaybeT (fst <$> Xlib.lookupString kev)+  (_, _, _, _, _, _, _, status, _, _) <- liftIO $ Xlib.get_KeyEvent $ Foreign.castPtr kev+  MaybeT $ return $ fromKeyEvent kmmap ev_type keysym status  type XModifierMap = [(Xlib.Modifier, [Xlib.KeyCode])] +-- | Get current 'KeyMaskMap'.+--+-- @since 0.2.0.0+getKeyMaskMap :: Xlib.Display -> IO KeyMaskMap+getKeyMaskMap disp = do+  xmodmap <- getXModifierMap disp+  let maskFor = lookupModifierKeyMask disp xmodmap+  numlock_mask <- maskFor Xlib.xK_Num_Lock+  capslock_mask <- maskFor Xlib.xK_Caps_Lock+  shiftlock_mask <- maskFor Xlib.xK_Shift_Lock+  scrolllock_mask <- maskFor Xlib.xK_Scroll_Lock+  alt_mask <- maskFor Xlib.xK_Alt_L+  super_mask <- maskFor Xlib.xK_Super_L+  return KeyMaskMap { maskShift = Xlib.shiftMask,+                      maskControl = Xlib.controlMask,+                      maskAlt = alt_mask,+                      maskSuper = super_mask,+                      maskNumLock = numlock_mask,+                      maskCapsLock = capslock_mask,+                      maskShiftLock = shiftlock_mask,+                      maskScrollLock = scrolllock_mask+                    }+ 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.+-- | Look up a modifier keymask associated to the given keysym. 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+lookupModifierKeyMask :: Xlib.Display -> XModifierMap -> Xlib.KeySym -> IO Xlib.KeyMask+lookupModifierKeyMask disp xmmap keysym = do+  keycode <- Xlib.keysymToKeycode disp keysym+  return $ maybe 0 modifierToKeyMask $ listToMaybe $ mapMaybe (lookupXMod' keycode) 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-------+modifierToKeyMask :: Xlib.Modifier -> Xlib.KeyMask+modifierToKeyMask = Bits.shift 1 . fromIntegral  -- | 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+--+-- @since 0.2.0.0+xGrabKey :: Xlib.Display -> Xlib.Window -> Xlib.KeySym -> Xlib.KeyMask -> IO ()+xGrabKey disp win key mask = do+  code <- Xlib.keysymToKeycode 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@@ -162,7 +252,169 @@ -- 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+--+-- @since 0.2.0.0+xUngrabKey :: Xlib.Display -> Xlib.Window -> Xlib.KeySym -> Xlib.KeyMask -> IO ()+xUngrabKey disp win key mask = do+  code <- Xlib.keysymToKeycode disp key   Xlib.ungrabKey disp code mask win++-- | X11 key modifiers.+--+-- @since 0.2.0.0+data XMod = Shift+          | Ctrl+          | Alt+          | Super+          deriving (Show,Eq,Ord,Enum,Bounded)++-- | High-level X11 key event.+--+-- @since 0.2.0.0+data XKeyEvent =+  XKeyEvent+  { xKeyEventType :: KeyEventType, +    xKeyEventMods :: S.Set XMod, -- ^ set of key modifiers enabled.+    xKeyEventKeySym :: Xlib.KeySym+    -- ^ X11 KeySym for the key. "WildBind.X11.KeySym" re-exports+    -- 'KeySym' values.+  }+  deriving (Show,Eq,Ord)++-- | 'fromKeyEvent' always returns 'Just'.+instance XKeyInput XKeyEvent where+  toKeySym (XKeyEvent _ _ ks) = ks+  toModifierMasks kmmap (XKeyEvent _ mods _) =+    fmap (.|. xModsToKeyMask kmmap mods) $ lockVariations kmmap+  fromKeyEvent kmmap ev_type keysym mask = Just $ XKeyEvent ev_type (keyMaskToXMods kmmap mask) keysym++-- | Something that can converted to 'XKeyEvent'.+--+-- @since 0.2.0.0+class ToXKeyEvent k where+  toXKeyEvent :: k -> XKeyEvent++instance ToXKeyEvent XKeyEvent where+  toXKeyEvent = id++-- | 'KeyPress' event of KeySym with empty 'XMod' set.+instance ToXKeyEvent Xlib.KeySym where+  toXKeyEvent keysym = XKeyEvent KeyPress mempty keysym++instance (ToXKeyEvent a, ToXKeyEvent b) => ToXKeyEvent (Either a b) where+  toXKeyEvent = either toXKeyEvent toXKeyEvent++instance Describable XKeyEvent where+  describe (XKeyEvent ev mods keysym) = ev_txt <> T.pack (mods_str ++ Xlib.keysymToString keysym)+    where+      mods_str = fold $ S.map (\m -> show m ++ "+") mods+      ev_txt = case ev of+        KeyPress -> "press "+        KeyRelease -> "release "++xModToKeyMask :: KeyMaskMap -> XMod -> Xlib.KeyMask+xModToKeyMask kmmap modi = case modi of+  Shift -> maskShift kmmap+  Ctrl -> maskControl kmmap+  Alt -> maskAlt kmmap+  Super -> maskSuper kmmap++xModsToKeyMask :: KeyMaskMap -> S.Set XMod -> Xlib.KeyMask+xModsToKeyMask kmmap = foldr f 0+  where+    f modi mask = xModToKeyMask kmmap modi .|. mask++lockVariations :: KeyMaskMap -> NonEmpty Xlib.KeyMask+lockVariations kmmap = toNonEmpty $ nub $ do+  numl <- [0, maskNumLock kmmap]+  capsl <- [0, maskCapsLock kmmap]+  shiftl <- [0, maskShiftLock kmmap]+  scl <- [0, maskScrollLock kmmap]+  return (numl .|. capsl .|. shiftl .|. scl)+  where+    toNonEmpty [] = return 0+    -- the result should always include 0, so the above case is not really necessary.+    toNonEmpty (x:rest) = x :| rest++keyMaskToXMods :: KeyMaskMap -> Xlib.KeyMask -> S.Set XMod+keyMaskToXMods kmmap mask = S.fromList$ toXMod =<< [ (maskShift, Shift),+                                                     (maskControl, Ctrl),+                                                     (maskAlt, Alt),+                                                     (maskSuper, Super)+                                                   ]+  where+    toXMod (acc, mod_symbol) = if isMasked kmmap acc mask+                               then [mod_symbol]+                               else []++-- | Add a 'XMod' to 'xKeyEventMods'.+--+-- @since 0.2.0.0+addXMod :: ToXKeyEvent k => XMod -> k -> XKeyEvent+addXMod modi mkey = case toXKeyEvent mkey of+  XKeyEvent ev_type mods ks -> XKeyEvent ev_type (S.insert modi mods) ks++-- | Set 'KeyPress' to 'xKeyEventType'.+--+-- @since 0.2.0.0+press :: ToXKeyEvent k => k -> XKeyEvent+press k = (toXKeyEvent k) { xKeyEventType = KeyPress }++-- | Set 'KeyRelease' to 'xKeyEventType'.+--+-- @since 0.2.0.0+release :: ToXKeyEvent k => k -> XKeyEvent+release k = (toXKeyEvent k) { xKeyEventType = KeyRelease }++-- | Add 'Shift' modifier to 'xKeyEventMods'.+--+-- @since 0.2.0.0+shift :: ToXKeyEvent k => k -> XKeyEvent+shift = addXMod Shift++-- | Add 'Ctrl' modifier to 'xKeyEventMods'.+--+-- @since 0.2.0.0+ctrl :: ToXKeyEvent k => k -> XKeyEvent+ctrl = addXMod Ctrl++-- | Add 'Alt' modifier to 'xKeyEventMods'.+--+-- @since 0.2.0.0+alt :: ToXKeyEvent k => k -> XKeyEvent+alt = addXMod Alt++-- | Add 'Super' modifier to 'xKeyEventMods'.+--+-- @since 0.2.0.0+super :: ToXKeyEvent k => k -> XKeyEvent+super = addXMod Super++-- | Send a 'XKeyEvent' to the window.+--+-- @since 0.2.0.0+xSendKeyEvent :: KeyMaskMap -> Xlib.Display -> Xlib.Window -> XKeyEvent -> IO ()+xSendKeyEvent kmmap disp target_win key_event = Xlib.allocaXEvent $ \xev -> do+  setupXEvent xev+  Xlib.sendEvent disp target_win propagate event_mask xev+  Xlib.sync disp False+  where+    propagate = True+    event_type = xKeyEventType key_event+    event_mask = case event_type of+      KeyPress -> Xlib.keyPressMask+      KeyRelease -> Xlib.keyReleaseMask+    xevent_type = case event_type of+      KeyPress -> Xlib.keyPress+      KeyRelease -> Xlib.keyRelease+    setupXEvent xev = do+      key_code <- Xlib.keysymToKeycode disp $ xKeyEventKeySym key_event+      XlibE.setEventType xev xevent_type+      XlibE.setKeyEvent xev target_win (Xlib.defaultRootWindow disp) subwindow key_mask key_code is_same_screen+    subwindow = 0 -- I mean, 'None' in Xlib. Graphics.X11 does not define 'None' window ID, I think...+    is_same_screen = True+    key_mask = xModsToKeyMask kmmap $ xKeyEventMods key_event++-- c.f. create_key_event function in xlib_wrapper.c from 'xremap'+-- https://github.com/k0kubun/xremap+

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- | -- Module: WildBind.X11.Internal.Window -- Description: types and functions related to X11 windows@@ -9,12 +10,16 @@          Window,          ActiveWindow,          emptyWindow,+         fromWinID,          -- * Accessor functions for 'Window'          winInstance,          winClass,          winName,+         -- ** project-internal accessor+         winID,          -- * Functions-         getActiveWindow+         getActiveWindow,+         defaultRootWindowForDisplay        ) where  import Control.Applicative ((<$>),(<|>),empty)@@ -24,6 +29,7 @@ import Data.Maybe (listToMaybe) import Data.Text (Text) import qualified Data.Text as Text+import qualified Foreign import qualified Graphics.X11.Xlib as Xlib import qualified Graphics.X11.Xlib.Extras as XlibE @@ -43,7 +49,11 @@   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+    winName :: Text,  -- ^ what's shown in the title bar+    winID :: Xlib.Window+    -- ^ X11 window ID.+    --+    -- @since 0.2.0.0   } deriving (Eq,Ord,Show)  -- | Use this type especially when the 'Window' is active.@@ -51,8 +61,14 @@  -- | An empty Window instance used for fallback and/or default value. emptyWindow :: Window-emptyWindow = Window "" "" ""+emptyWindow = Window "" "" "" 0 +-- | Create 'Window' from X11's 'Xlib.Window'. Only for testing.+--+-- @since 0.2.0.0+fromWinID :: Xlib.Window -> Window+fromWinID wid = emptyWindow { winID = wid }+ -- | Get currently active 'Window'. getActiveWindow :: Xlib.Display -> IO ActiveWindow getActiveWindow disp = maybe emptyWindow id <$> runMaybeT getActiveWindowM where@@ -61,8 +77,14 @@     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+    return $ (uncurry Window) class_hint name awin +-- | Get the default root window of the display.+--+-- @since 0.2.0.0+defaultRootWindowForDisplay :: Xlib.Display -> Window+defaultRootWindowForDisplay disp = Window "" "" "" $ Xlib.defaultRootWindow disp+ -- | 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@@ -89,7 +111,6 @@       [] -> empty       (val:_) -> return $ fromIntegral val - xGetClassHint :: Xlib.Display -> Xlib.Window -> IO (Text, Text) xGetClassHint disp win = do   hint <- XlibE.getClassHint disp win@@ -98,7 +119,12 @@ 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))+  text_prop <- MaybeT $ Foreign.alloca $ \ptr_prop -> do+    status <- XlibE.xGetTextProperty disp win ptr_prop req+    if status == 0+      then return Nothing+      else fmap Just $ Foreign.peek ptr_prop+  Text.pack <$> MaybeT (listToMaybe <$> (XlibE.wcTextPropertyToTextList disp text_prop))  -- | Get the window name for the X11 window. The window name refers to -- @_NET_WM_NAME@ or @WM_NAME@.

@@ -0,0 +1,371 @@+-- |+-- Module: WildBind.X11.KeySym+-- Description: Re-export KeySyms+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- This module re-exports X11 'KeySym's.+--+-- @since 0.2.0.0+module WildBind.X11.KeySym+       ( -- * The type+         KeySym,+         -- * Alphabet+         xK_a,+         xK_b,+         xK_c,+         xK_d,+         xK_e,+         xK_f,+         xK_g,+         xK_h,+         xK_i,+         xK_j,+         xK_k,+         xK_l,+         xK_m,+         xK_n,+         xK_o,+         xK_p,+         xK_q,+         xK_r,+         xK_s,+         xK_t,+         xK_u,+         xK_v,+         xK_w,+         xK_x,+         xK_y,+         xK_z,+         xK_A,+         xK_B,+         xK_C,+         xK_D,+         xK_E,+         xK_F,+         xK_G,+         xK_H,+         xK_I,+         xK_J,+         xK_K,+         xK_L,+         xK_M,+         xK_N,+         xK_O,+         xK_P,+         xK_Q,+         xK_R,+         xK_S,+         xK_T,+         xK_U,+         xK_V,+         xK_W,+         xK_X,+         xK_Y,+         xK_Z,+         -- * Numbers+         xK_0,+         xK_1,+         xK_2,+         xK_3,+         xK_4,+         xK_5,+         xK_6,+         xK_7,+         xK_8,+         xK_9,+         -- * ASCII symbols+         xK_space,+         xK_exclam,+         xK_quotedbl,+         xK_numbersign,+         xK_dollar,+         xK_percent,+         xK_ampersand,+         xK_apostrophe,+         xK_quoteright,+         xK_parenleft,+         xK_parenright,+         xK_asterisk,+         xK_plus,+         xK_comma,+         xK_minus,+         xK_period,+         xK_slash,+         xK_colon,+         xK_semicolon,+         xK_less,+         xK_equal,+         xK_greater,+         xK_question,+         xK_at,+         xK_bracketleft,+         xK_backslash,+         xK_bracketright,+         xK_asciicircum,+         xK_underscore,+         xK_grave,+         xK_quoteleft,+         xK_braceleft,+         xK_bar,+         xK_braceright,+         xK_asciitilde,+         -- * Control keys+         xK_BackSpace,+         xK_Tab,+         xK_Linefeed,+         xK_Clear,+         xK_Return,+         xK_Pause,+         xK_Scroll_Lock,+         xK_Sys_Req,+         xK_Escape,+         xK_Delete,+         xK_Multi_key,+         xK_Codeinput,+         xK_SingleCandidate,+         xK_MultipleCandidate,+         xK_PreviousCandidate,+         xK_Home,+         xK_Left,+         xK_Up,+         xK_Right,+         xK_Down,+         xK_Prior,+         xK_Page_Up,+         xK_Next,+         xK_Page_Down,+         xK_End,+         xK_Begin,+         xK_Select,+         xK_Print,+         xK_Execute,+         xK_Insert,+         xK_Undo,+         xK_Redo,+         xK_Menu,+         xK_Find,+         xK_Cancel,+         xK_Help,+         xK_Break,+         xK_Mode_switch,+         xK_script_switch,+         xK_Num_Lock,+         -- * Number pad keys+         xK_KP_Space,+         xK_KP_Tab,+         xK_KP_Enter,+         xK_KP_F1,+         xK_KP_F2,+         xK_KP_F3,+         xK_KP_F4,+         xK_KP_Home,+         xK_KP_Left,+         xK_KP_Up,+         xK_KP_Right,+         xK_KP_Down,+         xK_KP_Prior,+         xK_KP_Page_Up,+         xK_KP_Next,+         xK_KP_Page_Down,+         xK_KP_End,+         xK_KP_Begin,+         xK_KP_Insert,+         xK_KP_Delete,+         xK_KP_Equal,+         xK_KP_Multiply,+         xK_KP_Add,+         xK_KP_Separator,+         xK_KP_Subtract,+         xK_KP_Decimal,+         xK_KP_Divide,+         xK_KP_0,+         xK_KP_1,+         xK_KP_2,+         xK_KP_3,+         xK_KP_4,+         xK_KP_5,+         xK_KP_6,+         xK_KP_7,+         xK_KP_8,+         xK_KP_9,+         -- * Function keys+         xK_F1,+         xK_F2,+         xK_F3,+         xK_F4,+         xK_F5,+         xK_F6,+         xK_F7,+         xK_F8,+         xK_F9,+         xK_F10,+         xK_F11,+         xK_L1,+         xK_F12,+         xK_L2,+         xK_F13,+         xK_L3,+         xK_F14,+         xK_L4,+         xK_F15,+         xK_L5,+         xK_F16,+         xK_L6,+         xK_F17,+         xK_L7,+         xK_F18,+         xK_L8,+         xK_F19,+         xK_L9,+         xK_F20,+         xK_L10,+         xK_F21,+         xK_R1,+         xK_F22,+         xK_R2,+         xK_F23,+         xK_R3,+         xK_F24,+         xK_R4,+         xK_F25,+         xK_R5,+         xK_F26,+         xK_R6,+         xK_F27,+         xK_R7,+         xK_F28,+         xK_R8,+         xK_F29,+         xK_R9,+         xK_F30,+         xK_R10,+         xK_F31,+         xK_R11,+         xK_F32,+         xK_R12,+         xK_F33,+         xK_R13,+         xK_F34,+         xK_R14,+         xK_F35,+         xK_R15,+         -- * Modifier keys+         xK_Shift_L,+         xK_Shift_R,+         xK_Control_L,+         xK_Control_R,+         xK_Caps_Lock,+         xK_Shift_Lock,+         xK_Meta_L,+         xK_Meta_R,+         xK_Alt_L,+         xK_Alt_R,+         xK_Super_L,+         xK_Super_R,+         xK_Hyper_L,+         xK_Hyper_R,+         -- * Alphabet with accent and ligatures+         xK_Agrave,+         xK_Aacute,+         xK_Acircumflex,+         xK_Atilde,+         xK_Adiaeresis,+         xK_Aring,+         xK_AE,+         xK_Ccedilla,+         xK_Egrave,+         xK_Eacute,+         xK_Ecircumflex,+         xK_Ediaeresis,+         xK_Igrave,+         xK_Iacute,+         xK_Icircumflex,+         xK_Idiaeresis,+         xK_ETH,+         xK_Eth,+         xK_Ntilde,+         xK_Ograve,+         xK_Oacute,+         xK_Ocircumflex,+         xK_Otilde,+         xK_Odiaeresis,+         xK_multiply,+         xK_Ooblique,+         xK_Ugrave,+         xK_Uacute,+         xK_Ucircumflex,+         xK_Udiaeresis,+         xK_Yacute,+         xK_THORN,+         xK_Thorn,+         xK_ssharp,+         xK_agrave,+         xK_aacute,+         xK_acircumflex,+         xK_atilde,+         xK_adiaeresis,+         xK_aring,+         xK_ae,+         xK_ccedilla,+         xK_egrave,+         xK_eacute,+         xK_ecircumflex,+         xK_ediaeresis,+         xK_igrave,+         xK_iacute,+         xK_icircumflex,+         xK_idiaeresis,+         xK_eth,+         xK_ntilde,+         xK_ograve,+         xK_oacute,+         xK_ocircumflex,+         xK_otilde,+         xK_odiaeresis,+         xK_division,+         xK_oslash,+         xK_ugrave,+         xK_uacute,+         xK_ucircumflex,+         xK_udiaeresis,+         xK_yacute,+         xK_thorn,+         xK_ydiaeresis,+         -- * Other symbols+         xK_nobreakspace,+         xK_exclamdown,+         xK_cent,+         xK_sterling,+         xK_currency,+         xK_yen,+         xK_brokenbar,+         xK_section,+         xK_diaeresis,+         xK_copyright,+         xK_ordfeminine,+         xK_guillemotleft,+         xK_notsign,+         xK_hyphen,+         xK_registered,+         xK_macron,+         xK_degree,+         xK_plusminus,+         xK_twosuperior,+         xK_threesuperior,+         xK_acute,+         xK_mu,+         xK_paragraph,+         xK_periodcentered,+         xK_cedilla,+         xK_onesuperior,+         xK_masculine,+         xK_guillemotright,+         xK_onequarter,+         xK_onehalf,+         xK_threequarters,+         xK_questiondown,+         -- * special keysym+         xK_VoidSymbol,+       ) where++import Graphics.X11.Xlib

@@ -0,0 +1,106 @@+module WildBind.X11.EmulateSpec (main,spec) where++import Control.Exception (bracket)+import Control.Monad (forM_)+import Control.Monad.Trans.Maybe (runMaybeT)+import Data.Bits ((.|.))+import Data.Text (unpack)+import qualified Graphics.X11.Xlib as Xlib+import Test.Hspec++import WildBind (frontNextEvent, FrontEvent(..))+import qualified WildBind.Description as WBD+import WildBind.X11+  ( withX11Front, makeFrontEnd,+    XMod(..), release, press,+    defaultRootWindow,+    XKeyEvent(..), KeyEventType(..),+    alt, super, ctrl, shift+  )+import WildBind.X11.Emulate (sendKeyTo)+import WildBind.X11.Internal.Key (xKeyEventToXKeyInput, getKeyMaskMap, KeyMaskMap)+import WildBind.X11.Internal.Window (fromWinID)++import WildBind.X11.TestUtil (checkIfX11Available)++main :: IO ()+main = hspec spec++spec :: Spec+spec = checkIfX11Available $ describe "sendKeyTo" $ do+  let inputs = [ alt $ super Xlib.xK_r,+                 release Xlib.xK_w,+                 press Xlib.xK_Right,+                 release $ ctrl $ shift Xlib.xK_F12,+                 ctrl $ alt Xlib.xK_3+                   +                 -- ctrl $ shift Xlib.xK_bracketleft++                 ---- "Shift" modifier is tricky, because it affects+                 ---- the keysym depending on the keyboard and key map+                 ---- setting. E.g., with a typical Japanese keyboard,+                 ---- bracketleft "[" and braceleft "{" share the same+                 ---- key, and we use Shift to input the braceleft+                 ---- "{". So, if you use Shift modifier, you have to+                 ---- use xK_braceleft keysym.+               ]+  forM_ inputs $ \input -> specify (unpack $ WBD.describe input) $ withX11Front $ \x11 -> do+    bracket (Xlib.openDisplay "") Xlib.closeDisplay $ \disp -> do+      kmmap <- getKeyMaskMap disp+      win <- makeWindow disp+      -- putStrLn ("Window created: " ++ show win)+      Xlib.sync disp False+      -- putStrLn ("Do send input: " ++ show input)+      sendKeyTo x11 (fromWinID win) input+      -- putStrLn ("Receiving..")+      (nextKey kmmap disp) `shouldReturn` input++-- We have to create a dedicated window to receive events sent by+-- 'sendKeyTo', because XSendEvent ignores key grabs (so X11Front+-- cannot get the sent event.)+--+-- By the way, key events by XTEST extension emulate the real key+-- events from a real keyboard, so they are caught by key grabs.+--+-- c.f. http://t-sato.in.coocan.jp/xvkbd/events.html++makeWindow :: Xlib.Display -> IO Xlib.Window+makeWindow disp = do+  win <- Xlib.createSimpleWindow disp root x y w h border_width border_pixel bg_pixel+  -- Xlib.storeName disp win "test window"+  -- Xlib.mapWindow disp win+  Xlib.selectInput disp win select_mask+  Xlib.flush disp+  return win+  where+    root = Xlib.defaultRootWindow disp+    x = 0+    y = 0+    w = 50+    h = 50+    border_width = 1+    border_pixel = Xlib.blackPixel disp 0+    bg_pixel = Xlib.whitePixel disp 0+    select_mask = Xlib.keyPressMask .|. Xlib.keyReleaseMask++nextKey :: KeyMaskMap -> Xlib.Display -> IO XKeyEvent+nextKey kmmap disp = Xlib.allocaXEvent $ \xev -> do+  Xlib.nextEvent disp xev+  xtype <- Xlib.get_EventType xev+  -- putStrLn ("Got event type: " ++ show xtype)+  case toKeyType xtype of+   Nothing -> error ("Unknown event type: " ++ show xtype)+   Just key_type -> do+     -- putStrLn ("KeyEventType = " ++ show key_type)+     ret <- fmap unwrapMaybe $ runMaybeT $ xKeyEventToXKeyInput kmmap key_type $ Xlib.asKeyEvent xev+     -- putStrLn ("Converted: " ++ show ret)+     return ret+  where+    toKeyType xtype | xtype == Xlib.keyPress = Just KeyPress+                    | xtype == Xlib.keyRelease = Just KeyRelease+                    | otherwise = Nothing+    error_convert = error "Cannot convert the XEvent to XKeyEvent."+    unwrapMaybe = maybe error_convert id+++    

@@ -1,34 +0,0 @@-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-

@@ -5,14 +5,18 @@ -- --  module WildBind.X11.TestUtil-       ( checkIfX11Available+       ( checkIfX11Available,+         withGrabs        ) where +import Control.Exception (bracket) import Control.Monad (when) import Control.Applicative ((<$>)) import System.Environment (lookupEnv) import Test.Hspec +import WildBind (FrontEnd(..))+ isDisplaySet :: IO Bool isDisplaySet = exists <$> lookupEnv "DISPLAY" where   exists (Just v) = v /= ""@@ -22,3 +26,10 @@ checkIfX11Available = before $ do   available <- isDisplaySet   when (not available) $ pendingWith "DISPLAY env is not set. Skipped."++withGrabs :: FrontEnd s i -> [i] -> IO a -> IO a+withGrabs front inputs action = bracket grabAll (const ungrabAll) (const action)+  where+    grabAll = mapM_ (frontSetGrab front) inputs+    ungrabAll = mapM_ (frontUnsetGrab front) inputs+

@@ -1,54 +1,74 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, CPP #-}+{-# LANGUAGE FlexibleContexts, CPP, OverloadedStrings #-} module WildBind.X11Spec (main, spec) where  import Control.Applicative ((<$>))-import Control.Exception (finally)+import Control.Concurrent.Async (async, waitCatch)+import Control.Exception (finally, Exception(fromException), throwIO)+import Control.Monad (forM_)+import Control.Monad.IO.Class (liftIO)+import qualified Control.Monad.Trans.State as State+import Data.Monoid ((<>))+import Data.List (intercalate, reverse)+import Data.IORef (IORef, newIORef, readIORef, modifyIORef)+import Data.Text (unpack) import Data.Time.Clock (getCurrentTime, diffUTCTime)+import qualified Graphics.X11.Xlib as Xlib import System.IO (hPutStrLn,stderr) import Test.Hspec  import WildBind   ( FrontEnd(frontSetGrab, frontUnsetGrab, frontNextEvent),-    FrontEvent(FEChange,FEInput)+    FrontEvent(FEChange,FEInput), Describable, ActionDescription,+    Option(..), defOption, wildBind',+    binds', startFrom, on, as, run, whenBack, revise, justBefore   )+import qualified WildBind.Description as WBD import qualified WildBind.Input.NumPad as NumPad-import WildBind.X11 (withFrontEnd, ActiveWindow)+import WildBind.X11+  ( withFrontEnd, ActiveWindow, XKeyInput,+    XMod(..), XKeyEvent(..), KeyEventType(..),+    ctrl, alt, super, shift, release, press+  )+import qualified WildBind.X11.KeySym as WKS -import WildBind.X11.TestUtil (checkIfX11Available)+import WildBind.X11.TestUtil (checkIfX11Available, withGrabs) +newtype MyException = MyException String+                    deriving (Show,Eq,Ord)++instance Exception MyException+ main :: IO () main = hspec spec  maybeRun :: Expectation -> Expectation-#ifdef TEST_NUMPAD_INTERACTIVE+#ifdef TEST_INTERACTIVE maybeRun = id #else-maybeRun _ = pendingWith ("You need to set test_numpad_interactive flag to run the test.")+maybeRun _ = pendingWith ("You need to set test-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+withFrontEndForTest :: (XKeyInput i, Describable i, Ord i) => (FrontEnd ActiveWindow i -> IO a) -> IO a+withFrontEndForTest action = withFrontEnd $ \front -> do+  _ <- frontNextEvent front -- discard the first FEChange event.+  action front++grabExp :: (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)+    ev <- frontNextEvent front     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])+    ev `shouldBe` FEInput grab_input+  releaseAll = mapM_ (frontUnsetGrab front) (enumFromTo minBound maxBound) -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])+grabCase :: (Bounded i, Enum i, Show i, Eq i) => FrontEnd ActiveWindow i -> Expectation+grabCase front = mapM_ (grabExp front) (enumFromTo minBound maxBound)  stopWatchMsec :: IO a -> IO (a, Int) stopWatchMsec act = do@@ -57,6 +77,20 @@   end <- getCurrentTime   return (ret, floor ((diffUTCTime end start) * 1000)) +describeStr :: Describable a => a -> String+describeStr = unpack . WBD.describe++unshiftNewBinding :: Eq i => IORef [[(i,ActionDescription)]] -> [(i,ActionDescription)] -> IO ()+unshiftNewBinding ref got = do+  cur <- readIORef ref+  case cur of+   [] -> update+   (latest : _) -> if latest /= got+                   then update+                   else return ()+  where+    update = modifyIORef ref (got :)+ spec :: Spec spec = checkIfX11Available $ do   describe "X11Front" $ do@@ -71,10 +105,66 @@       withFrontEnd $ \f2 -> do         frontSetGrab f1 NumPad.NumLeft `shouldReturn` ()         frontSetGrab f2 NumPad.NumLeft `shouldReturn` ()+    it "should control key grab based on ('release' || 'press')" $ maybeRun $ withFrontEnd $ \f -> do+      got_binds_rev <- newIORef []+      let opt = defOption { optBindingHook = unshiftNewBinding got_binds_rev,+                            optCatch = (\_ _ e -> throwIO e)+                          }+          b_base = binds' $ do+            on (press $ ctrl $ WKS.xK_g) `as` "P(C-g)" `run` liftIO (throwIO $ MyException "NG")+            on (release $ alt $ ctrl $ WKS.xK_x) `as` "R(M-C-x)" `run` liftIO (throwIO $ MyException "OK")+          b_0 = whenBack (== 0) $ binds' $ do+            on (press $ ctrl $ WKS.xK_i) `as` "P(C-i)" `run` State.put 1+          b_1 = whenBack (== 1) $ binds' $ do+            on (press $ ctrl $ WKS.xK_i) `as` "P(C-i)" `run` State.put 0+            on (press $ alt $ ctrl $ WKS.xK_x) `as` "P(M-C-x)" `run` return ()+          rev _ _ i = justBefore $ p ("Input: " ++ (unpack $ WBD.describe i))+          b = revise rev $ startFrom (0 :: Int) $ b_base <> b_0 <> b_1+          exp_descs = [ ["P(C-g)", "R(M-C-x)", "P(C-i)"],+                        ["P(C-g)", "R(M-C-x)", "P(C-i)", "P(M-C-x)"],+                        ["P(C-g)", "R(M-C-x)", "P(C-i)"]+                      ]+      p "Input C-i C-i M-C-x. If wildBind is still blocked, then type C-g."+      result <- waitCatch =<< async (wildBind' opt b f)+      got_descs <- fmap ((map . map) snd . reverse) $ readIORef got_binds_rev+      length got_descs `shouldBe` length exp_descs+      forM_ (zip got_descs exp_descs) $ uncurry shouldMatchList+      case result of+       Right _ -> expectationFailure "expects an exception, but nothing happened."+       Left e -> fromException e `shouldBe` (Just $ MyException "OK")+         describe "X11Front - NumPadUnlocked" $ do-    it "should grab/ungrab keys" $ maybeRun $ withFrontEnd $ \(f :: FrontEnd ActiveWindow NumPad.NumPadUnlocked) -> do-      grabCase f+    it "should grab/ungrab keys" $ maybeRun $ withFrontEndForTest $ \f -> do+      let grabCase' :: FrontEnd ActiveWindow NumPad.NumPadUnlocked -> Expectation+          grabCase' = grabCase+      grabCase' f   describe "X11Front - NumPadLocked" $ do-    it "should grab/ungrab keys" $ maybeRun $ withFrontEnd $ \(f :: FrontEnd ActiveWindow NumPad.NumPadLocked) -> do-      grabCase f-+    it "should grab/ungrab keys" $ maybeRun $ withFrontEndForTest $ \f -> do+      let grabCase' :: FrontEnd ActiveWindow NumPad.NumPadLocked -> Expectation+          grabCase' = grabCase+      grabCase' f+  describe "X11Front - normal modified keys (pressed)" $ do+    it "should distinguish modifiers" $ maybeRun $ withFrontEndForTest $ \f -> do+      let inputs = [ ctrl Xlib.xK_i,+                     ctrl $ alt Xlib.xK_i,+                     super Xlib.xK_i,+                     shift $ super Xlib.xK_I+                   ]+      withGrabs f inputs $ do+        p ("Grabbed " ++ (intercalate ", " $ map describeStr inputs))+        forM_ inputs $ \input -> do+          p ("Push " ++ describeStr input)+          press_ev <- frontNextEvent f+          p ("Got event: " ++ show press_ev)+          press_ev `shouldBe` FEInput input+          release_ev <- frontNextEvent f+          p ("Got event: " ++ show release_ev)+          release_ev `shouldBe` (FEInput $ input { xKeyEventType = KeyRelease })+  describe "X11Front - Either" $ do+    it "should combine input types" $ maybeRun $ withFrontEndForTest $ \f -> do+      let inputs = [Left NumPad.NumLPeriod, Right NumPad.NumDelete]+      withGrabs f inputs $ do+        forM_ inputs $ \input -> do+          p ("Push " ++ show input)+          ev <- frontNextEvent f+          ev `shouldBe` FEInput input

@@ -1,5 +1,5 @@ name:                   wild-bind-x11-version:                0.1.0.7+version:                0.2.0.0 author:                 Toshio Ito <debug.ito@gmail.com> maintainer:             Toshio Ito <debug.ito@gmail.com> license:                BSD3@@ -17,20 +17,27 @@   default-language:     Haskell2010   hs-source-dirs:       src   ghc-options:          -Wall -fno-warn-unused-imports-  default-extensions:   TypeSynonymInstances, OverloadedStrings, MultiParamTypeClasses, FlexibleInstances+  other-extensions:     GeneralizedNewtypeDeriving, FlexibleContexts, TypeSynonymInstances,+                        OverloadedStrings   exposed-modules:      WildBind.X11,+                        WildBind.X11.Emulate,+                        WildBind.X11.Emulate.Example,+                        WildBind.X11.KeySym,                         WildBind.X11.Internal.Key,                         WildBind.X11.Internal.Window,                         WildBind.X11.Internal.NotificationDebouncer---  other-modules:        +  other-modules:        WildBind.X11.Internal.FrontEnd,+                        WildBind.X11.Internal.GrabMan   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.9,                         containers >=0.5.0 && <0.6,                         transformers >=0.3.0 && <0.6,+                        mtl >=2.2.1 && <2.3,                         fold-debounce >=0.2.0 && <0.3,-                        stm >=2.4.2 && <2.5+                        stm >=2.4.2 && <2.5,+                        semigroups >=0.16.2.2 && <0.19  -- executable wild-bind-x11 --   default-language:     Haskell2010@@ -41,8 +48,8 @@ --   -- 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.+flag test-interactive+  description: Run tests that require the user to interact with the test script.   default: False  test-suite spec@@ -50,19 +57,19 @@   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+  if flag(test-interactive)+    cpp-options:        -DTEST_INTERACTIVE   main-is:              Spec.hs-  other-extensions:     FlexibleContexts, ScopedTypeVariables, CPP+  other-extensions:     FlexibleContexts, CPP, OverloadedStrings   other-modules:        WildBind.X11Spec,-                        WildBind.X11.Internal.KeySpec,+                        WildBind.X11.EmulateSpec,                         WildBind.X11.Internal.NotificationDebouncerSpec,                         WildBind.X11.TestUtil   build-depends:        base, wild-bind-x11,-                        wild-bind, X11,+                        wild-bind, X11, text, transformers,                         hspec >=2.1.7,-                        QuickCheck >=2.6 && <3.0,-                        time >=1.5.0 && <1.9+                        time >=1.5.0 && <1.9,+                        async >=2.0.2 && <2.2  source-repository head   type:                 git