diff --git a/src/swarm-engine/Swarm/Game/Step/Validate.hs b/src/swarm-engine/Swarm/Game/Step/Validate.hs new file mode 100644 index 000000000..8217391af --- /dev/null +++ b/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 diff --git a/src/swarm-engine/Swarm/Log.hs b/src/swarm-engine/Swarm/Log.hs index 276c898a7..b02da0277 100644 --- a/src/swarm-engine/Swarm/Log.hs +++ b/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 diff --git a/src/swarm-tournament/Swarm/Web/Tournament/Validate.hs b/src/swarm-tournament/Swarm/Web/Tournament/Validate.hs index 823f9b49c..aa75b5667 100644 --- a/src/swarm-tournament/Swarm/Web/Tournament/Validate.hs +++ b/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 diff --git a/swarm.cabal b/swarm.cabal index 76255114a..73734c968 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -337,6 +337,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 @@ -657,6 +658,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, @@ -935,10 +937,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 diff --git a/test/integration/Main.hs b/test/integration/Main.hs index 0a671e9d2..2bab6d6fe 100644 --- a/test/integration/Main.hs +++ b/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" $