affection/src/Affection/Subsystems/AffectionJoystick.hs

{-# 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 ((which ==) <$> SDL.getJoystickID) 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