affection/src/Affection/Subsystems/AffectionJoystick.hs

117 lines
4.1 KiB
Haskell
Raw Normal View History

2018-01-09 17:40:54 +00:00
{-# 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
2018-01-10 15:58:23 +00:00
-- | Helper function that consumes all Joystick-related 'SDL.EventPayload's
-- and emits appropriate 'JoystickMessage's
2018-01-09 17:40:54 +00:00
consumeSDLJoystickEvents
:: forall am us. (Participant am us, Mesg am us ~ JoystickMessage)
2018-01-10 15:58:23 +00:00
=> am -- ^ The message system participant
-> [SDL.EventPayload] -- ^ Incoming events
-> Affection us [SDL.EventPayload] -- ^ Leftover SDL events
2018-01-09 17:40:54 +00:00
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)
2018-09-25 05:02:33 +00:00
-- | 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
2018-01-09 17:40:54 +00:00
joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do
[descr] <- V.toList <$>
2018-09-25 14:10:36 +00:00
(V.filter (\(SDL.JoystickDevice _ i) -> i == CInt which) <$>
SDL.availableJoysticks)
2018-01-12 21:08:23 +00:00
logIO Verbose $ "Connecting Joystick " ++ show which ++ " " ++ show descr
2018-01-09 17:40:54 +00:00
Just <$> SDL.openJoystick descr
joystickAutoConnect _ = return Nothing
2018-09-25 05:02:33 +00:00
-- | 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
2018-09-25 15:27:35 +00:00
-- specifically to 'MsgJoystickDevice' messages
2018-09-25 05:02:33 +00:00
-> Affection us [SDL.Joystick] -- ^ Returns altered list of Joystick descriptors
2018-01-09 17:40:54 +00:00
joystickAutoDisconnect js (MsgJoystickDevice _ which SDL.JoyDeviceRemoved) =
liftIO $ do
2018-01-12 21:08:23 +00:00
joyIds <- mapM SDL.getJoystickID js
logIO Verbose $ "These are the Joysticks connected: " ++ show joyIds
2018-10-10 12:13:21 +00:00
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
2018-01-09 17:40:54 +00:00
joystickAutoDisconnect js _ = return js