{-# 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 Data.String as S (fromString) 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. (Participant am, Mesg am ~ JoystickMessage) => am -- ^ The message system participant -> [SDL.EventPayload] -- ^ Incoming events -> Affection [SDL.EventPayload] -- ^ Leftover SDL events consumeSDLJoystickEvents am = doConsume where doConsume :: [SDL.EventPayload] -> Affection [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 (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 " <> fromString (show which) <> " " <> fromString (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 [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: " <> fromString (show joyIds) d <- filterM (\j -> fmap (== which) (SDL.getJoystickID j)) js if not (null d) then do logIO Verbose $ "disconnected joysticks: " <> fromString (show $ head d) logIO Verbose $ "Disconnecting Joystick " <> fromString (show which) SDL.closeJoystick (head d) njoys <- filterM (\j -> return $ head d /= j) js logIO Verbose $ "returning joysticks: " <> fromString (show njoys) return njoys else do logIO Error $ "Error while disconnecting Joystick" return js joystickAutoDisconnect js _ = return js