-
Notifications
You must be signed in to change notification settings - Fork 52
New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Fix capability checking, and refactor/add lots of comments #959
Changes from all commits
6feb69c
9375a0c
5a23d92
2cc01d0
b61c6ba
f60c35f
ed5fb33
File filter
Filter by extension
Conversations
Jump to
Diff view
Diff view
There are no files selected for viewing
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -17,3 +17,4 @@ | |
710-multi-robot.yaml | ||
920-meet.yaml | ||
955-heading.yaml | ||
397-wrong-missing.yaml |
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,38 @@ | ||
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: | | ||
t <- time; return (t == 2) | ||
goal: | ||
- | | ||
This is a dummy condition that just ensures the base has had | ||
time to run the problematic `build` command. The scenario | ||
*should* generate an error message; what we really care about is | ||
whether the generated error message is correct, which is checked | ||
in test/integration/Main.hs . | ||
solution: | | ||
build {move; turn right; loc <- whereami} | ||
robots: | ||
- name: base | ||
dir: [0,1] | ||
devices: | ||
- 3D printer | ||
- logger | ||
inventory: | ||
- [1, treads] | ||
- [1, solar panel] | ||
world: | ||
default: [blank] | ||
palette: | ||
'Ω': [grass, null, base] | ||
'.': [grass] | ||
upperleft: [0,1] | ||
map: | | ||
. | ||
Ω |
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -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 | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. ... but here we |
||
|
||
-- 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. | ||
|
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -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) | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Those are some impressive optics. 🤓 There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Haha, thanks, though I don't think it's that bad: |
||
|
||
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_ | ||
|
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
The bug was in the fact that we did a
nubOrd
here --- which could change the length of the list...