Use internal attribute type in Display (#1100)

This avoids using `Brick.AttrName` and we can remove the `-fno-warn-orphans` from `Attr.hs`.

As a bonus, we can now specify a terrain attribute (`terrain_stone`) in a scenario along with the `default` attribute.

- split off from #1069
- part of #1043

src/Swarm/Game/Display.hs

@@ -15,6 +15,7 @@
 module Swarm.Game.Display (
   -- * The display record
   Priority,
+  Attribute (..),
   Display,
 
   -- ** Fields
@@ -27,7 +28,6 @@ module Swarm.Game.Display (
 
   -- ** Rendering
   displayChar,
-  renderDisplay,
   hidden,
 
   -- ** Construction
@@ -36,33 +36,54 @@ module Swarm.Game.Display (
   defaultRobotDisplay,
 ) where
 
-import Brick (AttrName, Widget, str, withAttr)
 import Control.Lens hiding (Const, from, (.=))
 import Data.Hashable (Hashable)
 import Data.Map (Map)
 import Data.Map qualified as M
 import Data.Maybe (fromMaybe, isJust)
+import Data.Text (Text)
+import Data.Text qualified as T
 import Data.Yaml
 import GHC.Generics (Generic)
 import Swarm.Language.Syntax (AbsoluteDir (..), Direction (..))
-import Swarm.TUI.Attr (entityAttr, robotAttr, worldPrefix)
 import Swarm.Util (maxOn)
 import Swarm.Util.Yaml (FromJSONE (..), With (runE), getE, liftE, withObjectE)
 
 -- | Display priority.  Entities with higher priority will be drawn on
 --   top of entities with lower priority.
 type Priority = Int
 
--- Some orphan instances we need to be able to derive a Hashable
--- instance for Display
-instance Hashable AttrName
+-- | An internal attribute name.
+data Attribute = ADefault | ARobot | AEntity | AWorld Text | ATerrain Text
+  deriving (Eq, Ord, Show, Generic, Hashable)
+
+terrainPrefix :: Text
+terrainPrefix = "terrain_"
+
+instance FromJSON Attribute where
+  parseJSON =
+    withText "attribute" $
+      pure . \case
+        "robot" -> ARobot
+        "entity" -> AEntity
+        "default" -> ADefault
+        t | terrainPrefix `T.isPrefixOf` t -> ATerrain $ T.drop (T.length terrainPrefix) t
+        w -> AWorld w
+
+instance ToJSON Attribute where
+  toJSON = \case
+    ADefault -> String "default"
+    ARobot -> String "robot"
+    AEntity -> String "entity"
+    AWorld w -> String w
+    ATerrain t -> String $ terrainPrefix <> t
 
 -- | A record explaining how to display an entity in the TUI.
 data Display = Display
   { _defaultChar :: Char
   , _orientationMap :: Map AbsoluteDir Char
   , _curOrientation :: Maybe Direction
-  , _displayAttr :: AttrName
+  , _displayAttr :: Attribute
   , _displayPriority :: Priority
   , _invisible :: Bool
   }
@@ -90,7 +111,7 @@ orientationMap :: Lens' Display (Map AbsoluteDir Char)
 curOrientation :: Lens' Display (Maybe Direction)
 
 -- | The attribute to use for display.
-displayAttr :: Lens' Display AttrName
+displayAttr :: Lens' Display Attribute
 
 -- | This entity's display priority. Higher priorities are drawn
 --   on top of lower.
@@ -112,7 +133,7 @@ instance FromJSONE Display Display where
       Display c
         <$> v .:? "orientationMap" .!= dOM
         <*> v .:? "curOrientation" .!= (defD ^. curOrientation)
-        <*> (fmap (worldPrefix <>) <$> v .:? "attr") .!= (defD ^. displayAttr)
+        <*> (v .:? "attr") .!= (defD ^. displayAttr)
         <*> v .:? "priority" .!= (defD ^. displayPriority)
         <*> v .:? "invisible" .!= (defD ^. invisible)
 
@@ -132,18 +153,14 @@ displayChar disp = fromMaybe (disp ^. defaultChar) $ do
   DAbsolute d <- disp ^. curOrientation
   M.lookup d (disp ^. orientationMap)
 
--- | Render a display as a UI widget.
-renderDisplay :: Display -> Widget n
-renderDisplay disp = withAttr (disp ^. displayAttr) $ str [displayChar disp]
-
 -- | Modify a display to use a @?@ character for entities that are
 --   hidden/unknown.
 hidden :: Display -> Display
 hidden = (defaultChar .~ '?') . (curOrientation .~ Nothing)
 
 -- | The default way to display some terrain using the given character
 --   and attribute, with priority 0.
-defaultTerrainDisplay :: Char -> AttrName -> Display
+defaultTerrainDisplay :: Char -> Attribute -> Display
 defaultTerrainDisplay c attr =
   defaultEntityDisplay c
     & displayPriority .~ 0
@@ -157,7 +174,7 @@ defaultEntityDisplay c =
     { _defaultChar = c
     , _orientationMap = M.empty
     , _curOrientation = Nothing
-    , _displayAttr = entityAttr
+    , _displayAttr = AEntity
     , _displayPriority = 1
     , _invisible = False
     }
@@ -180,7 +197,7 @@ defaultRobotDisplay =
           , (DNorth, '^')
           ]
     , _curOrientation = Nothing
-    , _displayAttr = robotAttr
+    , _displayAttr = ARobot
     , _displayPriority = 10
     , _invisible = False
     }

src/Swarm/Game/Terrain.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 -- |
 -- Module      :  Swarm.Game.Terrain
 -- Copyright   :  Brent Yorgey
@@ -17,7 +19,6 @@ import Data.Map (Map)
 import Data.Map qualified as M
 import Data.Text qualified as T
 import Swarm.Game.Display
-import Swarm.TUI.Attr
 import Text.Read (readMaybe)
 import Witch (into)
 
@@ -41,9 +42,9 @@ instance FromJSON TerrainType where
 terrainMap :: Map TerrainType Display
 terrainMap =
   M.fromList
-    [ (StoneT, defaultTerrainDisplay '▒' rockAttr)
-    , (DirtT, defaultTerrainDisplay '▒' dirtAttr)
-    , (GrassT, defaultTerrainDisplay '▒' grassAttr)
-    , (IceT, defaultTerrainDisplay ' ' iceAttr)
-    , (BlankT, defaultTerrainDisplay ' ' defAttr)
+    [ (StoneT, defaultTerrainDisplay '▒' (ATerrain "stone"))
+    , (DirtT, defaultTerrainDisplay '▒' (ATerrain "dirt"))
+    , (GrassT, defaultTerrainDisplay '▒' (ATerrain "grass"))
+    , (IceT, defaultTerrainDisplay ' ' (ATerrain "ice"))
+    , (BlankT, defaultTerrainDisplay ' ' ADefault)
     ]

src/Swarm/TUI/Attr.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- |
 -- Module      :  Swarm.TUI.Attr
@@ -20,6 +19,7 @@ module Swarm.TUI.Attr (
   swarmAttrMap,
   worldAttributes,
   worldPrefix,
+  toAttrName,
 
   -- ** Terrain attributes
   dirtAttr,
@@ -55,9 +55,17 @@ import Brick.Forms
 import Brick.Widgets.Dialog
 import Brick.Widgets.List
 import Data.Bifunctor (bimap)
-import Data.Yaml
+import Data.Text (unpack)
 import Graphics.Vty qualified as V
-import Witch (from)
+import Swarm.Game.Display (Attribute (..))
+
+toAttrName :: Attribute -> AttrName
+toAttrName = \case
+  ARobot -> robotAttr
+  AEntity -> entityAttr
+  AWorld n -> worldPrefix <> attrName (unpack n)
+  ATerrain n -> terrainPrefix <> attrName (unpack n)
+  ADefault -> defAttr
 
 -- | A mapping from the defined attribute names to TUI attributes.
 swarmAttrMap :: AttrMap
@@ -173,9 +181,3 @@ yellowAttr = attrName "yellow"
 cyanAttr = attrName "cyan"
 lightCyanAttr = attrName "lightCyan"
 magentaAttr = attrName "magenta"
-
-instance ToJSON AttrName where
-  toJSON = toJSON . head . attrNameComponents
-
-instance FromJSON AttrName where
-  parseJSON = withText "AttrName" (pure . attrName . from)

src/Swarm/TUI/View/CellDisplay.hs

@@ -10,10 +10,15 @@ import Swarm.Game.Display
 import Swarm.Game.Entity as E
 import Swarm.Game.Robot
 import Swarm.Game.State
-import Swarm.Game.Terrain (terrainMap)
+import Swarm.Game.Terrain
 import Swarm.Game.World qualified as W
+import Swarm.TUI.Attr
 import Swarm.TUI.Model.Name
 
+-- | Render a display as a UI widget.
+renderDisplay :: Display -> Widget n
+renderDisplay disp = withAttr (disp ^. displayAttr . to toAttrName) $ str [displayChar disp]
+
 -- | Render the 'Display' for a specific location.
 drawLoc :: Bool -> GameState -> W.Coords -> Widget Name
 drawLoc showRobots g = renderDisplay . displayLoc showRobots g