pituicat/src/Affection/Subsystems/AffectionJoystick.hs
2018-01-09 18:40:54 +01:00

95 lines
3 KiB
Haskell

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Affection.Subsystems.AffectionJoystick where
import Affection.MessageBus
import Affection.Subsystems.Class
import Affection.Types
import Affection.Util
import Affection.Logging
import Control.Monad (filterM)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM
import qualified Data.Vector as V
import Foreign.C.Types (CInt(..))
import qualified SDL
consumeSDLJoystickEvents
:: forall am us. (Participant am us, Mesg am us ~ JoystickMessage)
=> am
-> [SDL.EventPayload]
-> Affection us [SDL.EventPayload]
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)
joystickAutoConnect :: JoystickMessage -> Affection us (Maybe SDL.Joystick)
joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do
[descr] <- V.toList <$>
(return . V.filter (\(SDL.JoystickDevice _ id) -> id == CInt which)
=<< SDL.availableJoysticks)
logIO Verbose $ "Connecting Joystick " ++ show which
Just <$> SDL.openJoystick descr
joystickAutoConnect _ = return Nothing
joystickAutoDisconnect :: [SDL.Joystick] -> JoystickMessage -> Affection us [SDL.Joystick]
joystickAutoDisconnect js (MsgJoystickDevice _ which SDL.JoyDeviceRemoved) =
liftIO $ do
[disc] <- filterM (\j -> return . (which ==) =<< SDL.getJoystickID j) js
logIO Verbose $ "Disconnecting Joystick " ++ show which
SDL.closeJoystick disc
filterM (\j -> return . (which /=) =<< SDL.getJoystickID j) js
joystickAutoDisconnect js _ = return js