From a3455462990dddadf8213c9e45a5fe5ec6bee475 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Sun, 4 Jun 2023 15:40:07 +1200
Subject: [PATCH] Parse background-colour CSS property.

---
 Mondrian.cabal                                |  3 ++-
 lib/Graphics/Rendering/Rect/CSS.hs            | 21 +++++++++++++++
 lib/Graphics/Rendering/Rect/CSS/Background.hs | 26 +++++++++++++++++++
 3 files changed, 49 insertions(+), 1 deletion(-)
 create mode 100644 lib/Graphics/Rendering/Rect/CSS.hs
 create mode 100644 lib/Graphics/Rendering/Rect/CSS/Background.hs

diff --git a/Mondrian.cabal b/Mondrian.cabal
index 466ceaa..c2df221 100644
--- a/Mondrian.cabal
+++ b/Mondrian.cabal
@@ -19,7 +19,8 @@ extra-source-files:  CHANGELOG.md
 
 library
   exposed-modules:     Graphics.Rendering.Rect.CSS,
-                       Graphics.Rendering.Rect.CSS.Colour
+                       Graphics.Rendering.Rect.CSS.Colour,
+                       Graphics.Rendering.Rect.CSS.Background
   -- other-modules:
   -- other-extensions:
   build-depends:       base >=4.13 && <4.14, stylist-traits >= 0.1.3.1 && < 1,
diff --git a/lib/Graphics/Rendering/Rect/CSS.hs b/lib/Graphics/Rendering/Rect/CSS.hs
new file mode 100644
index 0000000..61f5e4b
--- /dev/null
+++ b/lib/Graphics/Rendering/Rect/CSS.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+module Graphics.Rendering.Rect.CSS(CSSRect(..)) where
+
+import Stylist (PropertyParser(..))
+import Graphics.Rendering.Rect.CSS.Colour (ColourPallet(foreground))
+import Graphics.Rendering.Rect.CSS.Background (Backgrounds(..))
+
+data CSSRect = CSSRect { colours :: ColourPallet, backgrounds :: Backgrounds }
+colour = foreground . colours
+
+instance PropertyParser CSSRect where
+    temp = CSSRect { colours = temp, backgrounds = temp }
+    inherit CSSRect {..} = CSSRect { colours = inherit colours, backgrounds = temp }
+
+    shorthand self key value
+        | Just _ <- longhand self self key value = [(key, value)]
+        | otherwise = []
+    longhand parent self key value
+        | Just ret <- longhand (colours parent) (colours self) key value =
+            Just self { colours = ret }
+        | otherwise = Nothing
diff --git a/lib/Graphics/Rendering/Rect/CSS/Background.hs b/lib/Graphics/Rendering/Rect/CSS/Background.hs
new file mode 100644
index 0000000..34c5f06
--- /dev/null
+++ b/lib/Graphics/Rendering/Rect/CSS/Background.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Graphics.Rendering.Rect.CSS.Background (Backgrounds(..)) where
+
+import Stylist (PropertyParser(..), parseUnorderedShorthand)
+import Graphics.Rendering.Rect.CSS.Colour (ColourPallet, parseColour)
+import Data.Colour (AlphaColour, transparent)
+
+data Backgrounds = Backgrounds {
+    pallet :: ColourPallet,
+    colour :: AlphaColour Double
+}
+
+instance PropertyParser Backgrounds where
+    temp = Backgrounds { pallet = temp, colour = transparent }
+    inherit _ = temp
+    priority _ = []
+
+    longhand _ self@Backgrounds{ pallet = c } "background-color" toks
+        | Just ([], val) <- parseColour c toks = Just self { colour = val }
+    longhand _ _ _ _ = Nothing
+
+    shorthand self "background" toks = parseUnorderedShorthand self [
+        "background-color"
+      ] toks
+    shorthand self key val | Just _ <- longhand self self key val = [(key, val)]
+        | otherwise = []
-- 
2.30.2