diff --git a/.hlint.yaml b/.hlint.yaml index 7f8d06b48..6eaefc8b7 100644 --- a/.hlint.yaml +++ b/.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 diff --git a/data/scenarios/Testing/_Validation/2236-unparseable-attr-color.yaml b/data/scenarios/Testing/_Validation/2236-unparseable-attr-color.yaml new file mode 100644 index 000000000..6470378f3 --- /dev/null +++ b/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. diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Style.hs b/src/swarm-scenario/Swarm/Game/Scenario/Style.hs index 80e372bb0..d9c0435c6 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Style.hs +++ 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 diff --git a/src/swarm-tui/Swarm/TUI/View/Attribute/CustomStyling.hs b/src/swarm-tui/Swarm/TUI/View/Attribute/CustomStyling.hs index 68d02bbd0..a740e0661 100644 --- a/src/swarm-tui/Swarm/TUI/View/Attribute/CustomStyling.hs +++ b/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 = diff --git a/src/swarm-web/Swarm/Web/Worldview.hs b/src/swarm-web/Swarm/Web/Worldview.hs index 87e05e324..67a6a57e2 100644 --- a/src/swarm-web/Swarm/Web/Worldview.hs +++ b/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