116 lines
4.1 KiB
Haskell
116 lines
4.1 KiB
Haskell
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
module Affection.Subsystems.AffectionJoystick where
|
|
|
|
import Affection.MessageBus
|
|
import Affection.Types
|
|
import Affection.Util
|
|
import Affection.Logging
|
|
|
|
import Control.Monad (filterM)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
|
|
import qualified Data.Vector as V
|
|
|
|
import Foreign.C.Types (CInt(..))
|
|
|
|
import qualified SDL
|
|
|
|
-- | Helper function that consumes all Joystick-related 'SDL.EventPayload's
|
|
-- and emits appropriate 'JoystickMessage's
|
|
consumeSDLJoystickEvents
|
|
:: forall am us. (Participant am us, Mesg am us ~ JoystickMessage)
|
|
=> am -- ^ The message system participant
|
|
-> [SDL.EventPayload] -- ^ Incoming events
|
|
-> Affection us [SDL.EventPayload] -- ^ Leftover SDL events
|
|
consumeSDLJoystickEvents am = doConsume
|
|
where
|
|
doConsume
|
|
:: [SDL.EventPayload]
|
|
-> Affection us [SDL.EventPayload]
|
|
doConsume [] = return []
|
|
doConsume (e:es) = do
|
|
ts <- getElapsedTime
|
|
case e of
|
|
SDL.JoyAxisEvent dat -> do
|
|
partEmit am (MsgJoystickAxis
|
|
ts
|
|
(SDL.joyAxisEventWhich dat)
|
|
(SDL.joyAxisEventAxis dat)
|
|
(SDL.joyAxisEventValue dat)
|
|
)
|
|
doConsume es
|
|
SDL.JoyBallEvent dat -> do
|
|
partEmit am (MsgJoystickBall
|
|
ts
|
|
(SDL.joyBallEventWhich dat)
|
|
(SDL.joyBallEventBall dat)
|
|
(SDL.joyBallEventRelMotion dat)
|
|
)
|
|
doConsume es
|
|
SDL.JoyHatEvent dat -> do
|
|
partEmit am (MsgJoystickHat
|
|
ts
|
|
(SDL.joyHatEventWhich dat)
|
|
(SDL.joyHatEventHat dat)
|
|
(SDL.joyHatEventValue dat)
|
|
)
|
|
doConsume es
|
|
SDL.JoyButtonEvent dat -> do
|
|
partEmit am (MsgJoystickButton
|
|
ts
|
|
(SDL.joyButtonEventWhich dat)
|
|
(SDL.joyButtonEventButton dat)
|
|
(SDL.joyButtonEventState dat)
|
|
)
|
|
doConsume es
|
|
SDL.JoyDeviceEvent dat -> do
|
|
partEmit am (MsgJoystickDevice
|
|
ts
|
|
(SDL.joyDeviceEventWhich dat)
|
|
(SDL.joyDeviceEventConnection dat)
|
|
)
|
|
doConsume es
|
|
_ -> fmap (e :) (doConsume es)
|
|
|
|
-- | Helper function to automatically connect and open newly attached joystick
|
|
-- devices
|
|
joystickAutoConnect
|
|
:: JoystickMessage -- ^ Any 'JoystickMessage' will do,
|
|
-- but listens only on 'MsgJoystickDevice' messages
|
|
-> Affection us (Maybe SDL.Joystick)
|
|
-- ^ Returns a joystick descriptor, if successful
|
|
joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do
|
|
[descr] <- V.toList <$>
|
|
(V.filter (\(SDL.JoystickDevice _ i) -> i == CInt which) <$>
|
|
SDL.availableJoysticks)
|
|
logIO Verbose $ "Connecting Joystick " ++ show which ++ " " ++ show descr
|
|
Just <$> SDL.openJoystick descr
|
|
joystickAutoConnect _ = return Nothing
|
|
|
|
-- | Helper function to automatically close and disconnect freshly detached
|
|
-- joystick devices
|
|
joystickAutoDisconnect
|
|
:: [SDL.Joystick] -- ^ List of Joystick descriptors
|
|
-> JoystickMessage -- ^ Any 'JoystickMessage' will do, but listens
|
|
-- specifically to 'MsgJoystickDevice' messages
|
|
-> Affection us [SDL.Joystick] -- ^ Returns altered list of Joystick descriptors
|
|
joystickAutoDisconnect js (MsgJoystickDevice _ which SDL.JoyDeviceRemoved) =
|
|
liftIO $ do
|
|
joyIds <- mapM SDL.getJoystickID js
|
|
logIO Verbose $ "These are the Joysticks connected: " ++ show joyIds
|
|
d <- filterM (\j -> fmap (== which) (SDL.getJoystickID j)) js
|
|
if not (null d)
|
|
then do
|
|
logIO Verbose $ "disconnected joysticks: " ++ show (head d)
|
|
logIO Verbose $ "Disconnecting Joystick " ++ show which
|
|
SDL.closeJoystick (head d)
|
|
njoys <- filterM (\j -> return $ head d /= j) js
|
|
logIO Verbose $ "returning joysticks: " ++ show njoys
|
|
return njoys
|
|
else do
|
|
logIO Error $ "Error while disconnecting Joystick"
|
|
return js
|
|
joystickAutoDisconnect js _ = return js
|