Merge branch 'main' into refactor/structure-assembly

src/swarm-engine/Swarm/Game/Step/Validate.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+-- Description: Validation of gameplay.
+--
+-- Facilities for running a game state until completion, checking for
+-- any errors encountered.  This is not used for normal gameplay but
+-- can be used by /e.g./ integration tests.
+module Swarm.Game.Step.Validate where
+
+import Control.Lens (use, (^.))
+import Control.Monad.State (StateT, gets)
+import Data.List.NonEmpty qualified as NE
+import Data.Text qualified as T
+import Swarm.Effect.Time (runTimeIO)
+import Swarm.Game.Robot.Concrete (robotLog)
+import Swarm.Game.State (GameState, messageInfo, robotInfo, winCondition)
+import Swarm.Game.State.Robot (robotMap)
+import Swarm.Game.State.Substate (WinCondition (..), WinStatus (..), messageQueue)
+import Swarm.Game.Step (gameTick)
+import Swarm.Game.Tick (TickNumber)
+import Swarm.Log (logToText)
+
+-- | Keep stepping a 'GameState' until completion, returning the
+--   number of ticks taken if successful, or any bad error messages
+--   encountered.
+playUntilWin :: StateT GameState IO (Either (NE.NonEmpty T.Text) TickNumber)
+playUntilWin = do
+  w <- use winCondition
+  b <- gets badErrorsInLogs
+  case NE.nonEmpty b of
+    Just badErrs -> return $ Left badErrs
+    Nothing -> case w of
+      WinConditions (Won _ ts) _ -> return $ Right ts
+      _ -> runTimeIO gameTick >> playUntilWin
+
+-- | Extract any bad error messages from robot logs or the global
+--   message queue, where "bad" errors are either fatal errors or
+--   ones referring to issues in the issue tracker.
+badErrorsInLogs :: GameState -> [T.Text]
+badErrorsInLogs g =
+  concatMap
+    (\r -> filter isBad (logToText $ r ^. robotLog))
+    (g ^. robotInfo . robotMap)
+    <> filter isBad (logToText $ g ^. messageInfo . messageQueue)
+ where
+  isBad m = "Fatal error:" `T.isInfixOf` m || "swarm/issues" `T.isInfixOf` m

src/swarm-engine/Swarm/Log.hs

@@ -7,6 +7,7 @@
 -- A data type to represent log messages, both for robot logs and
 -- the system log.
 module Swarm.Log (
+  -- * Log entries
   Severity (..),
   RobotLogSource (..),
   LogSource (..),
@@ -16,10 +17,14 @@ module Swarm.Log (
   leSeverity,
   leName,
   leText,
+
+  -- * Utilities
+  logToText,
 ) where
 
-import Control.Lens (makeLenses)
+import Control.Lens (makeLenses, view)
 import Data.Aeson (FromJSON, ToJSON)
+import Data.Foldable (toList)
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Swarm.Game.Location (Location)
@@ -68,3 +73,7 @@ data LogEntry = LogEntry
   deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
 
 makeLenses ''LogEntry
+
+-- | Extract the text from a container of log entries.
+logToText :: Foldable t => t LogEntry -> [Text]
+logToText = map (view leText) . toList

src/swarm-tournament/Swarm/Web/Tournament/Validate.hs

@@ -13,41 +13,29 @@ import Control.Carrier.Throw.Either (runThrow)
 import Control.Lens
 import Control.Monad (unless)
 import Control.Monad.IO.Class (liftIO)
-import Control.Monad.State (StateT, evalStateT, gets)
+import Control.Monad.State (evalStateT)
 import Control.Monad.Trans.Except
 import Data.ByteString.Lazy qualified as LBS
 import Data.Either.Extra (maybeToEither)
-import Data.Foldable (Foldable (toList))
-import Data.List.NonEmpty qualified as NE
 import Data.Sequence (Seq)
 import Data.Text qualified as T
 import Data.Text.Encoding (decodeUtf8')
 import Data.Yaml (decodeEither', parseEither)
 import Servant.Multipart
-import Swarm.Effect (runTimeIO)
 import Swarm.Game.CESK (emptyStore, initMachine)
 import Swarm.Game.Failure (SystemFailure)
-import Swarm.Game.Robot.Concrete (machine, robotContext, robotLog)
+import Swarm.Game.Robot.Concrete (machine, robotContext)
 import Swarm.Game.Robot.Context (defReqs)
 import Swarm.Game.Scenario
 import Swarm.Game.Scenario.Scoring.CodeSize (codeMetricsFromSyntax)
 import Swarm.Game.Scenario.Status (emptyLaunchParams)
 import Swarm.Game.State
-import Swarm.Game.State.Robot (robotMap)
 import Swarm.Game.State.Runtime (initGameStateConfig, initScenarioInputs)
-import Swarm.Game.State.Substate (
-  WinCondition (WinConditions),
-  WinStatus (Won),
-  initState,
-  messageQueue,
-  seed,
- )
-import Swarm.Game.Step (gameTick)
-import Swarm.Game.Tick (TickNumber)
+import Swarm.Game.State.Substate (initState, seed)
+import Swarm.Game.Step.Validate (playUntilWin)
 import Swarm.Language.Context qualified as Ctx
 import Swarm.Language.Module (Module (..))
 import Swarm.Language.Pipeline (ProcessedTerm (..), processTermEither)
-import Swarm.Log
 import Swarm.Util.Yaml
 import Swarm.Web.Tournament.Database.Query
 import Swarm.Web.Tournament.Type
@@ -231,27 +219,3 @@ verifySolution (SolutionTimeout timeoutSeconds) sol gs = do
       -- hopefully, eventually, go away).
       & baseRobot . robotContext . defReqs <>~ reqCtx
       & baseRobot . machine .~ initMachine sol Ctx.empty emptyStore
-
--- ** Utils shared with integration tests
-
-playUntilWin :: StateT GameState IO (Either (NE.NonEmpty T.Text) TickNumber)
-playUntilWin = do
-  w <- use winCondition
-  b <- gets badErrorsInLogs
-  case NE.nonEmpty b of
-    Just badErrs -> return $ Left badErrs
-    Nothing -> case w of
-      WinConditions (Won _ ts) _ -> return $ Right ts
-      _ -> runTimeIO gameTick >> playUntilWin
-
-badErrorsInLogs :: GameState -> [T.Text]
-badErrorsInLogs g =
-  concatMap
-    (\r -> filter isBad (seqToTexts $ r ^. robotLog))
-    (g ^. robotInfo . robotMap)
-    <> filter isBad (seqToTexts $ g ^. messageInfo . messageQueue)
- where
-  isBad m = "Fatal error:" `T.isInfixOf` m || "swarm/issues" `T.isInfixOf` m
-
-seqToTexts :: Seq LogEntry -> [T.Text]
-seqToTexts = map (view leText) . toList

swarm.cabal

@@ -338,6 +338,7 @@ library swarm-engine
     Swarm.Game.Step.Util
     Swarm.Game.Step.Util.Command
     Swarm.Game.Step.Util.Inspect
+    Swarm.Game.Step.Validate
     Swarm.Game.Tick
     Swarm.Game.Value
     Swarm.Log
@@ -658,6 +659,7 @@ library
     Swarm.Game.Step.Util,
     Swarm.Game.Step.Util.Command,
     Swarm.Game.Step.Util.Inspect,
+    Swarm.Game.Step.Validate,
     Swarm.Game.Terrain,
     Swarm.Game.Tick,
     Swarm.Game.Universe,
@@ -936,10 +938,7 @@ test-suite swarm-integration
     witch,
     yaml,
 
-  build-depends:
-    swarm,
-    swarm:swarm-tournament,
-
+  build-depends: swarm
   hs-source-dirs: test/integration
   default-language: Haskell2010
   ghc-options: -threaded

test/integration/Main.hs

@@ -64,6 +64,7 @@ import Swarm.Game.State.Substate (
   ticks,
  )
 import Swarm.Game.Step.Path.Type
+import Swarm.Game.Step.Validate (badErrorsInLogs, playUntilWin)
 import Swarm.Game.Tick (getTickNumber)
 import Swarm.Language.Context qualified as Ctx
 import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm)
@@ -80,7 +81,6 @@ import Swarm.TUI.Model.UI (UIState)
 import Swarm.Util (acquireAllWithExt)
 import Swarm.Util.RingBuffer qualified as RB
 import Swarm.Util.Yaml (decodeFileEitherE)
-import Swarm.Web.Tournament.Validate
 import System.FilePath.Posix (splitDirectories)
 import System.Timeout (timeout)
 import Test.Tasty (TestTree, defaultMain, testGroup)
@@ -325,8 +325,8 @@ testScenarioSolutions rs ui =
         , testSolution Default "Testing/955-heading"
         , testSolution' Default "Testing/397-wrong-missing" CheckForBadErrors $ \g -> do
             let msgs =
-                  (g ^. messageInfo . messageQueue . to seqToTexts)
-                    <> (g ^.. robotInfo . robotMap . traverse . robotLog . to seqToTexts . traverse)
+                  (g ^. messageInfo . messageQueue . to logToText)
+                    <> (g ^.. robotInfo . robotMap . traverse . robotLog . to logToText . traverse)
 
             assertBool "Should be some messages" (not (null msgs))
             assertBool "Error messages should not mention treads" $