module Graphics.X11.XInput.Parser where
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 <- (\ptr -> do {peekByteOff ptr 0 ::IO CInt}) ptr
namePtr <- (\ptr -> do {peekByteOff ptr 4 ::IO (Ptr CChar)}) ptr
name <- peekCString namePtr
use <- int2deviceType <$> (\ptr -> do {peekByteOff ptr 8 ::IO CInt}) ptr
att <- (\ptr -> do {peekByteOff ptr 12 ::IO CInt}) ptr
on <- toBool <$> (\ptr -> do {peekByteOff ptr 16 ::IO CInt}) ptr
ncls <- fromIntegral <$> (\ptr -> do {peekByteOff ptr 20 ::IO CInt}) ptr
clsptr <- (\ptr -> do {peekByteOff ptr 24 ::IO (Ptr (Ptr ()))}) 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) <$> (\ptr -> do {peekByteOff ptr 0 ::IO CInt}) ptr
src <- (\ptr -> do {peekByteOff ptr 4 ::IO CInt}) 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 ((\ptr -> do {peekByteOff ptr 16 ::IO CInt}))
((\ptr -> do {peekByteOff ptr 20 ::IO (Ptr CUChar)}))
ptr
peekButtonClass :: GDeviceClassPtr -> IO DeviceClass
peekButtonClass ptr = do
n <- (\ptr -> do {peekByteOff ptr 8 ::IO CInt}) ptr
labelsPtr <- (\ptr -> do {peekByteOff ptr 12 ::IO (Ptr CULong)}) 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 <- (\ptr -> do {peekByteOff ptr 8 ::IO CInt}) ptr
kptr <- (\ptr -> do {peekByteOff ptr 12 ::IO (Ptr CInt)}) ptr
keycodes <- peekArray (fromIntegral n) kptr
return $ KeyClass (fromIntegral n) (map fromIntegral keycodes)
peekValuatorClass :: GDeviceClassPtr -> IO DeviceClass
peekValuatorClass ptr = ValuatorClass
<$> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 8 ::IO CInt}) ptr)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 12 ::IO CULong}) ptr)
<*> (realToFrac <$> (\ptr -> do {peekByteOff ptr 16 ::IO CDouble}) ptr)
<*> (realToFrac <$> (\ptr -> do {peekByteOff ptr 24 ::IO CDouble}) ptr)
<*> (realToFrac <$> (\ptr -> do {peekByteOff ptr 32 ::IO CDouble}) ptr)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 40 ::IO CInt}) ptr)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 44 ::IO CInt}) 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 <$> (\ptr -> do {peekByteOff ptr 0 ::IO CInt}) ptr
get_event_extension :: X11.XEventPtr -> IO Opcode
get_event_extension ptr = (\ptr -> do {peekByteOff ptr 16 ::IO CInt}) ptr
instance Struct EventCookie where
type Pointer EventCookie = EventCookiePtr
peekStruct xev = do
ev <- E.getEvent (castPtr xev)
ext <- (\ptr -> do {peekByteOff ptr 16 ::IO CInt}) xev
et <- (\ptr -> do {peekByteOff ptr 20 ::IO CInt}) xev
cookie <- (\ptr -> do {peekByteOff ptr 24 ::IO CUInt}) xev
dptr <- (\ptr -> do {peekByteOff ptr 28 ::IO (Ptr ())}) 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 <$> (\ptr -> do {peekByteOff ptr 8 ::IO CInt}) de
dpy <- ptr2display <$> (\ptr -> do {peekByteOff ptr 12 ::IO (Ptr ())}) de
ext <- (\ptr -> do {peekByteOff ptr 16 ::IO CInt}) de
evt <- int2eventType <$> (\ptr -> do {peekByteOff ptr 20 ::IO CInt}) de
dev <- (\ptr -> do {peekByteOff ptr 28 ::IO CInt}) de
spec <- peekEventSpecific evt de
return $ Event se dpy ext evt dev spec
peekEventSpecific XI_PropertyEvent e = PropertyEvent
<$> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 32 ::IO CULong}) e)
<*> (\ptr -> do {peekByteOff ptr 36 ::IO CInt}) e
peekEventSpecific XI_DeviceChanged e = do
reason <- (\ptr -> do {peekByteOff ptr 36 ::IO CInt}) e
ncls <- (fromIntegral <$> (\ptr -> do {peekByteOff ptr 40 ::IO CInt}) e)
clsPtr <- (\ptr -> do {peekByteOff ptr 44 ::IO (Ptr (Ptr ()))}) e
classes <- peekClasses ncls clsPtr
return $ DeviceChangedEvent reason classes
peekEventSpecific t e = GPointerEvent
<$> (\ptr -> do {peekByteOff ptr 32 ::IO CInt}) e
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 36 ::IO CInt}) e)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 40 ::IO CULong}) e)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 44 ::IO CULong}) e)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 48 ::IO CULong}) e)
<*> (\ptr -> do {peekByteOff ptr 52 ::IO CDouble}) e
<*> (\ptr -> do {peekByteOff ptr 60 ::IO CDouble}) e
<*> (\ptr -> do {peekByteOff ptr 68 ::IO CDouble}) e
<*> (\ptr -> do {peekByteOff ptr 76 ::IO CDouble}) e
<*> trace "pointerEvent" (peekPointerEvent t e)
trace :: Show a => String -> IO a -> IO a
trace _ x = x
peekPointerEvent XI_Enter e = EnterLeaveEvent
<$> (\ptr -> do {peekByteOff ptr 84 ::IO CInt}) e
<*> (toBool <$> (\ptr -> do {peekByteOff ptr 88 ::IO CInt}) e)
<*> (toBool <$> (\ptr -> do {peekByteOff ptr 92 ::IO CInt}) e)
<*> (ButtonState <$>
(peekMask ((\ptr -> do {peekByteOff ptr 96 ::IO CInt}))
((\ptr -> do {peekByteOff ptr 100 ::IO (Ptr CUChar)}))
e ) )
<*> (ModifierState
<$> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 104 ::IO CInt}) e)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 108 ::IO CInt}) e)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 112 ::IO CInt}) e)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 116 ::IO CInt}) e))
<*> (ModifierState
<$> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 120 ::IO CInt}) e)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 124 ::IO CInt}) e)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 128 ::IO CInt}) e)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 132 ::IO CInt}) 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" ((\ptr -> do {peekByteOff ptr 84 ::IO CInt}) e)
<*> trace "buttons" (ButtonState <$>
(peekMask ((\ptr -> do {peekByteOff ptr 88 ::IO CInt}))
((\ptr -> do {peekByteOff ptr 92 ::IO (Ptr CUChar)}))
e ) )
<*> trace "valuators" (do
mask <- trace "mask" $ peekMask ((\ptr -> do {peekByteOff ptr 96 ::IO CInt}))
((\ptr -> do {peekByteOff ptr 100 ::IO (Ptr CUChar)}))
e
valuesPtr <- trace "valuesPtr" $ (\ptr -> do {peekByteOff ptr 104 ::IO (Ptr CDouble)}) 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 <$> (\ptr -> do {peekByteOff ptr 108 ::IO CInt}) e)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 112 ::IO CInt}) e)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 116 ::IO CInt}) e)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 120 ::IO CInt}) e))
<*> trace "group" (ModifierState
<$> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 124 ::IO CInt}) e)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 128 ::IO CInt}) e)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 132 ::IO CInt}) e)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 136 ::IO CInt}) e))
peekRawEvent t e = RawEvent
<$> trace "event type" (return t)
<*> trace "flags" ((\ptr -> do {peekByteOff ptr 40 ::IO CInt}) e)
<*> trace "valuators" (do
mask <- trace "mask" $ peekMask ((\ptr -> do {peekByteOff ptr 44 ::IO CInt}))
((\ptr -> do {peekByteOff ptr 48 ::IO (Ptr CUChar)}))
e
valuesPtr <- trace "valuesPtr" $ (\ptr -> do {peekByteOff ptr 52 ::IO (Ptr CDouble)}) e
values <- trace "values" $ peekArray (length mask) valuesPtr :: IO [CDouble]
let values' = map realToFrac values :: [Double]
return $ M.fromList $ zip mask values' )