From e7b4d657dee7516117eb1ae6a5b43b7bb0ef66d1 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Mon, 6 Jan 2025 14:50:00 -0800 Subject: [PATCH] Use forM_/mapM_ (#2273) Searched for instances of `return ()` and `pure ()`, especially `Nothing -> return ()`, which uncovered several opportunities to use `when/unless` and `mapM_/forM_`. --- src/swarm-doc/Swarm/Doc/Schema/Refined.hs | 6 +- src/swarm-engine/Swarm/Game/ScenarioInfo.hs | 24 ++--- src/swarm-engine/Swarm/Game/State/Robot.hs | 22 ++-- src/swarm-engine/Swarm/Game/Step.hs | 15 ++- src/swarm-engine/Swarm/Game/Step/Const.hs | 56 +++++----- .../Swarm/Game/Step/Util/Command.hs | 50 ++++----- src/swarm-lang/Swarm/Language/Typecheck.hs | 21 ++-- src/swarm-scenario/Swarm/Game/Entity.hs | 5 +- src/swarm-scenario/Swarm/Game/Scenario.hs | 5 +- .../Game/Scenario/Objective/Validation.hs | 25 ++--- src/swarm-tui/Swarm/TUI/Controller.hs | 101 +++++++++--------- .../Swarm/TUI/Controller/SaveScenario.hs | 80 +++++++------- src/swarm-tui/Swarm/TUI/Controller/Util.hs | 2 +- src/swarm-tui/Swarm/TUI/Editor/Controller.hs | 2 - test/integration/Main.hs | 10 +- test/unit/TestOverlay.hs | 8 +- 16 files changed, 196 insertions(+), 236 deletions(-) diff --git a/src/swarm-doc/Swarm/Doc/Schema/Refined.hs b/src/swarm-doc/Swarm/Doc/Schema/Refined.hs index 0968d01bd..26dff362d 100644 --- a/src/swarm-doc/Swarm/Doc/Schema/Refined.hs +++ b/src/swarm-doc/Swarm/Doc/Schema/Refined.hs @@ -9,6 +9,7 @@ module Swarm.Doc.Schema.Refined where import Control.Applicative ((<|>)) +import Control.Monad (unless) import Data.Aeson import Data.List.Extra (replace) import Data.List.NonEmpty (NonEmpty) @@ -122,9 +123,8 @@ toSwarmSchema rawSchema = do theType <- maybe (fail "Unspecified sub-schema type") return maybeType markdownDescription <- mapM getMarkdown $ _description rawSchema - if null (_properties rawSchema) || not (fromMaybe True (_additionalProperties rawSchema)) - then return () - else fail "All objects must specify '\"additionalProperties\": true'" + unless (null (_properties rawSchema) || not (fromMaybe True (_additionalProperties rawSchema))) $ + fail "All objects must specify '\"additionalProperties\": true'" return SwarmSchema diff --git a/src/swarm-engine/Swarm/Game/ScenarioInfo.hs b/src/swarm-engine/Swarm/Game/ScenarioInfo.hs index 107dbe85a..54ce19c29 100644 --- a/src/swarm-engine/Swarm/Game/ScenarioInfo.hs +++ b/src/swarm-engine/Swarm/Game/ScenarioInfo.hs @@ -188,21 +188,19 @@ loadScenarioDir scenarioInputs loadTestScenarios dir = do True -> Just <$> readOrderFile orderFile itemPaths <- sendIO $ keepYamlOrPublicDirectory dir =<< listDirectory dir - case morder of - Just order -> do - let missing = itemPaths \\ order - dangling = order \\ itemPaths + forM_ morder $ \order -> do + let missing = itemPaths \\ order + dangling = order \\ itemPaths - forM_ (NE.nonEmpty missing) $ - warn - . OrderFileWarning (dirName orderFileName) - . MissingFiles + forM_ (NE.nonEmpty missing) $ + warn + . OrderFileWarning (dirName orderFileName) + . MissingFiles - forM_ (NE.nonEmpty dangling) $ - warn - . OrderFileWarning (dirName orderFileName) - . DanglingFiles - Nothing -> pure () + forM_ (NE.nonEmpty dangling) $ + warn + . OrderFileWarning (dirName orderFileName) + . DanglingFiles -- Only keep the files from 00-ORDER.txt that actually exist. let morder' = filter (`elem` itemPaths) <$> morder diff --git a/src/swarm-engine/Swarm/Game/State/Robot.hs b/src/swarm-engine/Swarm/Game/State/Robot.hs index af89419b3..9fc6aa2c2 100644 --- a/src/swarm-engine/Swarm/Game/State/Robot.hs +++ b/src/swarm-engine/Swarm/Game/State/Robot.hs @@ -302,21 +302,19 @@ activateRobot rid = internalActiveRobots %= IS.insert rid wakeUpRobotsDoneSleeping :: (Has (State Robots) sig m) => TickNumber -> m () wakeUpRobotsDoneSleeping time = do mrids <- internalWaitingRobots . at time <<.= Nothing - case mrids of - Nothing -> return () - Just rids -> do - robots <- use robotMap - let robotIdSet = IM.keysSet robots - wakeableRIDsSet = IS.fromList rids + forM_ mrids $ \rids -> do + robots <- use robotMap + let robotIdSet = IM.keysSet robots + wakeableRIDsSet = IS.fromList rids - -- Limit ourselves to the robots that have not expired in their sleep - newlyAlive = IS.intersection robotIdSet wakeableRIDsSet + -- Limit ourselves to the robots that have not expired in their sleep + newlyAlive = IS.intersection robotIdSet wakeableRIDsSet - internalActiveRobots %= IS.union newlyAlive + internalActiveRobots %= IS.union newlyAlive - -- These robots' wake times may have been moved "forward" - -- by 'wakeWatchingRobots'. - clearWatchingRobots wakeableRIDsSet + -- These robots' wake times may have been moved "forward" + -- by 'wakeWatchingRobots'. + clearWatchingRobots wakeableRIDsSet -- | Clear the "watch" state of all of the -- awakened robots diff --git a/src/swarm-engine/Swarm/Game/Step.hs b/src/swarm-engine/Swarm/Game/Step.hs index 5fdf74ebd..706b50132 100644 --- a/src/swarm-engine/Swarm/Game/Step.hs +++ b/src/swarm-engine/Swarm/Game/Step.hs @@ -101,15 +101,12 @@ gameTick = do -- also save the current store into the robotContext so we can -- restore it the next time we start a computation. mr <- use (robotInfo . robotMap . at 0) - case mr of - Just r -> do - res <- use $ gameControls . replStatus - case res of - REPLWorking ty Nothing -> case getResult r of - Just v -> gameControls . replStatus .= REPLWorking ty (Just v) - Nothing -> pure () - _otherREPLStatus -> pure () - Nothing -> pure () + forM_ mr $ \r -> do + res <- use $ gameControls . replStatus + case res of + REPLWorking ty Nothing -> forM_ (getResult r) $ \v -> + gameControls . replStatus .= REPLWorking ty (Just v) + _otherREPLStatus -> pure () -- Possibly update the view center. modify recalcViewCenterAndRedraw diff --git a/src/swarm-engine/Swarm/Game/Step/Const.hs b/src/swarm-engine/Swarm/Game/Step/Const.hs index de3eda30e..28b096f99 100644 --- a/src/swarm-engine/Swarm/Game/Step/Const.hs +++ b/src/swarm-engine/Swarm/Game/Step/Const.hs @@ -214,22 +214,20 @@ execConst runChildProg c vs s k = do -- If unobstructed, the robot will move even if -- there is nothing to push. maybeCurrentE <- entityAt nextLoc - case maybeCurrentE of - Just e -> do - -- Make sure there's nothing already occupying the destination - nothingHere <- isNothing <$> entityAt placementLoc - nothingHere `holdsOrFail` ["Something is in the way!"] - - let verbed = verbedGrabbingCmd Push' - -- Ensure it can be pushed. - omni <- isPrivilegedBot - (omni || e `hasProperty` Pushable || e `hasProperty` Pickable && not (e `hasProperty` Liquid)) - `holdsOrFail` ["The", e ^. entityName, "here can't be", verbed <> "."] - - -- Place the entity and remove it from previous loc - updateEntityAt nextLoc (const Nothing) - updateEntityAt placementLoc (const (Just e)) - Nothing -> return () + forM_ maybeCurrentE $ \e -> do + -- Make sure there's nothing already occupying the destination + nothingHere <- isNothing <$> entityAt placementLoc + nothingHere `holdsOrFail` ["Something is in the way!"] + + let verbed = verbedGrabbingCmd Push' + -- Ensure it can be pushed. + omni <- isPrivilegedBot + (omni || e `hasProperty` Pushable || e `hasProperty` Pickable && not (e `hasProperty` Liquid)) + `holdsOrFail` ["The", e ^. entityName, "here can't be", verbed <> "."] + + -- Place the entity and remove it from previous loc + updateEntityAt nextLoc (const Nothing) + updateEntityAt placementLoc (const (Just e)) updateRobotLocation loc nextLoc return $ mkReturn () @@ -1657,7 +1655,7 @@ execConst runChildProg c vs s k = do (mAch False) selfDestruct .= True - maybe (return ()) grantAchievementForRobot (mAch True) + forM_ (mAch True) grantAchievementForRobot moveInDirection :: (HasRobotStepState sig m, Has (Lift IO) sig m) => Heading -> m CESK moveInDirection orientation = do @@ -1676,19 +1674,17 @@ execConst runChildProg c vs s k = do MoveFailureHandler -> m () applyMoveFailureEffect maybeFailure failureHandler = - case maybeFailure of - Nothing -> return () - Just failureMode -> case failureHandler failureMode of - IgnoreFail -> return () - Destroy -> destroyIfNotBase $ \b -> case (b, failureMode) of - (True, PathLiquid _) -> Just RobotIntoWater -- achievement for drowning - _ -> Nothing - ThrowExn -> throwError . cmdExn c $ - case failureMode of - PathBlockedBy ent -> case ent of - Just e -> ["There is a", e ^. entityName, "in the way!"] - Nothing -> ["There is nothing to travel on!"] - PathLiquid e -> ["There is a dangerous liquid", e ^. entityName, "in the way!"] + forM_ maybeFailure $ \failureMode -> case failureHandler failureMode of + IgnoreFail -> return () + Destroy -> destroyIfNotBase $ \b -> case (b, failureMode) of + (True, PathLiquid _) -> Just RobotIntoWater -- achievement for drowning + _ -> Nothing + ThrowExn -> throwError . cmdExn c $ + case failureMode of + PathBlockedBy ent -> case ent of + Just e -> ["There is a", e ^. entityName, "in the way!"] + Nothing -> ["There is nothing to travel on!"] + PathLiquid e -> ["There is a dangerous liquid", e ^. entityName, "in the way!"] -- Determine the move failure mode and apply the corresponding effect. checkMoveAhead :: diff --git a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs index 037cb008c..4d148015b 100644 --- a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs +++ b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs @@ -99,19 +99,17 @@ ensureCanExecute :: Const -> m () ensureCanExecute c = - gets @Robot (constCapsFor c) >>= \case - Nothing -> pure () - Just cap -> do - isPrivileged <- isPrivilegedBot - -- Privileged robots can execute commands regardless - -- of equipped devices, and without expending - -- a capability's exercise cost. - unless isPrivileged $ do - robotCaps <- use robotCapabilities - let capProviders = M.lookup cap $ getMap robotCaps - case capProviders of - Nothing -> throwError $ Incapable FixByEquip (R.singletonCap cap) (TConst c) - Just rawCosts -> payExerciseCost c rawCosts + gets @Robot (constCapsFor c) >>= mapM_ \cap -> do + isPrivileged <- isPrivilegedBot + -- Privileged robots can execute commands regardless + -- of equipped devices, and without expending + -- a capability's exercise cost. + unless isPrivileged $ do + robotCaps <- use robotCapabilities + let capProviders = M.lookup cap $ getMap robotCaps + case capProviders of + Nothing -> throwError $ Incapable FixByEquip (R.singletonCap cap) (TConst c) + Just rawCosts -> payExerciseCost c rawCosts payExerciseCost :: ( Has (State Robot) sig m @@ -212,14 +210,12 @@ onTarget rid act = do True -> act False -> do mtgt <- use (robotInfo . robotMap . at rid) - case mtgt of - Nothing -> return () - Just tgt -> do - tgt' <- execState @Robot tgt act - zoomRobots $ - if tgt' ^. selfDestruct - then deleteRobot rid - else robotMap . ix rid .= tgt' + forM_ mtgt $ \tgt -> do + tgt' <- execState @Robot tgt act + zoomRobots $ + if tgt' ^. selfDestruct + then deleteRobot rid + else robotMap . ix rid .= tgt' -- | Enforces validity of the robot's privileged status to receive -- an achievement. @@ -292,13 +288,11 @@ isNearbyOrExempt privileged myLoc otherLoc = updateDiscoveredEntities :: (HasRobotStepState sig m) => Entity -> m () updateDiscoveredEntities e = do allDiscovered <- use $ discovery . allDiscoveredEntities - if E.contains0plus e allDiscovered - then pure () - else do - let newAllDiscovered = E.insertCount 1 e allDiscovered - updateAvailableRecipes (newAllDiscovered, newAllDiscovered) e - updateAvailableCommands e - discovery . allDiscoveredEntities .= newAllDiscovered + unless (E.contains0plus e allDiscovered) $ do + let newAllDiscovered = E.insertCount 1 e allDiscovered + updateAvailableRecipes (newAllDiscovered, newAllDiscovered) e + updateAvailableCommands e + discovery . allDiscoveredEntities .= newAllDiscovered -- | Update the availableRecipes list. -- This implementation is not efficient: diff --git a/src/swarm-lang/Swarm/Language/Typecheck.hs b/src/swarm-lang/Swarm/Language/Typecheck.hs index 60ef0400e..0f08dece5 100644 --- a/src/swarm-lang/Swarm/Language/Typecheck.hs +++ b/src/swarm-lang/Swarm/Language/Typecheck.hs @@ -1160,17 +1160,16 @@ check s@(CSyntax l t cs) expected = addLocToTypeErr l $ case t of SLam x mxTy body -> do (argTy, resTy) <- decomposeFunTy s (Expected, expected) traverse_ (adaptToTypeErr l KindErr . checkKind) mxTy - case toU mxTy of - Just xTy -> do - res <- argTy U.=:= xTy - case res of - -- Generate a special error when the explicit type annotation - -- on a lambda doesn't match the expected type, - -- e.g. (\x:Int. x + 2) : Text -> Int, since the usual - -- "expected/but got" language would probably be confusing. - Left _ -> throwTypeErr l $ LambdaArgMismatch (joined argTy xTy) - Right _ -> return () - Nothing -> return () + forM_ (toU mxTy) $ \xTy -> do + res <- argTy U.=:= xTy + case res of + -- Generate a special error when the explicit type annotation + -- on a lambda doesn't match the expected type, + -- e.g. (\x:Int. x + 2) : Text -> Int, since the usual + -- "expected/but got" language would probably be confusing. + Left _ -> throwTypeErr l $ LambdaArgMismatch (joined argTy xTy) + Right _ -> return () + body' <- withBinding @UPolytype (lvVar x) (mkTrivPoly argTy) $ check body resTy return $ Syntax' l (SLam x mxTy body') cs (UTyFun argTy resTy) diff --git a/src/swarm-scenario/Swarm/Game/Entity.hs b/src/swarm-scenario/Swarm/Game/Entity.hs index e7ec9051d..ecb8db46c 100644 --- a/src/swarm-scenario/Swarm/Game/Entity.hs +++ b/src/swarm-scenario/Swarm/Game/Entity.hs @@ -506,9 +506,8 @@ validateEntityAttrRefs validAttrs es = -- from a file; see 'loadEntities'. buildEntityMap :: Has (Throw LoadingFailure) sig m => [Entity] -> m EntityMap buildEntityMap es = do - case findDup (map fst namedEntities) of - Nothing -> return () - Just duped -> throwError $ Duplicate Entities duped + forM_ (findDup $ map fst namedEntities) $ + throwError . Duplicate Entities case combineEntityCapsM entsByName es of Left x -> throwError $ CustomMessage x Right ebc -> diff --git a/src/swarm-scenario/Swarm/Game/Scenario.hs b/src/swarm-scenario/Swarm/Game/Scenario.hs index fb731ce5c..cd632d564 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario.hs @@ -286,9 +286,8 @@ instance FromJSONE ScenarioInputs Scenario where combinedTEM <- getE let TerrainEntityMaps _tm emCombined = combinedTEM - case filter (isNothing . (`lookupEntityName` emCombined)) known of - [] -> return () - unk -> failT ["Unknown entities in 'known' list:", T.intercalate ", " unk] + forM_ (NE.nonEmpty $ filter (isNothing . (`lookupEntityName` emCombined)) known) $ \unk -> + failT ["Unknown entities in 'known' list:", T.intercalate ", " $ NE.toList unk] -- parse robots and build RobotMap rs <- v ..: "robots" diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs b/src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs index 130c2a4c0..e84902034 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Objective/Validation.hs @@ -7,7 +7,7 @@ module Swarm.Game.Scenario.Objective.Validation where import Control.Lens (view, (^.)) -import Control.Monad (unless) +import Control.Monad (forM_, unless) import Data.Foldable (for_, toList) import Data.Maybe (fromMaybe, mapMaybe) import Data.Set qualified as Set @@ -29,19 +29,16 @@ validateObjectives :: [Objective] -> m [Objective] validateObjectives objectives = do - for_ objectives $ \x -> case x ^. objectivePrerequisite of - Just p -> - unless (null remaining) $ - failT - [ "Reference to undefined objective(s)" - , T.intercalate ", " (map quote $ Set.toList remaining) <> "." - , "Defined are:" - , T.intercalate ", " (map quote $ Set.toList allIds) - ] - where - refs = Set.fromList $ toList $ logic p - remaining = Set.difference refs allIds - Nothing -> return () + for_ objectives $ \x -> forM_ (x ^. objectivePrerequisite) $ \p -> + let refs = Set.fromList $ toList $ logic p + remaining = Set.difference refs allIds + in unless (null remaining) $ + failT + [ "Reference to undefined objective(s)" + , T.intercalate ", " (map quote $ Set.toList remaining) <> "." + , "Defined are:" + , T.intercalate ", " (map quote $ Set.toList allIds) + ] either (fail . T.unpack) return $ failOnCyclicGraph "Prerequisites" (fromMaybe "N/A" . view objectiveId) edges diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 0a58cc2f2..b495fb9ec 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -171,39 +171,37 @@ handleMainMenuEvent :: BL.List Name MainMenuEntry -> BrickEvent Name AppEvent -> EventM Name AppState () handleMainMenuEvent menu = \case Key V.KEnter -> - case snd <$> BL.listSelectedElement menu of - Nothing -> pure () - Just x0 -> case x0 of - NewGame -> do - ss <- use $ runtimeState . scenarios - uiState . uiMenu .= NewGameMenu (pure $ mkScenarioList ss) - Tutorial -> do - -- Set up the menu stack as if the user had chosen "New Game > Tutorials" - ss <- use $ runtimeState . scenarios - let tutorialCollection = getTutorials ss - topMenu = - BL.listFindBy - ((== tutorialsDirname) . T.unpack . scenarioItemName) - (mkScenarioList ss) - tutorialMenu = mkScenarioList tutorialCollection - menuStack = tutorialMenu :| pure topMenu - uiState . uiMenu .= NewGameMenu menuStack - - -- Extract the first tutorial challenge and run it - let firstTutorial = case scOrder tutorialCollection of - Just (t : _) -> case M.lookup t (scMap tutorialCollection) of - Just (SISingle siPair) -> siPair - _ -> error "No first tutorial found!" + forM_ (snd <$> BL.listSelectedElement menu) $ \case + NewGame -> do + ss <- use $ runtimeState . scenarios + uiState . uiMenu .= NewGameMenu (pure $ mkScenarioList ss) + Tutorial -> do + -- Set up the menu stack as if the user had chosen "New Game > Tutorials" + ss <- use $ runtimeState . scenarios + let tutorialCollection = getTutorials ss + topMenu = + BL.listFindBy + ((== tutorialsDirname) . T.unpack . scenarioItemName) + (mkScenarioList ss) + tutorialMenu = mkScenarioList tutorialCollection + menuStack = tutorialMenu :| pure topMenu + uiState . uiMenu .= NewGameMenu menuStack + + -- Extract the first tutorial challenge and run it + let firstTutorial = case scOrder tutorialCollection of + Just (t : _) -> case M.lookup t (scMap tutorialCollection) of + Just (SISingle siPair) -> siPair _ -> error "No first tutorial found!" - startGame firstTutorial Nothing - Achievements -> uiState . uiMenu .= AchievementsMenu (BL.list AchievementList (V.fromList listAchievements) 1) - Messages -> do - runtimeState . eventLog . notificationsCount .= 0 - uiState . uiMenu .= MessagesMenu - About -> do - uiState . uiMenu .= AboutMenu - attainAchievement $ GlobalAchievement LookedAtAboutScreen - Quit -> halt + _ -> error "No first tutorial found!" + startGame firstTutorial Nothing + Achievements -> uiState . uiMenu .= AchievementsMenu (BL.list AchievementList (V.fromList listAchievements) 1) + Messages -> do + runtimeState . eventLog . notificationsCount .= 0 + uiState . uiMenu .= MessagesMenu + About -> do + uiState . uiMenu .= AboutMenu + attainAchievement $ GlobalAchievement LookedAtAboutScreen + Quit -> halt CharKey 'q' -> halt ControlChar 'q' -> halt VtyEvent ev -> do @@ -250,10 +248,9 @@ handleNewGameMenuEvent :: EventM Name AppState () handleNewGameMenuEvent scenarioStack@(curMenu :| rest) = \case Key V.KEnter -> - case snd <$> BL.listSelectedElement curMenu of - Nothing -> pure () - Just (SISingle siPair) -> invalidateCache >> startGame siPair Nothing - Just (SICollection _ c) -> do + forM_ (snd <$> BL.listSelectedElement curMenu) $ \case + SISingle siPair -> invalidateCache >> startGame siPair Nothing + SICollection _ c -> do uiState . uiMenu .= NewGameMenu (NE.cons (mkScenarioList c) scenarioStack) CharKey 'o' -> showLaunchDialog CharKey 'O' -> showLaunchDialog @@ -517,22 +514,21 @@ handleREPLEvent x = do runInputHandler :: KeyCombo -> EventM Name AppState () runInputHandler kc = do mhandler <- use $ gameState . gameControls . inputHandler - case mhandler of + forM_ mhandler $ \(_, handler) -> do -- Shouldn't be possible to get here if there is no input handler, but -- if we do somehow, just do nothing. - Nothing -> return () - Just (_, handler) -> do - -- Make sure the base is currently idle; if so, apply the - -- installed input handler function to a `key` value - -- representing the typed input. - working <- use $ gameState . gameControls . replWorking - unless working $ do - s <- get - let env = s ^. gameState . baseEnv - store = s ^. gameState . baseStore - handlerCESK = Out (VKey kc) store [FApp handler, FExec, FSuspend env] - gameState . baseRobot . machine .= handlerCESK - gameState %= execState (zoomRobots $ activateRobot 0) + + -- Make sure the base is currently idle; if so, apply the + -- installed input handler function to a `key` value + -- representing the typed input. + working <- use $ gameState . gameControls . replWorking + unless working $ do + s <- get + let env = s ^. gameState . baseEnv + store = s ^. gameState . baseStore + handlerCESK = Out (VKey kc) store [FApp handler, FExec, FSuspend env] + gameState . baseRobot . machine .= handlerCESK + gameState %= execState (zoomRobots $ activateRobot 0) -- | Handle a user "piloting" input event for the REPL. -- @@ -647,9 +643,8 @@ handleREPLEventTyping = \case let uinput = uir ^. replPromptText case uir ^. replPromptType of CmdPrompt _ -> replPromptType .= SearchPrompt (uir ^. replHistory) - SearchPrompt rh -> case lastEntry uinput rh of - Nothing -> pure () - Just found -> replPromptType .= SearchPrompt (removeEntry found rh) + SearchPrompt rh -> forM_ (lastEntry uinput rh) $ \found -> + replPromptType .= SearchPrompt (removeEntry found rh) CharKey '\t' -> do s <- get let names = s ^.. gameState . baseEnv . envTypes . to assocs . traverse . _1 diff --git a/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs b/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs index ec287031d..e9ff1a28f 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs @@ -11,10 +11,10 @@ module Swarm.TUI.Controller.SaveScenario ( -- See Note [liftA2 re-export from Prelude] import Brick.Widgets.List qualified as BL import Control.Lens as Lens -import Control.Monad (forM_, unless, void, when) +import Control.Monad (forM_, unless, when) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.State (MonadState) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, listToMaybe) import Data.Time (getZonedTime) import Swarm.Game.Achievement.Definitions import Swarm.Game.Scenario.Status (updateScenarioInfoOnFinish) @@ -65,16 +65,12 @@ saveScenarioInfoOnFinish p = do currentScenarioInfo %= updateScenarioInfoOnFinish determinator t ts won status <- preuse currentScenarioInfo - case status of - Nothing -> return () - Just si -> do - let segments = splitDirectories p - case segments of - firstDir : _ -> do - when (won && firstDir == tutorialsDirname) $ - attainAchievement' t (Just p) (GlobalAchievement CompletedSingleTutorial) - _ -> return () - liftIO $ saveScenarioInfo p si + forM_ status $ \si -> do + forM_ (listToMaybe $ splitDirectories p) $ \firstDir -> do + when (won && firstDir == tutorialsDirname) $ + attainAchievement' t (Just p) $ + GlobalAchievement CompletedSingleTutorial + liftIO $ saveScenarioInfo p si gameState . completionStatsSaved .= won @@ -90,40 +86,38 @@ unlessCheating a = do -- | Write the @ScenarioInfo@ out to disk when finishing a game (i.e. on winning or exit). saveScenarioInfoOnFinishNocheat :: (MonadIO m, MonadState AppState m) => m () saveScenarioInfoOnFinishNocheat = - unlessCheating $ do + unlessCheating $ -- the path should be normalized and good to search in scenario collection - getNormalizedCurrentScenarioPath >>= \case - Nothing -> return () - Just p -> void $ saveScenarioInfoOnFinish p + getNormalizedCurrentScenarioPath >>= mapM_ saveScenarioInfoOnFinish -- | Write the @ScenarioInfo@ out to disk when exiting a game. saveScenarioInfoOnQuit :: (MonadIO m, MonadState AppState m) => m () saveScenarioInfoOnQuit = - unlessCheating $ do - getNormalizedCurrentScenarioPath >>= \case - Nothing -> return () - Just p -> do - maybeSi <- saveScenarioInfoOnFinish p - -- Note [scenario menu update] - -- Ensures that the scenario selection menu gets updated - -- with the high score/completion status - forM_ - maybeSi - ( uiState - . uiMenu - . _NewGameMenu - . ix 0 - . BL.listSelectedElementL - . _SISingle - . _2 - .= - ) + unlessCheating $ + getNormalizedCurrentScenarioPath >>= mapM_ go + where + go p = do + maybeSi <- saveScenarioInfoOnFinish p + -- Note [scenario menu update] + -- Ensures that the scenario selection menu gets updated + -- with the high score/completion status + forM_ + maybeSi + ( uiState + . uiMenu + . _NewGameMenu + . ix 0 + . BL.listSelectedElementL + . _SISingle + . _2 + .= + ) - -- See what scenario is currently focused in the menu. Depending on how the - -- previous scenario ended (via quit vs. via win), it might be the same as - -- currentScenarioPath or it might be different. - curPath <- preuse $ uiState . uiMenu . _NewGameMenu . ix 0 . BL.listSelectedElementL . _SISingle . _2 . scenarioPath - -- Now rebuild the NewGameMenu so it gets the updated ScenarioInfo, - -- being sure to preserve the same focused scenario. - sc <- use $ runtimeState . scenarios - forM_ (mkNewGameMenu sc (fromMaybe p curPath)) (uiState . uiMenu .=) + -- See what scenario is currently focused in the menu. Depending on how the + -- previous scenario ended (via quit vs. via win), it might be the same as + -- currentScenarioPath or it might be different. + curPath <- preuse $ uiState . uiMenu . _NewGameMenu . ix 0 . BL.listSelectedElementL . _SISingle . _2 . scenarioPath + -- Now rebuild the NewGameMenu so it gets the updated ScenarioInfo, + -- being sure to preserve the same focused scenario. + sc <- use $ runtimeState . scenarios + forM_ (mkNewGameMenu sc (fromMaybe p curPath)) (uiState . uiMenu .=) diff --git a/src/swarm-tui/Swarm/TUI/Controller/Util.hs b/src/swarm-tui/Swarm/TUI/Controller/Util.hs index 0ad84b013..5cc9cb064 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/Util.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/Util.hs @@ -194,7 +194,7 @@ allHandlers eEmbed f = map handleEvent1 enumerate handleEvent1 e1 = let (n, a) = f e1 in onEvent (eEmbed e1) n a runBaseTerm :: (MonadState AppState m) => Maybe TSyntax -> m () -runBaseTerm = maybe (pure ()) startBaseProgram +runBaseTerm = mapM_ startBaseProgram where -- The player typed something at the REPL and hit Enter; this -- function takes the resulting term (if the REPL diff --git a/src/swarm-tui/Swarm/TUI/Editor/Controller.hs b/src/swarm-tui/Swarm/TUI/Editor/Controller.hs index 0029b17f1..a28c05f37 100644 --- a/src/swarm-tui/Swarm/TUI/Editor/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Editor/Controller.hs @@ -68,7 +68,6 @@ handleCtrlLeftClick mouseLoc = do worldOverdraw . paintedTerrain %= M.insert (mouseCoords ^. planar) (terrain, maybeToErasable maybeEntityPaint) lastWorldEditorMessage .= Nothing immediatelyRedrawWorld - return () handleRightClick :: B.Location -> EventM Name AppState () handleRightClick mouseLoc = do @@ -78,7 +77,6 @@ handleRightClick mouseLoc = do mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc uiState . uiGameplay . uiWorldEditor . worldOverdraw . paintedTerrain %= M.delete (mouseCoords ^. planar) immediatelyRedrawWorld - return () -- | "Eye Dropper" tool: handleMiddleClick :: B.Location -> EventM Name AppState () diff --git a/test/integration/Main.hs b/test/integration/Main.hs index 2b835a534..84961cf94 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -135,13 +135,13 @@ isError :: LogEntry -> Bool isError = (>= Warning) . view leSeverity exampleTests :: [FilePath] -> TestTree -exampleTests inputs = testGroup "Test example" (map exampleTest inputs) +exampleTests = testGroup "Test example" . map exampleTest exampleTest :: FilePath -> TestTree exampleTest path = testCase ("processTerm for contents of " ++ show path) $ do value <- processTerm <$> T.readFile path - either (assertFailure . into @String) (\_ -> return ()) value + either (assertFailure . into @String) (const $ return ()) value scenarioParseTests :: ScenarioInputs -> [FilePath] -> TestTree scenarioParseTests scenarioInputs inputs = @@ -166,11 +166,9 @@ getScenario expRes scenarioInputs p = do res <- decodeFileEitherE scenarioInputs p :: IO (Either ParseException Scenario) case expRes of Parsed -> case res of - Left err -> assertFailure (prettyPrintParseException err) + Left err -> assertFailure $ prettyPrintParseException err Right _s -> return () - Failed -> case res of - Left _err -> return () - Right _s -> assertFailure "Unexpectedly parsed invalid scenario!" + Failed -> forM_ res $ const $ assertFailure "Unexpectedly parsed invalid scenario!" data Time = -- | One second should be enough to run most programs. diff --git a/test/unit/TestOverlay.hs b/test/unit/TestOverlay.hs index a9aadafcc..13bb39805 100644 --- a/test/unit/TestOverlay.hs +++ b/test/unit/TestOverlay.hs @@ -214,8 +214,6 @@ mkNamedStructure theName pos g = mempty renderGridResult :: Either a (PositionedGrid (Maybe Int)) -> IO () -renderGridResult eitherResult = case eitherResult of - Right pg -> do - print pg - print $ getRows $ gridContent pg - Left _ -> return () +renderGridResult = mapM_ $ \pg -> do + print pg + print $ getRows $ gridContent pg