Skip to content

Commit 21519b5

Browse files
jtnuttalljtnuttall
authored
Add high-level GameController bindings (#279)
1 parent 299a34d commit 21519b5

File tree

3 files changed

+203
-6
lines changed

3 files changed

+203
-6
lines changed

‎src/SDL/Event.hs

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -405,7 +405,7 @@ data JoyDeviceEventData =
405405
data ControllerAxisEventData =
406406
ControllerAxisEventData {controllerAxisEventWhich :: !Raw.JoystickID
407407
-- ^ The joystick instance ID that reported the event.
408-
,controllerAxisEventAxis :: !Word8
408+
,controllerAxisEventAxis :: !ControllerAxis
409409
-- ^ The index of the axis.
410410
,controllerAxisEventValue :: !Int16
411411
-- ^ The axis value ranging between -32768 and 32767.
@@ -681,7 +681,11 @@ convertRaw (Raw.JoyButtonEvent _ ts a b c) =
681681
convertRaw (Raw.JoyDeviceEvent t ts a) =
682682
return (Event ts (JoyDeviceEvent (JoyDeviceEventData (fromNumber t) a)))
683683
convertRaw (Raw.ControllerAxisEvent _ ts a b c) =
684-
return (Event ts (ControllerAxisEvent (ControllerAxisEventData a b c)))
684+
return (Event ts
685+
(ControllerAxisEvent
686+
(ControllerAxisEventData a
687+
(fromNumber $ fromIntegral b)
688+
c)))
685689
convertRaw (Raw.ControllerButtonEvent t ts a b _) =
686690
return (Event ts
687691
(ControllerButtonEvent

‎src/SDL/Input/GameController.hs

Lines changed: 192 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,21 +1,176 @@
1+
{-# LANGUAGE CPP #-}
12
{-# LANGUAGE DeriveDataTypeable #-}
23
{-# LANGUAGE DeriveGeneric #-}
34
{-# LANGUAGE MultiParamTypeClasses #-}
5+
{-# LANGUAGE OverloadedStrings #-}
46
{-# LANGUAGE PatternSynonyms #-}
57

68
module SDL.Input.GameController
7-
( ControllerButton(..)
8-
, ControllerButtonState(..)
9-
, ControllerDeviceConnection(..)
9+
( ControllerDevice (..)
10+
, availableControllers
11+
12+
, openController
13+
, closeController
14+
, controllerAttached
15+
16+
, getControllerID
17+
18+
, controllerMapping
19+
, addControllerMapping
20+
, addControllerMappingsFromFile
21+
22+
, ControllerButton (..)
23+
, ControllerButtonState (..)
24+
, controllerButton
25+
26+
, ControllerAxis (..)
27+
, controllerAxis
28+
29+
, ControllerDeviceConnection (..)
1030
) where
1131

32+
import Control.Monad (filterM)
33+
import Control.Monad.IO.Class (MonadIO, liftIO)
1234
import Data.Data (Data)
35+
import Data.Int
36+
import Data.Text (Text)
37+
import Data.Traversable (for)
1338
import Data.Typeable
1439
import Data.Word
40+
import Foreign.C (withCString)
41+
import Foreign.C.Types
42+
import Foreign.ForeignPtr
43+
import Foreign.Marshal.Alloc
44+
import Foreign.Ptr
45+
import Foreign.Storable
1546
import GHC.Generics (Generic)
1647
import GHC.Int (Int32)
48+
import SDL.Input.Joystick (numJoysticks)
49+
import SDL.Internal.Exception
1750
import SDL.Internal.Numbered
51+
import SDL.Internal.Types
52+
import SDL.Vect
53+
import qualified Data.ByteString as BS
54+
import qualified Data.ByteString.Internal as BSI
1855
import qualified SDL.Raw as Raw
56+
import qualified Data.Text.Encoding as Text
57+
import qualified Data.Vector as V
58+
59+
#if !MIN_VERSION_base(4,8,0)
60+
import Control.Applicative
61+
#endif
62+
63+
{- | A description of game controller that can be opened using 'openController'.
64+
To retrieve a list of connected game controllers, use 'availableControllers'.
65+
-}
66+
data ControllerDevice = ControllerDevice
67+
{ gameControllerDeviceName :: Text
68+
, gameControllerDeviceId :: CInt
69+
}
70+
deriving (Eq, Generic, Read, Ord, Show, Typeable)
71+
72+
-- | Enumerate all connected Controllers, retrieving a description of each.
73+
availableControllers :: MonadIO m => m (V.Vector ControllerDevice)
74+
availableControllers = liftIO $ do
75+
n <- numJoysticks
76+
indices <- filterM Raw.isGameController [0 .. (n - 1)]
77+
fmap V.fromList $ for indices $ \i -> do
78+
cstr <-
79+
throwIfNull "SDL.Input.Controller.availableGameControllers" "SDL_GameControllerNameForIndex" $
80+
Raw.gameControllerNameForIndex i
81+
name <- Text.decodeUtf8 <$> BS.packCString cstr
82+
return (ControllerDevice name i)
83+
84+
{- | Open a controller so that you can start receiving events from interaction with this controller.
85+
86+
See @<https://wiki.libsdl.org/SDL_GameControllerOpen SDL_GameControllerOpen>@ for C documentation.
87+
-}
88+
openController
89+
:: (Functor m, MonadIO m)
90+
=> ControllerDevice
91+
-- ^ The device to open. Use 'availableControllers' to find 'JoystickDevices's
92+
-> m GameController
93+
openController (ControllerDevice _ x) =
94+
fmap GameController $
95+
throwIfNull "SDL.Input.GameController.openController" "SDL_GameControllerOpen" $
96+
Raw.gameControllerOpen x
97+
98+
{- | Close a controller previously opened with 'openController'.
99+
100+
See @<https://wiki.libsdl.org/SDL_GameControllerClose SDL_GameControllerClose>@ for C documentation.
101+
-}
102+
closeController :: MonadIO m => GameController -> m ()
103+
closeController (GameController j) = Raw.gameControllerClose j
104+
105+
{- | Check if a controller has been opened and is currently connected.
106+
107+
See @<https://wiki.libsdl.org/SDL_GameControllerGetAttached SDL_GameControllerGetAttached>@ for C documentation.
108+
-}
109+
controllerAttached :: MonadIO m => GameController -> m Bool
110+
controllerAttached (GameController c) = Raw.gameControllerGetAttached c
111+
112+
{- | Get the instance ID of an opened controller. The instance ID is used to identify the controller
113+
in future SDL events.
114+
115+
See @<https://wiki.libsdl.org/SDL_GameControllerInstanceID SDL_GameControllerInstanceID>@ for C documentation.
116+
-}
117+
getControllerID :: MonadIO m => GameController -> m Int32
118+
getControllerID (GameController c) =
119+
throwIfNeg "SDL.Input.GameController.getControllerID" "SDL_JoystickInstanceID" $
120+
Raw.joystickInstanceID c
121+
122+
{- | Get the current mapping of a Game Controller.
123+
124+
See @<https://wiki.libsdl.org/SDL_GameControllerMapping SDL_GameControllerMapping>@ for C documentation.
125+
-}
126+
controllerMapping :: MonadIO m => GameController -> m Text
127+
controllerMapping (GameController c) = liftIO $ do
128+
mapping <-
129+
throwIfNull "SDL.Input.GameController.getControllerMapping" "SDL_GameControllerMapping" $
130+
Raw.gameControllerMapping c
131+
Text.decodeUtf8 <$> BS.packCString mapping
132+
133+
{- | Add support for controllers that SDL is unaware of or to cause an existing controller to
134+
have a different binding.
135+
136+
See @<https://wiki.libsdl.org/SDL_GameControllerAddMapping SDL_GameControllerAddMapping>@ for C documentation.
137+
-}
138+
addControllerMapping :: MonadIO m => BS.ByteString -> m ()
139+
addControllerMapping mapping =
140+
liftIO $
141+
throwIfNeg_ "SDL.Input.GameController.addControllerMapping" "SDL_GameControllerAddMapping" $
142+
let (mappingForeign, _, _) = BSI.toForeignPtr mapping
143+
in withForeignPtr mappingForeign $ \mappingPtr ->
144+
Raw.gameControllerAddMapping (castPtr mappingPtr)
145+
146+
{- | Use this function to load a set of Game Controller mappings from a file, filtered by the
147+
current SDL_GetPlatform(). A community sourced database of controllers is available
148+
@<https://raw.githubusercontent.com/gabomdq/SDL_GameControllerDB/master/gamecontrollerdb.txt here>@
149+
(on GitHub).
150+
151+
See @<https://wiki.libsdl.org/SDL_GameControllerAddMappingsFromFile SDL_GameControllerAddMappingsFromFile>@ for C documentation.
152+
-}
153+
addControllerMappingsFromFile :: MonadIO m => FilePath -> m ()
154+
addControllerMappingsFromFile mappingFile =
155+
liftIO $
156+
throwIfNeg_ "SDL.Input.GameController.addControllerMappingsFromFile" "SDL_GameControllerAddMappingsFromFile" $
157+
withCString mappingFile Raw.gameControllerAddMappingsFromFile
158+
159+
{- | Get the current state of an axis control on a game controller.
160+
161+
See @<https://wiki.libsdl.org/SDL_GameControllerGetAxis SDL_GameControllerGetAxis>@ for C documentation.
162+
-}
163+
controllerAxis :: MonadIO m => GameController -> ControllerAxis -> m Int16
164+
controllerAxis (GameController c) axis =
165+
Raw.gameControllerGetAxis c (toNumber axis)
166+
167+
{- | Get the current state of a button on a game controller.
168+
169+
See @<https://wiki.libsdl.org/SDL_GameControllerGetButton SDL_GameControllerGetButton>@ for C documentation.
170+
-}
171+
controllerButton :: MonadIO m => GameController -> ControllerButton -> m ControllerButtonState
172+
controllerButton (GameController c) button =
173+
fromNumber . fromIntegral <$> Raw.gameControllerGetButton c (toNumber button)
19174

20175
-- | Identifies a gamepad button.
21176
data ControllerButton
@@ -88,7 +243,40 @@ instance FromNumber ControllerButtonState Word32 where
88243
Raw.SDL_CONTROLLERBUTTONUP -> ControllerButtonReleased
89244
_ -> ControllerButtonInvalidState
90245

91-
-- | Identified whether the game controller was added, removed, or remapped.
246+
data ControllerAxis
247+
= ControllerAxisInvalid
248+
| ControllerAxisLeftX
249+
| ControllerAxisLeftY
250+
| ControllerAxisRightX
251+
| ControllerAxisRightY
252+
| ControllerAxisTriggerLeft
253+
| ControllerAxisTriggerRight
254+
| ControllerAxisMax
255+
deriving (Data, Eq, Generic, Ord, Read, Show, Typeable)
256+
257+
instance ToNumber ControllerAxis Int32 where
258+
toNumber a = case a of
259+
ControllerAxisLeftX -> Raw.SDL_CONTROLLER_AXIS_LEFTX
260+
ControllerAxisLeftY -> Raw.SDL_CONTROLLER_AXIS_LEFTY
261+
ControllerAxisRightX -> Raw.SDL_CONTROLLER_AXIS_RIGHTX
262+
ControllerAxisRightY -> Raw.SDL_CONTROLLER_AXIS_RIGHTY
263+
ControllerAxisTriggerLeft -> Raw.SDL_CONTROLLER_AXIS_TRIGGERLEFT
264+
ControllerAxisTriggerRight -> Raw.SDL_CONTROLLER_AXIS_TRIGGERRIGHT
265+
ControllerAxisMax -> Raw.SDL_CONTROLLER_AXIS_MAX
266+
ControllerAxisInvalid -> Raw.SDL_CONTROLLER_AXIS_INVALID
267+
268+
instance FromNumber ControllerAxis Int32 where
269+
fromNumber n = case n of
270+
Raw.SDL_CONTROLLER_AXIS_LEFTX -> ControllerAxisLeftX
271+
Raw.SDL_CONTROLLER_AXIS_LEFTY -> ControllerAxisLeftY
272+
Raw.SDL_CONTROLLER_AXIS_RIGHTX -> ControllerAxisRightX
273+
Raw.SDL_CONTROLLER_AXIS_RIGHTY -> ControllerAxisRightY
274+
Raw.SDL_CONTROLLER_AXIS_TRIGGERLEFT -> ControllerAxisTriggerLeft
275+
Raw.SDL_CONTROLLER_AXIS_TRIGGERRIGHT -> ControllerAxisTriggerRight
276+
Raw.SDL_CONTROLLER_AXIS_MAX -> ControllerAxisMax
277+
_ -> ControllerAxisInvalid
278+
279+
-- | Identifies whether the game controller was added, removed, or remapped.
92280
data ControllerDeviceConnection
93281
= ControllerDeviceAdded
94282
| ControllerDeviceRemoved

‎src/SDL/Internal/Types.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE DeriveGeneric #-}
33
module SDL.Internal.Types
44
( Joystick(..)
5+
, GameController(..)
56
, Window(..)
67
, Renderer(..)
78
) where
@@ -15,6 +16,10 @@ import qualified SDL.Raw as Raw
1516
newtype Joystick = Joystick { joystickPtr :: Raw.Joystick }
1617
deriving (Data, Eq, Generic, Ord, Show, Typeable)
1718

19+
newtype GameController = GameController
20+
{ gameControllerPtr :: Raw.GameController }
21+
deriving (Data, Eq, Generic, Ord, Show, Typeable)
22+
1823
newtype Window = Window (Raw.Window)
1924
deriving (Data, Eq, Generic, Ord, Show, Typeable)
2025

0 commit comments

Comments
 (0)