From 36e87766cddd08ad3c5c1d9061b0e5bac734f426 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Sun, 4 Jun 2023 15:04:11 +1200
Subject: [PATCH] Integrate colour parsing & add accent-colour support.

accent-colour takes no effort & helps (custom) form controls clash less with webpages.
---
 Mondrian.cabal                            |  2 +-
 lib/Graphics/Rendering/Rect/CSS/Colour.hs | 27 +++++++++++++++++++----
 2 files changed, 24 insertions(+), 5 deletions(-)

diff --git a/Mondrian.cabal b/Mondrian.cabal
index e1b2a91..466ceaa 100644
--- a/Mondrian.cabal
+++ b/Mondrian.cabal
@@ -22,7 +22,7 @@ library
                        Graphics.Rendering.Rect.CSS.Colour
   -- other-modules:
   -- other-extensions:
-  build-depends:       base >=4.13 && <4.14, stylist-traits >= 0.1.2 && < 1,
+  build-depends:       base >=4.13 && <4.14, stylist-traits >= 0.1.3.1 && < 1,
                        css-syntax, colour >= 2.3.6 && < 3, scientific, text
   hs-source-dirs:      lib
   default-language:    Haskell2010
diff --git a/lib/Graphics/Rendering/Rect/CSS/Colour.hs b/lib/Graphics/Rendering/Rect/CSS/Colour.hs
index 37e57bc..306b77c 100644
--- a/lib/Graphics/Rendering/Rect/CSS/Colour.hs
+++ b/lib/Graphics/Rendering/Rect/CSS/Colour.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
-module Graphics.Rendering.Rect.CSS.Colour(parseColour) where
+module Graphics.Rendering.Rect.CSS.Colour(ColourPallet(..), parseColour) where
 
 import Data.Colour (Colour, AlphaColour, withOpacity, opaque, transparent)
 import Data.Colour.SRGB (sRGB, sRGB24)
@@ -18,9 +18,27 @@ import Data.Char (isHexDigit, toLower, isUpper)
 import Data.List (elemIndex)
 import Debug.Trace (trace) -- For warning messages.
 
+import Stylist (PropertyParser(..))
+
 hsl' h s l = uncurryRGB rgb $ hsl h s l
 
-data ColourPallet = ColourPallet { foreground :: AlphaColour Double }
+data ColourPallet = ColourPallet {
+    foreground :: AlphaColour Double,
+    accent :: AlphaColour Double
+}
+
+instance PropertyParser ColourPallet where
+    temp = ColourPallet { foreground = opaque blue, accent = opaque blue }
+    inherit = id
+    priority _ = ["color", "accent"]
+
+    longhand _ self "color" toks | Just ([], val) <- parseColour self toks =
+        Just self { foreground = val }
+    longhand _ self "accent-color" t | Just ([], val) <- parseColour self t =
+        Just self { accent = val }
+    longhand _ _ _ _ = Nothing
+    shorthand self key val | Just _ <- longhand self self key val = [(key, val)]
+        | otherwise = []
 
 parseColour :: ColourPallet -> [Token] -> Maybe ([Token], AlphaColour Double)
 parseColour _ (Function "rgb":Percentage _ r:Comma:
@@ -213,8 +231,9 @@ parseColour _ (Ident x:toks) | Just x' <- inner $ Txt.toLower x =
 parseColour _ (Ident x:toks) | Txt.toLower x == "transparent" =
     Just (toks, transparent)
 -- FIXME: Add infrastructure to prioritize resolving `color`
-parseColour ColourPallet { foreground = ret } (Ident x:toks)
-    | Txt.toLower x == "currentcolor" = Just (toks, ret)
+parseColour self (Ident x:toks)
+    | Txt.toLower x == "currentcolor" = Just (toks, foreground self)
+    | Txt.toLower x == "accentcolor" = Just (toks, accent self)
 
 parseColour _ (Function "hsl":h':Comma:
         Percentage _ s:Comma:Percentage _ l:RightParen:toks) | Just h <- d h' =
-- 
2.30.2