Fix capability checking, and refactor/add lots of comments

data/scenarios/Testing/00-ORDER.txt

@@ -17,3 +17,4 @@
 710-multi-robot.yaml
 920-meet.yaml
 955-heading.yaml
+397-wrong-missing.yaml

data/scenarios/Testing/397-wrong-missing.yaml

@@ -0,0 +1,42 @@
+version: 1
+name: Test issue 397 (wrong device reported missing)
+description: |
+  A scenario designed to trigger issue 397, where in certain
+  situations involving a capability with no candidate devices,
+  an incorrect error message was generated reporting some other
+  device to be missing.
+  https://github.com/swarm-game/swarm/issues/397
+objectives:
+  - condition: |
+      as base { ishere "rock" }
+    goal:
+    - |
+      This is a dummy condition that just ensures the base has
+      finished trying to run the problematic `build` command.  The
+      scenario *should* generate an error message; what really care
+      about is whether the generated error message is correct, which
+      is checked in test/integration/Main.hs .
+solution: |
+  build {require 1 "rock"; wait 4; place "rock"};
+  build {move; turn right; loc <- whereami}
+robots:
+  - name: base
+    dir: [0,1]
+    devices:
+      - 3D printer
+      - logger
+    inventory:
+      - [1, clock]
+      - [1, grabber]
+      - [1, treads]
+      - [2, solar panel]
+      - [1, rock]
+world:
+  default: [blank]
+  palette:
+    'Ω': [grass, null, base]
+    '.': [grass]
+  upperleft: [0,1]
+  map: |
+    .
+    Ω

src/Swarm/Game/Step.hs

@@ -18,19 +18,19 @@
 module Swarm.Game.Step where
 
 import Control.Applicative (liftA2)
+import Control.Arrow ((&&&))
 import Control.Carrier.Error.Either (runError)
 import Control.Carrier.State.Lazy
 import Control.Carrier.Throw.Either (ThrowC, runThrow)
 import Control.Effect.Error
 import Control.Effect.Lens
 import Control.Effect.Lift
-import Control.Lens as Lens hiding (Const, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))
+import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))
 import Control.Monad (forM, forM_, guard, msum, unless, when)
 import Data.Array (bounds, (!))
 import Data.Bifunctor (second)
 import Data.Bool (bool)
 import Data.Char (chr, ord)
-import Data.Containers.ListUtils (nubOrd)
 import Data.Either (partitionEithers, rights)
 import Data.Foldable (asum, traverse_)
 import Data.Functor (void)
@@ -41,7 +41,7 @@ import Data.List qualified as L
 import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.List.NonEmpty qualified as NE
 import Data.Map qualified as M
-import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe)
+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)
 import Data.Ord (Down (Down))
 import Data.Sequence qualified as Seq
 import Data.Set (Set)
@@ -1712,65 +1712,85 @@ execConst c vs s k = do
         -- See #349
         (R.Requirements (S.toList -> caps) (S.toList -> devNames) reqInvNames, _capCtx) = R.requirements currentContext cmd
 
-    -- Check that all required device names exist, and fail with
-    -- an exception if not
-    devs <- forM devNames $ \devName ->
+    -- Check that all required device names exist (fail with
+    -- an exception if not) and convert them to 'Entity' values.
+    (devs :: [Entity]) <- forM devNames $ \devName ->
       E.lookupEntityName devName em `isJustOrFail` ["Unknown device required: " <> devName]
 
-    -- Check that all required inventory entity names exist, and fail
-    -- with an exception if not
-    reqElems <- forM (M.assocs reqInvNames) $ \(eName, n) ->
+    -- Check that all required inventory entity names exist (fail with
+    -- an exception if not) and convert them to 'Entity' values, with
+    -- an associated count for each.
+    (reqInv :: Inventory) <- fmap E.fromElems . forM (M.assocs reqInvNames) $ \(eName, n) ->
       (n,)
         <$> ( E.lookupEntityName eName em
                 `isJustOrFail` ["Unknown entity required: " <> eName]
             )
-    let reqInv = E.fromElems reqElems
 
-    let -- List of possible devices per requirement.  Devices for
-        -- required capabilities come first, then singleton devices
-        -- that are required directly.  This order is important since
-        -- later we zip required capabilities with this list to figure
-        -- out which capabilities are missing.
-        capDevices = map (`deviceForCap` em) caps ++ map (: []) devs
+    let -- List of possible devices per requirement.  For the
+        -- requirements that stem from a required capability, we
+        -- remember the capability alongside the possible devices, to
+        -- help with later error message generation.
+        possibleDevices :: [(Maybe Capability, [Entity])]
+        possibleDevices =
+          map (Just &&& (`deviceForCap` em)) caps -- Possible devices for capabilities
+            ++ map ((Nothing,) . (: [])) devs -- Outright required devices
 
         -- A device is OK if it is available in the inventory of the
         -- parent robot, or already installed in the child robot.
+        deviceOK :: Entity -> Bool
         deviceOK d = parentInventory `E.contains` d || childDevices `E.contains` d
 
-        -- take a pair of device sets providing capabilities that is
-        -- split into (AVAIL,MISSING) and if there are some available
-        -- ignore missing because we only need them for error message
-        ignoreOK ([], miss) = ([], miss)
-        ignoreOK (ds, _miss) = (ds, [])
-
-        (deviceSets, missingDeviceSets) =
-          Lens.over both (nubOrd . map S.fromList) . unzip $
-            map (ignoreOK . L.partition deviceOK) capDevices
-
-        formatDevices = T.intercalate " or " . map (^. entityName) . S.toList
-        -- capabilities not provided by any device in inventory
-        missingCaps = S.fromList . map fst . filter (null . snd) $ zip caps deviceSets
-
+        -- Partition each list of possible devices into a set of
+        -- available devices and a set of unavailable devices.
+        -- There's a problem if some capability is required but no
+        -- devices that provide it are available.  In that case we can
+        -- print an error message, using the second set as a list of
+        -- suggestions.
+        partitionedDevices :: [(Set Entity, Set Entity)]
+        partitionedDevices =
+          map (Lens.over both S.fromList . L.partition deviceOK . snd) possibleDevices
+
+        -- Devices installed on the child, as a Set instead of an
+        -- Inventory for convenience.
+        alreadyInstalled :: Set Entity
         alreadyInstalled = S.fromList . map snd . E.elems $ childDevices
 
-        -- Figure out what is missing from the required inventory
+        -- Figure out what is still missing of the required inventory:
+        -- the required inventory, less any inventory the child robot
+        -- already has.
         missingChildInv = reqInv `E.difference` childInventory
 
     if creative
-      then -- In creative mode, just return ALL the devices
-        return (S.unions (map S.fromList capDevices) `S.difference` alreadyInstalled, missingChildInv)
+      then
+        return
+          ( -- In creative mode, just install ALL the devices
+            -- providing each required capability (because, why
+            -- not?). But don't reinstall any that are already
+            -- installed.
+            S.unions (map (S.fromList . snd) possibleDevices) `S.difference` alreadyInstalled
+          , -- Conjure the necessary missing inventory out of thin
+            -- air.
+            missingChildInv
+          )
       else do
-        -- check if robot has all devices to execute new command
-        all null missingDeviceSets
+        -- First, check that devices actually exist AT ALL to provide every
+        -- required capability.  If not, we will generate an error message saying
+        -- something like "missing capability X but no device yet provides it".
+        let capsWithNoDevice = mapMaybe fst . filter (null . snd) $ possibleDevices
+        null capsWithNoDevice
+          `holdsOr` Incapable fixI (R.Requirements (S.fromList capsWithNoDevice) S.empty M.empty) cmd
+
+        -- Now, ensure there is at least one device available to be
+        -- installed for each requirement.
+        let missingDevices = map snd . filter (null . fst) $ partitionedDevices
+        null missingDevices
           `holdsOrFail` ( singularSubjectVerb subject "do"
                             : "not have required devices, please"
                             : formatIncapableFix fixI <> ":"
-                            : (("\n  - " <>) . formatDevices <$> filter (not . null) missingDeviceSets)
+                            : (("\n  - " <>) . formatDevices <$> missingDevices)
                         )
-        -- check that there are in fact devices to provide every required capability
-        not (any null deviceSets) `holdsOr` Incapable fixI (R.Requirements missingCaps S.empty M.empty) cmd
 
-        let minimalInstallSet = smallHittingSet (filter (S.null . S.intersection alreadyInstalled) deviceSets)
+        let minimalInstallSet = smallHittingSet (filter (S.null . S.intersection alreadyInstalled) (map fst partitionedDevices))
 
             -- Check that we have enough in our inventory to cover the
             -- required installs PLUS what's missing from the child
@@ -1951,6 +1971,11 @@ verbedGrabbingCmd = \case
   Grab' -> "grabbed"
   Swap' -> "swapped"
 
+-- | Format a set of suggested devices for use in an error message,
+--   in the format @device1 or device2 or ... or deviceN@.
+formatDevices :: Set Entity -> Text
+formatDevices = T.intercalate " or " . map (^. entityName) . S.toList
+
 -- | Give some entities from a parent robot (the robot represented by
 --   the ambient @State Robot@ effect) to a child robot (represented
 --   by the given 'RID') as part of a 'Build' or 'Reprogram' command.

test/integration/Main.hs

@@ -5,7 +5,7 @@
 -- | Swarm integration tests
 module Main where
 
-import Control.Lens (Ixed (ix), to, use, view, (&), (.~), (<&>), (^.), (^?!))
+import Control.Lens (Ixed (ix), to, use, view, (&), (.~), (<&>), (^.), (^..), (^?!))
 import Control.Monad (filterM, forM_, unless, void, when)
 import Control.Monad.State (StateT (runStateT), gets)
 import Control.Monad.Trans.Except (runExceptT)
@@ -15,6 +15,7 @@ import Data.Foldable (Foldable (toList), find)
 import Data.IntSet qualified as IS
 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
@@ -23,7 +24,7 @@ import Swarm.DocGen (EditorType (..))
 import Swarm.DocGen qualified as DocGen
 import Swarm.Game.CESK (emptyStore, initMachine)
 import Swarm.Game.Entity (EntityMap, loadEntities)
-import Swarm.Game.Robot (defReqs, leText, machine, robotContext, robotLog, waitingUntil)
+import Swarm.Game.Robot (LogEntry, defReqs, leText, machine, robotContext, robotLog, waitingUntil)
 import Swarm.Game.Scenario (Scenario)
 import Swarm.Game.State (
   GameState,
@@ -123,6 +124,8 @@ time = \case
   sec :: Int
   sec = 10 ^ (6 :: Int)
 
+data ShouldCheckBadErrors = CheckForBadErrors | AllowBadErrors deriving (Eq, Show)
+
 testScenarioSolution :: Bool -> EntityMap -> TestTree
 testScenarioSolution _ci _em =
   testGroup
@@ -139,7 +142,7 @@ testScenarioSolution _ci _em =
         , testSolution Default "Tutorials/install"
         , testSolution Default "Tutorials/build"
         , testSolution Default "Tutorials/bind2"
-        , testSolution' Default "Tutorials/crash" $ \g -> do
+        , testSolution' Default "Tutorials/crash" CheckForBadErrors $ \g -> do
             let rs = toList $ g ^. robotMap
             let hints = any (T.isInfixOf "you will win" . view leText) . toList . view robotLog
             let win = isJust $ find hints rs
@@ -176,7 +179,7 @@ testScenarioSolution _ci _em =
         [ testSolution Default "Testing/394-build-drill"
         , testSolution Default "Testing/373-drill"
         , testSolution Default "Testing/428-drowning-destroy"
-        , testSolution' Default "Testing/475-wait-one" $ \g -> do
+        , testSolution' Default "Testing/475-wait-one" CheckForBadErrors $ \g -> do
             let t = g ^. ticks
                 r1Waits = g ^?! robotMap . ix 1 . to waitingUntil
                 active = IS.member 1 $ g ^. activeRobots
@@ -216,17 +219,27 @@ testScenarioSolution _ci _em =
         , testSolution Default "Testing/710-multi-robot"
         , testSolution Default "Testing/920-meet"
         , testSolution Default "Testing/955-heading"
+        , testSolution' Default "Testing/397-wrong-missing" AllowBadErrors $ \g -> do
+            let msgs =
+                  (g ^. 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 no device provides senseloc" $
+              any ("senseloc" `T.isInfixOf`) msgs
         ]
     ]
  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 (const $ pure ())
+  testSolution s p = testSolution' s p CheckForBadErrors (const $ pure ())
 
-  testSolution' :: Time -> FilePath -> (GameState -> Assertion) -> TestTree
-  testSolution' s p verify = testCase p $ do
+  testSolution' :: Time -> FilePath -> ShouldCheckBadErrors -> (GameState -> Assertion) -> TestTree
+  testSolution' s p shouldCheckBadErrors verify = testCase p $ do
     out <- runExceptT $ initGameStateForScenario p Nothing Nothing
     case out of
       Left x -> assertFailure $ unwords ["Failure in initGameStateForScenario:", T.unpack x]
@@ -246,7 +259,7 @@ testScenarioSolution _ci _em =
             Just g -> do
               -- When debugging, try logging all robot messages.
               -- printAllLogs
-              noBadErrors g
+              when (shouldCheckBadErrors == CheckForBadErrors) $ noBadErrors g
               verify g
 
   playUntilWin :: StateT GameState IO ()
@@ -269,9 +282,11 @@ badErrorsInLogs g =
     (g ^. robotMap)
     <> filter isBad (seqToTexts $ g ^. messageQueue)
  where
-  seqToTexts = map (view leText) . toList
   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_