Merge branch 'main' into robot-into-water

.hlint.yaml

@@ -24,9 +24,10 @@
 #   - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
 #   - {name: Control.Arrow, within: []} # Certain modules are banned entirely
 #
-# - functions:
-#   - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
-
+- functions:
+  - {name: Data.List.head, within: []}
+  - {name: Prelude.head, within: []}
+  - {name: Data.List.NonEmpty.fromList, within: [Swarm.Util, Swarm.Util.Parse]}
 
 # Add custom hints for this project
 #

src/Swarm/Doc/Gen.hs

@@ -24,6 +24,7 @@ module Swarm.Doc.Gen (
 ) where
 
 import Control.Effect.Lift
+import Control.Effect.Throw (Throw, throwError)
 import Control.Lens (view, (^.))
 import Control.Lens.Combinators (to)
 import Control.Monad (zipWithM, zipWithM_)
@@ -32,7 +33,7 @@ import Data.Foldable (find, toList)
 import Data.List (transpose)
 import Data.Map.Lazy (Map, (!))
 import Data.Map.Lazy qualified as Map
-import Data.Maybe (fromMaybe, isJust)
+import Data.Maybe (fromMaybe, isJust, listToMaybe)
 import Data.Sequence (Seq)
 import Data.Set (Set)
 import Data.Set qualified as Set
@@ -44,7 +45,7 @@ import Swarm.Doc.Pedagogy
 import Swarm.Game.Display (displayChar)
 import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityDisplay, entityName, loadEntities)
 import Swarm.Game.Entity qualified as E
-import Swarm.Game.Failure (SystemFailure)
+import Swarm.Game.Failure (SystemFailure (CustomFailure))
 import Swarm.Game.Recipe (Recipe, loadRecipes, recipeCatalysts, recipeInputs, recipeOutputs, recipeTime, recipeWeight)
 import Swarm.Game.Robot (Robot, equippedDevices, instantiateRobot, robotInventory)
 import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots)
@@ -419,6 +420,11 @@ recipeTable a rs = T.unlines $ header <> map (listToRow mw) recipeRows
 recipePage :: PageAddress -> [Recipe Entity] -> Text
 recipePage = recipeTable
 
+getBaseRobot :: Has (Throw SystemFailure) sig m => Scenario -> m Robot
+getBaseRobot s = case listToMaybe $ view scenarioRobots s of
+  Just r -> pure $ instantiateRobot 0 r
+  Nothing -> throwError $ CustomFailure "Scenario contains no robots"
+
 -- ----------------------------------------------------------------------------
 -- GENERATE GRAPHVIZ: ENTITY DEPENDENCIES BY RECIPES
 -- ----------------------------------------------------------------------------
@@ -429,10 +435,11 @@ generateRecipe = simpleErrorHandle $ do
   recipes <- loadRecipes entities
   worlds <- ignoreWarnings @(Seq SystemFailure) $ loadWorlds entities
   classic <- fst <$> loadScenario "data/scenarios/classic.yaml" entities worlds
-  return . Dot.showDot $ recipesToDot classic (worlds ! "classic") entities recipes
+  baseRobot <- getBaseRobot classic
+  return . Dot.showDot $ recipesToDot baseRobot (worlds ! "classic") entities recipes
 
-recipesToDot :: Scenario -> Some (TTerm '[]) -> EntityMap -> [Recipe Entity] -> Dot ()
-recipesToDot classic classicTerm emap recipes = do
+recipesToDot :: Robot -> Some (TTerm '[]) -> EntityMap -> [Recipe Entity] -> Dot ()
+recipesToDot baseRobot classicTerm emap recipes = do
   Dot.attribute ("rankdir", "LR")
   Dot.attribute ("ranksep", "2")
   world <- diamond "World"
@@ -450,8 +457,8 @@ recipesToDot classic classicTerm emap recipes = do
   -- --------------------------------------------------------------------------
   -- Get the starting inventories, entities present in the world and compute
   -- how hard each entity is to get - see 'recipeLevels'.
-  let devs = startingDevices classic
-      inv = startingInventory classic
+  let devs = startingDevices baseRobot
+      inv = startingInventory baseRobot
       worldEntities = case classicTerm of Some _ t -> extractEntities t
       levels = recipeLevels recipes (Set.unions [worldEntities, devs])
   -- --------------------------------------------------------------------------
@@ -547,14 +554,11 @@ recipeLevels recipes start = levels
             then ls
             else go (n : ls) (Set.union n known)
 
-startingHelper :: Scenario -> Robot
-startingHelper = instantiateRobot 0 . head . view scenarioRobots
-
-startingDevices :: Scenario -> Set Entity
-startingDevices = Set.fromList . map snd . E.elems . view equippedDevices . startingHelper
+startingDevices :: Robot -> Set Entity
+startingDevices = Set.fromList . map snd . E.elems . view equippedDevices
 
-startingInventory :: Scenario -> Map Entity Int
-startingInventory = Map.fromList . map swap . E.elems . view robotInventory . startingHelper
+startingInventory :: Robot -> Map Entity Int
+startingInventory = Map.fromList . map swap . E.elems . view robotInventory
 
 -- | Ignore utility entities that are just used for tutorials and challenges.
 ignoredEntities :: Set Text

src/Swarm/Game/Achievement/Definitions.hs

@@ -19,6 +19,8 @@ module Swarm.Game.Achievement.Definitions (
 import Data.Aeson
 import Data.Text (Text)
 import GHC.Generics (Generic)
+import Swarm.Language.Syntax (Syntax)
+import Swarm.Language.Text.Markdown (Document)
 import Swarm.Util
 
 -- | How hard do we expect the achievement to be?
@@ -39,7 +41,7 @@ data Quotation = Quotation
 -- | Flavor text to spice up the description of an achievement, either
 --   freeform text or a quotation.
 data FlavorText
-  = Freeform Text
+  = Freeform (Document Syntax)
   | FTQuotation Quotation
   deriving (Eq, Show, Generic, FromJSON, ToJSON)
 
@@ -58,7 +60,7 @@ data AchievementInfo = AchievementInfo
   -- ^ Explain the reference, e.g. in the form of a full quote
   -- from a movie, or something you might find
   -- in a fortune cookie
-  , attainmentProcess :: Text
+  , attainmentProcess :: Document Syntax
   -- ^ Precisely what must be done to obtain this achievement.
   , effort :: ExpectedEffort
   -- ^ How hard the achievement is expected to be.

src/Swarm/Game/Achievement/Description.hs

@@ -85,6 +85,6 @@ describe = \case
               "Lil Jon"
               "Fire up that loud / Another round of shots / Turn down for what?"
       )
-      "'turn down' without a compass. Congratulations, you are 'disoriented'. How are you supposed to move now?"
+      "`turn down` without a compass. Congratulations, you are \"disoriented\". How are you supposed to move now?"
       Easy
       True

src/Swarm/Game/Exception.hs

@@ -17,6 +17,7 @@ module Swarm.Game.Exception (
 
 import Control.Lens ((^.))
 import Data.Aeson (FromJSON, ToJSON)
+import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.Map qualified as M
 import Data.Set qualified as S
 import Data.Text (Text)
@@ -142,29 +143,29 @@ formatIncapableFix = \case
 formatIncapable :: EntityMap -> IncapableFix -> Requirements -> Term -> Text
 formatIncapable em f (Requirements caps _ inv) tm
   | CGod `S.member` caps =
-      unlinesExText
-        [ "Thou shalt not utter such blasphemy:"
-        , squote $ prettyText tm
-        , "If God in troth thou wantest to play, try thou a Creative game."
-        ]
+      unlinesExText $
+        "Thou shalt not utter such blasphemy:"
+          :| [ squote $ prettyText tm
+             , "If God in troth thou wantest to play, try thou a Creative game."
+             ]
   | not (null capsNone) =
-      unlinesExText
-        [ "Missing the " <> capMsg <> " for:"
-        , squote $ prettyText tm
-        , "but no device yet provides it. See"
-        , swarmRepoUrl <> "issues/26"
-        ]
+      unlinesExText $
+        "Missing the " <> capMsg <> " for:"
+          :| [ squote $ prettyText tm
+             , "but no device yet provides it. See"
+             , swarmRepoUrl <> "issues/26"
+             ]
   | not (S.null caps) =
       unlinesExText
         ( "You do not have the devices required for:"
-            : squote (prettyText tm)
+            :| squote (prettyText tm)
             : "Please " <> formatIncapableFix f <> ":"
             : (("- " <>) . formatDevices <$> filter (not . null) deviceSets)
         )
   | otherwise =
       unlinesExText
         ( "You are missing required inventory for:"
-            : squote (prettyText tm)
+            :| squote (prettyText tm)
             : "Please obtain:"
             : (("- " <>) . formatEntity <$> M.assocs inv)
         )
@@ -182,5 +183,5 @@ formatIncapable em f (Requirements caps _ inv) tm
   formatEntity (e, n) = e <> " (" <> from (show n) <> ")"
 
 -- | Exceptions that span multiple lines should be indented.
-unlinesExText :: [Text] -> Text
-unlinesExText ts = T.unlines . (head ts :) . map ("  " <>) $ tail ts
+unlinesExText :: NonEmpty Text -> Text
+unlinesExText (t :| ts) = T.unlines $ (t :) $ map ("  " <>) ts

src/Swarm/Game/Failure.hs

@@ -44,7 +44,7 @@ data Asset = Achievement | Data AssetData | History | Save
 data Entry = Directory | File
   deriving (Eq, Show)
 
--- | An error that occured while attempting to load some kind of asset.
+-- | An error that occurred while attempting to load some kind of asset.
 data LoadingFailure
   = DoesNotExist Entry
   | EntryNot Entry

src/Swarm/Game/Scenario/Topography/Cell.hs

@@ -11,8 +11,8 @@ module Swarm.Game.Scenario.Topography.Cell (
 ) where
 
 import Control.Lens hiding (from, (.=), (<.>))
-import Control.Monad (when)
 import Control.Monad.Extra (mapMaybeM)
+import Data.List.NonEmpty qualified as NE
 import Data.Maybe (catMaybes, listToMaybe)
 import Data.Text (Text)
 import Data.Vector qualified as V
@@ -69,10 +69,12 @@ instance ToJSON Cell where
 
 instance FromJSONE (EntityMap, RobotMap) Cell where
   parseJSONE = withArrayE "tuple" $ \v -> do
-    let tup = V.toList v
-    when (null tup) $ fail "palette entry must nonzero length (terrain, optional entity and then robots if any)"
+    let tupRaw = V.toList v
+    tup <- case NE.nonEmpty tupRaw of
+      Nothing -> fail "palette entry must have nonzero length (terrain, optional entity and then robots if any)"
+      Just x -> return x
 
-    terr <- liftE $ parseJSON (head tup)
+    terr <- liftE $ parseJSON (NE.head tup)
 
     ent <- case tup ^? ix 1 of
       Nothing -> return ENothing
@@ -87,7 +89,7 @@ instance FromJSONE (EntityMap, RobotMap) Cell where
           mrName <- liftE $ parseJSON @(Maybe RobotName) r
           traverse (localE snd . getRobot) mrName
 
-    robs <- mapMaybeM name2rob (drop 2 tup)
+    robs <- mapMaybeM name2rob (drop 2 tupRaw)
 
     return $ Cell terr ent robs
 

src/Swarm/Game/State.hs

@@ -146,7 +146,7 @@ import Data.List.NonEmpty (NonEmpty)
 import Data.List.NonEmpty qualified as NE
 import Data.Map (Map)
 import Data.Map qualified as M
-import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
+import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)
 import Data.Sequence (Seq ((:<|)))
 import Data.Sequence qualified as Seq
 import Data.Set qualified as S
@@ -1244,7 +1244,7 @@ buildWorld :: WorldDescription -> ([IndexedTRobot], Seed -> WorldFun Int Entity)
 buildWorld WorldDescription {..} = (robots worldName, first fromEnum . wf)
  where
   rs = fromIntegral $ length area
-  cs = fromIntegral $ length (head area)
+  cs = fromIntegral $ maybe 0 length $ listToMaybe area
   Coords (ulr, ulc) = locToCoords ul
 
   worldGrid :: [[(TerrainType, Erasable Entity)]]

src/Swarm/Game/Terrain.hs

@@ -14,11 +14,12 @@ module Swarm.Game.Terrain (
 ) where
 
 import Data.Aeson (FromJSON (..), withText)
+import Data.List.NonEmpty qualified as NE
 import Data.Map (Map)
 import Data.Map qualified as M
 import Data.Text qualified as T
 import Swarm.Game.Display
-import Swarm.Util (failT)
+import Swarm.Util (failT, showEnum)
 import Text.Read (readMaybe)
 import Witch (into)
 
@@ -49,7 +50,7 @@ instance FromJSON TerrainType where
       Nothing -> failT ["Unknown terrain type:", t]
 
 getTerrainDefaultPaletteChar :: TerrainType -> Char
-getTerrainDefaultPaletteChar = head . show
+getTerrainDefaultPaletteChar = NE.head . showEnum
 
 getTerrainWord :: TerrainType -> T.Text
 getTerrainWord = T.toLower . T.pack . init . show

src/Swarm/Game/World/Parse.hs

@@ -10,13 +10,12 @@
 -- Parser for the Swarm world description DSL.
 module Swarm.Game.World.Parse where
 
-import Control.Monad (MonadPlus, void)
+import Control.Monad (void)
 import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)
-import Data.List.NonEmpty (NonEmpty)
-import Data.List.NonEmpty qualified as NE
+import Control.Monad.Combinators.NonEmpty qualified as CNE (sepBy1)
 import Data.Text (Text)
 import Data.Text qualified as T
-import Data.Void
+import Data.Void (Void)
 import Data.Yaml (FromJSON (parseJSON), withText)
 import Swarm.Game.World.Syntax
 import Swarm.Util (failT, showT, squote)
@@ -29,12 +28,6 @@ import Witch (into)
 type Parser = Parsec Void Text
 type ParserError = ParseErrorBundle Text Void
 
-------------------------------------------------------------
--- Utility
-
-sepByNE :: (MonadPlus m) => m a -> m sep -> m (NonEmpty a)
-sepByNE p sep = NE.fromList <$> p `sepBy1` sep
-
 ------------------------------------------------------------
 -- Lexing
 
@@ -233,7 +226,7 @@ parseLet =
 parseOverlay :: Parser WExp
 parseOverlay = do
   reserved "overlay"
-  brackets $ WOverlay <$> parseWExp `sepByNE` comma
+  brackets $ WOverlay <$> parseWExp `CNE.sepBy1` comma
 
 parseMask :: Parser WExp
 parseMask = do

src/Swarm/TUI/Controller.hs

@@ -172,7 +172,7 @@ handleMainMenuEvent menu = \case
         NewGame -> do
           cheat <- use $ uiState . uiCheatMode
           ss <- use $ runtimeState . scenarios
-          uiState . uiMenu .= NewGameMenu (NE.fromList [mkScenarioList cheat ss])
+          uiState . uiMenu .= NewGameMenu (pure $ mkScenarioList cheat ss)
         Tutorial -> do
           -- Set up the menu stack as if the user had chosen "New Game > Tutorials"
           cheat <- use $ uiState . uiCheatMode
@@ -183,7 +183,7 @@ handleMainMenuEvent menu = \case
                   ((== tutorialsDirname) . T.unpack . scenarioItemName)
                   (mkScenarioList cheat ss)
               tutorialMenu = mkScenarioList cheat tutorialCollection
-              menuStack = NE.fromList [tutorialMenu, topMenu]
+              menuStack = tutorialMenu :| pure topMenu
           uiState . uiMenu .= NewGameMenu menuStack
 
           -- Extract the first tutorial challenge and run it

src/Swarm/TUI/Model/Menu.hs

@@ -108,7 +108,7 @@ mkScenarioList cheat = flip (BL.list ScenarioList) 1 . V.fromList . filterTest .
 --   path to some folder or scenario, construct a 'NewGameMenu' stack
 --   focused on the given item, if possible.
 mkNewGameMenu :: Bool -> ScenarioCollection -> FilePath -> Maybe Menu
-mkNewGameMenu cheat sc path = NewGameMenu . NE.fromList <$> go (Just sc) (splitPath path) []
+mkNewGameMenu cheat sc path = fmap NewGameMenu $ NE.nonEmpty =<< go (Just sc) (splitPath path) []
  where
   go ::
     Maybe ScenarioCollection ->

src/Swarm/TUI/View/Achievement.hs

@@ -18,6 +18,7 @@ import Swarm.Game.Achievement.Description
 import Swarm.TUI.Model
 import Swarm.TUI.Model.UI
 import Swarm.TUI.View.Attribute.Attr
+import Swarm.TUI.View.Util (drawMarkdown)
 import Text.Wrap
 
 padAllEvenly :: Int -> Widget Name -> Widget Name
@@ -66,7 +67,7 @@ singleAchievementDetails attainedMap x =
   wasAttained = M.member x attainedMap
 
   renderFlavorTextWidget :: FlavorText -> Widget Name
-  renderFlavorTextWidget (Freeform t) = txtWrap t
+  renderFlavorTextWidget (Freeform t) = drawMarkdown t
   renderFlavorTextWidget (FTQuotation (Quotation author quoteContent)) =
     vBox
       [ txtWrap quoteContent
@@ -79,10 +80,9 @@ singleAchievementDetails attainedMap x =
   innerContent =
     vBox
       [ maybe emptyWidget (padAllEvenly 2 . renderFlavorTextWidget) $ humorousElaboration details
-      , txtWrap $
-          if wasAttained || not (isObfuscated details)
-            then attainmentProcess details
-            else "???"
+      , if wasAttained || not (isObfuscated details)
+          then drawMarkdown $ attainmentProcess details
+          else txt "???"
       , case M.lookup x attainedMap of
           Nothing -> emptyWidget
           Just attainment ->

src/Swarm/TUI/View/Objective.hs

@@ -34,12 +34,16 @@ renderGoalsDisplay :: GoalDisplay -> Widget Name
 renderGoalsDisplay gd =
   if hasMultiple
     then
-      hBox
-        [ leftSide
-        , hLimitPercent 70 $ padLeft (Pad 2) goalElaboration
+      vBox
+        [ hBox
+            [ leftSide
+            , hLimitPercent 70 $ padLeft (Pad 2) goalElaboration
+            ]
+        , footer
         ]
     else goalElaboration
  where
+  footer = hCenter $ withAttr italicAttr $ txt "NOTE: [Tab] toggles focus between panes"
   hasMultiple = hasMultipleGoals $ gd ^. goalsContent
   lw = _listWidget gd
   fr = _focus gd