keyboard subsystem added

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.

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

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)