-----------------------------------------------------------------------------
-- |
-- 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