XInput-0.1: 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
}
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
}
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
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
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