affection/src/Affection/Subsystems/AffectionJoystick.hs

{-# 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)

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