handle first Vty event: quit on escape key

src-client/Client/Communication.hs

@@ -55,13 +55,10 @@ sendMessage msg sock = do
 handleMessages
   :: Game ()
 handleMessages = do
-  queue <- asks rcQueue
+  queue <- asks rcMessageQueue
   msgs <- liftIO $ STM.atomically $ STM.flushTQueue queue
   mapM_
-    (\msg -> do
+    handleMessage
-      -- liftIO $ putStrLn $ "Handling following: " <> show msg
-      handleMessage msg
-    )
     msgs
 
 handleMessage

src-client/Client/Events.hs

@@ -0,0 +1,46 @@
+module Client.Events where
+
+import Control.Concurrent.STM (atomically, writeTQueue, flushTQueue)
+
+import Control.Monad.IO.Class (liftIO)
+
+import Control.Monad.RWS (asks, gets)
+
+import Data.IORef (modifyIORef')
+
+import Graphics.Vty
+
+-- internal imports
+
+import Client.Types
+
+handleEvent
+  :: Event
+  -> Game ()
+handleEvent (EvKey KEsc _) = do
+  stopper <- gets scStopper
+  liftIO $ modifyIORef' stopper (const True)
+handleEvent _ =
+  pure ()
+
+handleEvents
+  :: Game ()
+handleEvents = do
+  eventQueue <- asks rcEventQueue
+  evs <- liftIO $ atomically $ flushTQueue eventQueue
+  mapM_
+    handleEvent
+    evs
+
+pumpEvents
+        :: Vty
+  -> Game ()
+pumpEvents vty = do
+  eventQueue <- asks rcEventQueue
+  mev <- liftIO $ nextEventNonblocking vty
+  case mev of
+    Just ev -> do
+      liftIO $ atomically $ writeTQueue eventQueue ev
+      pumpEvents vty
+    Nothing ->
+      return ()

src-client/Client/Game.hs

@@ -1,16 +1,19 @@
 module Client.Game where
 
+import Control.Concurrent.STM (atomically, readTMVar)
+
+import Control.Monad.IO.Class (liftIO)
+
 import Control.Monad.Loops
 
 import Control.Monad.RWS
 
 import Data.IORef (readIORef)
 
-import Graphics.Vty
-
 -- internal imports
 
 import Client.Communication
+import Client.Events
 import Client.Graphics
 import Client.Types
 
@@ -20,22 +23,18 @@ runGame
   :: Game ()
 runGame = do
   sock <- asks rcSocket
-  queue <- asks rcQueue
+  messageQueue <- asks rcMessageQueue
   clientId <- asks rcClientUUID
   st <- get
+  vty <- clientVty <$> liftIO (atomically $ readTMVar (scClientState st))
   liftIO $ sendMessage (ClientMessage clientId ClientReady) sock
   whileM_
     (liftIO (not <$> readIORef (scStopper st)))
     (do
-      liftIO $ receiveMessage sock queue st
+      liftIO $ receiveMessage sock messageQueue st
       handleMessages
+      pumpEvents vty
+      handleEvents
       draw
     )
-
+  liftIO $ sendMessage (ClientMessage clientId ClientQuit) sock
-handleEvent
-  :: Maybe Event
-  -> Game ()
-handleEvent Nothing =
-  pure ()
-handleEvent (Just event) =
-  pure ()

src-client/Client/Types.hs

@@ -10,6 +10,8 @@ import Data.IORef (IORef)
 
 import Data.UUID
 
+import Graphics.Vty
+
 import Network.Socket
 
 import Options.Applicative as O
@@ -32,7 +34,8 @@ options = Options
 data ReaderContainer = ReaderContainer
   { rcSocket       :: Socket
   , rcClientUUID   :: UUID
-  , rcQueue      :: STM.TQueue ServerMessage
+  , rcMessageQueue :: STM.TQueue ServerMessage
+  , rcEventQueue   :: STM.TQueue Event
   }
 
 data StateContainer = StateContainer

src-client/Main.hs

@@ -34,16 +34,17 @@ main = do
   putStrLn "connected"
 
 
-  queue <- STM.newTQueueIO
+  messageQueue <- STM.newTQueueIO
+  eventQueue <- STM.newTQueueIO
 
 
   -- threadDelay $ 1 * 10 ^ 6
   mockClientState <- STM.newTMVarIO (ClientState undefined False)
   let mockState = StateContainer undefined mockClientState undefined undefined
   sendMessage IdRequest sock
-  receiveMessage sock queue mockState
+  receiveMessage sock messageQueue mockState
-  awaitResponse queue 1
+  awaitResponse messageQueue 1
-  clientIdMsg <- head <$> STM.atomically (STM.flushTQueue queue)
+  clientIdMsg <- head <$> STM.atomically (STM.flushTQueue messageQueue)
   let clientId = acClientUUID clientIdMsg
   putStrLn $ "received client UUID: " <> show clientId
 
@@ -54,9 +55,9 @@ main = do
 
   sendMessage (ClientMessage clientId ClientRequestWizard) sock
   -- threadDelay $ 1 * 10 ^ 6
-  receiveMessage sock queue mockState
+  receiveMessage sock messageQueue mockState
-  awaitResponse queue 1
+  awaitResponse messageQueue 1
-  playerWizard <- head <$> STM.atomically (STM.flushTQueue queue)
+  playerWizard <- head <$> STM.atomically (STM.flushTQueue messageQueue)
   putStrLn $ "received wizard: " <> show (initWizard playerWizard)
 
   vty <- mkVty defaultConfig
@@ -68,7 +69,7 @@ main = do
   stopper <- newIORef False
   clientState <- STM.newTMVarIO (ClientState vty False)
   let initSlice = MapSlice (M.matrix 9 9 (const Nothing)) []
-  let initRead = ReaderContainer sock clientId queue
+  let initRead = ReaderContainer sock clientId messageQueue eventQueue
       initState = StateContainer (initWizard playerWizard) clientState initSlice stopper
   -- putStrLn "sending quit message"
   -- sendMessage (ClientMessage clientId ClientQuit) sock
@@ -112,10 +113,10 @@ awaitResponse
   -> Int
   -> IO ()
 awaitResponse _ 10 = error "Tries to communicate with server exceeded"
-awaitResponse queue numTries = do
+awaitResponse messageQueue numTries = do
-  responsePresent <- not <$> STM.atomically (STM.isEmptyTQueue queue)
+  responsePresent <- not <$> STM.atomically (STM.isEmptyTQueue messageQueue)
   if responsePresent
   then pure ()
   else do
     threadDelay $ 10 ^ 6
-    awaitResponse queue (succ numTries)
+    awaitResponse messageQueue (succ numTries)

wizard-wipeout.cabal

@@ -37,6 +37,7 @@ executable wizard-wipeout-client
     import:           warnings
     main-is:          Main.hs
     other-modules:    Client.Communication
+                      Client.Events
                       Client.Game
                       Client.Graphics
                       Client.Types