Load persistent state from disk only once and reuse for all integrati…

…on tests (#1383)

This seems to make a big difference --- the integration test suite now takes only about 35% as long as it used to. Fixes #1279.

src/Swarm/TUI/Model/StateUpdate.hs

@@ -5,6 +5,8 @@
 -- SPDX-License-Identifier: BSD-3-Clause
 module Swarm.TUI.Model.StateUpdate (
   initAppState,
+  initPersistentState,
+  constructAppState,
   initAppStateForScenario,
   classicGame0,
   startGame,
@@ -31,6 +33,7 @@ import Data.Time (ZonedTime, getZonedTime)
 import Swarm.Game.Achievement.Attainment
 import Swarm.Game.Achievement.Definitions
 import Swarm.Game.Achievement.Persistence
+import Swarm.Game.Failure (SystemFailure)
 import Swarm.Game.Failure.Render (prettyFailure)
 import Swarm.Game.Log (ErrorLevel (..), LogSource (ErrorTrace))
 import Swarm.Game.Scenario (loadScenario, scenarioAttrs, scenarioWorld)
@@ -58,18 +61,43 @@ import Swarm.TUI.Model.UI
 import Swarm.TUI.View.CustomStyling (toAttrPair)
 import System.Clock
 
--- | Initialize the 'AppState'.
+-- | Initialize the 'AppState' from scratch.
 initAppState :: AppOpts -> ExceptT Text IO AppState
-initAppState AppOpts {..} = do
-  let isRunningInitialProgram = isJust scriptToRun || autoPlay
-      skipMenu = isJust userScenario || isRunningInitialProgram || isJust userSeed
+initAppState opts = do
+  (rs, ui) <- initPersistentState opts
+  constructAppState rs ui opts
+
+-- | Add some system failures to the list of messages in the
+--   'RuntimeState'.
+addWarnings :: RuntimeState -> [SystemFailure] -> RuntimeState
+addWarnings = List.foldl' logWarning
+ where
+  logWarning rs' w = rs' & eventLog %~ logEvent (ErrorTrace Error) ("UI Loading", -8) (prettyFailure w)
+
+-- | Based on the command line options, should we skip displaying the
+--   menu?
+skipMenu :: AppOpts -> Bool
+skipMenu AppOpts {..} = isJust userScenario || isRunningInitialProgram || isJust userSeed
+ where
+  isRunningInitialProgram = isJust scriptToRun || autoPlay
+
+-- | Initialize the more persistent parts of the app state, /i.e./ the
+--   'RuntimeState' and 'UIState'.  This is split out into a separate
+--   function so that in the integration test suite we can call this
+--   once and reuse the resulting states for all tests.
+initPersistentState :: AppOpts -> ExceptT Text IO (RuntimeState, UIState)
+initPersistentState opts@(AppOpts {..}) = do
   (rsWarnings, initRS) <- initRuntimeState
-  let gs = initGameState (mkGameStateConfig initRS)
-  (uiWarnings, ui) <- initUIState speed (not skipMenu) (cheatMode || autoPlay)
-  let logWarning rs' w = rs' & eventLog %~ logEvent (ErrorTrace Error) ("UI Loading", -8) (prettyFailure w)
-      addWarnings = List.foldl' logWarning
-      rs = addWarnings initRS $ rsWarnings <> uiWarnings
-  case skipMenu of
+  (uiWarnings, ui) <- initUIState speed (not (skipMenu opts)) (cheatMode || autoPlay)
+  let rs = addWarnings initRS $ rsWarnings <> uiWarnings
+  return (rs, ui)
+
+-- | Construct an 'AppState' from an already-loaded 'RuntimeState' and
+--   'UIState', given the 'AppOpts' the app was started with.
+constructAppState :: RuntimeState -> UIState -> AppOpts -> ExceptT Text IO AppState
+constructAppState rs ui opts@(AppOpts {..}) = do
+  let gs = initGameState (mkGameStateConfig rs)
+  case skipMenu opts of
     False -> return $ AppState gs (ui & lgTicksPerSecond .~ defaultInitLgTicksPerSecond) rs
     True -> do
       (scenario, path) <- loadScenario (fromMaybe "classic" userScenario) (gs ^. entityMap)

test/integration/Main.hs

@@ -47,8 +47,9 @@ import Swarm.Game.State (
 import Swarm.Game.Step (gameTick)
 import Swarm.Language.Context qualified as Ctx
 import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm)
-import Swarm.TUI.Model (gameState)
-import Swarm.TUI.Model.StateUpdate (initAppStateForScenario)
+import Swarm.TUI.Model (RuntimeState, defaultAppOpts, gameState, userScenario)
+import Swarm.TUI.Model.StateUpdate (constructAppState, initPersistentState)
+import Swarm.TUI.Model.UI (UIState)
 import Swarm.Util.Yaml (decodeFileEitherE)
 import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
 import System.Environment (getEnvironment)
@@ -70,6 +71,11 @@ main = do
   scenarioPrograms <- acquire "data/scenarios" "sw"
   ci <- any (("CI" ==) . fst) <$> getEnvironment
   entities <- loadEntities
+  (rs, ui) <- do
+    out <- runExceptT $ initPersistentState defaultAppOpts
+    case out of
+      Left x -> assertFailure $ unwords ["Failure in initPersistentState:", T.unpack x]
+      Right res -> return res
   case entities of
     Left t -> fail $ "Couldn't load entities: " <> into @String t
     Right em -> do
@@ -80,7 +86,7 @@ main = do
           , exampleTests scenarioPrograms
           , scenarioParseTests em parseableScenarios
           , scenarioParseInvalidTests em unparseableScenarios
-          , testScenarioSolution ci em
+          , testScenarioSolution rs ui ci em
           , testEditorFiles
           ]
 
@@ -154,8 +160,8 @@ time = \case
 
 data ShouldCheckBadErrors = CheckForBadErrors | AllowBadErrors deriving (Eq, Show)
 
-testScenarioSolution :: Bool -> EntityMap -> TestTree
-testScenarioSolution _ci _em =
+testScenarioSolution :: RuntimeState -> UIState -> Bool -> EntityMap -> TestTree
+testScenarioSolution rs ui _ci _em =
   testGroup
     "Test scenario solutions"
     [ testGroup
@@ -171,9 +177,9 @@ testScenarioSolution _ci _em =
         , testTutorialSolution Default "Tutorials/build"
         , testTutorialSolution Default "Tutorials/bind2"
         , testTutorialSolution' Default "Tutorials/crash" CheckForBadErrors $ \g -> do
-            let rs = toList $ g ^. robotMap
+            let robots = toList $ g ^. robotMap
             let hints = any (T.isInfixOf "you will win" . view leText) . toList . view robotLog
-            let win = isJust $ find hints rs
+            let win = isJust $ find hints robots
             assertBool "Could not find a robot with winning instructions!" win
         , testTutorialSolution Default "Tutorials/scan"
         , testTutorialSolution Default "Tutorials/give"
@@ -308,9 +314,9 @@ testScenarioSolution _ci _em =
 
   testSolution' :: Time -> FilePath -> ShouldCheckBadErrors -> (GameState -> Assertion) -> TestTree
   testSolution' s p shouldCheckBadErrors verify = testCase p $ do
-    out <- runExceptT $ initAppStateForScenario p Nothing Nothing
+    out <- runExceptT $ constructAppState rs ui $ defaultAppOpts {userScenario = Just p}
     case out of
-      Left x -> assertFailure $ unwords ["Failure in initAppStateForScenario:", T.unpack x]
+      Left x -> assertFailure $ unwords ["Failure in constructAppState:", T.unpack x]
       Right (view gameState -> gs) -> case gs ^. winSolution of
         Nothing -> assertFailure "No solution to test!"
         Just sol@(ProcessedTerm _ _ reqCtx) -> do