affection/src/Affection/Subsystems/AffectionKeyboard.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Affection.Subsystems.AffectionKeyboard where

import Affection.Types
import Affection.Util
import Affection.MessageBus

import qualified SDL

-- | Helper function that consumes all Keyboard-related 'SDL.EventPayload's
-- and emits appropriate 'KeyboardMessage's
consumeSDLKeyboardEvents
  :: forall ak. (Participant ak, Mesg ak ~ KeyboardMessage)
  => ak                              -- ^ The message system participant
  -> [SDL.EventPayload]              -- ^ Incoming events
  -> Affection [SDL.EventPayload] -- ^ Leftover SDL Events
consumeSDLKeyboardEvents ak = doConsume
  where
    doConsume [] = return []
    doConsume (e:es) = do
      ts <- getElapsedTime
      case e of
        SDL.KeyboardEvent dat -> do
          partEmit ak (MsgKeyboardEvent
            ts
            (SDL.keyboardEventWindow dat)
            (SDL.keyboardEventKeyMotion dat)
            (SDL.keyboardEventRepeat dat)
            (SDL.keyboardEventKeysym dat)
            )
          doConsume es
        _ -> fmap (e :) (doConsume es)