From d8bd783b480ca60d05f62a6d1a797aef86c64672 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 1 Sep 2024 12:12:48 +0200 Subject: [PATCH] Refactor App using standalone functions * Make `appMain` fit on screen. * Replace state `s1` and `s2` versions with `modifyIORef`. --- app/game/Swarm/App.hs | 163 +++++++++++++++++++++++++----------------- 1 file changed, 99 insertions(+), 64 deletions(-) diff --git a/app/game/Swarm/App.hs b/app/game/Swarm/App.hs index 558c529d9..ad4b4974c 100644 --- a/app/game/Swarm/App.hs +++ b/app/game/Swarm/App.hs @@ -9,19 +9,27 @@ -- Description: Application entry point -- -- Main entry point for the Swarm application. -module Swarm.App where +module Swarm.App ( + app, + appMain, + EventHandler, + + -- * Demo web + demoWeb, +) where import Brick import Brick.BChan import Control.Carrier.Lift (runM) import Control.Carrier.Throw.Either (runThrow) import Control.Concurrent (forkIO, threadDelay) -import Control.Lens (view, (%~), (&), (?~)) +import Control.Lens (view, (%~), (?~)) import Control.Monad (forever, void, when) import Control.Monad.IO.Class (liftIO) -import Data.IORef (newIORef, readIORef, writeIORef) +import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef) import Data.Text qualified as T import Data.Text.IO qualified as T +import GitHash (GitInfo) import Graphics.Vty qualified as V import Graphics.Vty.CrossPlatform qualified as V import Swarm.Game.Failure (SystemFailure) @@ -35,6 +43,7 @@ import Swarm.TUI.Model.UI (uiAttrMap) import Swarm.TUI.View import Swarm.Version (getNewerReleaseVersion) import Swarm.Web +import System.Exit import System.IO (stderr) type EventHandler = BrickEvent Name AppEvent -> EventM Name AppState () @@ -47,7 +56,7 @@ app eventHandler = { appDraw = drawUI , appChooseCursor = chooseCursor , appHandleEvent = eventHandler - , appStartEvent = enablePasteMode + , appStartEvent = pure () , appAttrMap = view $ uiState . uiAttrMap } @@ -57,69 +66,37 @@ appMain :: AppOpts -> IO () appMain opts = do res <- runM . runThrow $ initAppState opts case res of - Left err -> T.hPutStrLn stderr (prettyText @SystemFailure err) + Left err -> do + T.hPutStrLn stderr (prettyText @SystemFailure err) + exitFailure Right s -> do - -- Send Frame events as at a reasonable rate for 30 fps. The - -- game is responsible for figuring out how many steps to take - -- each frame to achieve the desired speed, regardless of the - -- frame rate. Note that if the game cannot keep up with 30 - -- fps, it's not a problem: the channel will fill up and this - -- thread will block. So the force of the threadDelay is just - -- to set a *maximum* possible frame rate. - -- - -- 5 is the size of the bounded channel; when it gets that big, - -- any writes to it will block. Probably 1 would work fine, - -- though it seems like it could be good to have a bit of buffer - -- just so the app never has to wait for the thread to wake up - -- and do another write. - - chan <- newBChan 5 - _ <- forkIO $ - forever $ do - writeBChan chan Frame - threadDelay 33_333 -- cap maximum framerate at 30 FPS - _ <- forkIO $ do - upRel <- getNewerReleaseVersion (repoGitInfo opts) - writeBChan chan (UpstreamVersion upRel) - - -- Start the web service with a reference to the game state. - -- NOTE: This reference should be considered read-only by - -- the web service; the game alone shall host the canonical state. + -- NOTE: The state reference is read-only by the web service; + -- the brick app has the real state and updates the reference. appStateRef <- newIORef s + chan <- createChannel + sendFrameEvents chan + sendUpstreamVersion chan (repoGitInfo opts) + -- Start web service eport <- Swarm.Web.startWebThread (userWebPort opts) (readIORef appStateRef) (writeBChan chan) - let logP p = logEvent SystemLog Info "Web API" ("started on :" <> T.pack (show p)) - let logE e = logEvent SystemLog Error "Web API" (T.pack e) - let s1 = - s - & runtimeState - %~ case eport of - Right p -> (webPort ?~ p) . (eventLog %~ logP p) - Left e -> eventLog %~ logE e - - -- Update the reference for every event - let eventHandler e = do - curSt <- get - liftIO $ writeIORef appStateRef curSt - handleEvent e + modifyIORef appStateRef $ logWebPort eport -- Setup virtual terminal - let buildVty = V.mkVty V.defaultConfig {V.configPreferredColorMode = colorMode opts} - vty <- buildVty - - V.setMode (V.outputIface vty) V.Mouse True - - let cm = V.outputColorMode $ V.outputIface vty - let s2 = - s1 - & runtimeState . eventLog %~ logEvent SystemLog Info "Graphics" ("Color mode: " <> T.pack (show cm)) + vty <- buildVty $ colorMode opts + modifyIORef appStateRef $ logColorMode vty -- Run the app. - void $ customMain vty buildVty (Just chan) (app eventHandler) s2 + void $ + readIORef appStateRef + >>= customMain + vty + (buildVty $ colorMode opts) + (Just chan) + (app $ handleEventAndUpdateWeb appStateRef) -- | A demo program to run the web service directly, without the terminal application. -- This is useful to live update the code using @ghcid -W --test "Swarm.App.demoWeb"@. @@ -131,21 +108,79 @@ demoWeb = do case res of Left err -> T.putStrLn (prettyText @SystemFailure err) Right s -> do - appStateRef <- newIORef s - chan <- newBChan 5 + chan <- createChannel webMain Nothing demoPort - (readIORef appStateRef) + (pure s) (writeBChan chan) where demoScenario = Just "./data/scenarios/Testing/475-wait-one.yaml" --- | If available for the terminal emulator, enable bracketed paste mode. -enablePasteMode :: EventM n s () -enablePasteMode = do - vty <- getVtyHandle +-- | Create a channel for app events. +-- +-- 5 is the size of the bounded channel; when it gets that big, +-- any writes to it will block. Probably 1 would work fine, +-- though it seems like it could be good to have a bit of buffer +-- just so the app never has to wait for the thread to wake up +-- and do another write. +-- +-- Note that there are occasionally other events (web, version) +-- so this buffer is big enough for them too. +createChannel :: IO (BChan AppEvent) +createChannel = newBChan 5 + +-- | Send Frame events as at a reasonable rate for 30 fps. +-- +-- The game is responsible for figuring out how many steps to take +-- each frame to achieve the desired speed, regardless of the +-- frame rate. Note that if the game cannot keep up with 30 +-- fps, it's not a problem: the channel will fill up and this +-- thread will block. So the force of the threadDelay is just +-- to set a *maximum* possible frame rate. +sendFrameEvents :: BChan AppEvent -> IO () +sendFrameEvents chan = void . forkIO . forever $ do + writeBChan chan Frame + threadDelay 33_333 -- cap maximum framerate at 30 FPS + +-- | Get newer upstream version and send event to channel. +sendUpstreamVersion :: BChan AppEvent -> Maybe GitInfo -> IO () +sendUpstreamVersion chan gitInfo = void . forkIO $ do + upRel <- getNewerReleaseVersion gitInfo + writeBChan chan (UpstreamVersion upRel) + +-- | Log and save the web port or log web startup failure. +logWebPort :: Either String Int -> AppState -> AppState +logWebPort eport = + runtimeState %~ case eport of + Right p -> (webPort ?~ p) . (eventLog %~ logP p) + Left e -> eventLog %~ logE e + where + logP p = logEvent SystemLog Info "Web API" ("started on :" <> T.pack (show p)) + logE e = logEvent SystemLog Error "Web API" (T.pack e) + +-- | Build VTY with preffered color mode and bracketed paste mode if available. +-- +-- Note that this will also run whenever the event loop needs to reinitialize +-- the terminal, e.g. on resume after suspension. See 'customMain'. +buildVty :: Maybe ColorMode -> IO V.Vty +buildVty cm = do + vty <- V.mkVty V.defaultConfig {V.configPreferredColorMode = cm} let output = V.outputIface vty + V.setMode output V.Mouse True when (V.supportsMode output V.BracketedPaste) $ - liftIO $ - V.setMode output V.BracketedPaste True + V.setMode output V.BracketedPaste True + return vty + +-- | Log the VTY color mode to system log. +logColorMode :: V.Vty -> AppState -> AppState +logColorMode vty = runtimeState . eventLog %~ logEvent SystemLog Info "Graphics" ("Color mode: " <> T.pack (show cm)) + where + cm = V.outputColorMode $ V.outputIface vty + +-- | Update the reference after every event. +handleEventAndUpdateWeb :: IORef AppState -> BrickEvent Name AppEvent -> EventM Name AppState () +handleEventAndUpdateWeb appStateRef e = do + handleEvent e + curSt <- get + liftIO $ writeIORef appStateRef curSt