feat: expand game controller bindings (#319)

jtnuttall · web-flow · commit 1d872db4e627 · 2025-11-09T09:09:36.000+02:00
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -1,6 +1,12 @@
 2.5.X.Y
 =======
 
+* Added game controller helper functions: `isGameController`, `mkControllerDevice`, `mkControllerDevice'`, `controllerFromInstanceID`
+* Added raw bindings for player index, LED control, rumble triggers, and touchpad query functions
+* Added `JoystickIndex` type alias for clarity
+* `getControllerID` now returns `Raw.JoystickID` for improved type documentation
+* Fixed `controllerDeviceEventWhich` documentation to clarify index vs instance ID semantics
+
 2.5.5.1
 =======
 
diff --git a/src/SDL/Event.hs b/src/SDL/Event.hs
@@ -428,7 +428,7 @@ data ControllerDeviceEventData =
   ControllerDeviceEventData {controllerDeviceEventConnection :: !ControllerDeviceConnection
                              -- ^ Was the device added, removed, or remapped?
                             ,controllerDeviceEventWhich :: !Raw.JoystickID
-                             -- ^ The joystick instance ID that reported the event.
+                             -- ^ The joystick device index for the ADDED event, instance id for the REMOVED or REMAPPED event
                             }
   deriving (Eq,Ord,Generic,Show,Typeable)
 
diff --git a/src/SDL/Input/GameController.hs b/src/SDL/Input/GameController.hs
@@ -7,8 +7,15 @@
 
 module SDL.Input.GameController
   ( ControllerDevice (..)
+  , GameController
+  , JoystickIndex
+  , Raw.JoystickID
+
+  , isGameController
+  , mkControllerDevice
+  , mkControllerDevice'
+  , controllerFromInstanceID
   , availableControllers
-
   , openController
   , closeController
   , controllerAttached
@@ -29,12 +36,12 @@ module SDL.Input.GameController
   , ControllerDeviceConnection (..)
   ) where
 
-import Control.Monad (filterM)
+import Control.Monad (guard)
 import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Trans.Maybe (runMaybeT)
 import Data.Data (Data)
 import Data.Int
 import Data.Text (Text)
-import Data.Traversable (for)
 import Data.Typeable
 import Data.Word
 import Foreign.C (withCString)
@@ -60,26 +67,61 @@ import qualified Data.Vector as V
 import Control.Applicative
 #endif
 
+type JoystickIndex = CInt
+
 {- | A description of game controller that can be opened using 'openController'.
  To retrieve a list of connected game controllers, use 'availableControllers'.
 -}
 data ControllerDevice = ControllerDevice
   { gameControllerDeviceName :: Text
-  , gameControllerDeviceId :: CInt
+  , gameControllerDeviceId :: JoystickIndex
   }
   deriving (Eq, Generic, Read, Ord, Show, Typeable)
 
+
+{- | Check if the given joystick is supported by the game controller interface.
+
+ See @<https://wiki.libsdl.org/SDL2/SDL_IsGameController SDL_IsGameController>@ for C documentation.
+-}
+isGameController :: MonadIO m => JoystickIndex -> m Bool
+isGameController = Raw.isGameController
+
+{- | Create a 'ControllerDevice' from a 'JoystickIndex'. Returns 'Nothing' if 
+     the 'JoystickIndex' does not support the game controller interface.
+-}
+mkControllerDevice :: MonadIO m => JoystickIndex -> m (Maybe ControllerDevice)
+mkControllerDevice i = runMaybeT $ do
+  isGC <- isGameController i
+  guard isGC
+  mkControllerDevice' i
+
+{- | Create a 'ControllerDevice' from a 'JoystickIndex'. Does not check whether
+     the 'JoystickIndex' supports the game controller interface.
+-}
+mkControllerDevice' :: MonadIO m => JoystickIndex -> m ControllerDevice
+mkControllerDevice' i = do
+  cstr <- liftIO $
+    throwIfNull "SDL.Input.GameController.mkControllerDevice'" "SDL_GameControllerNameForIndex" $
+      Raw.gameControllerNameForIndex (fromIntegral i)
+  name <- liftIO $ Text.decodeUtf8 <$> BS.packCString cstr
+  return (ControllerDevice name i)
+
+{- | Get the 'GameController' associated with a 'Raw.JoystickID'.
+
+ See @<https://wiki.libsdl.org/SDL2/SDL_GameControllerFromInstanceID SDL_GameControllerFromInstanceID>@ for C documentation.
+-}
+controllerFromInstanceID :: MonadIO m => Raw.JoystickID -> m GameController
+controllerFromInstanceID i =
+  fmap GameController $
+    throwIfNull "SDL.Input.GameController.controllerFromInstanceID" "SDL_GameControllerFromInstanceID" $
+      Raw.gameControllerFromInstanceID (fromIntegral i)
+
+
 -- | Enumerate all connected Controllers, retrieving a description of each.
 availableControllers :: MonadIO m => m (V.Vector ControllerDevice)
 availableControllers = liftIO $ do
-  n <- numJoysticks
-  indices <- filterM Raw.isGameController [0 .. (n - 1)]
-  fmap V.fromList $ for indices $ \i -> do
-    cstr <-
-      throwIfNull "SDL.Input.Controller.availableGameControllers" "SDL_GameControllerNameForIndex" $
-        Raw.gameControllerNameForIndex i
-    name <- Text.decodeUtf8 <$> BS.packCString cstr
-    return (ControllerDevice name i)
+  n <- fromIntegral <$> numJoysticks
+  V.catMaybes <$> V.generateM n (mkControllerDevice . fromIntegral)
 
 {- | Open a controller so that you can start receiving events from interaction with this controller.
 
@@ -90,10 +132,10 @@ openController
   => ControllerDevice
   -- ^ The device to open. Use 'availableControllers' to find 'JoystickDevices's
   -> m GameController
-openController (ControllerDevice _ x) =
+openController (ControllerDevice _ i) =
   fmap GameController $
     throwIfNull "SDL.Input.GameController.openController" "SDL_GameControllerOpen" $
-      Raw.gameControllerOpen x
+      Raw.gameControllerOpen (fromIntegral i)
 
 {- | Close a controller previously opened with 'openController'.
 
@@ -114,7 +156,7 @@ controllerAttached (GameController c) = Raw.gameControllerGetAttached c
 
  See @<https://wiki.libsdl.org/SDL2/SDL_GameControllerInstanceID SDL_GameControllerInstanceID>@ for C documentation.
 -}
-getControllerID :: MonadIO m => GameController -> m Int32
+getControllerID :: MonadIO m => GameController -> m Raw.JoystickID
 getControllerID (GameController c) =
   throwIfNeg "SDL.Input.GameController.getControllerID" "SDL_JoystickInstanceID" $
     Raw.joystickInstanceID c
diff --git a/src/SDL/Raw/Event.hs b/src/SDL/Raw/Event.hs
@@ -96,6 +96,7 @@ module SDL.Raw.Event (
   gameControllerClose,
   gameControllerEventState,
   gameControllerFromInstanceID,
+  gameControllerFromPlayerIndex,
   gameControllerGetAttached,
   gameControllerGetAxis,
   gameControllerGetAxisFromString,
@@ -104,6 +105,12 @@ module SDL.Raw.Event (
   gameControllerGetButton,
   gameControllerGetButtonFromString,
   gameControllerGetJoystick,
+  gameControllerGetNumTouchpadFingers,
+  gameControllerGetNumTouchpads,
+  gameControllerGetPlayerIndex,
+  gameControllerHasLED,
+  gameControllerHasRumble,
+  gameControllerHasRumbleTriggers,
   gameControllerGetStringForAxis,
   gameControllerGetStringForButton,
   gameControllerMapping,
@@ -113,6 +120,9 @@ module SDL.Raw.Event (
   gameControllerOpen,
   gameControllerUpdate,
   gameControllerRumble,
+  gameControllerRumbleTriggers,
+  gameControllerSetLED,
+  gameControllerSetPlayerIndex,
   isGameController,
   eventBuffer,
   eventBufferSize
@@ -220,6 +230,7 @@ foreign import ccall "SDL.h SDL_GameControllerAddMappingsFromRW" gameControllerA
 foreign import ccall "SDL.h SDL_GameControllerClose" gameControllerCloseFFI :: GameController -> IO ()
 foreign import ccall "SDL.h SDL_GameControllerEventState" gameControllerEventStateFFI :: CInt -> IO CInt
 foreign import ccall "SDL.h SDL_GameControllerFromInstanceID" gameControllerFromInstanceIDFFI :: JoystickID -> IO GameController
+foreign import ccall "SDL.h SDL_GameControllerFromPlayerIndex" gameControllerFromPlayerIndexFFI :: CInt -> IO GameController
 foreign import ccall "SDL.h SDL_GameControllerGetAttached" gameControllerGetAttachedFFI :: GameController -> IO Bool
 foreign import ccall "SDL.h SDL_GameControllerGetAxis" gameControllerGetAxisFFI :: GameController -> GameControllerAxis -> IO Int16
 foreign import ccall "SDL.h SDL_GameControllerGetAxisFromString" gameControllerGetAxisFromStringFFI :: CString -> IO GameControllerAxis
@@ -228,6 +239,12 @@ foreign import ccall "sdlhelper.h SDLHelper_GameControllerGetBindForButton" game
 foreign import ccall "SDL.h SDL_GameControllerGetButton" gameControllerGetButtonFFI :: GameController -> GameControllerButton -> IO Word8
 foreign import ccall "SDL.h SDL_GameControllerGetButtonFromString" gameControllerGetButtonFromStringFFI :: CString -> IO GameControllerButton
 foreign import ccall "SDL.h SDL_GameControllerGetJoystick" gameControllerGetJoystickFFI :: GameController -> IO Joystick
+foreign import ccall "SDL.h SDL_GameControllerGetNumTouchpadFingers" gameControllerGetNumTouchpadFingersFFI :: GameController -> CInt -> IO CInt
+foreign import ccall "SDL.h SDL_GameControllerGetNumTouchpads" gameControllerGetNumTouchpadsFFI :: GameController -> IO CInt
+foreign import ccall "SDL.h SDL_GameControllerGetPlayerIndex" gameControllerGetPlayerIndexFFI :: GameController -> IO CInt
+foreign import ccall "SDL.h SDL_GameControllerHasLED" gameControllerHasLEDFFI :: GameController -> IO Bool
+foreign import ccall "SDL.h SDL_GameControllerHasRumble" gameControllerHasRumbleFFI :: GameController -> IO Bool
+foreign import ccall "SDL.h SDL_GameControllerHasRumbleTriggers" gameControllerHasRumbleTriggersFFI :: GameController -> IO Bool
 foreign import ccall "SDL.h SDL_GameControllerGetStringForAxis" gameControllerGetStringForAxisFFI :: GameControllerAxis -> IO CString
 foreign import ccall "SDL.h SDL_GameControllerGetStringForButton" gameControllerGetStringForButtonFFI :: GameControllerButton -> IO CString
 foreign import ccall "SDL.h SDL_GameControllerMapping" gameControllerMappingFFI :: GameController -> IO CString
@@ -237,6 +254,9 @@ foreign import ccall "SDL.h SDL_GameControllerNameForIndex" gameControllerNameFo
 foreign import ccall "SDL.h SDL_GameControllerOpen" gameControllerOpenFFI :: CInt -> IO GameController
 foreign import ccall "SDL.h SDL_GameControllerUpdate" gameControllerUpdateFFI :: IO ()
 foreign import ccall "SDL.h SDL_GameControllerRumble" gameControllerRumbleFFI :: GameController -> CUShort -> CUShort -> CUInt -> IO CInt
+foreign import ccall "SDL.h SDL_GameControllerRumbleTriggers" gameControllerRumbleTriggersFFI :: GameController -> CUShort -> CUShort -> CUInt -> IO CInt
+foreign import ccall "SDL.h SDL_GameControllerSetLED" gameControllerSetLEDFFI :: GameController -> Word8 -> Word8 -> Word8 -> IO CInt
+foreign import ccall "SDL.h SDL_GameControllerSetPlayerIndex" gameControllerSetPlayerIndexFFI :: GameController -> CInt -> IO ()
 foreign import ccall "SDL.h SDL_IsGameController" isGameControllerFFI :: CInt -> IO Bool
 
 foreign import ccall "sdlhelper.c SDLHelper_GetEventBufferSize" eventBufferSize :: CInt
@@ -607,6 +627,10 @@ gameControllerFromInstanceID :: MonadIO m => JoystickID -> m GameController
 gameControllerFromInstanceID v1 = liftIO $ gameControllerFromInstanceIDFFI v1
 {-# INLINE gameControllerFromInstanceID #-}
 
+gameControllerFromPlayerIndex :: MonadIO m => CInt -> m GameController
+gameControllerFromPlayerIndex v1 = liftIO $ gameControllerFromPlayerIndexFFI v1
+{-# INLINE gameControllerFromPlayerIndex #-}
+
 gameControllerGetAttached :: MonadIO m => GameController -> m Bool
 gameControllerGetAttached v1 = liftIO $ gameControllerGetAttachedFFI v1
 {-# INLINE gameControllerGetAttached #-}
@@ -643,6 +667,31 @@ gameControllerGetJoystick :: MonadIO m => GameController -> m Joystick
 gameControllerGetJoystick v1 = liftIO $ gameControllerGetJoystickFFI v1
 {-# INLINE gameControllerGetJoystick #-}
 
+gameControllerGetNumTouchpadFingers :: MonadIO m => GameController -> CInt -> m CInt
+gameControllerGetNumTouchpadFingers gamecontroller touchpad =
+  liftIO $ gameControllerGetNumTouchpadFingersFFI gamecontroller touchpad
+{-# INLINE gameControllerGetNumTouchpadFingers #-}
+
+gameControllerGetNumTouchpads :: MonadIO m => GameController -> m CInt
+gameControllerGetNumTouchpads gamecontroller = liftIO $ gameControllerGetNumTouchpadsFFI gamecontroller
+{-# INLINE gameControllerGetNumTouchpads #-}
+
+gameControllerGetPlayerIndex :: MonadIO m => GameController -> m CInt
+gameControllerGetPlayerIndex gamecontroller = liftIO $ gameControllerGetPlayerIndexFFI gamecontroller
+{-# INLINE gameControllerGetPlayerIndex #-}
+
+gameControllerHasLED :: MonadIO m => GameController -> m Bool
+gameControllerHasLED gamecontroller = liftIO $ gameControllerHasLEDFFI gamecontroller
+{-# INLINE gameControllerHasLED #-}
+
+gameControllerHasRumble :: MonadIO m => GameController -> m Bool
+gameControllerHasRumble gamecontroller = liftIO $ gameControllerHasRumbleFFI gamecontroller
+{-# INLINE gameControllerHasRumble #-}
+
+gameControllerHasRumbleTriggers :: MonadIO m => GameController -> m Bool
+gameControllerHasRumbleTriggers gamecontroller = liftIO $ gameControllerHasRumbleTriggersFFI gamecontroller
+{-# INLINE gameControllerHasRumbleTriggers #-}
+
 gameControllerGetStringForAxis :: MonadIO m => GameControllerAxis -> m CString
 gameControllerGetStringForAxis v1 = liftIO $ gameControllerGetStringForAxisFFI v1
 {-# INLINE gameControllerGetStringForAxis #-}
@@ -681,6 +730,18 @@ gameControllerRumble :: MonadIO m => GameController -> CUShort -> CUShort -> CUI
 gameControllerRumble v1 v2 v3 v4 = liftIO $ gameControllerRumbleFFI v1 v2 v3 v4
 {-# INLINE gameControllerRumble #-}
 
+gameControllerRumbleTriggers :: MonadIO m => GameController -> CUShort -> CUShort -> CUInt -> m CInt
+gameControllerRumbleTriggers gamecontroller v1 v2 v3 = liftIO $ gameControllerRumbleTriggersFFI gamecontroller v1 v2 v3
+{-# INLINE gameControllerRumbleTriggers #-}
+
+gameControllerSetLED :: MonadIO m => GameController -> Word8 -> Word8 -> Word8 -> m CInt
+gameControllerSetLED gamecontroller v1 v2 v3 = liftIO $ gameControllerSetLEDFFI gamecontroller v1 v2 v3
+{-# INLINE gameControllerSetLED #-}
+
+gameControllerSetPlayerIndex :: MonadIO m => GameController -> CInt -> m ()
+gameControllerSetPlayerIndex gamecontroller v1 = liftIO $ gameControllerSetPlayerIndexFFI gamecontroller v1
+{-# INLINE gameControllerSetPlayerIndex #-}
+
 isGameController :: MonadIO m => CInt -> m Bool
 isGameController v1 = liftIO $ isGameControllerFFI v1
 {-# INLINE isGameController #-}

Original file line number	Diff line number	Diff line change
`@@ -428,7 +428,7 @@ data ControllerDeviceEventData =`
`428`	`428`	`ControllerDeviceEventData {controllerDeviceEventConnection :: !ControllerDeviceConnection`
`429`	`429`	`-- ^ Was the device added, removed, or remapped?`
`430`	`430`	`,controllerDeviceEventWhich :: !Raw.JoystickID`
`431`		`- -- ^ The joystick instance ID that reported the event.`
	`431`	`+ -- ^ The joystick device index for the ADDED event, instance id for the REMOVED or REMAPPED event`
`432`	`432`	`}`
`433`	`433`	`deriving (Eq,Ord,Generic,Show,Typeable)`
`434`	`434`