{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
module Graphics.Rendering.Rect.CSS.Colour(ColourPallet(..), parseColour) where
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)
import qualified Data.Text as Txt
import Data.Word (Word8)
import Data.Char (isHexDigit, toLower)
import Data.List (elemIndex)
import Debug.Trace (trace) -- For warning messages.
import Stylist (PropertyParser(..))
hsl' :: RealFrac a => a -> a -> a -> Colour a
hsl' hue s l = uncurryRGB rgb $ hsl hue s l
data ColourPallet = ColourPallet {
foreground :: AlphaColour Float,
accent :: AlphaColour Float
} deriving (Read, Show, Eq)
instance PropertyParser ColourPallet where
temp = ColourPallet { foreground = opaque black, accent = opaque blue }
inherit = id
priority _ = ["color", "accent"]
longhand _ self "color" [Ident "initial"]=Just self {foreground=opaque black}
longhand _ self "color" toks | Just ([], val) <- parseColour self toks =
Just self { foreground = val }
longhand _ self "accent-color" [Ident kw]
| kw `elem` ["initial", "auto"] = Just self {accent = opaque blue}
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 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)
| 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:
Number _ (NVInteger g):Comma:Number _ (NVInteger b):Comma:
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)
| 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 _ (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)
| 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 =
Just (toks, opaque $ sRGBhex r r g g b b)
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 =
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
inner "aquamarine" = Just aquamarine
inner "azure" = Just azure
inner "beige" = Just beige
inner "bisque" = Just bisque
inner "black" = Just black
inner "blanchedalmond" = Just blanchedalmond
inner "blue" = Just blue
inner "blueviolet" = Just blueviolet
inner "brown" = Just brown
inner "burlywood" = Just burlywood
inner "cadetblue" = Just cadetblue
inner "chartreuse" = Just chartreuse
inner "chocolate" = Just chocolate
inner "coral" = Just coral
inner "cornflowerblue" = Just cornflowerblue
inner "cornsilk" = Just cornsilk
inner "crimson" = Just crimson
inner "cyan" = Just cyan
inner "darkblue" = Just darkblue
inner "darkcyan" = Just darkcyan
inner "darkgoldenrod" = Just darkgoldenrod
inner "darkgray" = Just darkgray
inner "darkgrey" = Just darkgrey
inner "darkgreen" = Just darkgreen
inner "darkkhaki" = Just darkkhaki
inner "darkmagenta" = Just darkmagenta
inner "darkolivegreen" = Just darkolivegreen
inner "darkorange" = Just darkorange
inner "darkorchid" = Just darkorchid
inner "darkred" = Just darkred
inner "darksalmon" = Just darksalmon
inner "darkseagreen" = Just darkseagreen
inner "darkslateblue" = Just darkslateblue
inner "darkslategray" = Just darkslategray
inner "darkslategrey" = Just darkslategrey
inner "darkturquoise" = Just darkturquoise
inner "darkviolet" = Just darkviolet
inner "deeppink" = Just deeppink
inner "deepskyblue" = Just deepskyblue
inner "dimgray" = Just dimgray
inner "dimgrey" = Just dimgrey
inner "dodgerblue" = Just dodgerblue
inner "firebrick" = Just firebrick
inner "floralwhite" = Just floralwhite
inner "forestgreen" = Just forestgreen
inner "fuchsia" = Just fuchsia
inner "gainsboro" = Just gainsboro
inner "ghostwhite" = Just ghostwhite
inner "gold" = Just gold
inner "goldenrod" = Just goldenrod
inner "gray" = Just gray
inner "grey" = Just grey
inner "green" = Just green
inner "greenyellow" = Just greenyellow
inner "honeydew" = Just honeydew
inner "hotpink" = Just hotpink
inner "indianred" = Just indianred
inner "indigo" = Just indigo
inner "ivory" = Just ivory
inner "khaki" = Just khaki
inner "lavender" = Just lavender
inner "lavenderblush" = Just lavenderblush
inner "lawngreen" = Just lawngreen
inner "lemonchiffon" = Just lemonchiffon
inner "lightblue" = Just lightblue
inner "lightcoral" = Just lightcoral
inner "lightcyan" = Just lightcyan
inner "lightgoldenrodyellow" = Just lightgoldenrodyellow
inner "lightgray" = Just lightgray
inner "lightgrey" = Just lightgrey
inner "lightgreen" = Just lightgreen
inner "lightpink" = Just lightpink
inner "lightsalmon" = Just lightsalmon
inner "lightseagreen" = Just lightseagreen
inner "lightskyblue" = Just lightskyblue
inner "lightslategray" = Just lightslategray
inner "lightslategrey" = Just lightslategrey
inner "lightsteelblue" = Just lightsteelblue
inner "lightyellow" = Just lightyellow
inner "lime" = Just lime
inner "limegreen" = Just limegreen
inner "linen" = Just linen
inner "magenta" = Just magenta
inner "maroon" = Just maroon
inner "mediumaquamarine" = Just mediumaquamarine
inner "mediumblue" = Just mediumblue
inner "mediumorchid" = Just mediumorchid
inner "mediumpurple" = Just mediumpurple
inner "mediumseagreen" = Just mediumseagreen
inner "mediumslateblue" = Just mediumslateblue
inner "mediumspringgreen" = Just mediumspringgreen
inner "mediumturquoise" = Just mediumturquoise
inner "mediumvioletred" = Just mediumvioletred
inner "midnightblue" = Just midnightblue
inner "mintcream" = Just mintcream
inner "mistyrose" = Just mistyrose
inner "moccasin" = Just moccasin
inner "navajowhite" = Just navajowhite
inner "navy" = Just navy
inner "oldlace" = Just oldlace
inner "olive" = Just olive
inner "olivedrab" = Just olivedrab
inner "orange" = Just orange
inner "orangered" = Just orangered
inner "orchid" = Just orchid
inner "palegoldenrod" = Just palegoldenrod
inner "palegreen" = Just palegreen
inner "paleturquoise" = Just paleturquoise
inner "palevioletred" = Just palevioletred
inner "papayawhip" = Just papayawhip
inner "peachpuff" = Just peachpuff
inner "peru" = Just peru
inner "pink" = Just pink
inner "plum" = Just plum
inner "powderblue" = Just powderblue
inner "purple" = Just purple
-- Named after CSS pioneer Eric Meyer's late daughter
inner "rebeccapurple" = Just $ sRGB 102 51 153
inner "red" = Just red
inner "rosybrown" = Just rosybrown
inner "royalblue" = Just royalblue
inner "saddlebrown" = Just saddlebrown
inner "salmon" = Just salmon
inner "sandybrown" = Just sandybrown
inner "seagreen" = Just seagreen
inner "seashell" = Just seashell
inner "sienna" = Just sienna
inner "silver" = Just silver
inner "skyblue" = Just skyblue
inner "slateblue" = Just slateblue
inner "slategray" = Just slategray
inner "slategrey" = Just slategrey
inner "snow" = Just snow
inner "springgreen" = Just springgreen
inner "steelblue" = Just steelblue
inner "tan" = Just Data.Colour.Names.tan
inner "teal" = Just teal
inner "thistle" = Just thistle
inner "tomato" = Just tomato
inner "turquoise" = Just turquoise
inner "violet" = Just violet
inner "wheat" = Just wheat
inner "white" = Just white
inner "whitesmoke" = Just whitesmoke
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 self@ColourPallet { foreground = colour} (Ident x:toks)
| Txt.toLower x `elem` ["currentcolor", "initial"] = Just (toks, colour)
| Txt.toLower x == "accentcolor" = Just (toks, accent self)
parseColour _ (Function "hsl":hue':Comma:Percentage _ s:Comma:Percentage _ l:
RightParen:toks)
| Just hue <- d hue' = Just (toks, opaque $ hsl' hue (pc s) (pc l))
parseColour _ (Function "hsl":hue':Comma:Percentage _ s:Comma:Percentage _ l:
Comma:a':RightParen:toks) | Just hue <- d hue', Just a <- f' a' =
Just (toks, hsl' hue (pc s) (pc l) `withOpacity` a)
parseColour _ (Function "hsla":hue':Comma:Percentage _ s:Comma:Percentage _ l:
Comma:a':RightParen:toks) | Just hue <- d hue', Just a <- f' a' =
Just (toks, hsl' hue (pc s) (pc l) `withOpacity` a)
parseColour _ (Function "hsl":hue':s':l':RightParen:toks)
| Just hue <- d' hue', Just s <- pc' s', Just l <- pc' l' =
Just (toks, opaque $ hsl' hue s l)
parseColour _ (Function "hsl":hue':s':l':Delim '/':a':RightParen:toks)
| Just hue <- d' hue', Just s <- pc' s', Just l <- pc' l', Just a <- f' a' =
Just (toks, hsl' hue s l `withOpacity` a)
parseColour _ _ = Nothing
sRGBhex :: Char -> Char -> Char -> Char -> Char -> Char -> Colour Float
sRGBhex r0 r1 g0 g1 b0 b1 = sRGB24 (h r0 r1) (h g0 g1) (h b0 b1)
h :: Char -> Char -> Word8
h a b
| Just a' <- toLower a `elemIndex` digits,
Just b' <- toLower b `elemIndex` digits = toEnum a'*16 + toEnum b'
| otherwise = trace (a:b:" Invalid hexcode!") 0 -- Should already be checked!
where
digits = "0123456789abcdef"
h' :: Char -> Char -> Float
h' a b = fromIntegral (h a b) / 255
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
d', d :: Token -> Maybe Float
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))
infixr 5 :.