From 95fd608dd4b15eb713823db288d1dde959bb710a Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Thu, 11 May 2023 16:57:21 +1200
Subject: [PATCH] Start parsing CSS colours!

---
 Mondrian.cabal                            |  6 ++-
 lib/Graphics/Rendering/Rect/CSS/Colour.hs | 57 +++++++++++++++++++++++
 2 files changed, 61 insertions(+), 2 deletions(-)
 create mode 100644 lib/Graphics/Rendering/Rect/CSS/Colour.hs

diff --git a/Mondrian.cabal b/Mondrian.cabal
index 2648542..cf9b37c 100644
--- a/Mondrian.cabal
+++ b/Mondrian.cabal
@@ -18,10 +18,12 @@ build-type:          Simple
 extra-source-files:  CHANGELOG.md
 
 library
-  exposed-modules:     Graphics.Rendering.Rect.CSS
+  exposed-modules:     Graphics.Rendering.Rect.CSS,
+                       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.2 && < 1,
+                       css-syntax, colour >= 2.3.6 && < 3, scientific
   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
new file mode 100644
index 0000000..75de2fb
--- /dev/null
+++ b/lib/Graphics/Rendering/Rect/CSS/Colour.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Graphics.Rendering.Rect.CSS.Colour(parseColour) where
+
+import Data.Colour (AlphaColour, withOpacity, opaque)
+import Data.Colour.SRGB (sRGB, sRGB24)
+import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
+import Data.Scientific (toRealFloat)
+import Data.Word (Word8)
+import Data.Bits (toIntegralSized)
+
+parseColour :: [Token] -> Maybe ([Token], AlphaColour Float)
+parseColour (Function "rgb":Percentage _ r:Comma:
+        Percentage _ g:Comma:Percentage _ b:RightParen:toks) =
+    Just (toks, opaque $ sRGB (pc r) (pc g) (pc b))
+parseColour (Function "rgba":Percentage _ r:Comma:
+        Percentage _ g:Comma:Percentage _ b:Comma:a':RightParen:toks)
+    | Just a <- f' a' = Just (toks, sRGB (pc r) (pc g) (pc b) `withOpacity` a)
+parseColour (Function "rgb":Number _ (NVInteger r):Comma:
+        Number _ (NVInteger g):Comma:Number _ (NVInteger b):RightParen:toks) =
+    Just (toks, opaque $ sRGB24 (w r) (w g) (w b))
+parseColour (Function "rgba":Number _ (NVInteger r):Comma:
+        Number _ (NVInteger g):Comma:Number _ (NVInteger b):Comma:
+        a':RightParen:toks) | Just a <- f' a' =
+    Just (toks, sRGB24 (w r) (w g) (w b) `withOpacity` a)
+
+parseColour (Function "rgb":r':g':b':RightParen:toks)
+    | Just r <- w' r', Just g <- w' g', Just b <- w' b' =
+        Just (toks, opaque $ sRGB24 r g b)
+parseColour (Function "rgb":r':g':b':Delim '/':a':RightParen:toks)
+    | Just r <- w' r', Just g <- w' g', Just b <- w' b', Just a <- f' a' =
+        Just (toks, sRGB24 r g b `withOpacity` a)
+
+parseColour _ = Nothing
+
+pc :: NumericValue -> Float
+pc x = f x / 100
+pc' :: Token -> Maybe Float
+pc' (Ident "none") = Just 0
+pc' (Percentage _ x) = Just $ pc x
+pc' _ = Nothing
+
+f :: NumericValue -> Float
+f (NVInteger x) = fromIntegral x
+f (NVNumber x) = toRealFloat x
+f' :: Token -> Maybe Float
+f' (Ident "none") = Just 0
+f' (Percentage _ x) = Just $ pc x
+f' (Number _ x) = Just $ f x
+f' _ = Nothing
+
+w :: Integer -> Word8
+w = fromInteger
+w' :: Token -> Maybe Word8
+w' (Ident "none") = Just 0
+w' (Number _ (NVInteger x)) | x >= 0 && x <= 255 = Just $ fromIntegral $ w x
+w' (Percentage _ x) = Just $ toEnum $ fromEnum (pc x * 255)
+w' _ = Nothing
-- 
2.30.2