From 589e2665b5005578a53f140fb27d0b5c991b22fe Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?=
 <44544735+xsebek@users.noreply.github.com>
Date: Mon, 2 Sep 2024 17:39:42 +0200
Subject: [PATCH] Refactor App using standalone functions (#2130)

* Make `appMain` fit on the 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 558c529d..ad4b4974 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