Validate hex colors in FromJSON instance (#2237)

Fixes #2236.  Stores `Kolor` instead of `Text` inside a `HexColor`, and validates and parses it when reading from JSON.  This simplifies the code in multiple places where we were taking the `Text` out of a `HexColor` and parsing it.

.hlint.yaml

@@ -33,6 +33,7 @@
   - {name: Prelude.!!, within: [Swarm.Util.indexWrapNonEmpty, TestEval]}
   - {name: undefined, within: [Swarm.Language.Key, TestUtil]}
   - {name: fromJust, within: []}
+  - {name: Data.Colour.SRGB.sRGB24read, within: []}
 # - {name: Data.Map.!, within: []} # TODO: #1494
 # - {name: error, within: []} # TODO: #1494
 

data/scenarios/Testing/_Validation/2236-unparseable-attr-color.yaml

@@ -0,0 +1,25 @@
+version: 1
+name: Custom attribute - invalid color
+description: |
+  Invalid color in custom attribute
+creative: false
+attrs:
+  - name: bogus
+    bg: "this is not a color"
+terrains:
+  - name: whatzit
+    attr: bogus
+    description: |
+      A thingy
+robots:
+  - name: base
+    dir: east
+world:
+  dsl: |
+    {grass}
+  palette:
+    'B': [grass, null, base]
+    '.': [whatzit]
+  upperleft: [0, 0]
+  map: |
+    B.

src/swarm-scenario/Swarm/Game/Scenario/Style.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE ViewPatterns #-}
+
 -- |
 -- SPDX-License-Identifier: BSD-3-Clause
 --
@@ -7,9 +9,9 @@ module Swarm.Game.Scenario.Style where
 import Codec.Picture (PixelRGBA8 (..))
 import Data.Aeson
 import Data.Colour.Palette.Types (Kolor)
-import Data.Colour.SRGB (RGB (..), sRGB24read, toSRGB24)
+import Data.Colour.SRGB (RGB (..), sRGB24reads, sRGB24show, toSRGB24)
+import Data.Colour.SRGB.Linear (toRGB)
 import Data.Set (Set)
-import Data.Text (Text)
 import Data.Text qualified as T
 import GHC.Generics (Generic)
 import Swarm.Game.Entity.Cosmetic
@@ -38,17 +40,36 @@ instance FromJSON StyleFlag where
 instance ToJSON StyleFlag where
   toJSON = genericToJSON styleFlagJsonOptions
 
--- | Hexadecimal color notation.
--- May include a leading hash symbol (see 'Data.Colour.SRGB.sRGB24read').
-newtype HexColor = HexColor Text
-  deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)
+-- | A color, parsed from hexadecimal notation.  May include a leading
+--   hash symbol (see 'Data.Colour.SRGB.sRGB24read').
+newtype HexColor = HexColor {getHexColor :: Kolor}
+  deriving (Eq, Show, Generic)
+
+instance Ord HexColor where
+  -- There is no Ord instance for Colour a, but we need one to use
+  -- with OccurrenceEncoder, so we make our own.
+  --
+  -- We use toRGB here since it does no conversions whatsoever, it
+  -- simply unpacks the raw color data into an RGB triple.  For the
+  -- purposes of an Ord instance, it doesn't matter: we just want a
+  -- consistent way to put a total ordering on colors as fast as
+  -- possible.
+  compare (HexColor (toRGB -> RGB r1 g1 b1)) (HexColor (toRGB -> RGB r2 g2 b2)) =
+    compare (r1, g1, b1) (r2, g2, b2)
+
+instance FromJSON HexColor where
+  parseJSON = withText "hex color" $ \t ->
+    case sRGB24reads (T.unpack t) of
+      ((c, _) : _) -> pure $ HexColor c
+      _ -> fail $ "Could not parse hex color '" ++ T.unpack t ++ "'"
+
+instance ToJSON HexColor where
+  toJSON = toJSON . T.pack . sRGB24show . getHexColor
 
 instance ToPixel HexColor where
-  toPixel (HexColor colorText) = PixelRGBA8 r g b 255
+  toPixel (HexColor kolor) = PixelRGBA8 r g b 255
    where
-    temp :: Kolor
-    temp = sRGB24read $ T.unpack colorText
-    RGB r g b = toSRGB24 temp
+    RGB r g b = toSRGB24 kolor
 
 data CustomAttr = CustomAttr
   { name :: String
@@ -77,7 +98,4 @@ toHifiPair (CustomAttr n maybeFg maybeBg _) =
     (Nothing, Just b) -> Just $ BgOnly b
     (Nothing, Nothing) -> Nothing
 
-  conv (HexColor x) = Triple $ toSRGB24 kolor
-   where
-    kolor :: Kolor
-    kolor = sRGB24read $ T.unpack x
+  conv (HexColor kolor) = Triple $ toSRGB24 kolor

src/swarm-tui/Swarm/TUI/View/Attribute/CustomStyling.hs

@@ -2,9 +2,7 @@
 -- SPDX-License-Identifier: BSD-3-Clause
 module Swarm.TUI.View.Attribute.CustomStyling where
 
-import Data.Colour.SRGB (sRGB24read)
 import Data.Set (toList)
-import Data.Text qualified as T
 import Graphics.Vty.Attributes
 import Swarm.Game.Entity.Cosmetic (WorldAttr (..))
 import Swarm.Game.Scenario.Style
@@ -22,10 +20,7 @@ toStyle = \case
   Bold -> bold
 
 hexToAttrColor :: HexColor -> Color
-hexToAttrColor (HexColor colorText) =
-  kolorToAttrColor c
- where
-  c = sRGB24read $ T.unpack colorText
+hexToAttrColor (HexColor kolor) = kolorToAttrColor kolor
 
 toAttrPair :: CustomAttr -> (WorldAttr, Attr)
 toAttrPair ca =

src/swarm-web/Swarm/Web/Worldview.hs

@@ -6,9 +6,8 @@ module Swarm.Web.Worldview where
 import Control.Lens ((^.))
 import Data.Aeson (ToJSON)
 import Data.Colour.Palette.BrewerSet (Kolor)
-import Data.Colour.SRGB (RGB (..), sRGB24, sRGB24show)
+import Data.Colour.SRGB (RGB (..), sRGB24)
 import Data.IntMap qualified as IM
-import Data.Text qualified as T
 import GHC.Generics (Generic)
 import Servant.Docs qualified as SD
 import Swarm.Game.Entity.Cosmetic (RGBColor, flattenBg, fromHiFi)
@@ -44,7 +43,7 @@ getCellGrid myScenario gs requestedSize =
 
   asColour :: RGBColor -> Kolor
   asColour (RGB r g b) = sRGB24 r g b
-  asHex = HexColor . T.pack . sRGB24show . asColour
+  asHex = HexColor . asColour
 
   f = asHex . maybe (RGB 0 0 0) (flattenBg . fromHiFi) . getTerrainEntityColor aMap
   (indexGrid, encoding) = runEncoder $ f <$> dg