affection/src/Affection/Subsystems/AffectionKeyboard.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
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

data AffectionKeyboard us = AffectionKeyboard
  { keyboardSubscribers :: forall us. TVar [(UUID, KeyboardMessage -> Affection us ())]
  }

instance Participant (AffectionKeyboard us) KeyboardMessage where
  partSubscribe p funct = do
    uuid <- genUUID
    liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) ((uuid, funct) :)
    return uuid

  partUnSubscribe p uuid =
    liftIO $ atomically $ modifyTVar' (keyboardSubscribers p)
      (filter (\(u, _) -> u /= uuid))

  partSubscribers p = do
    subTups <- liftIO $ readTVarIO $ keyboardSubscribers p
    return $ map snd subTups

instance SDLSubsystem (AffectionKeyboard us) KeyboardMessage where
  consumeSDLEvents ak eps = doConsume eps
    where
      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)