Add test per recipe

swarm-game · Jul 13, 2024 · cf7eaa1 · cf7eaa1
1 parent 804dd08
commit cf7eaa1
Show file tree

Hide file tree

Showing 2 changed files with 52 additions and 23 deletions.
diff --git a/test/integration/Main.hs b/test/integration/Main.hs
@@ -102,6 +102,7 @@ main = do
     either (assertFailure . prettyString) return out
   let scenarioInputs = gsiScenarioInputs $ initState $ rs ^. stdGameConfigInputs
       rs' = rs & eventLog .~ mempty
+  recipeTests <- testRecipeCoverage
   defaultMain $
     testGroup
       "Tests"
@@ -112,7 +113,7 @@ main = do
       , scenarioParseInvalidTests scenarioInputs unparseableScenarios
       , testScenarioSolutions rs' ui key
       , testEditorFiles
-      , testRecipeCoverage
+      , recipeTests
       ]
 
 testNoLoadingErrors :: RuntimeState -> TestTree

diff --git a/test/integration/TestRecipeCoverage.hs b/test/integration/TestRecipeCoverage.hs
@@ -4,36 +4,64 @@
 -- SPDX-License-Identifier: BSD-3-Clause
 --
 -- Ensure recipe coverage for all entities.
-module TestRecipeCoverage where
+module TestRecipeCoverage (testRecipeCoverage) where
 
 import Control.Lens (view)
-import Data.Function ((&))
-import Data.List (intercalate, sort)
+import Data.Function (applyWhen)
+import Data.List qualified as List
 import Data.Set qualified as Set
 import Data.Text qualified as T
 import Swarm.Doc.Gen
-import Swarm.Game.Entity (entityName)
+import Swarm.Game.Entity (Entity, EntityName, entityName)
+import Swarm.Util (quote)
 import Test.Tasty
 import Test.Tasty.ExpectedFailure (expectFailBecause)
 import Test.Tasty.HUnit
 
-testRecipeCoverage :: TestTree
-testRecipeCoverage =
-  expectFailBecause "Need to come up with more recipes" checkCoverage
+testRecipeCoverage :: IO TestTree
+testRecipeCoverage = do
+  graphData <- classicScenarioRecipeGraphData
+  let sortE = List.sortOn (T.unpack . view entityName)
+      allEntities = sortE . Set.toList $ rgAllEntities graphData
+      nonCovered = getNonCoveredEntities graphData
+  return . testGroup "Ensure all devices have recipes" $
+    map (\e -> expectNonCovered e $ checkCoverage nonCovered e) allEntities
  where
-  checkCoverage :: TestTree
-  checkCoverage =
-    testCase "Ensure all devices have recipes (#1268)" $ do
-      graphData <- classicScenarioRecipeGraphData
-      let nonCoveredEntities =
-            Set.unions (rgLevels graphData)
-              & Set.difference (rgAllEntities graphData)
-              & Set.toList
-              & map (view entityName)
-              & filter (`notElem` ignoredEntities)
-              & map T.unpack
-              & sort -- Text and String give different sort
-      assertBool (errMessage nonCoveredEntities) (null nonCoveredEntities)
+  checkCoverage :: Set.Set Entity -> Entity -> TestTree
+  checkCoverage s e =
+    let name = view entityName e
+     in testCase (T.unpack name) $ do
+          assertBool (errMessage name) (name `elem` ignoredEntities || e `Set.notMember` s)
    where
-    errMessage missing = "Missing recipes for: " <> intercalate ", " (quote <$> missing)
-    quote t = concat ["\"", t, "\""]
+    errMessage missing = T.unpack $ "Can not make " <> quote missing <> " from starting entities."
+
+expectNonCovered :: Entity -> TestTree -> TestTree
+expectNonCovered e =
+  let name = T.toCaseFold (view entityName e)
+   in applyWhen (name `elem` nonCoveredList) $
+        expectFailBecause "More recipes needed (#1268)"
+
+nonCoveredList :: [EntityName]
+nonCoveredList =
+  map
+    T.toCaseFold
+    [ "Elmer's glue"
+    , "ash"
+    , "binoculars"
+    , "blueprint"
+    , "caliper"
+    , "cup of tea"
+    , "decoder ring"
+    , "dozer blade"
+    , "hourglass"
+    , "infinite improbability drive"
+    , "linotype"
+    , "olfactometer"
+    , "rolex"
+    , "tape drive"
+    , "tea leaves"
+    , "wedge"
+    ]
+
+getNonCoveredEntities :: RecipeGraphData -> Set.Set Entity
+getNonCoveredEntities graphData = rgAllEntities graphData `Set.difference` Set.unions (rgLevels graphData)