Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Refactor App using standalone functions #2130

Merged
merged 1 commit into from
Sep 2, 2024
Merged

Refactor App using standalone functions #2130

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
163 changes: 99 additions & 64 deletions app/game/Swarm/App.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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 ()
Expand All @@ -47,7 +56,7 @@ app eventHandler =
{ appDraw = drawUI
, appChooseCursor = chooseCursor
, appHandleEvent = eventHandler
, appStartEvent = enablePasteMode
, appStartEvent = pure ()
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why was enablePasteMode removed?

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I moved it to buildVty - I don't see why you would not want the paste mode on reinitialize, and we already have a similar mouse option set there.

When does the mode come into play? Currently, we only have a one-line REPL.

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Ah, it allows us to strip newlines and paste the whole definition into one line.

So it works with the refactor. 🙂

, appAttrMap = view $ uiState . uiAttrMap
}

Expand All @@ -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"@.
Expand All @@ -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