x11-xinput (empty) → 0.1.0.0
raw patch · 10 files changed
+1212/−0 lines, 10 filesdep +X11dep +basedep +containerssetup-changed
Dependencies added: X11, base, containers, mtl
Files
- Graphics/X11/XInput.hs +13/−0
- Graphics/X11/XInput/Devices.hs +81/−0
- Graphics/X11/XInput/Foreign.chs +275/−0
- Graphics/X11/XInput/Functions.hs +120/−0
- Graphics/X11/XInput/Parser.chs +250/−0
- Graphics/X11/XInput/Types.chs +358/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- x11-xinput.cabal +36/−0
- xitest.hs +47/−0
+ Graphics/X11/XInput.hs view
@@ -0,0 +1,13 @@++module Graphics.X11.XInput+ (module Graphics.X11.XInput.Types,+ module Graphics.X11.XInput.Foreign,+ module Graphics.X11.XInput.Functions,+ module Graphics.X11.XInput.Devices)+ where++import Graphics.X11.XInput.Types+import Graphics.X11.XInput.Foreign+import Graphics.X11.XInput.Functions+import Graphics.X11.XInput.Devices+
+ Graphics/X11/XInput/Devices.hs view
@@ -0,0 +1,81 @@++module Graphics.X11.XInput.Devices+ (Device (..),+ DevicesMap (..),+ buildDevicesMap,+ showDevicesMap,+ isMasterDevice,+ deviceById, masterDeviceById,+ deviceByName+ ) where++import qualified Data.Map as M+import Text.Printf++import Graphics.X11.XInput.Types++data Device = Device {+ masterDevice :: DeviceInfo,+ slaveDevices :: [DeviceInfo] }+ deriving (Eq, Show)++data DevicesMap = DevicesMap {+ masterDevices :: M.Map DeviceID Device+ , allDevices :: M.Map DeviceID DeviceInfo+ , byName :: M.Map String DeviceInfo }+ deriving (Eq, Show)++buildDevicesMap :: [DeviceInfo] -> DevicesMap+buildDevicesMap list = DevicesMap {+ masterDevices = M.fromList $ build [] list+ , allDevices = M.fromList [(diID di, di) | di <- list]+ , byName = M.fromList [(diName di, di) | di <- list]+ }+ where+ build :: [(DeviceID, Device)] -> [DeviceInfo] -> [(DeviceID, Device)]+ build done [] = done+ build done (d:ds) = + case diUse d of+ XIMasterPointer -> build (simply d: done) ds+ XIMasterKeyboard -> build (simply d: done) ds+ XISlavePointer -> build (up d done) ds+ XISlaveKeyboard -> build (up d done) ds+ XIFloatingSlave -> build (up d done) ds++ simply d = (diID d, Device d [])++ up :: DeviceInfo -> [(DeviceID, Device)] -> [(DeviceID, Device)]+ up d ds = map (update d) ds++ update :: DeviceInfo -> (DeviceID, Device) -> (DeviceID, Device)+ update slave pair@(masterID, master)+ | diAttachment slave == masterID = (masterID, add master slave)+ | otherwise = pair++ add master slave =+ master {slaveDevices = slave: slaveDevices master}++showDevicesMap :: DevicesMap -> String+showDevicesMap m = unlines $ map go $ M.assocs $ masterDevices m+ where+ go (devID, dev) =+ (printf "#%s: %s\n" (show devID) (show $ masterDevice dev))+ ++ (unlines $ map one $ slaveDevices dev)++ one dev = printf " +-- #%s: %s"+ (show $ diID dev)+ (show dev)++isMasterDevice :: DeviceID -> DevicesMap -> Bool+isMasterDevice i dmap = i `M.member` masterDevices dmap++deviceById :: DeviceID -> DevicesMap -> Maybe DeviceInfo+deviceById i dmap = M.lookup i (allDevices dmap)++masterDeviceById :: DeviceID -> DevicesMap -> Maybe Device+masterDeviceById i dmap = M.lookup i (masterDevices dmap)++deviceByName :: String -> DevicesMap -> Maybe DeviceInfo+deviceByName name dmap = M.lookup name (byName dmap)++
+ Graphics/X11/XInput/Foreign.chs view
@@ -0,0 +1,275 @@+{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}+{-|+This module contains FFI imports and thin wrappers for them.+-}+module Graphics.X11.XInput.Foreign+ (-- * XInput initialization+ xinputVersion,+ setEventMask,+ -- * Wrappers for XInput calls+ queryDevice,+ grabDevice, ungrabDevice,+ grabButton, ungrabButton,+ grabKeycode, ungrabKeycode,+ -- * FFI imports+ xiQueryDevice,+ xQueryExtension,+ getEventData,+ freeEventData+ ) where++#include <X11/Xlib.h>+#include <X11/extensions/XInput2.h>++import Control.Applicative+import Control.Monad+import Data.Bits+import Foreign.C+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import qualified Graphics.X11 as X11++import Graphics.X11.XInput.Types+import Graphics.X11.XInput.Parser++-- | Query list of devices+queryDevice :: X11.Display+ -> SelectDevices -- ^ Which devices to list+ -> IO [DeviceInfo]+queryDevice dpy devs = do+ alloca $ \nptr -> do+ dptr <- xiQueryDevice dpy (selectDevices devs) nptr+ n <- peek nptr+ let sz = {# sizeof XIDeviceInfo #}+ offsets = take (fromIntegral n) [0, sz ..]+ dptrs = map (plusPtr dptr) offsets+ forM dptrs peekStruct++foreign import ccall "Foreign.chs.h XIQueryDevice"+ xiQueryDevice :: X11.Display -> CInt -> Ptr CInt -> IO DeviceInfoPtr++foreign import ccall "Foreign.chs.h XQueryExtension"+ xQueryExtension :: X11.Display -> CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO CInt++foreign import ccall "Foreign.chs.h XIQueryVersion"+ xinputVersion :: X11.Display -> Ptr CInt -> Ptr CInt -> IO CInt++{# fun unsafe XGetEventData as getEventData {display2ptr `X11.Display',+ castPtr `EventCookiePtr'} -> `Bool' #}++{# fun unsafe XFreeEventData as freeEventData {display2ptr `X11.Display',+ castPtr `EventCookiePtr'} -> `()' #}++pokeAlloca :: Storable a => a -> (Ptr a -> IO b) -> IO b+pokeAlloca x f =+ alloca $ \ptr -> do+ poke ptr x+ f ptr++{# fun unsafe XISelectEvents as selectEvents {display2ptr `X11.Display',+ fromIntegral `X11.Window',+ castPtr `EventMaskPtr',+ `Int'} -> `()' #}++foreign import ccall unsafe "Foreign.chs.h XIGrabDevice"+ xiGrabDevice :: X11.Display+ -> DeviceID+ -> X11.Window+ -> X11.Time+ -> X11.Cursor+ -> X11.GrabMode+ -> X11.GrabMode+ -> CInt+ -> EventMaskPtr+ -> IO CInt++foreign import ccall unsafe "Foreign.chs.h XIUngrabDevice"+ xiUngrabDevice :: X11.Display+ -> DeviceID+ -> X11.Time+ -> IO X11.Status++foreign import ccall unsafe "Foreign.chs.h XIGrabButton"+ xiGrabButton :: X11.Display+ -> DeviceID+ -> CInt+ -> X11.Window+ -> X11.Cursor+ -> X11.GrabMode+ -> X11.GrabMode+ -> CInt+ -> EventMaskPtr+ -> CInt+ -> GrabModifiersPtr+ -> IO CInt++foreign import ccall unsafe "Foreign.chs.h XIUngrabButton"+ xiUngrabButton :: X11.Display+ -> DeviceID+ -> X11.Button+ -> X11.Window+ -> CInt+ -> GrabModifiersPtr+ -> IO X11.Status++foreign import ccall unsafe "Foreign.chs.h XIGrabKeycode"+ xiGrabKeycode :: X11.Display+ -> DeviceID+ -> X11.KeyCode+ -> X11.Window+ -> X11.GrabMode+ -> X11.GrabMode+ -> CInt+ -> EventMaskPtr+ -> CInt+ -> GrabModifiersPtr+ -> IO CInt++foreign import ccall unsafe "Foreign.chs.h XIUngrabKeycode"+ xiUngrabKeycode :: X11.Display+ -> DeviceID+ -> X11.KeyCode+ -> X11.Window+ -> CInt+ -> GrabModifiersPtr+ -> IO X11.Status++grabDevice :: X11.Display+ -> DeviceID+ -> X11.Window+ -> X11.Cursor+ -> X11.GrabMode+ -> X11.GrabMode+ -> Bool+ -> EventMask + -> IO X11.Status+grabDevice dpy dev win cursor+ grab_mode paired_mode owner_events mask =+ pokeAlloca mask $ \maskPtr ->+ xiGrabDevice dpy dev win 0 cursor+ grab_mode paired_mode+ (fromBool owner_events)+ maskPtr++ungrabDevice :: X11.Display+ -> DeviceID+ -> IO X11.Status+ungrabDevice dpy dev =+ xiUngrabDevice dpy dev 0++grabButton :: X11.Display+ -> SelectDevices+ -> X11.Button+ -> X11.Window+ -> X11.Cursor+ -> X11.GrabMode+ -> X11.GrabMode+ -> Bool+ -> [EventType]+ -> [GrabModifiers]+ -> IO [GrabModifiers]+grabButton dpy dev btn win cursor+ grab_mode paired_mode owner_events+ events mods = do+ let nMods = length mods+ allocaArray nMods $ \modsPtr ->+ withEventMask dpy win events $ \maskPtr -> do+ pokeArray modsPtr mods+ n <- xiGrabButton dpy (selectDevices dev)+ (fromIntegral btn) win cursor+ grab_mode paired_mode+ (fromBool owner_events)+ maskPtr+ (fromIntegral nMods)+ modsPtr+ peekArray (fromIntegral n) modsPtr++ungrabButton :: X11.Display+ -> SelectDevices+ -> X11.Button+ -> X11.Window+ -> [GrabModifiers]+ -> IO X11.Status+ungrabButton dpy dev btn win mods = do+ let nMods = length mods+ allocaArray nMods $ \modsPtr -> do+ xiUngrabButton dpy (selectDevices dev)+ (fromIntegral btn) win+ (fromIntegral nMods)+ modsPtr++grabKeycode :: X11.Display+ -> SelectDevices+ -> X11.KeyCode+ -> X11.Window+ -> X11.GrabMode+ -> X11.GrabMode+ -> Bool+ -> [EventType]+ -> [GrabModifiers]+ -> IO [GrabModifiers]+grabKeycode dpy dev btn win+ grab_mode paired_mode owner_events+ events mods = do+ let nMods = length mods+ allocaArray nMods $ \modsPtr ->+ withEventMask dpy win events $ \maskPtr -> do+ pokeArray modsPtr mods+ n <- xiGrabKeycode dpy (selectDevices dev)+ (fromIntegral btn) win+ grab_mode paired_mode+ (fromBool owner_events)+ maskPtr+ (fromIntegral nMods)+ modsPtr+ peekArray (fromIntegral n) modsPtr++ungrabKeycode :: X11.Display+ -> SelectDevices+ -> X11.KeyCode+ -> X11.Window+ -> [GrabModifiers]+ -> IO X11.Status+ungrabKeycode dpy dev btn win mods = do+ let nMods = length mods+ allocaArray nMods $ \modsPtr -> do+ xiUngrabKeycode dpy (selectDevices dev)+ (fromIntegral btn) win+ (fromIntegral nMods)+ modsPtr++addMask :: Ptr CUChar -> EventType -> IO ()+addMask ptr t = do+ let event = eventType2int t+ offset = fromIntegral $ event `shiftR` 3+ mask = (1 `shiftL` (event .&. 7)) :: CUChar+ value <- peekByteOff ptr offset :: IO CUChar+ let newValue = value .|. mask+ pokeByteOff ptr offset newValue++-- | Select XInput events.+setEventMask :: X11.Display+ -> X11.Window+ -> [EventType] -- ^ List of events to listen+ -> IO ()+setEventMask dpy win list =+ withEventMask dpy win list $ \maskptr ->+ selectEvents dpy win maskptr 1++withEventMask :: X11.Display+ -> X11.Window+ -> [EventType]+ -> (EventMaskPtr -> IO a)+ -> IO a+withEventMask dpy win list callback = do+ let len = (eventType2int XI_RawMotion + 7) `shiftR` 3+ allocaBytes (fromIntegral len) $ \(maskptr :: EventMaskPtr) -> do+ {# set XIEventMask.deviceid #} maskptr 0+ {# set XIEventMask.mask_len #} maskptr len+ allocaArray (fromIntegral len) $ \mask -> do+ forM list $ addMask mask+ {# set XIEventMask.mask #} maskptr mask+ callback maskptr+
+ Graphics/X11/XInput/Functions.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE RecordWildCards #-}+{-| This module contains some higher-level functions,+ - wrapping XInput calls. #-}+module Graphics.X11.XInput.Functions+ (xinputInit,+ xinputCheckVersion,+ handleXCookie,+ eventButton,+ eventWindow,+ eventKeyMask,+ eventMousePos+ ) where++import Control.Applicative+import Control.Monad.Trans+import Foreign.C+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import qualified Graphics.X11 as X11+import qualified Graphics.X11.Xlib.Extras as E++import Graphics.X11.XInput.Types+import Graphics.X11.XInput.Foreign+import Graphics.X11.XInput.Parser++-- | Initialize XInput 2.0 extension.+xinputInit :: X11.Display -> IO XInputInitResult+xinputInit dpy = do+ withCString "XInputExtension" $ \xinput ->+ alloca $ \opcode -> + alloca $ \event ->+ alloca $ \error -> do+ result <- xQueryExtension dpy xinput opcode event error+ if result /= 0+ then do+ xi_opcode <- peek opcode+ mbVer <- xinputCheckVersion dpy+ case mbVer of+ Nothing -> return $ InitOK xi_opcode+ Just (major, minor) -> return $ VersionMismatch major minor+ else return NoXInput++xinputMajor, xinputMinor :: CInt+xinputMajor = 2+xinputMinor = 0++-- | Returns Nothing if XInput 2.0 is supported, or+-- Just (major, minor) if another version is supported+xinputCheckVersion :: X11.Display -> IO (Maybe (Int, Int))+xinputCheckVersion dpy = do+ alloca $ \majorPtr ->+ alloca $ \minorPtr -> do+ poke majorPtr xinputMajor+ poke minorPtr xinputMinor+ result <- xinputVersion dpy majorPtr minorPtr+ supportedMajor <- peek majorPtr+ supportedMinor <- peek minorPtr+ if result == 1+ then return $ Just (fromIntegral supportedMajor, fromIntegral supportedMinor)+ else return Nothing++-- | Handle usual X11 event or cookie event.+handleXCookie :: (MonadIO m) => X11.Display+ -> Opcode -- ^ Extension identifier (one got from xinputInit)+ -> X11.XEventPtr -- ^ Pointer to X11 event+ -> (E.Event -> m a) -- ^ Handler for usual X11 event+ -> (EventCookie -> m a) -- ^ Handler for X11 cookie event+ -> m a+handleXCookie dpy xi_opcode xev evHandler cookieHandler = do+-- liftIO $ putStrLn "handling XCookie"+ evtype <- liftIO $ get_event_type xev+ ext <- liftIO $ get_event_extension xev+ hasCookie <- liftIO $ getEventData dpy (castPtr xev)+ result <- if (evtype == genericEvent) && (ext == xi_opcode) && hasCookie+ then do+-- liftIO $ putStrLn "XInput event"+ cookieHandler =<< (liftIO $ getXGenericEventCookie xev)+ else evHandler =<< (liftIO $ E.getEvent xev)+ liftIO $ freeEventData dpy (castPtr xev)+ return result++-- | Shortcut to get button number or keycode+-- from keyboard or mouse event. Returns Nothing+-- if this is not mouse or keyboard event.+eventButton :: Event -> Maybe Int+eventButton (Event {..})+ | (eType `elem` [XI_ButtonPress, XI_ButtonRelease,+ XI_KeyPress, XI_KeyRelease]) =+ case eSpecific of+ GPointerEvent {peDetail = n} -> Just n+ _ -> Nothing+ | otherwise = Nothing++-- | Shortcut to get pointer position from event+eventMousePos :: Event -> Maybe (X11.Position, X11.Position)+eventMousePos (Event {..})+ | (eType `elem` [XI_ButtonPress, XI_ButtonRelease,+ XI_KeyPress, XI_KeyRelease,+ XI_Enter, XI_Leave]) =+ let x = round (peRootX eSpecific)+ y = round (peRootY eSpecific)+ in Just (x, y)+ | otherwise = Nothing++-- | Shortcut to get event window.+-- Returns Nothing if this is not pointer-related event+eventWindow :: Event -> Maybe X11.Window+eventWindow e =+ case eSpecific e of+ GPointerEvent {peEvent = w} -> Just w+ _ -> Nothing++-- | Shortcut to get keymask from event+eventKeyMask :: Event -> Maybe X11.KeyMask+eventKeyMask (Event {eSpecific = GPointerEvent {peSpecific = e}}) =+ Just $ fromIntegral $ msBase $ peMods e+eventKeyMask _ = Nothing+
+ Graphics/X11/XInput/Parser.chs view
@@ -0,0 +1,250 @@+{-# LANGUAGE TypeFamilies #-}+{-| Functions of this module perform parsing of XInput events structures. -}+module Graphics.X11.XInput.Parser where++#include <X11/Xlib.h>+#include <X11/extensions/XInput2.h>++import Control.Applicative+import Control.Monad+import qualified Data.Map as M+import Data.Bits+import Foreign.C+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Text.Printf+import qualified Graphics.X11 as X11+import qualified Graphics.X11.Xlib.Extras as E++import Graphics.X11.XInput.Types++class Struct a where+ type Pointer a+ peekStruct :: Pointer a -> IO a++peekClasses :: Int -> Ptr a -> IO [GDeviceClass]+peekClasses n ptr = do+ let ptr' = castPtr ptr :: Ptr GDeviceClassPtr+ classesPtrs <- peekArray (fromIntegral n) ptr'+ forM classesPtrs (peekStruct . castPtr)++checkByte :: CUChar -> [Int]+checkByte x = [i | i <- [0..7], x .&. (1 `shiftL` i) /= 0]++parseMask :: Mask -> [Int]+parseMask [] = []+parseMask [x] = checkByte x+parseMask list =+ let x = last list+ xs = init list+ in map (+ 8) (checkByte x) ++ parseMask xs++peekMask :: (Ptr a -> IO CInt) -> (Ptr a -> IO (Ptr CUChar)) -> Ptr a -> IO [Int]+peekMask getLength getMask ptr = do+ len <- trace "maskLen" $ getLength ptr+ maskPtr <- trace "maskPtr" $ getMask ptr+ mask <- trace "mask" $ peekArray (fromIntegral len) maskPtr+ return $ parseMask mask++packMask :: [Int] -> X11.KeyMask+packMask list = foldr (.|.) 0 $ map (1 `shiftL`) list++instance Struct DeviceInfo where+ type Pointer DeviceInfo = DeviceInfoPtr++ peekStruct ptr = do+ id <- {# get XIDeviceInfo->deviceid #} ptr+ namePtr <- {# get XIDeviceInfo->name #} ptr+ name <- peekCString namePtr+ use <- int2deviceType <$> {# get XIDeviceInfo->use #} ptr+ att <- {# get XIDeviceInfo->attachment #} ptr+ on <- toBool <$> {# get XIDeviceInfo->enabled #} ptr+ ncls <- fromIntegral <$> {# get XIDeviceInfo->num_classes #} ptr+ clsptr <- {# get XIDeviceInfo->classes #} ptr+ classes <- peekClasses ncls clsptr+ return $ DeviceInfo id name use att on classes++instance Struct GDeviceClass where+ type Pointer GDeviceClass = GDeviceClassPtr++ peekStruct ptr = do+ tp <- (toEnum . fromIntegral) <$> {# get XIAnyClassInfo->type #} ptr+ src <- {# get XIAnyClassInfo->sourceid #} ptr+ cls <- case tp of+ XIButtonClass -> peekButtonClass ptr+ XIKeyClass -> peekKeyClass ptr+ XIValuatorClass -> peekValuatorClass ptr+ return $ GDeviceClass tp (fromIntegral src) cls++instance Struct ButtonState where+ type Pointer ButtonState = GDeviceClassPtr++ peekStruct ptr = ButtonState+ <$> peekMask ({# get XIButtonClassInfo->state.mask_len #})+ ({# get XIButtonClassInfo->state.mask #})+ ptr++peekButtonClass :: GDeviceClassPtr -> IO DeviceClass+peekButtonClass ptr = do+ n <- {# get XIButtonClassInfo->num_buttons #} ptr+ labelsPtr <- {# get XIButtonClassInfo->labels #} ptr+ labels <- peekArray (fromIntegral n) labelsPtr+ st <- peekStruct ptr+ return $ ButtonClass (fromIntegral n) (map fromIntegral labels) st++peekKeyClass :: GDeviceClassPtr -> IO DeviceClass+peekKeyClass ptr = do+ n <- {# get XIKeyClassInfo->num_keycodes #} ptr+ kptr <- {# get XIKeyClassInfo->keycodes #} ptr+ keycodes <- peekArray (fromIntegral n) kptr+ return $ KeyClass (fromIntegral n) (map fromIntegral keycodes)++peekValuatorClass :: GDeviceClassPtr -> IO DeviceClass+peekValuatorClass ptr = ValuatorClass + <$> (fromIntegral <$> {# get XIValuatorClassInfo->number #} ptr)+ <*> (fromIntegral <$> {# get XIValuatorClassInfo->label #} ptr)+ <*> (realToFrac <$> {# get XIValuatorClassInfo->min #} ptr)+ <*> (realToFrac <$> {# get XIValuatorClassInfo->max #} ptr)+ <*> (realToFrac <$> {# get XIValuatorClassInfo->value #} ptr)+ <*> (fromIntegral <$> {# get XIValuatorClassInfo->resolution #} ptr)+ <*> (fromIntegral <$> {# get XIValuatorClassInfo->mode #} ptr)++instance Struct Int where+ type Pointer Int = Ptr CInt+ peekStruct x = fromIntegral <$> peek x++get_event_type :: X11.XEventPtr -> IO X11.EventType+get_event_type ptr = fromIntegral <$> {# get XEvent->type #} ptr++get_event_extension :: X11.XEventPtr -> IO Opcode+get_event_extension ptr = {# get XGenericEvent->extension #} ptr++instance Struct EventCookie where+ type Pointer EventCookie = EventCookiePtr++ peekStruct xev = do+ ev <- E.getEvent (castPtr xev)+ ext <- {# get XGenericEventCookie->extension #} xev+ et <- {# get XGenericEventCookie->evtype #} xev+ cookie <- {# get XGenericEventCookie->cookie #} xev+ dptr <- {# get XGenericEventCookie->data #} xev+ cdata <- peekStruct (castPtr dptr)++ return $ EventCookie {+ ecEvent = ev,+ ecExtension = ext,+ ecType = int2eventType et,+ ecCookie = cookie,+ ecData = cdata }++getXGenericEventCookie :: X11.XEventPtr -> IO EventCookie+getXGenericEventCookie = peekStruct . castPtr++instance Struct Event where+ type Pointer Event = EventPtr++ peekStruct de = do + se <- toBool <$> {# get XIEvent->send_event #} de+ dpy <- ptr2display <$> {# get XIEvent->display #} de+ ext <- {# get XIDeviceEvent->extension #} de+ evt <- int2eventType <$> {# get XIEvent->evtype #} de+ dev <- {# get XIDeviceEvent->deviceid #} de+ spec <- peekEventSpecific evt de+ return $ Event se dpy ext evt dev spec+++peekEventSpecific XI_PropertyEvent e = PropertyEvent+ <$> (fromIntegral <$> {# get XIPropertyEvent->property #} e)+ <*> {# get XIPropertyEvent->what #} e++peekEventSpecific XI_DeviceChanged e = do+ reason <- {# get XIDeviceChangedEvent->reason #} e+ ncls <- (fromIntegral <$> {# get XIDeviceChangedEvent->num_classes #} e)+ clsPtr <- {# get XIDeviceChangedEvent->classes #} e+ classes <- peekClasses ncls clsPtr+ return $ DeviceChangedEvent reason classes++peekEventSpecific t e = GPointerEvent+ <$> {# get XIDeviceEvent->sourceid #} e+ <*> (fromIntegral <$> {# get XIDeviceEvent->detail #} e)+ <*> (fromIntegral <$> {# get XIDeviceEvent->root #} e)+ <*> (fromIntegral <$> {# get XIDeviceEvent->event #} e)+ <*> (fromIntegral <$> {# get XIDeviceEvent->child #} e)+ <*> {# get XIDeviceEvent->root_x #} e+ <*> {# get XIDeviceEvent->root_y #} e+ <*> {# get XIDeviceEvent->event_x #} e+ <*> {# get XIDeviceEvent->event_y #} e+ <*> trace "pointerEvent" (peekPointerEvent t e)++trace :: Show a => String -> IO a -> IO a+trace _ x = x+-- trace prefix action = do+-- result <- action+-- putStrLn $ prefix ++ ": " ++ show result+-- return result++peekPointerEvent XI_Enter e = EnterLeaveEvent+ <$> {# get XIEnterEvent->mode #} e+ <*> (toBool <$> {# get XIEnterEvent->focus #} e)+ <*> (toBool <$> {# get XIEnterEvent->same_screen #} e)+ <*> (ButtonState <$>+ (peekMask ({# get XIEnterEvent->buttons.mask_len #})+ ({# get XIEnterEvent->buttons.mask #})+ e ) )+ <*> (ModifierState+ <$> (fromIntegral <$> {# get XIEnterEvent->mods.base #} e)+ <*> (fromIntegral <$> {# get XIEnterEvent->mods.latched #} e)+ <*> (fromIntegral <$> {# get XIEnterEvent->mods.locked #} e)+ <*> (fromIntegral <$> {# get XIEnterEvent->mods.effective #} e))+ <*> (ModifierState+ <$> (fromIntegral <$> {# get XIEnterEvent->group.base #} e)+ <*> (fromIntegral <$> {# get XIEnterEvent->group.latched #} e)+ <*> (fromIntegral <$> {# get XIEnterEvent->group.locked #} e)+ <*> (fromIntegral <$> {# get XIEnterEvent->group.effective #} e))++peekPointerEvent XI_Leave e = peekPointerEvent XI_Enter e++peekPointerEvent XI_RawKeyPress e = peekRawEvent XI_RawKeyPress e++peekPointerEvent XI_RawKeyRelease e = peekRawEvent XI_RawKeyRelease e++peekPointerEvent t e = DeviceEvent+ <$> trace "event type" (return t)+ <*> trace "flags" ({# get XIDeviceEvent->flags #} e)+ <*> trace "buttons" (ButtonState <$>+ (peekMask ({# get XIDeviceEvent->buttons.mask_len #})+ ({# get XIDeviceEvent->buttons.mask #})+ e ) )+ <*> trace "valuators" (do+ mask <- trace "mask" $ peekMask ({# get XIDeviceEvent->valuators.mask_len #})+ ({# get XIDeviceEvent->valuators.mask #})+ e+ valuesPtr <- trace "valuesPtr" $ {# get XIDeviceEvent->valuators.values #} e+ values <- trace "values" $ peekArray (length mask) valuesPtr :: IO [CDouble]+ let values' = map realToFrac values :: [Double]+ return $ M.fromList $ zip mask values' )+ <*> trace "mods" (ModifierState+ <$> (fromIntegral <$> {# get XIDeviceEvent->mods.base #} e)+ <*> (fromIntegral <$> {# get XIDeviceEvent->mods.latched #} e)+ <*> (fromIntegral <$> {# get XIDeviceEvent->mods.locked #} e)+ <*> (fromIntegral <$> {# get XIDeviceEvent->mods.effective #} e))+ <*> trace "group" (ModifierState+ <$> (fromIntegral <$> {# get XIDeviceEvent->group.base #} e)+ <*> (fromIntegral <$> {# get XIDeviceEvent->group.latched #} e)+ <*> (fromIntegral <$> {# get XIDeviceEvent->group.locked #} e)+ <*> (fromIntegral <$> {# get XIDeviceEvent->group.effective #} e))+++peekRawEvent t e = RawEvent+ <$> trace "event type" (return t)+ <*> trace "flags" ({# get XIRawEvent->flags #} e)+ <*> trace "valuators" (do+ mask <- trace "mask" $ peekMask ({# get XIRawEvent->valuators.mask_len #})+ ({# get XIRawEvent->valuators.mask #})+ e+ valuesPtr <- trace "valuesPtr" $ {# get XIRawEvent->valuators.values #} e+ values <- trace "values" $ peekArray (length mask) valuesPtr :: IO [CDouble]+ let values' = map realToFrac values :: [Double]+ return $ M.fromList $ zip mask values' )
+ Graphics/X11/XInput/Types.chs view
@@ -0,0 +1,358 @@+{-# LANGUAGE RecordWildCards #-}+{-| This module contains declarations of used XInput event structures.+See XInput2.h for more info.+-}+module Graphics.X11.XInput.Types where++#include <X11/Xlib.h>+#include <X11/extensions/XInput2.h>++import Control.Applicative+import Control.Monad+import qualified Data.Map as M+import Data.Bits+import Foreign.C+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Text.Printf+import qualified Graphics.X11 as X11+import qualified Graphics.X11.Xlib.Extras as E++instance Eq E.Event where+ x == y = E.ev_serial x == E.ev_serial y++genericEvent :: X11.EventType+genericEvent = 35++type Opcode = CInt++-- | Type for X11 cookie events+data EventCookie = EventCookie {+ ecEvent :: E.Event -- ^ Usual X11 event+ , ecExtension :: Opcode -- ^ X11 extension identifier + , ecType :: EventType -- ^ Event type+ , ecCookie :: CUInt+ , ecData :: Event -- ^ XInput event+ }+ deriving (Eq)++instance Show EventCookie where+ show e = printf "<%s: %s>"+ (show $ ecType e)+ (show $ ecData e)++-- | XInput events+data Event = Event {+ eSendEvent :: Bool -- ^ True if event was sent by SendEvent+ , eDisplay :: X11.Display -- + , eExtension :: Opcode -- ^ X11 extension identifier+ , eType :: EventType -- ^ Event type+ , eDeviceId :: DeviceID -- ^ Device identifier+ , eSpecific :: EventSpecific -- ^ Event-specific data+ }+ deriving (Eq)++instance Show Event where+ show e = printf "Event [device #%s] (%s)"+ (show $ eDeviceId e)+ (show $ eSpecific e)++-- | Event-specific info+data EventSpecific =+ GPointerEvent {+ peSourceId :: CInt -- ^ Source device identifier+ , peDetail :: Int -- ^ Detailed info; for example, button number or keycode+ , peRoot :: X11.Window -- ^ Root window+ , peEvent :: X11.Window -- ^ Event window+ , peChild :: X11.Window -- ^ Child window+ , peRootX :: CDouble+ , peRootY :: CDouble+ , peEventX :: CDouble+ , peEventY :: CDouble+ , peSpecific :: PointerEvent -- ^ Event-specific+ } -- ^ General constructor for all pointer-related events+ | PropertyEvent {+ peProperty :: X11.Atom,+ peWhat :: CInt }+ | DeviceChangedEvent {+ dceReason :: CInt,+ dceClasses :: [GDeviceClass] }+ | UnsupportedEvent CInt+ deriving (Eq)++instance Show EventSpecific where+ show (GPointerEvent {..}) =+ printf "from %s [%s], at (%.2f, %.2f): window %s, child %s: %s"+ (show peSourceId)+ (show peDetail)+ (realToFrac peRootX :: Double)+ (realToFrac peRootY :: Double)+ (show peEvent)+ (show peChild)+ (show peSpecific)++ show (PropertyEvent {..}) =+ printf "property %s: %s"+ (show peProperty)+ (show peWhat)++ show (DeviceChangedEvent {..}) =+ printf "device change [reason %s]: classes %s"+ (show dceReason)+ (show dceClasses)++ show (UnsupportedEvent e) = "unsupported event #" ++ show e++-- | All pointer-related event details+data PointerEvent =+ EnterLeaveEvent {+ eeMode :: CInt+ , eeFocus :: Bool+ , eeSameScreen :: Bool+ , peButtons :: ButtonState+ , peMods :: ModifierState+ , peGroup :: GroupState+ } -- ^ XIEnterEvent or XILeaveEvent+ | RawEvent {+ reType :: EventType+ , reFlags :: CInt+ , reValuators :: ValuatorState+ -- raw_values+ }+ | DeviceEvent {+ deType :: EventType+ , deFlags :: CInt+ , peButtons :: ButtonState+ , deValuators :: ValuatorState+ , peMods :: ModifierState+ , peGroup :: GroupState+ } -- ^ Device event, such as button press+ deriving (Eq, Show)++-- | XInput event type+data EventType =+ XI_DeviceChanged -- 1+ | XI_KeyPress -- 2+ | XI_KeyRelease -- 3+ | XI_ButtonPress -- 4+ | XI_ButtonRelease -- 5+ | XI_Motion -- 6+ | XI_Enter -- 7+ | XI_Leave -- 8+ | XI_FocusIn -- 9+ | XI_FocusOut -- 10+ | XI_HierarchyChanged -- 11+ | XI_PropertyEvent -- 12+ | XI_RawKeyPress -- 13+ | XI_RawKeyRelease -- 14+ | XI_RawButtonPress -- 15+ | XI_RawButtonRelease -- 16+ | XI_RawMotion -- 17+ deriving (Eq, Show, Ord, Enum)++eventType2int :: Num a => EventType -> a+eventType2int et = fromIntegral $ fromEnum et + 1++int2eventType :: Integral a => a -> EventType+int2eventType n = toEnum (fromIntegral n - 1)++data EventMask = EventMask {+ emDeviceID :: DeviceID,+ emMask :: [Int] }+ deriving (Eq, Show)++instance Storable EventMask where+ sizeOf (EventMask dev mask) =+ let w = sizeOf (0 :: CInt)+ in (length mask + 2) * w++ alignment _ = alignment (0 :: CInt)++ peek ptr = do+ dev <- {# get XIEventMask->deviceid #} ptr+ len <- {# get XIEventMask->mask_len #} ptr+ maskPtr <- {# get XIEventMask->mask #} ptr+ mask <- peekArray (fromIntegral len) maskPtr+ return $ EventMask dev (map fromIntegral mask)++ poke ptr (EventMask dev mask) = do+ {# set XIEventMask->deviceid #} ptr dev+ let len = length mask+ w = sizeOf (0 :: CInt)+ p = sizeOf (nullPtr :: Ptr CUChar)+ maskPtr = castPtr (ptr `plusPtr` (w*2 + p)) :: Ptr CInt+ {# set XIEventMask->mask_len #} ptr (fromIntegral len)+ pokeArray maskPtr (map fromIntegral mask)++{# pointer *XIEventMask as EventMaskPtr -> EventMask #}++{# pointer *XGenericEventCookie as EventCookiePtr -> EventCookie #}++{# pointer *XIEvent as EventPtr -> Event #}++data DeviceType =+ XIMasterPointer -- 1+ | XIMasterKeyboard -- 2+ | XISlavePointer -- 3+ | XISlaveKeyboard -- 4+ | XIFloatingSlave -- 5+ deriving (Eq, Show, Ord, Enum)++deviceType2int :: DeviceType -> CInt+deviceType2int dt = fromIntegral (fromEnum dt + 1)++int2deviceType :: CInt -> DeviceType+int2deviceType n = toEnum (fromIntegral n - 1)++type DeviceID = CInt++-- | Device info+data DeviceInfo = DeviceInfo {+ diID :: DeviceID -- ^ Device identifier+ , diName :: String -- ^ Device name+ , diUse :: DeviceType -- ^ Device type: master or slave+ , diAttachment :: DeviceID -- ^ Identifier of device this device is attached to+ , diEnabled :: Bool -- + , diClasses :: [GDeviceClass] -- ^ Device classes+ }+ deriving (Eq)++instance Show DeviceInfo where+ show x = printf "<%s #%s: %s, attached to #%s, classes: %s>"+ (show $ diUse x)+ (show $ diID x)+ (diName x)+ (show $ diAttachment x)+ (show $ diClasses x)++{# pointer *XIDeviceInfo as DeviceInfoPtr -> DeviceInfo #}++-- | Type of device class+data DeviceClassType =+ XIKeyClass+ | XIButtonClass+ | XIValuatorClass+ deriving (Eq, Show, Ord, Enum)++-- | Any device class+data GDeviceClass = GDeviceClass {+ dcType :: DeviceClassType+ , dcSourceId :: Int+ , dcSpecific :: DeviceClass+ }+ deriving (Eq)++instance Show GDeviceClass where+ show t = printf "<%s [%s]>" (show $ dcType t) (show $ dcSpecific t)++{# pointer *XIAnyClassInfo as GDeviceClassPtr -> GDeviceClass #}++type Mask = [CUChar]++data ButtonState = ButtonState {+ bsMask :: [Int] }+ deriving (Eq, Show)++{# pointer *XIButtonState as ButtonStatePtr -> ButtonState #}++data ModifierState = ModifierState {+ msBase :: Int+ , msLatched :: Int+ , msLocked :: Int+ , msEffective :: Int+ }+ deriving (Eq, Show)++{# pointer *XIModifierState as ModifierStatePtr -> ModifierState #}++type GroupState = ModifierState++type ValuatorState = M.Map Int Double++{# pointer *XIValuatorState as ValuatorStatePtr -> ValuatorState #}++-- | Device class specific info+data DeviceClass =+ ButtonClass {+ dcNumButtons :: Int+ , dcLabels :: [X11.Atom]+ , dcState :: ButtonState+ }+ | KeyClass {+ dcNumKeycodes :: Int+ , dcKeycodes :: [Int]+ }+ | ValuatorClass {+ dcNumber :: Int+ , dcLabel :: X11.Atom+ , dcMin :: Double+ , dcMax :: Double+ , dcValue :: Double+ , dcResolution :: Int+ , dcMode :: Int+ }+ deriving (Eq)++instance Show DeviceClass where+ show (ButtonClass n _ _) = printf "%s buttons" (show n)+ show (KeyClass n _) = printf "%s keycodes" (show n)+ show (ValuatorClass _ _ min max _ _ _) =+ printf "%.2f..%.2f" min max++data SelectDevices =+ XIAllDevices+ | XIAllMasterDevices+ | OneDevice DeviceID+ deriving (Eq, Show, Ord)++data GrabModifiers = GrabModifiers {+ gModifiers :: Int,+ gStatus :: Int }+ deriving (Eq, Show)++xiAnyModifier :: GrabModifiers+xiAnyModifier = GrabModifiers 1 0++keymask2grabModifiers :: X11.KeyMask -> GrabModifiers+keymask2grabModifiers mask = GrabModifiers (fromIntegral mask) 0++instance Storable GrabModifiers where+ sizeOf x = 2 * sizeOf (0 :: CInt)+ alignment _ = alignment (0 :: CInt)++ peek ptr = GrabModifiers+ <$> (fromIntegral <$> {# get XIGrabModifiers->modifiers #} ptr)+ <*> (fromIntegral <$> {# get XIGrabModifiers->status #} ptr)+ + poke ptr (GrabModifiers mods status) = do+ {# set XIGrabModifiers->modifiers #} ptr (fromIntegral mods)+ {# set XIGrabModifiers->status #} ptr (fromIntegral status)++{# pointer *XIGrabModifiers as GrabModifiersPtr -> GrabModifiers #}++selectDevices :: SelectDevices -> CInt+selectDevices XIAllDevices = 0+selectDevices XIAllMasterDevices = 1+selectDevices (OneDevice n) = n++ptr2display :: Ptr () -> X11.Display+ptr2display = X11.Display . castPtr++display2ptr :: X11.Display -> Ptr ()+display2ptr (X11.Display ptr) = castPtr ptr++toBool 0 = False+toBool 1 = True++fromBool True = 1+fromBool False = 0++-- | XInput initialization result+data XInputInitResult =+ NoXInput -- ^ Extension is not supported at all.+ | VersionMismatch Int Int -- ^ XInput 2.0 is not supported, but other version is.+ | InitOK Opcode -- ^ XInput 2.0 is supported, return xi_opcode.+ deriving (Eq, Show)+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, IlyaPortnov++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 IlyaPortnov 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ x11-xinput.cabal view
@@ -0,0 +1,36 @@+name: x11-xinput+version: 0.1.0.0+synopsis: Haskell FFI bindings for X11 XInput library (-lXi)+description: Haskell FFI bindings for X11 XInput library (-lXi).+ Only XInput version 2.0 is supported.+ See XInput manual pages and XInput2.h, XI2.h for more documentation.+homepage: http://redmine.iportnov.ru/projects/x11-xinput+license: BSD3+license-file: LICENSE+author: IlyaPortnov+maintainer: portnov84@rambler.ru+-- copyright: +category: Graphics+build-type: Simple+cabal-version: >=1.8++extra-source-files: xitest.hs++library+ exposed-modules: Graphics.X11.XInput,+ Graphics.X11.XInput.Parser,+ Graphics.X11.XInput.Foreign,+ Graphics.X11.XInput.Functions,+ Graphics.X11.XInput.Devices,+ Graphics.X11.XInput.Types+ -- other-modules: + build-depends: base >= 4.5 && < 5,+ containers >= 0.4,+ mtl >= 2.1,+ X11 >= 1.6+ build-tools: c2hs+ extra-libraries: "Xi"++source-repository head+ type: git+ location: git://redmine.iportnov.ru/x11-xinput.git
+ xitest.hs view
@@ -0,0 +1,47 @@++import Control.Applicative+import Control.Monad+import Control.Concurrent (threadDelay)+import Data.Bits+import System.Environment+import Graphics.X11+import Graphics.X11.XInput++withDisplay :: String -> (Display -> IO a) -> IO ()+withDisplay str action = do+ dpy <- openDisplay str+ action dpy+ closeDisplay dpy++main = do+ args <- getArgs+ let dpyStr = case args of+ [] -> ""+ [s] -> s+ _ -> error "Synopsis: xitest DISPLAY"+ withDisplay dpyStr $ \dpy -> do+ InitOK xi_opcode <- xinputInit dpy+ devices <- buildDevicesMap <$> queryDevice dpy XIAllDevices + putStrLn (showDevicesMap devices)+ let dflt = defaultScreen dpy+ border = blackPixel dpy dflt+ background = whitePixel dpy dflt+ rootw <- rootWindow dpy dflt+ win <- createSimpleWindow dpy rootw 0 0 100 100 1 border background+ selectInput dpy win (exposureMask .|. buttonPressMask .|. buttonReleaseMask)+ setEventMask dpy win [XI_Enter, XI_Leave,+ XI_ButtonPress, XI_ButtonRelease,+ XI_KeyPress, XI_KeyRelease]+ setTextProperty dpy win "Hello World" wM_NAME+ mapWindow dpy win+ sync dpy False+ allocaXEvent $ \eptr ->+ forever $ do+ nextEvent dpy eptr+ handleXCookie dpy xi_opcode eptr evHandler cookieHandler+ sync dpy False++evHandler e =+ putStrLn $ "X11 event: " ++ show e++cookieHandler e = print e