{-# 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)