XInput-0.0: System/Win32/XInput.hsc
-----------------------------------------------------------------------------
-- |
-- Module : System.Win32.XInput
-- Copyright : (c) Erik Charlebois, 2008
-- License : BSD
--
-- Maintainer : Erik Charlebois <erikcharlebois@gmail.com>
-- Stability : provisional
-- Portability : Windows
--
-- FFI bindings for interfacing with DirectX XInput.
--
-----------------------------------------------------------------------------
module System.Win32.XInput where
import System.Win32.Types
import Foreign
import Foreign.C.Types
#include <XInput.h>
#include <windows.h>
type PlayerNumber = DWORD
playerOne :: PlayerNumber
playerOne = 0
playerTwo :: PlayerNumber
playerTwo = 1
playerThree :: PlayerNumber
playerThree = 2
playerFour :: PlayerNumber
playerFour = 3
type DeviceType = BYTE
#{enum DeviceType,
, xINPUT_DEVTYPE_GAMEPAD = XINPUT_DEVTYPE_GAMEPAD
}
type DeviceSubtype = BYTE
#{enum DeviceSubtype,
, xINPUT_DEVSUBTYPE_GAMEPAD = XINPUT_DEVSUBTYPE_GAMEPAD
, xINPUT_DEVSUBTYPE_WHEEL = XINPUT_DEVSUBTYPE_WHEEL
, xINPUT_DEVSUBTYPE_ARCADE_STICK = XINPUT_DEVSUBTYPE_ARCADE_STICK
, xINPUT_DEVSUBTYPE_FLIGHT_SICK = XINPUT_DEVSUBTYPE_FLIGHT_SICK
, xINPUT_DEVSUBTYPE_DANCE_PAD = XINPUT_DEVSUBTYPE_DANCE_PAD
, xINPUT_DEVSUBTYPE_GUITAR = XINPUT_DEVSUBTYPE_GUITAR
, xINPUT_DEVSUBTYPE_DRUM_KIT = XINPUT_DEVSUBTYPE_DRUM_KIT
}
type DeviceFlags = WORD
#{enum DeviceFlags,
, xINPUT_CAPS_VOICE_SUPPORTED = XINPUT_CAPS_VOICE_SUPPORTED
}
type Button = WORD
#{enum Button,
, xINPUT_GAMEPAD_DPAD_UP = XINPUT_GAMEPAD_DPAD_UP
, xINPUT_GAMEPAD_DPAD_DOWN = XINPUT_GAMEPAD_DPAD_DOWN
, xINPUT_GAMEPAD_DPAD_LEFT = XINPUT_GAMEPAD_DPAD_LEFT
, xINPUT_GAMEPAD_DPAD_RIGHT = XINPUT_GAMEPAD_DPAD_RIGHT
, xINPUT_GAMEPAD_START = XINPUT_GAMEPAD_START
, xINPUT_GAMEPAD_BACK = XINPUT_GAMEPAD_BACK
, xINPUT_GAMEPAD_LEFT_THUMB = XINPUT_GAMEPAD_LEFT_THUMB
, xINPUT_GAMEPAD_RIGHT_THUMB = XINPUT_GAMEPAD_RIGHT_THUMB
, xINPUT_GAMEPAD_LEFT_SHOULDER = XINPUT_GAMEPAD_LEFT_SHOULDER
, xINPUT_GAMEPAD_RIGHT_SHOULDER = XINPUT_GAMEPAD_RIGHT_SHOULDER
, xINPUT_GAMEPAD_A = XINPUT_GAMEPAD_A
, xINPUT_GAMEPAD_B = XINPUT_GAMEPAD_B
, xINPUT_GAMEPAD_X = XINPUT_GAMEPAD_X
, xINPUT_GAMEPAD_Y = XINPUT_GAMEPAD_Y
}
type Threshold = WORD
#{enum Threshold,
, xINPUT_GAMEPAD_LEFT_THUMB_DEADZONE = XINPUT_GAMEPAD_LEFT_THUMB_DEADZONE
, xINPUT_GAMEPAD_RIGHT_THUMB_DEADZONE = XINPUT_GAMEPAD_RIGHT_THUMB_DEADZONE
, xINPUT_GAMEPAD_TRIGGER_THRESHOLD = XINPUT_GAMEPAD_TRIGGER_THRESHOLD
}
type GetCapabilitiesFlag = DWORD
#{enum GetCapabilitiesFlag,
, xINPUT_FLAG_GAMEPAD = XINPUT_FLAG_GAMEPAD
}
type BatteryDeviceType = BYTE
#{enum BatteryDeviceType,
, bATTERY_DEVTYPE_GAMEPAD = BATTERY_DEVTYPE_GAMEPAD
, bATTERY_DEVTYPE_HEADSET = BATTERY_DEVTYPE_HEADSET
}
type BatteryType = BYTE
#{enum BatteryType,
, bATTERY_TYPE_DISCONNECTED = BATTERY_TYPE_DISCONNECTED
, bATTERY_TYPE_WIRED = BATTERY_TYPE_WIRED
, bATTERY_TYPE_ALKALINE = BATTERY_TYPE_ALKALINE
, bATTERY_TYPE_NIMH = BATTERY_TYPE_NIMH
, bATTERY_TYPE_UNKNOWN = BATTERY_TYPE_UNKNOWN
}
type BatteryLevel = BYTE
#{enum BatteryLevel,
, bATTERY_LEVEL_EMPTY = BATTERY_LEVEL_EMPTY
, bATTERY_LEVEL_LOW = BATTERY_LEVEL_LOW
, bATTERY_LEVEL_MEDIUM = BATTERY_LEVEL_MEDIUM
, bATTERY_LEVEL_FULL = BATTERY_LEVEL_FULL
}
type UserMaxCount = Int
#{enum UserMaxCount,
, userMaxCount = XUSER_MAX_COUNT
}
type UserIndexAny = Int
#{enum UserMaxCount,
, userIndexAny = XUSER_INDEX_ANY
}
type VirtualKey = WORD
#{enum VirtualKey,
, vK_PAD_A = VK_PAD_A
, vK_PAD_B = VK_PAD_B
, vK_PAD_X = VK_PAD_X
, vK_PAD_Y = VK_PAD_Y
, vK_PAD_RSHOULDER = VK_PAD_RSHOULDER
, vK_PAD_LSHOULDER = VK_PAD_LSHOULDER
, vK_PAD_LTRIGGER = VK_PAD_LTRIGGER
, vK_PAD_RTRIGGER = VK_PAD_RTRIGGER
, vK_PAD_DPAD_UP = VK_PAD_DPAD_UP
, vK_PAD_DPAD_DOWN = VK_PAD_DPAD_DOWN
, vK_PAD_DPAD_LEFT = VK_PAD_DPAD_LEFT
, vK_PAD_DPAD_RIGHT = VK_PAD_DPAD_RIGHT
, vK_PAD_START = VK_PAD_START
, vK_PAD_BACK = VK_PAD_BACK
, vK_PAD_LTHUMB_PRESS = VK_PAD_LTHUMB_PRESS
, vK_PAD_RTHUMB_PRESS = VK_PAD_RTHUMB_PRESS
, vK_PAD_LTHUMB_UP = VK_PAD_LTHUMB_UP
, vK_PAD_LTHUMB_DOWN = VK_PAD_LTHUMB_DOWN
, vK_PAD_LTHUMB_RIGHT = VK_PAD_LTHUMB_RIGHT
, vK_PAD_LTHUMB_LEFT = VK_PAD_LTHUMB_LEFT
, vK_PAD_LTHUMB_UPLEFT = VK_PAD_LTHUMB_UPLEFT
, vK_PAD_LTHUMB_UPRIGHT = VK_PAD_LTHUMB_UPRIGHT
, vK_PAD_LTHUMB_DOWNRIGHT = VK_PAD_LTHUMB_DOWNRIGHT
, vK_PAD_LTHUMB_DOWNLEFT = VK_PAD_LTHUMB_DOWNLEFT
, vK_PAD_RTHUMB_UP = VK_PAD_RTHUMB_UP
, vK_PAD_RTHUMB_DOWN = VK_PAD_RTHUMB_DOWN
, vK_PAD_RTHUMB_RIGHT = VK_PAD_RTHUMB_RIGHT
, vK_PAD_RTHUMB_LEFT = VK_PAD_RTHUMB_LEFT
, vK_PAD_RTHUMB_UPLEFT = VK_PAD_RTHUMB_UPLEFT
, vK_PAD_RTHUMB_UPRIGHT = VK_PAD_RTHUMB_UPRIGHT
, vK_PAD_RTHUMB_DOWNRIGHT = VK_PAD_RTHUMB_DOWNRIGHT
, vK_PAD_RTHUMB_DOWNLEFT = VK_PAD_RTHUMB_DOWNLEFT
}
type KeystrokeFlag = WORD
#{enum KeystrokeFlag,
, xINPUT_KEYSTROKE_KEYDOWN = XINPUT_KEYSTROKE_KEYDOWN
, xINPUT_KEYSTROKE_KEYUP = XINPUT_KEYSTROKE_KEYUP
, xINPUT_KEYSTROKE_REPEAT = XINPUT_KEYSTROKE_REPEAT
}
data GUID = GUID
{ data1 :: Int32
, data2 :: Int16
, data3 :: Int16
, data4 :: [Char]
}
instance Storable GUID where
sizeOf = const (#size GUID)
alignment = sizeOf
poke buf k = do
(#poke GUID, Data1) buf (data1 k)
(#poke GUID, Data2) buf (data2 k)
(#poke GUID, Data3) buf (data3 k)
pokeArray ((#ptr GUID, Data4) buf) (data4 k)
peek buf = do
d1 <- (#peek GUID, Data1) buf
d2 <- (#peek GUID, Data2) buf
d3 <- (#peek GUID, Data3) buf
d4 <- peekArray 8 ((#ptr GUID, Data4) buf)
return $ GUID d1 d2 d3 d4
data Gamepad = Gamepad
{ wButtons :: WORD
, bLeftTrigger, bRightTrigger :: BYTE
, sThumbLX, sThumbLY, sThumbRX, sThumbRY :: USHORT
}
instance Storable Gamepad where
sizeOf = const (#size XINPUT_GAMEPAD)
alignment = sizeOf
poke buf k = do
(#poke XINPUT_GAMEPAD, wButtons) buf (wButtons k)
(#poke XINPUT_GAMEPAD, bLeftTrigger) buf (bLeftTrigger k)
(#poke XINPUT_GAMEPAD, bRightTrigger) buf (bRightTrigger k)
(#poke XINPUT_GAMEPAD, sThumbLX) buf (sThumbLX k)
(#poke XINPUT_GAMEPAD, sThumbLY) buf (sThumbLY k)
(#poke XINPUT_GAMEPAD, sThumbRX) buf (sThumbRX k)
(#poke XINPUT_GAMEPAD, sThumbRY) buf (sThumbRY k)
peek buf = do
b <- (#peek XINPUT_GAMEPAD, wButtons) buf
lt <- (#peek XINPUT_GAMEPAD, bLeftTrigger) buf
rt <- (#peek XINPUT_GAMEPAD, bRightTrigger) buf
lx <- (#peek XINPUT_GAMEPAD, sThumbLX) buf
ly <- (#peek XINPUT_GAMEPAD, sThumbLY) buf
rx <- (#peek XINPUT_GAMEPAD, sThumbRX) buf
ry <- (#peek XINPUT_GAMEPAD, sThumbRY) buf
return $ Gamepad b lt rt lx ly rx ry
data PadState = PadState { dwPacketNumber :: DWORD, gamepad :: Gamepad }
instance Storable PadState where
sizeOf = const (#size XINPUT_STATE)
alignment = sizeOf
poke buf k = do
(#poke XINPUT_STATE, dwPacketNumber) buf (dwPacketNumber k)
(#poke XINPUT_STATE, Gamepad) buf (gamepad k)
peek buf = do
n <- (#peek XINPUT_STATE, dwPacketNumber) buf
g <- (#peek XINPUT_STATE, Gamepad) buf
return $ PadState n g
data Vibration = Vibration { wLeftMotorSpeed, wRightMotorSpeed :: WORD }
instance Storable Vibration where
sizeOf = const (#size XINPUT_VIBRATION)
alignment = sizeOf
poke buf k = do
(#poke XINPUT_VIBRATION, wLeftMotorSpeed) buf (wLeftMotorSpeed k)
(#poke XINPUT_VIBRATION, wRightMotorSpeed) buf (wRightMotorSpeed k)
peek buf = do
l <- (#peek XINPUT_VIBRATION, wLeftMotorSpeed) buf
r <- (#peek XINPUT_VIBRATION, wRightMotorSpeed) buf
return $ Vibration l r
data Capabilities = Capabilities
{ capabilitiesType :: DeviceType
, capabilitiesSubtype :: DeviceSubtype
, capabilitiesFlags :: DeviceFlags
, capabilitiesGamepad :: Gamepad
, capabilitiesVibration :: Vibration
}
instance Storable Capabilities where
sizeOf = const (#size XINPUT_CAPABILITIES)
alignment = sizeOf
poke buf k = do
(#poke XINPUT_CAPABILITIES, Type) buf (capabilitiesType k)
(#poke XINPUT_CAPABILITIES, SubType) buf (capabilitiesSubtype k)
(#poke XINPUT_CAPABILITIES, Flags) buf (capabilitiesFlags k)
(#poke XINPUT_CAPABILITIES, Gamepad) buf (capabilitiesGamepad k)
(#poke XINPUT_CAPABILITIES, Vibration) buf (capabilitiesVibration k)
peek buf = do
t <- (#peek XINPUT_CAPABILITIES, Type) buf
s <- (#peek XINPUT_CAPABILITIES, SubType) buf
f <- (#peek XINPUT_CAPABILITIES, Flags) buf
g <- (#peek XINPUT_CAPABILITIES, Gamepad) buf
v <- (#peek XINPUT_CAPABILITIES, Vibration) buf
return $ Capabilities t s f g v
data Battery = Battery { batteryType, batteryLevel :: BYTE }
instance Storable Battery where
sizeOf = const (#size XINPUT_BATTERY_INFORMATION)
alignment = sizeOf
poke buf k = do
(#poke XINPUT_BATTERY_INFORMATION, BatteryType) buf (batteryType k)
(#poke XINPUT_BATTERY_INFORMATION, BatteryLevel) buf (batteryLevel k)
peek buf = do
t <- (#peek XINPUT_BATTERY_INFORMATION, BatteryType) buf
l <- (#peek XINPUT_BATTERY_INFORMATION, BatteryLevel) buf
return $ Battery t l
data Keystroke = Keystroke
{ virtualKey :: VirtualKey
, unicode :: CWchar
, flags :: KeystrokeFlag
, userIndex :: BYTE
, hidCode :: BYTE
}
instance Storable Keystroke where
sizeOf = const (#size XINPUT_KEYSTROKE)
alignment = sizeOf
poke buf k = do
(#poke XINPUT_KEYSTROKE, VirtualKey) buf (virtualKey k)
(#poke XINPUT_KEYSTROKE, Unicode) buf (unicode k)
(#poke XINPUT_KEYSTROKE, Flags) buf (flags k)
(#poke XINPUT_KEYSTROKE, UserIndex) buf (userIndex k)
(#poke XINPUT_KEYSTROKE, HidCode) buf (hidCode k)
peek buf = do
v <- (#peek XINPUT_KEYSTROKE, VirtualKey) buf
u <- (#peek XINPUT_KEYSTROKE, Unicode) buf
f <- (#peek XINPUT_KEYSTROKE, Flags) buf
i <- (#peek XINPUT_KEYSTROKE, UserIndex) buf
h <- (#peek XINPUT_KEYSTROKE, HidCode) buf
return $ Keystroke v u f i h
getState :: PlayerNumber -> IO (Maybe PadState)
getState u = alloca $ \res -> do
r <- c_XInputGetState u res
if r == 0
then do
s <- peek res
return $ Just s
else return $ Nothing
foreign import stdcall unsafe "XInput.h XInputGetState"
c_XInputGetState :: DWORD -> Ptr PadState -> IO DWORD
setState :: PlayerNumber -> Vibration -> IO Bool
setState u v = alloca $ \res -> do
poke res v
r <- c_XInputSetState u res
return $ r == 0
foreign import stdcall unsafe "XInput.h XInputSetState"
c_XInputSetState :: DWORD -> Ptr Vibration -> IO DWORD
getDSoundAudioDeviceGuids :: PlayerNumber -> IO (Maybe (GUID, GUID))
getDSoundAudioDeviceGuids u = alloca $ \res1 -> do
alloca $ \res2 -> do
r <- c_XInputGetDSoundAudioDeviceGuids u res1 res2
if r == 0
then do
r1 <- peek res1
r2 <- peek res2
return $ Just (r1, r2)
else
return Nothing
foreign import stdcall unsafe "XInput.h XInputGetDSoundAudioDeviceGuids"
c_XInputGetDSoundAudioDeviceGuids :: DWORD -> Ptr GUID -> Ptr GUID -> IO DWORD
getBatteryInformation :: PlayerNumber -> BatteryDeviceType -> IO (Maybe Battery)
getBatteryInformation u d = alloca $ \res -> do
r <- c_XInputGetBatteryInformation u d res
if r == 0
then do
b <- peek res
return $ Just b
else
return Nothing
foreign import stdcall unsafe "XInput.h XInputGetBatteryInformation"
c_XInputGetBatteryInformation :: DWORD -> BYTE -> Ptr Battery -> IO DWORD
getKeystroke :: PlayerNumber -> IO (Maybe Keystroke)
getKeystroke u = alloca $ \res -> do
r <- c_XInputGetKeystroke u xINPUT_FLAG_GAMEPAD res
if r == 0
then do
k <- peek res
return $ Just k
else
return Nothing
foreign import stdcall unsafe "XInput.h XInputGetKeystroke"
c_XInputGetKeystroke :: DWORD -> DWORD -> Ptr Keystroke -> IO DWORD
getCapabilities :: PlayerNumber -> IO (Maybe Capabilities)
getCapabilities u = alloca $ \res -> do
r <- c_XInputGetCapabilities u xINPUT_FLAG_GAMEPAD res
if r == 0
then do
c <- peek res
return $ Just c
else
return Nothing
foreign import stdcall unsafe "XInput.h XInputGetCapabilities"
c_XInputGetCapabilities :: DWORD -> DWORD -> Ptr Capabilities -> IO DWORD
enable :: Bool -> IO ()
enable b = c_XInputEnable b
foreign import stdcall unsafe "XInput.h XInputEnable"
c_XInputEnable :: BOOL -> IO ()
withInit :: IO a -> IO a
withInit a = do
enable True
r <- a
enable False
return r
-- Lazy getKeystroke
-- Lazy getState