diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,10 @@ +Copyright (c) 2008, Erik Charlebois +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + * The names of its contributors may not be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/Win32/XInput.hsc b/System/Win32/XInput.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/XInput.hsc @@ -0,0 +1,382 @@ +----------------------------------------------------------------------------- +-- | +-- 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 + , 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 + + diff --git a/XInput.cabal b/XInput.cabal new file mode 100644 --- /dev/null +++ b/XInput.cabal @@ -0,0 +1,17 @@ +Name: XInput +Version: 0.0 +Cabal-Version: >= 1.2 +Synopsis: Bindings for the DirectX XInput library. +Build-Type: Custom +License: BSD3 +License-file: LICENSE +Author: Erik Charlebois +Maintainer: Erik Charlebois + +Library + Build-Depends: base, Win32 + Exposed-modules: System.Win32.XInput + Extensions: ForeignFunctionInterface + Includes: XInput.h + Extra-libraries: xinput +