~alcinnz/Mondrian

b485cd037e7cde46e72f7b265ea7fd1b8184251e — Adrian Cochrane 1 year, 7 months ago fcb9479
Add support for transparent, currentcolor, & hsl() colours!
1 files changed, 58 insertions(+), 16 deletions(-)

M lib/Graphics/Rendering/Rect/CSS/Colour.hs
M lib/Graphics/Rendering/Rect/CSS/Colour.hs => lib/Graphics/Rendering/Rect/CSS/Colour.hs +58 -16
@@ 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))