diff --git a/affection.cabal b/affection.cabal index 97fc92d..0f144f5 100644 --- a/affection.cabal +++ b/affection.cabal @@ -68,8 +68,10 @@ library , Affection.MessageBus.Message , Affection.MessageBus.Message.Class , Affection.MessageBus.Message.WindowMessage + , Affection.MessageBus.Message.KeyboardMessage , Affection.Subsystems.Class , Affection.Subsystems.AffectionWindow + , Affection.Subsystems.AffectionKeyboard default-extensions: OverloadedStrings -- Modules included in this library but not exported. diff --git a/src/Affection/MessageBus/Message/KeyboardMessage.hs b/src/Affection/MessageBus/Message/KeyboardMessage.hs new file mode 100644 index 0000000..e783592 --- /dev/null +++ b/src/Affection/MessageBus/Message/KeyboardMessage.hs @@ -0,0 +1,18 @@ +module Affection.MessageBus.Message.KeyboardMessage where + +import Affection.MessageBus.Message.Class + +import Data.Word (Word32(..)) + +import qualified SDL + +data KeyboardMessage = MsgKeyboardEvent + { msgKbdWhen :: Word32 + , msgKbdWindow :: Maybe SDL.Window + , msgKbdKeyMotion :: SDL.InputMotion + , msgKbdLeyRepeat :: Bool + , msgKbdKeysym :: SDL.Keysym + } + +instance Message KeyboardMessage where + msgTime (MsgKeyboardEvent t _ _ _ _) = t diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs new file mode 100644 index 0000000..de5ad62 --- /dev/null +++ b/src/Affection/Subsystems/AffectionKeyboard.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +module Affection.Subsystems.AffectionKeyboard where + +import Affection.MessageBus +import Affection.Subsystems.Class +import Affection.Types + +import Control.Monad.IO.Class (liftIO) + +import qualified SDL + +data AffectionKeyboard = AffectionKeyboard + { keyboardInChannel :: Channel KeyboardMessage + , keyboardOutChannel :: Channel KeyboardMessage + } + +instance Participant AffectionKeyboard KeyboardMessage where + partChannel = keyboardOutChannel + + partInit ichan = do + ochan <- liftIO $ newBroadcastChannel + return $ AffectionKeyboard ichan ochan + + partListen p = + liftIO $ tryPeekChannel (keyboardInChannel p) + + partEmit p m = + liftIO $ writeChannel (keyboardOutChannel p) m + +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)