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

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

import Control.Monad.IO.Class (liftIO)

import qualified SDL

data AffectionKeyboard = AffectionKeyboard
  { keyboardInChannel :: Channel KeyboardMessage
  , keyboardOutChannel :: Channel KeyboardMessage
  }

instance Participant AffectionKeyboard KeyboardMessage where
  partChannel = keyboardOutChannel

  partInit ichan = do
    ochan <- liftIO $ newBroadcastChannel
    return $ AffectionKeyboard ichan ochan

  partListen p =
    liftIO $ tryPeekChannel (keyboardInChannel p)

  partEmit p m =
    liftIO $ writeChannel (keyboardOutChannel p) m

instance SDLSubsystem AffectionKeyboard KeyboardMessage where
  consumeSDLEvents ak evs = doConsume evs
    where
      doConsume [] = return []
      doConsume (e:es) = case SDL.eventPayload e of
        SDL.KeyboardEvent dat -> do
          partEmit ak (MsgKeyboardEvent
            (SDL.eventTimestamp e)
            (SDL.keyboardEventWindow dat)
            (SDL.keyboardEventKeyMotion dat)
            (SDL.keyboardEventRepeat dat)
            (SDL.keyboardEventKeysym dat)
            )
          doConsume es
        _ -> fmap (e :) (doConsume es)