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.Log
import Client.Types
import Library.Types

-- | Function for Handling singular input events
handleEvent
  :: Event -- A single event
  -> Game ()
handleEvent (EvKey KEsc _) = do
  st <- get
  curLevel <- asks rcLogLevel
  liftIO $ gracefulExit curLevel st "Quitting due to user input"

handleEvent (EvKey (KChar c) _) = do
  curLevel <- asks rcLogLevel
  cId <- asks rcClientUUID
  sock <- asks rcSocket
  let action = case c of
        'w' -> Just StepForward
        's' -> Just StepBackward
        'a' -> Just TurnLeft
        'd' -> Just TurnRight
        'q' -> Just StrifeLeft
        'e' -> Just StrifeRight
        _ -> Nothing
  maybe
    (logPrint Verbose $ "Unmapped input:" <> [c])
    (\act -> do
      let msg = ClientMessage
            cId
            (ClientAction act)
      liftIO $ sendMessage curLevel msg sock
    )
    action
handleEvent _ =
  pure ()

-- | Function handling the event list from the queue
handleEvents
  :: Game ()
handleEvents = do
  eventQueue <- asks rcEventQueue
  evs <- liftIO $ atomically $ flushTQueue eventQueue
  mapM_
    handleEvent
    evs

-- | Function for punping all Events from Vty into a queue
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 ()