preparing for keyboard input

src/Init.hs

@@ -46,6 +46,7 @@ init = do
   subs <- Subsystems
     <$> (Window <$> newTVarIO [])
     <*> (Mouse <$> newTVarIO [])
+    <*> (Keyboard <$> newTVarIO [])
   _ <- glewInit
   (ws, _) <- yieldSystemT (0, defStorage) (return ())
   nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes])

src/Main.hs

@@ -50,7 +50,7 @@ pre = do
   -- _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
   threadContext <- SDL.glCreateContext (drawWindow ad)
   SDL.glMakeCurrent (drawWindow ad) (glContext ad)
-  Subsystems w m <- subsystems <$> getAffection
+  Subsystems w m k <- subsystems <$> getAffection
   _ <- partSubscribe w (fitViewport (1280/720))
   _ <- partSubscribe w exitOnWindowClose
   putAffection ud

src/StateMachine.hs

@@ -23,17 +23,18 @@ instance StateMachine State UserData where
   smDraw Load = drawLoad
 
   smEvent _ evs = do
-    Subsystems w m <- subsystems <$> getAffection
-    _ <- consumeSDLEvents w =<< consumeSDLEvents m evs
+    Subsystems w m k <- subsystems <$> getAffection
+    _ <- consumeSDLEvents k =<< consumeSDLEvents w =<< consumeSDLEvents m evs
     return ()
 
   smClean _ = do
     ud <- getAffection
-    let Subsystems w m = subsystems ud
+    let Subsystems w m k = subsystems ud
         toClean          = uuid ud
     mapM_ (\u -> do
       partUnSubscribe w u
       partUnSubscribe m u
+      partUnSubscribe k u
       ) toClean
     putAffection ud
       { uuid = []

src/Test.hs

@@ -35,7 +35,7 @@ import NPC
 loadMap :: Affection UserData ()
 loadMap = do
   ud <- getAffection
-  let (Subsystems _ m) = subsystems ud
+  let (Subsystems _ m k) = subsystems ud
       ctx = nano ud
   uu <- partSubscribe m movePlayer
   future <- liftIO $ newEmptyMVar

src/Types/UserData.hs

@@ -72,10 +72,12 @@ data NPCState
 data Subsystems = Subsystems
   { subWindow   :: Window
   , subMouse    :: Mouse
+  , subkeyboard :: Keyboard
   }
 
 newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData())])
 newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection UserData ())])
+newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
 
 instance Participant Window UserData where
   type Mesg Window UserData = WindowMessage
@@ -101,6 +103,18 @@ instance Participant Mouse UserData where
 instance SDLSubsystem Mouse UserData where
   consumeSDLEvents = consumeSDLMouseEvents
 
+instance Participant Keyboard UserData where
+  type Mesg Keyboard UserData = KeyboardMessage
+
+  partSubscribers (Keyboard t) = generalSubscribers t
+
+  partSubscribe (Keyboard t) = generalSubscribe t
+
+  partUnSubscribe (Keyboard t) = generalUnSubscribe t
+
+instance SDLSubsystem Keyboard UserData where
+  consumeSDLEvents = consumeSDLKeyboardEvents
+
 generalSubscribers
   :: TVar [(UUID, msg -> Affection UserData ())]
   -> Affection UserData [(msg -> Affection UserData ())]