{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -- | -- SPDX-License-Identifier: BSD-3-Clause -- -- Swarm integration tests module Main where import Control.Carrier.Lift (runM) import Control.Carrier.Throw.Either (runThrow) import Control.Lens (Ixed (ix), at, to, use, view, (&), (.~), (<>~), (^.), (^..), (^?), (^?!)) import Control.Monad (forM_, unless, when) import Control.Monad.State (StateT (runStateT), gets) import Data.Char (isSpace) import Data.Containers.ListUtils (nubOrd) import Data.Foldable (Foldable (toList), find) import Data.IntSet qualified as IS import Data.List (partition) import Data.Map qualified as M import Data.Maybe (isJust) import Data.Sequence (Seq) import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Yaml (ParseException, prettyPrintParseException) import Swarm.Doc.Gen (EditorType (..)) import Swarm.Doc.Gen qualified as DocGen import Swarm.Game.Achievement.Definitions (GameplayAchievement (..)) import Swarm.Game.CESK (emptyStore, getTickNumber, initMachine) import Swarm.Game.Entity (EntityMap, lookupByName) import Swarm.Game.Failure (SystemFailure) import Swarm.Game.Robot (activityCounts, commandsHistogram, defReqs, equippedDevices, lifetimeStepCount, machine, robotContext, robotLog, systemRobot, tangibleCommandCount, waitingUntil) import Swarm.Game.Scenario (Scenario) import Swarm.Game.State ( GameState, WinCondition (WinConditions), WinStatus (Won), activeRobots, baseRobot, discovery, gameAchievements, messageInfo, messageQueue, notificationsContent, robotMap, temporal, ticks, waitingRobots, winCondition, winSolution, ) import Swarm.Game.Step (gameTick) import Swarm.Game.World.Typecheck (WorldMap) import Swarm.Language.Context qualified as Ctx import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm) import Swarm.Language.Pretty (prettyString) import Swarm.Log import Swarm.TUI.Model ( RuntimeState, defaultAppOpts, eventLog, gameState, runtimeState, stdEntityMap, userScenario, worlds, ) import Swarm.TUI.Model.StateUpdate (constructAppState, initPersistentState) import Swarm.TUI.Model.UI (UIState) import Swarm.Util (acquireAllWithExt) import Swarm.Util.Yaml (decodeFileEitherE) import System.FilePath.Posix (splitDirectories) import System.Timeout (timeout) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) import Witch (into) isUnparseableTest :: (FilePath, String) -> Bool isUnparseableTest (fp, _) = "_Validation" `elem` splitDirectories fp main :: IO () main = do examplePaths <- acquireAllWithExt "example" "sw" scenarioPaths <- acquireAllWithExt "data/scenarios" "yaml" let (unparseableScenarios, parseableScenarios) = partition isUnparseableTest scenarioPaths scenarioPrograms <- acquireAllWithExt "data/scenarios" "sw" (rs, ui) <- do out <- runM . runThrow @SystemFailure $ initPersistentState defaultAppOpts either (assertFailure . prettyString) return out let em = rs ^. stdEntityMap let rs' = rs & eventLog .~ mempty defaultMain $ testGroup "Tests" [ testNoLoadingErrors rs , exampleTests examplePaths , exampleTests scenarioPrograms , scenarioParseTests em (rs ^. worlds) parseableScenarios , scenarioParseInvalidTests em (rs ^. worlds) unparseableScenarios , testScenarioSolutions rs' ui , testEditorFiles ] testNoLoadingErrors :: RuntimeState -> TestTree testNoLoadingErrors r = testCase "Test runtime log does not contain errors" (checkNoRuntimeErrors r) checkNoRuntimeErrors :: RuntimeState -> IO () checkNoRuntimeErrors r = forM_ (r ^. eventLog . notificationsContent) $ \e -> when (isError e) $ assertFailure $ show (e ^. leSeverity) <> " was produced during loading: " <> T.unpack (e ^. leText) isError :: LogEntry -> Bool isError = (>= Warning) . view leSeverity exampleTests :: [(FilePath, String)] -> TestTree exampleTests inputs = testGroup "Test example" (map exampleTest inputs) exampleTest :: (FilePath, String) -> TestTree exampleTest (path, fileContent) = testCase ("processTerm for contents of " ++ show path) $ do either (assertFailure . into @String) (const . return $ ()) value where value = processTerm $ into @Text fileContent scenarioParseTests :: EntityMap -> WorldMap -> [(FilePath, String)] -> TestTree scenarioParseTests em worldMap inputs = testGroup "Test scenarios parse" (map (scenarioTest Parsed em worldMap) inputs) scenarioParseInvalidTests :: EntityMap -> WorldMap -> [(FilePath, String)] -> TestTree scenarioParseInvalidTests em worldMap inputs = testGroup "Test invalid scenarios fail to parse" (map (scenarioTest Failed em worldMap) inputs) data ParseResult = Parsed | Failed scenarioTest :: ParseResult -> EntityMap -> WorldMap -> (FilePath, String) -> TestTree scenarioTest expRes em worldMap (path, _) = testCase ("parse scenario " ++ show path) (getScenario expRes em worldMap path) getScenario :: ParseResult -> EntityMap -> WorldMap -> FilePath -> IO () getScenario expRes em worldMap p = do res <- decodeFileEitherE (em, worldMap) p :: IO (Either ParseException Scenario) case expRes of Parsed -> case res of Left err -> assertFailure (prettyPrintParseException err) Right _s -> return () Failed -> case res of Left _err -> return () Right _s -> assertFailure "Unexpectedly parsed invalid scenario!" data Time = -- | One second should be enough to run most programs. Default | -- | You can specify more seconds if you need to. Sec Int | -- | If you absolutely have to, you can ignore timeout. None time :: Time -> Int time = \case Default -> 1 * sec Sec s -> s * sec None -> -1 where sec :: Int sec = 10 ^ (6 :: Int) data ShouldCheckBadErrors = CheckForBadErrors | AllowBadErrors deriving (Eq, Show) testScenarioSolutions :: RuntimeState -> UIState -> TestTree testScenarioSolutions rs ui = testGroup "Test scenario solutions" [ testGroup "Tutorial" [ testTutorialSolution Default "Tutorials/backstory" , testTutorialSolution (Sec 3) "Tutorials/move" , testTutorialSolution Default "Tutorials/craft" , testTutorialSolution Default "Tutorials/grab" , testTutorialSolution Default "Tutorials/place" , testTutorialSolution Default "Tutorials/types" , testTutorialSolution Default "Tutorials/type-errors" , testTutorialSolution Default "Tutorials/equip" , testTutorialSolution Default "Tutorials/build" , testTutorialSolution Default "Tutorials/bind2" , testTutorialSolution' Default "Tutorials/crash" CheckForBadErrors $ \g -> do let robots = toList $ g ^. robotMap let hints = any (T.isInfixOf "you will win" . view leText) . toList . view robotLog let win = isJust $ find hints robots assertBool "Could not find a robot with winning instructions!" win , testTutorialSolution Default "Tutorials/scan" , testTutorialSolution Default "Tutorials/give" , testTutorialSolution Default "Tutorials/def" , testTutorialSolution Default "Tutorials/lambda" , testTutorialSolution Default "Tutorials/require" , testTutorialSolution (Sec 3) "Tutorials/requireinv" , testTutorialSolution Default "Tutorials/conditionals" , testTutorialSolution Default "Tutorials/world101" , testTutorialSolution (Sec 5) "Tutorials/farming" ] , testGroup "Challenges" [ testSolution Default "Challenges/chess_horse" , testSolution Default "Challenges/teleport" , testSolution Default "Challenges/maypole" , testSolution (Sec 5) "Challenges/2048" , testSolution (Sec 3) "Challenges/word-search" , testSolution (Sec 10) "Challenges/bridge-building" , testSolution (Sec 5) "Challenges/ice-cream" , testSolution (Sec 10) "Challenges/combo-lock" , testSolution (Sec 15) "Challenges/wave" , testSolution (Sec 3) "Challenges/arbitrage" , testSolution (Sec 10) "Challenges/gopher" , testSolution (Sec 5) "Challenges/hackman" , testSolution (Sec 5) "Challenges/blender" , testSolution (Sec 10) "Challenges/hanoi" , testSolution (Sec 3) "Challenges/lights-out" , testSolution (Sec 10) "Challenges/Sliding Puzzles/3x3" , testSolution Default "Challenges/friend" , testGroup "Mazes" [ testSolution Default "Challenges/Mazes/easy_cave_maze" , testSolution Default "Challenges/Mazes/easy_spiral_maze" , testSolution Default "Challenges/Mazes/invisible_maze" , testSolution Default "Challenges/Mazes/loopy_maze" ] , testGroup "Ranching" [ testSolution Default "Challenges/Ranching/capture" , testSolution (Sec 10) "Challenges/Ranching/powerset" , testSolution (Sec 30) "Challenges/Ranching/gated-paddock" ] , testGroup "Sokoban" [ testSolution Default "Challenges/Sokoban/foresight.yaml" , testSolution Default "Challenges/Sokoban/Gadgets/no-reverse.yaml" , testSolution Default "Challenges/Sokoban/Gadgets/one-way.yaml" , testSolution Default "Challenges/Sokoban/Simple/trapdoor.yaml" ] , testGroup "Mechanics" [ testSolution Default "Mechanics/active-trapdoor.yaml" ] ] , testGroup "Achievements" [ testSolution' Default "Testing/Achievements/RobotIntoWater" CheckForBadErrors $ \g -> assertBool "Did not get RobotIntoWater achievement!" (isJust $ g ^? discovery . gameAchievements . at RobotIntoWater) ] , testGroup "Regression tests" [ testSolution Default "Testing/394-build-drill" , testSolution Default "Testing/373-drill" , testSolution Default "Testing/428-drowning-destroy" , testSolution' Default "Testing/475-wait-one" CheckForBadErrors $ \g -> do let t = g ^. temporal . ticks r1Waits = g ^?! robotMap . ix 1 . to waitingUntil active = IS.member 1 $ g ^. activeRobots waiting = elem 1 . concat . M.elems $ g ^. waitingRobots assertBool "The game should only take two ticks" $ getTickNumber t == 2 assertBool "Robot 1 should have waiting machine" $ isJust r1Waits assertBool "Robot 1 should be still active" active assertBool "Robot 1 should not be in waiting set" $ not waiting , testSolution Default "Testing/490-harvest" , testSolution Default "Testing/504-teleport-self" , testSolution Default "Testing/508-capability-subset" , testGroup "Possession criteria (#858)" [ testSolution Default "Testing/858-inventory/858-possession-objective" , testSolution Default "Testing/858-inventory/858-counting-objective" , testSolution Default "Testing/858-inventory/858-nonpossession-objective" ] , testGroup "Require (#201)" [ testSolution Default "Testing/201-require/201-require-device" , testSolution Default "Testing/201-require/201-require-device-creative" , testSolution Default "Testing/201-require/201-require-device-creative1" , testSolution Default "Testing/201-require/201-require-entities" , testSolution Default "Testing/201-require/201-require-entities-def" , testSolution Default "Testing/201-require/533-reprogram-simple" , testSolution Default "Testing/201-require/533-reprogram" ] , testSolution Default "Testing/479-atomic-race" , testSolution (Sec 5) "Testing/479-atomic" , testSolution Default "Testing/555-teleport-location" , testSolution (Sec 2) "Testing/562-lodestone" , testSolution Default "Testing/378-objectives" , testSolution Default "Testing/684-swap" , testSolution Default "Testing/699-movement-fail/699-move-blocked" , testSolution Default "Testing/699-movement-fail/699-move-liquid" , testSolution Default "Testing/699-movement-fail/699-teleport-blocked" , testSolution Default "Testing/710-multi-robot" , testSolution Default "Testing/920-meet" , testSolution Default "Testing/955-heading" , testSolution' Default "Testing/397-wrong-missing" CheckForBadErrors $ \g -> do let msgs = (g ^. messageInfo . messageQueue . to seqToTexts) <> (g ^.. robotMap . traverse . robotLog . to seqToTexts . traverse) assertBool "Should be some messages" (not (null msgs)) assertBool "Error messages should not mention treads" $ not (any ("treads" `T.isInfixOf`) msgs) assertBool "Error message should mention GPS receiver" $ any ("GPS receiver" `T.isInfixOf`) msgs , testSolution Default "Testing/961-custom-capabilities" , testSolution Default "Testing/956-GPS" , testSolution Default "Testing/958-isempty" , testSolution Default "Testing/1007-use-command" , testSolution Default "Testing/1024-sand" , testSolution Default "Testing/1140-detect-command" , testSolution Default "Testing/1157-drill-return-value" , testSolution Default "Testing/1171-sniff-command" , testSolution Default "Testing/1171-chirp-command" , testSolution Default "Testing/1171-resonate-command" , testSolution Default "Testing/1207-scout-command" , testSolution Default "Testing/1218-stride-command" , testSolution Default "Testing/1234-push-command" , testSolution Default "Testing/1256-halt-command" , testSolution Default "Testing/1295-density-command" , testSolution Default "Testing/1356-portals/portals-flip-and-rotate" , testSolution Default "Testing/144-subworlds/basic-subworld" , testSolution Default "Testing/144-subworlds/subworld-mapped-robots" , testSolution Default "Testing/144-subworlds/subworld-located-robots" , testSolution Default "Testing/1355-combustion" , testSolution Default "Testing/1379-single-world-portal-reorientation" , testSolution Default "Testing/1399-backup-command" , testSolution Default "Testing/1536-custom-unwalkable-entities" , testGroup -- Note that the description of the classic world in -- data/worlds/classic.yaml (automatically tested to some -- extent by the solution to Tutorial/world101 and -- Tutorial/farming) also constitutes a fairly -- comprehensive test of world DSL features. "World DSL (#1320)" [ testSolution Default "Testing/1320-world-DSL/constant" , testSolution Default "Testing/1320-world-DSL/erase" , testSolution Default "Testing/1320-world-DSL/override" ] , testGroup "Pathfinding (#836)" [ testSolution Default "Testing/836-pathfinding/836-path-exists-find-entity" , testSolution Default "Testing/836-pathfinding/836-path-exists-find-location" , testSolution Default "Testing/836-pathfinding/836-path-exists-find-entity-unwalkable" , testSolution Default "Testing/836-pathfinding/836-path-exists-distance-limit-unreachable" , testSolution Default "Testing/836-pathfinding/836-path-exists-distance-limit-unreachable" , testSolution Default "Testing/836-pathfinding/836-no-path-exists1" , testSolution (Sec 10) "Testing/836-pathfinding/836-no-path-exists2" , testSolution (Sec 3) "Testing/836-pathfinding/836-automatic-waypoint-navigation.yaml" ] , testGroup "Ping (#1535)" [ testSolution Default "Testing/1535-ping/1535-in-range" , testSolution Default "Testing/1535-ping/1535-out-of-range" ] ] , testSolution' Default "Testing/1430-built-robot-ownership" CheckForBadErrors $ \g -> do let r2 = g ^. robotMap . at 2 let r3 = g ^. robotMap . at 3 assertBool "The second built robot should be a system robot like it's parent." $ maybe False (view systemRobot) r2 assertBool "The third built robot should be a normal robot like base." $ maybe False (not . view systemRobot) r3 , testSolution' Default "Testing/1341-command-count" CheckForBadErrors $ \g -> case g ^. robotMap . at 0 of Nothing -> assertFailure "No base bot!" Just base -> do let counters = base ^. activityCounts -- NOTE: The values of 7 and 10 for "tangible" and "total" command counts -- make sense from the test program and match the F2 screen upon winning the scenario. -- However, the F2 dialog actually shows 64 for the step count. This test was -- hardcoded to 62 just to make it pass. assertEqual "Incorrect tangible command count." 7 $ view tangibleCommandCount counters assertEqual "Incorrect command count." 10 $ sum . M.elems $ view commandsHistogram counters assertEqual "Incorrect step count." 62 $ view lifetimeStepCount counters ] where -- expectFailIf :: Bool -> String -> TestTree -> TestTree -- expectFailIf b = if b then expectFailBecause else (\_ x -> x) testSolution :: Time -> FilePath -> TestTree testSolution s p = testSolution' s p CheckForBadErrors (const $ pure ()) testSolution' :: Time -> FilePath -> ShouldCheckBadErrors -> (GameState -> Assertion) -> TestTree testSolution' s p shouldCheckBadErrors verify = testCase p $ do out <- runM . runThrow @SystemFailure $ constructAppState rs ui $ defaultAppOpts {userScenario = Just p} case out of Left err -> assertFailure $ prettyString err Right appState -> case appState ^. gameState . winSolution of Nothing -> assertFailure "No solution to test!" Just sol@(ProcessedTerm _ _ reqCtx) -> do when (shouldCheckBadErrors == CheckForBadErrors) (checkNoRuntimeErrors $ appState ^. runtimeState) let gs' = (appState ^. gameState) -- See #827 for an explanation of why it's important to add to -- the robotContext defReqs here (and also why this will, -- hopefully, eventually, go away). & baseRobot . robotContext . defReqs <>~ reqCtx & baseRobot . machine .~ initMachine sol Ctx.empty emptyStore m <- timeout (time s) (snd <$> runStateT playUntilWin gs') case m of Nothing -> assertFailure "Timed out - this likely means that the solution did not work." Just g -> do -- When debugging, try logging all robot messages. -- printAllLogs when (shouldCheckBadErrors == CheckForBadErrors) $ noBadErrors g verify g tutorialHasLog :: GameState -> Assertion tutorialHasLog gs = let baseDevs = gs ^?! baseRobot . equippedDevices in assertBool "Base should have a logger installed!" (not . null $ lookupByName "logger" baseDevs) testTutorialSolution t f = testSolution' t f CheckForBadErrors tutorialHasLog testTutorialSolution' t f s v = testSolution' t f s $ \g -> tutorialHasLog g >> v g playUntilWin :: StateT GameState IO () playUntilWin = do w <- use winCondition b <- gets badErrorsInLogs when (null b) $ case w of WinConditions (Won _) _ -> return () _ -> gameTick >> playUntilWin noBadErrors :: GameState -> Assertion noBadErrors g = do let bad = badErrorsInLogs g unless (null bad) (assertFailure . T.unpack . T.unlines . take 5 $ nubOrd bad) badErrorsInLogs :: GameState -> [Text] badErrorsInLogs g = concatMap (\r -> filter isBad (seqToTexts $ r ^. robotLog)) (g ^. robotMap) <> filter isBad (seqToTexts $ g ^. messageInfo . messageQueue) where isBad m = "Fatal error:" `T.isInfixOf` m || "swarm/issues" `T.isInfixOf` m seqToTexts :: Seq LogEntry -> [Text] seqToTexts = map (view leText) . toList printAllLogs :: GameState -> IO () printAllLogs g = mapM_ (\r -> forM_ (r ^. robotLog) (putStrLn . T.unpack . view leText)) (g ^. robotMap) -- | Test that editor files are up-to-date. testEditorFiles :: TestTree testEditorFiles = testGroup "editors" [ testGroup "VS Code" [ testTextInVSCode "operators" (const DocGen.operatorNames) , testTextInVSCode "builtin" DocGen.builtinFunctionList , testTextInVSCode "commands" DocGen.keywordsCommands , testTextInVSCode "directions" DocGen.keywordsDirections ] , testGroup "Emacs" [ testTextInEmacs "builtin" DocGen.builtinFunctionList , testTextInEmacs "commands" DocGen.keywordsCommands , testTextInEmacs "directions" DocGen.keywordsDirections ] , testGroup "Vim" [ testTextInVim "builtin" DocGen.builtinFunctionList , testTextInVim "commands" DocGen.keywordsCommands , testTextInVim "directions" DocGen.keywordsDirections ] ] where testTextInVSCode name tf = testTextInFile False name (tf VSCode) "editors/vscode/syntaxes/swarm.tmLanguage.json" testTextInEmacs name tf = testTextInFile True name (tf Emacs) "editors/emacs/swarm-mode.el" testTextInVim name tf = testTextInFile True name (tf Vim) "editors/vim/swarm.vim" testTextInFile :: Bool -> String -> Text -> FilePath -> TestTree testTextInFile whitespace name t fp = testCase name $ do let removeLW' = T.unlines . map (T.dropWhile isSpace) . T.lines removeLW = if whitespace then removeLW' else id f <- T.readFile fp assertBool ( "EDITOR FILE IS NOT UP TO DATE!\n" <> "I could not find the text:\n" <> T.unpack t <> "\nin file " <> fp ) (removeLW t `T.isInfixOf` removeLW f)