pituicat/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 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 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)