Fix Semigroup EntityMap instance to update Capabilities map properly when there are overridden devices

data/scenarios/Testing/00-ORDER.txt

@@ -71,3 +71,4 @@ Achievements
 2085-toplevel-mask.yaml
 2086-structure-palette.yaml
 2239-custom-entity.yaml
+2240-overridden-entity-capabilities.yaml

data/scenarios/Testing/2240-overridden-entity-capabilities.yaml

@@ -0,0 +1,49 @@
+version: 1
+name: Overridden entity capabilities
+description: |
+  Overridden standard entity should not still be suggested for its
+  capabilities. The error message should suggest "- tank treads", not
+  "- treads or tank treads".
+creative: false
+objectives:
+  - goal:
+      - Place a rock
+    condition: |
+      as base {
+        isHere "rock"
+      };
+entities:
+  - name: treads
+    display:
+      char: '#'
+      attr: red
+    description:
+      - Broken treads
+    properties: [known, pickable]
+robots:
+  - name: base
+    dir: east
+    devices:
+      - logger
+      - clock
+      - grabber
+    inventory:
+      - [1, rock]
+  - name: crasher
+    dir: east
+    devices:
+      - logger
+      - treads
+    program: |
+      move
+solution: |
+  wait 5; place "rock"
+world:
+  dsl: |
+    {grass}
+  palette:
+    'C': [grass, null, crasher]
+    'B': [grass, null, base]
+  upperleft: [0, 0]
+  map: |
+    BC

src/swarm-scenario/Swarm/Game/Entity.hs

@@ -104,6 +104,7 @@ import Data.Char (toLower)
 import Data.Either.Extra (maybeToEither)
 import Data.Foldable (Foldable (..))
 import Data.Function (on)
+import Data.Functor.Identity
 import Data.Hashable
 import Data.IntMap (IntMap)
 import Data.IntMap qualified as IM
@@ -429,16 +430,36 @@ data EntityMap = EntityMap
 --   Note that duplicates in a single 'EntityMap' are precluded by the
 --   'buildEntityMap' function.  But it is possible for the right-hand
 --   'EntityMap' to override members of the left-hand with the same name.
---   This replacement happens automatically with 'Map', but needs to
---   be explicitly handled for the list concatenation of
---   'entityDefinitionOrder' (overridden entries are removed from the
---   former 'EntityMap').
+--   For example, this is how custom entities defined in a scenario
+--   can override standard entities. This replacement happens
+--   automatically with 'Map' (as long as we keep in mind that Map
+--   union is *left*-biased), but needs to be explicitly handled for the
+--   list concatenation of 'entityDefinitionOrder' (overridden entries
+--   are removed from the former 'EntityMap'), and for 'entitiesByCap',
+--   which are organized by capability rather than by entity.
 instance Semigroup EntityMap where
   EntityMap n1 c1 d1 <> EntityMap n2 c2 d2 =
     EntityMap
       (n2 <> n1)
-      (c1 <> c2)
-      (filter ((`M.notMember` n2) . view entityName) d1 <> d2)
+      (removeOverriddenDevices c1 <> c2)
+      (filter notOverridden d1 <> d2)
+   where
+    notOverridden :: Entity -> Bool
+    notOverridden = (`M.notMember` n2) . view entityName
+    removeOverriddenDevices (Capabilities m) =
+      Capabilities
+        . runIdentity
+        -- traverseMaybeWithKey allows us in one operation to filter
+        -- the NonEmpty list of devices for each capability, turn the
+        -- resulting lists into Maybe NonEmpty, and then remove from
+        -- the map any that became Nothing.  However, it is more
+        -- general than we need: it gives us access to the key which
+        -- we don't need (this explains the call to 'const'), and runs
+        -- in an arbitrary Applicative which we also don't need (this
+        -- explains the Identity).
+        . M.traverseMaybeWithKey
+          (const (Identity . NE.nonEmpty . NE.filter (notOverridden . device)))
+        $ m
 
 instance Monoid EntityMap where
   mempty = EntityMap M.empty mempty []

test/integration/Main.hs

@@ -500,6 +500,12 @@ testScenarioSolutions rs ui key =
           assertEqual "Incorrect step count." 62 $ view lifetimeStepCount counters
     , expectFailBecause "Awaiting fix for #231" $
         testSolution Default "Testing/231-requirements/231-command-transformer-reqs"
+    , testSolution Default "Testing/2239-custom-entity"
+    , testSolution' Default "Testing/2240-overridden-entity-capabilities" CheckForBadErrors $ \g -> do
+        let msgs = g ^.. robotInfo . robotMap . traverse . robotLog . to logToText . traverse
+        assertBool "Error message should mention tank treads but not treads" $
+          not (any ("- treads" `T.isInfixOf`) msgs)
+            && any ("- tank treads" `T.isInfixOf`) msgs
     ]
  where
   -- expectFailIf :: Bool -> String -> TestTree -> TestTree