{-# 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 -- | 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 <$> (return . V.filter (\(SDL.JoystickDevice _ id) -> id == 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 -> return . (which ==) =<< SDL.getJoystickID j) js logIO Verbose $ "disconnected joysticks: " ++ show d logIO Verbose $ "Disconnecting Joystick " ++ show which SDL.closeJoystick d njoys <- filterM (\j -> return $ d /= j) js logIO Verbose $ "returning joysticks: " ++ show njoys return njoys joystickAutoDisconnect js _ = return js