{-# LANGUAGE MultiParamTypeClasses #-} 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 = AffectionKeyboard { keyboardSubscribers :: TVar [(UUID, KeyboardMessage -> IO ())] } instance Participant AffectionKeyboard 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 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)