----------------------------------------------------------------------------- -- | -- Module : System.Win32.XInput -- Copyright : (c) Erik Charlebois, 2008 -- License : BSD -- -- Maintainer : Erik Charlebois -- 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 #include 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