affection/src/Affection/Subsystems/AffectionKeyboard.hs

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

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

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

import qualified SDL

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

instance Participant (AffectionKeyboard sd) 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 sd) 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)