diff --git a/Graphics/X11/XInput.hs b/Graphics/X11/XInput.hs new file mode 100644 --- /dev/null +++ b/Graphics/X11/XInput.hs @@ -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 + diff --git a/Graphics/X11/XInput/Devices.hs b/Graphics/X11/XInput/Devices.hs new file mode 100644 --- /dev/null +++ b/Graphics/X11/XInput/Devices.hs @@ -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) + + diff --git a/Graphics/X11/XInput/Foreign.chs b/Graphics/X11/XInput/Foreign.chs new file mode 100644 --- /dev/null +++ b/Graphics/X11/XInput/Foreign.chs @@ -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 +#include + +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 + diff --git a/Graphics/X11/XInput/Functions.hs b/Graphics/X11/XInput/Functions.hs new file mode 100644 --- /dev/null +++ b/Graphics/X11/XInput/Functions.hs @@ -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 + diff --git a/Graphics/X11/XInput/Parser.chs b/Graphics/X11/XInput/Parser.chs new file mode 100644 --- /dev/null +++ b/Graphics/X11/XInput/Parser.chs @@ -0,0 +1,250 @@ +{-# LANGUAGE TypeFamilies #-} +{-| Functions of this module perform parsing of XInput events structures. -} +module Graphics.X11.XInput.Parser where + +#include +#include + +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' ) diff --git a/Graphics/X11/XInput/Types.chs b/Graphics/X11/XInput/Types.chs new file mode 100644 --- /dev/null +++ b/Graphics/X11/XInput/Types.chs @@ -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 +#include + +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) + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/x11-xinput.cabal b/x11-xinput.cabal new file mode 100644 --- /dev/null +++ b/x11-xinput.cabal @@ -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 diff --git a/xitest.hs b/xitest.hs new file mode 100644 --- /dev/null +++ b/xitest.hs @@ -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