@@ 1,9 1,12 @@
{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
module Graphics.Rendering.Rect.CSS.Colour(parseColour) where
-import Data.Colour (Colour, AlphaColour, withOpacity, opaque)
+import Data.Colour (Colour, AlphaColour, withOpacity, opaque, transparent)
import Data.Colour.SRGB (sRGB, sRGB24)
import Data.Colour.Names
+import Data.Colour.RGBSpace.HSL (hsl)
+import Data.Colour.RGBSpace (uncurryRGB)
+import Data.Colour.SRGB.Linear (rgb)
import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Data.Scientific (toRealFloat)
@@ 15,40 18,48 @@ import Data.Char (isHexDigit, toLower, isUpper)
import Data.List (elemIndex)
import Debug.Trace (trace) -- For warning messages.
-parseColour :: [Token] -> Maybe ([Token], AlphaColour Double)
-parseColour (Function "rgb":Percentage _ r:Comma:
+hsl' h s l = uncurryRGB rgb $ hsl h s l
+
+data ColourPallet = ColourPallet { foreground :: AlphaColour Double }
+
+parseColour :: ColourPallet -> [Token] -> Maybe ([Token], AlphaColour Double)
+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:
+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:
+ | a' /= Ident "none", 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:
+parseColour _ (Function "rgba":Number _ (NVInteger r):Comma:
Number _ (NVInteger g):Comma:Number _ (NVInteger b):Comma:
- a':RightParen:toks) | Just a <- f' a' =
+ a':RightParen:toks) | a' /= Ident "none", Just a <- f' a' =
Just (toks, sRGB24 (w r) (w g) (w b) `withOpacity` a)
-parseColour (Function "rgb":r':g':b':RightParen:toks)
+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)
+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 (Hash _ v@(r0 :. r1 :. g0 :. g1 :. b0 :. b1 :. ""):toks)
+parseColour _ (Hash _ v@(r0 :. r1 :. g0 :. g1 :. b0 :. b1 :. ""):toks)
| Txt.all isHexDigit v = Just (toks, opaque $ sRGBhex r0 r1 g0 g1 b0 b1)
-parseColour (Hash _ v@(r0 :. r1 :. g0 :. g1 :. b0 :. b1 :. a0 :. a1 :. ""):toks)
+parseColour _ (Hash _ v@(r0 :. r1 :. g0 :. g1 :. b0 :. b1 :. a0 :. a1 :. ""):toks)
| Txt.all isHexDigit v =
Just (toks, sRGBhex r0 r1 g0 g1 b0 b1 `withOpacity` h' a0 a1)
-parseColour (Hash _ v@(r:.g:.b:.""):toks) | Txt.all isHexDigit v =
+parseColour _ (Hash _ v@(r:.g:.b:.""):toks) | Txt.all isHexDigit v =
Just (toks, opaque $ sRGBhex r r g g b b)
-parseColour (Hash _ v@(r:.g:.b:.a:.""):toks) | Txt.all isHexDigit v =
+parseColour _ (Hash _ v@(r:.g:.b:.a:.""):toks) | Txt.all isHexDigit v =
Just (toks, sRGBhex r r g g b b `withOpacity` h' a a)
-parseColour (Ident x:toks) | Just x' <- inner $ Txt.toLower x =
+parseColour _ (Ident x:toks) | Just x' <- inner $ Txt.toLower x =
Just (toks, opaque x')
where
+ -- NOTE: Some of these colour names are inconsistant or even offensive.
+ -- There are historical reasons for this labelling.
+ -- https://www.youtube.com/watch?v=HmStJQzclHc
inner "aliceblue" = Just aliceblue
inner "antiquewhite" = Just antiquewhite
inner "aqua" = Just aqua
@@ 199,8 210,29 @@ parseColour (Ident x:toks) | Just x' <- inner $ Txt.toLower x =
inner "yellow" = Just yellow
inner "yellowgreen" = Just yellowgreen
inner _ = Nothing
+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 _ = Nothing
+parseColour _ (Function "hsl":h':Comma:
+ Percentage _ s:Comma:Percentage _ l:RightParen:toks) | Just h <- d h' =
+ Just (toks, opaque $ hsl' h (pc s) (pc l))
+parseColour _ (Function "hsl":h':Comma:Percentage _ s:Comma:Percentage _ l:
+ Comma:a':RightParen:toks) | Just h <- d h', Just a <- f' a' =
+ Just (toks, hsl' h (pc s) (pc l) `withOpacity` a)
+parseColour _ (Function "hsla":h':Comma:Percentage _ s:Comma:Percentage _ l:
+ Comma:a':RightParen:toks) | Just h <- d h', Just a <- f' a' =
+ Just (toks, hsl' h (pc s) (pc l) `withOpacity` a)
+parseColour _ (Function "hsl":h':s':l':RightParen:toks)
+ | Just h <- d' h', Just s <- pc' s', Just l <- pc' l' =
+ Just (toks, opaque $ hsl' h s l)
+parseColour _ (Function "hsl":h':s':l':Delim '/':a':RightParen:toks)
+ | Just h <- d' h', Just s <- pc' s', Just l <- pc' l', Just a <- f' a' =
+ Just (toks, hsl' h s l `withOpacity` a)
+
+parseColour _ _ = Nothing
sRGBhex :: Char -> Char -> Char -> Char -> Char -> Char -> Colour Double
sRGBhex r0 r1 g0 g1 b0 b1 = sRGB24 (h r0 r1) (h g0 g1) (h b0 b1)
@@ 239,6 271,16 @@ w' (Number _ (NVInteger x)) | x >= 0 && x <= 255 = Just $ fromIntegral $ w x
w' (Percentage _ x) = Just $ toEnum $ fromEnum (pc x * 255)
w' _ = Nothing
+d', d :: Token -> Maybe Double
+d (Dimension _ x "deg") = Just $ f x
+d (Dimension _ x "grad") = Just $ f x / 400 * 360
+d (Dimension _ x "rad") = Just $ f x / pi * 180
+d (Dimension _ x "turn") = Just $ f x * 360
+d (Number _ x) = Just $ f x
+d _ = Nothing
+d' (Ident "none") = Just 0
+d' x = d x
+
-- Copied from css-syntax.
pattern (:.) :: Char -> Txt.Text -> Txt.Text
pattern x :. xs <- (Txt.uncons -> Just (x, xs))