module Graphics.X11.XInput.Types 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
instance Eq E.Event where
x == y = E.ev_serial x == E.ev_serial y
genericEvent :: X11.EventType
genericEvent = 35
type Opcode = CInt
data EventCookie = EventCookie {
ecEvent :: E.Event
, ecExtension :: Opcode
, ecType :: EventType
, ecCookie :: CUInt
, ecData :: Event
}
deriving (Eq)
instance Show EventCookie where
show e = printf "<%s: %s>"
(show $ ecType e)
(show $ ecData e)
data Event = Event {
eSendEvent :: Bool
, eDisplay :: X11.Display
, eExtension :: Opcode
, eType :: EventType
, eDeviceId :: DeviceID
, eSpecific :: EventSpecific
}
deriving (Eq)
instance Show Event where
show e = printf "Event [device #%s] (%s)"
(show $ eDeviceId e)
(show $ eSpecific e)
data EventSpecific =
GPointerEvent {
peSourceId :: CInt
, peDetail :: Int
, peRoot :: X11.Window
, peEvent :: X11.Window
, peChild :: X11.Window
, peRootX :: CDouble
, peRootY :: CDouble
, peEventX :: CDouble
, peEventY :: CDouble
, peSpecific :: PointerEvent
}
| 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
data PointerEvent =
EnterLeaveEvent {
eeMode :: CInt
, eeFocus :: Bool
, eeSameScreen :: Bool
, peButtons :: ButtonState
, peMods :: ModifierState
, peGroup :: GroupState
}
| RawEvent {
reType :: EventType
, reFlags :: CInt
, reValuators :: ValuatorState
}
| DeviceEvent {
deType :: EventType
, deFlags :: CInt
, peButtons :: ButtonState
, deValuators :: ValuatorState
, peMods :: ModifierState
, peGroup :: GroupState
}
deriving (Eq, Show)
data EventType =
XI_DeviceChanged
| XI_KeyPress
| XI_KeyRelease
| XI_ButtonPress
| XI_ButtonRelease
| XI_Motion
| XI_Enter
| XI_Leave
| XI_FocusIn
| XI_FocusOut
| XI_HierarchyChanged
| XI_PropertyEvent
| XI_RawKeyPress
| XI_RawKeyRelease
| XI_RawButtonPress
| XI_RawButtonRelease
| XI_RawMotion
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 <- (\ptr -> do {peekByteOff ptr 0 ::IO CInt}) ptr
len <- (\ptr -> do {peekByteOff ptr 4 ::IO CInt}) ptr
maskPtr <- (\ptr -> do {peekByteOff ptr 8 ::IO (Ptr CUChar)}) ptr
mask <- peekArray (fromIntegral len) maskPtr
return $ EventMask dev (map fromIntegral mask)
poke ptr (EventMask dev mask) = do
(\ptr val -> do {pokeByteOff ptr 0 (val::CInt)}) ptr dev
let len = length mask
w = sizeOf (0 :: CInt)
p = sizeOf (nullPtr :: Ptr CUChar)
maskPtr = castPtr (ptr `plusPtr` (w*2 + p)) :: Ptr CInt
(\ptr val -> do {pokeByteOff ptr 4 (val::CInt)}) ptr (fromIntegral len)
pokeArray maskPtr (map fromIntegral mask)
type EventMaskPtr = Ptr (EventMask)
type EventCookiePtr = Ptr (EventCookie)
type EventPtr = Ptr (Event)
data DeviceType =
XIMasterPointer
| XIMasterKeyboard
| XISlavePointer
| XISlaveKeyboard
| XIFloatingSlave
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
data DeviceInfo = DeviceInfo {
diID :: DeviceID
, diName :: String
, diUse :: DeviceType
, diAttachment :: DeviceID
, diEnabled :: Bool
, diClasses :: [GDeviceClass]
}
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)
type DeviceInfoPtr = Ptr (DeviceInfo)
data DeviceClassType =
XIKeyClass
| XIButtonClass
| XIValuatorClass
deriving (Eq, Show, Ord, Enum)
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)
type GDeviceClassPtr = Ptr (GDeviceClass)
type Mask = [CUChar]
data ButtonState = ButtonState {
bsMask :: [Int] }
deriving (Eq, Show)
type ButtonStatePtr = Ptr (ButtonState)
data ModifierState = ModifierState {
msBase :: Int
, msLatched :: Int
, msLocked :: Int
, msEffective :: Int
}
deriving (Eq, Show)
type ModifierStatePtr = Ptr (ModifierState)
type GroupState = ModifierState
type ValuatorState = M.Map Int Double
type ValuatorStatePtr = Ptr (ValuatorState)
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 <$> (\ptr -> do {peekByteOff ptr 0 ::IO CInt}) ptr)
<*> (fromIntegral <$> (\ptr -> do {peekByteOff ptr 4 ::IO CInt}) ptr)
poke ptr (GrabModifiers mods status) = do
(\ptr val -> do {pokeByteOff ptr 0 (val::CInt)}) ptr (fromIntegral mods)
(\ptr val -> do {pokeByteOff ptr 4 (val::CInt)}) ptr (fromIntegral status)
type GrabModifiersPtr = Ptr (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
data XInputInitResult =
NoXInput
| VersionMismatch Int Int
| InitOK Opcode
deriving (Eq, Show)