affection/src/Affection/Subsystems/AffectionKeyboard.hs

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

import Affection.Types
import Affection.Util
import Affection.MessageBus
import Affection.Subsystems.Class

import Control.Concurrent.STM as STM
import Control.Monad.IO.Class (liftIO)

import qualified SDL

consumeSDLKeyboardEvents
  :: (Participant ak KeyboardMessage us)
  => ak
  -> [SDL.EventPayload]
  -> Affection us [SDL.EventPayload]
consumeSDLKeyboardEvents ak eps = doConsume eps
  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)