@@ 23,7 23,7 @@ library
-- other-modules:
-- other-extensions:
build-depends: base >=4.13 && <4.14, stylist-traits >= 0.1.2 && < 1,
- css-syntax, colour >= 2.3.6 && < 3, scientific
+ css-syntax, colour >= 2.3.6 && < 3, scientific, text
hs-source-dirs: lib
default-language: Haskell2010
@@ 1,14 1,21 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
module Graphics.Rendering.Rect.CSS.Colour(parseColour) where
-import Data.Colour (AlphaColour, withOpacity, opaque)
+import Data.Colour (Colour, AlphaColour, withOpacity, opaque)
import Data.Colour.SRGB (sRGB, sRGB24)
+import Data.Colour.Names
+
import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Data.Scientific (toRealFloat)
+import qualified Data.Text as Txt
+
import Data.Word (Word8)
import Data.Bits (toIntegralSized)
+import Data.Char (isHexDigit, toLower, isUpper)
+import Data.List (elemIndex)
+import Debug.Trace (trace) -- For warning messages.
-parseColour :: [Token] -> Maybe ([Token], AlphaColour Float)
+parseColour :: [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))
@@ 29,20 36,196 @@ parseColour (Function "rgb":r':g':b':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)
+ | 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
+ 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 _ = Nothing
-pc :: NumericValue -> Float
+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)
+
+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 -> Double
+h' a b = fromIntegral (h a b) / 255
+
+pc :: NumericValue -> Double
pc x = f x / 100
-pc' :: Token -> Maybe Float
+pc' :: Token -> Maybe Double
pc' (Ident "none") = Just 0
pc' (Percentage _ x) = Just $ pc x
pc' _ = Nothing
-f :: NumericValue -> Float
+f :: NumericValue -> Double
f (NVInteger x) = fromIntegral x
f (NVNumber x) = toRealFloat x
-f' :: Token -> Maybe Float
+f' :: Token -> Maybe Double
f' (Ident "none") = Just 0
f' (Percentage _ x) = Just $ pc x
f' (Number _ x) = Just $ f x
@@ 55,3 238,9 @@ 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
+
+-- Copied from css-syntax.
+pattern (:.) :: Char -> Txt.Text -> Txt.Text
+pattern x :. xs <- (Txt.uncons -> Just (x, xs))
+
+infixr 5 :.