Use and enforce Char as palette keys (#2077)

As title

data/scenarios/Testing/_Validation/2077-palette-chars.yaml

@@ -0,0 +1,14 @@
+version: 1
+name: Enforce single-char palette keys
+description: |
+  No multiple-char or zero-length entries allowed.
+robots: []
+world:
+  palette:
+    '.': [grass]
+    '': [stone]
+    'foo': [dirt]
+  upperleft: [0, 0]
+  map: |
+    ..
+    ..

src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldPalette.hs

@@ -4,7 +4,6 @@
 -- SPDX-License-Identifier: BSD-3-Clause
 module Swarm.Game.Scenario.Topography.WorldPalette where
 
-import Control.Arrow (first)
 import Control.Lens hiding (from, (.=), (<.>))
 import Data.Aeson.KeyMap qualified as KM
 import Data.Map qualified as M
@@ -105,9 +104,8 @@ prepForJson (PaletteAndMaskChar (StructurePalette suggestedPalette) maybeMaskCha
  where
   preassignments :: [(Char, TerrainWith EntityFacade)]
   preassignments =
-    map (first T.head . fmap (cellToTerrainPair . standardCell)) $
-      M.toList $
-        KM.toMapText suggestedPalette
+    map (fmap (cellToTerrainPair . standardCell)) $
+      M.toList suggestedPalette
 
   entityCells :: M.Map (TerrainWith EntityName) (TerrainWith EntityFacade)
   entityCells = getUniqueTerrainFacadePairs $ catMaybes $ allMembers cellGrid

src/swarm-topography/Swarm/Game/Scenario/Topography/ProtoCell.hs

@@ -9,19 +9,38 @@ module Swarm.Game.Scenario.Topography.ProtoCell (
 ) where
 
 import Control.Applicative ((<|>))
-import Data.Aeson.KeyMap (KeyMap)
+import Data.Aeson.Key qualified as K
+import Data.Aeson.KeyMap qualified as KM
+import Data.Map (Map, fromList, toList)
+import Data.Text qualified as T
+import Data.Tuple (swap)
 import Data.Yaml as Y
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointConfig)
+import Swarm.Util (quote)
 import Swarm.Util.Yaml
 
 newtype StructurePalette e = StructurePalette
-  {unPalette :: KeyMap (SignpostableCell e)}
+  {unPalette :: Map Char (SignpostableCell e)}
   deriving (Eq, Show)
 
 instance (FromJSONE e a) => FromJSONE e (StructurePalette a) where
   parseJSONE =
-    withObjectE "palette" $
-      fmap StructurePalette . mapM parseJSONE
+    withObjectE "palette" $ \v -> do
+      m <- mapM parseJSONE v
+      -- We swap the tuples twice so we can traverse over the second
+      -- element of the tuple in between.
+      swappedPairs <- mapM (verifyChar . swap) $ toList $ KM.toMap m
+      return . StructurePalette . fromList $ map swap swappedPairs
+   where
+    verifyChar = traverse $ ensureSingleChar . K.toString
+    ensureSingleChar [x] = return x
+    ensureSingleChar x =
+      fail $
+        T.unpack $
+          T.unwords
+            [ "Palette entry is not a single character:"
+            , quote $ T.pack x
+            ]
 
 -- | Supplements a cell with waypoint information
 data SignpostableCell c = SignpostableCell

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs

@@ -10,8 +10,7 @@
 module Swarm.Game.Scenario.Topography.Structure where
 
 import Control.Monad (unless)
-import Data.Aeson.Key qualified as Key
-import Data.Aeson.KeyMap qualified as KeyMap
+import Data.List (intercalate)
 import Data.List.NonEmpty qualified as NE
 import Data.Map qualified as M
 import Data.Maybe (catMaybes)
@@ -133,18 +132,17 @@ paintMap ::
   m (Grid (Maybe c), [Waypoint])
 paintMap maskChar pal g = do
   nestedLists <- mapM toCell g
-  let usedChars = Set.fromList $ map T.singleton $ allMembers g
+  let usedChars = Set.fromList $ allMembers g
       unusedChars =
         filter (`Set.notMember` usedChars)
           . M.keys
-          . KeyMap.toMapText
           $ unPalette pal
 
   unless (null unusedChars) $
     fail $
       unwords
         [ "Unused characters in palette:"
-        , T.unpack $ T.intercalate ", " unusedChars
+        , intercalate ", " $ map pure unusedChars
         ]
 
   let cells = fmap standardCell <$> nestedLists
@@ -158,6 +156,6 @@ paintMap maskChar pal g = do
   toCell c =
     if Just c == maskChar
       then return Nothing
-      else case KeyMap.lookup (Key.fromString [c]) (unPalette pal) of
+      else case M.lookup c (unPalette pal) of
         Nothing -> failT ["Char not in world palette:", showT c]
         Just cell -> return $ Just cell

src/swarm-tui/Swarm/TUI/Editor/Palette.hs

@@ -7,7 +7,6 @@ module Swarm.TUI.Editor.Palette where
 
 import Control.Lens
 import Control.Monad (guard)
-import Data.Aeson.KeyMap qualified as KM
 import Data.List (sortOn)
 import Data.List.NonEmpty qualified as NE
 import Data.Map (Map)
@@ -16,7 +15,6 @@ import Data.Maybe (catMaybes, mapMaybe)
 import Data.Ord (Down (..))
 import Data.Set (Set)
 import Data.Set qualified as Set
-import Data.Text qualified as T
 import Data.Tuple (swap)
 import Swarm.Game.Display (Display, defaultChar)
 import Swarm.Game.Entity (Entity, EntityName, entitiesByName)
@@ -41,12 +39,11 @@ import Swarm.Util.Erasable
 
 makeSuggestedPalette ::
   TerrainMap ->
-  KM.KeyMap (AugmentedCell Entity) ->
+  Map Char (AugmentedCell Entity) ->
   Grid (Maybe CellPaintDisplay) ->
-  KM.KeyMap (AugmentedCell EntityFacade)
+  Map Char (AugmentedCell EntityFacade)
 makeSuggestedPalette tm originalScenarioPalette cellGrid =
-  KM.fromMapText
-    . M.map (SignpostableCell Nothing)
+  M.map (SignpostableCell Nothing)
     . M.fromList
     . M.elems
     -- NOTE: the left-most maps take precedence!
@@ -87,38 +84,38 @@ makeSuggestedPalette tm originalScenarioPalette cellGrid =
   invertPaletteMapToDedupe =
     map (\x@(_, c) -> (toKey $ cellToTerrainPair c, x)) . M.toList
 
-  paletteCellsByKey :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay)
+  paletteCellsByKey :: Map (TerrainWith EntityName) (Char, CellPaintDisplay)
   paletteCellsByKey =
     M.map (NE.head . NE.sortWith toSortVal)
       . binTuples
       . invertPaletteMapToDedupe
-      $ KM.toMapText originalPalette
+      $ originalPalette
    where
     toSortVal (symbol, Cell _terrain _maybeEntity robots) = Down (null robots, symbol)
 
   excludedPaletteChars :: Set Char
   excludedPaletteChars = Set.fromList [' ']
 
-  originalPalette :: KM.KeyMap CellPaintDisplay
+  originalPalette :: Map Char CellPaintDisplay
   originalPalette =
-    KM.map (toCellPaintDisplay . standardCell) originalScenarioPalette
+    M.map (toCellPaintDisplay . standardCell) originalScenarioPalette
 
-  pairsWithDisplays :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay)
+  pairsWithDisplays :: Map (TerrainWith EntityName) (Char, CellPaintDisplay)
   pairsWithDisplays = M.fromList $ mapMaybe g entitiesWithModalTerrain
    where
     g (terrain, eName) = do
       eDisplay <- M.lookup eName usedEntityDisplays
       let displayChar = eDisplay ^. defaultChar
       guard $ Set.notMember displayChar excludedPaletteChars
       let cell = Cell terrain (EJust $ EntityFacade eName eDisplay) []
-      return ((terrain, EJust eName), (T.singleton displayChar, cell))
+      return ((terrain, EJust eName), (displayChar, cell))
 
   -- TODO (#1153): Filter out terrain-only palette entries that aren't actually
   -- used in the map.
-  terrainOnlyPalette :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay)
+  terrainOnlyPalette :: Map (TerrainWith EntityName) (Char, CellPaintDisplay)
   terrainOnlyPalette = M.fromList . map f . M.keys $ terrainByName tm
    where
-    f x = ((x, ENothing), (T.singleton $ getTerrainDefaultPaletteChar x, Cell x ENothing []))
+    f x = ((x, ENothing), (getTerrainDefaultPaletteChar x, Cell x ENothing []))
 
 -- | Generate a \"skeleton\" scenario with placeholders for certain required fields
 constructScenario :: Maybe Scenario -> Grid (Maybe CellPaintDisplay) -> SkeletonScenario