47 lines
881 B
Haskell
47 lines
881 B
Haskell
|
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 ()
|