wizard-wipeout/src-client/Client/Events.hs

module Client.Events where

import Control.Concurrent.STM (atomically, writeTQueue, flushTQueue)

import Control.Monad.IO.Class (liftIO)

import Control.Monad.RWS (asks, get)

import Graphics.Vty

-- internal imports

import Client.Communication
import Client.Types

handleEvent
  :: Event
  -> Game ()
handleEvent (EvKey KEsc _) = do
  st <- get
  curLevel <- asks rcLogLevel
  liftIO $ gracefulExit curLevel st "Quitting due to user input"
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 ()