From fcb9479801c3a8a24ea98dde1d681ab494180c08 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 12 May 2023 15:44:22 +1200 Subject: [PATCH] Parse CSS colour hexcodes & keywords. --- Mondrian.cabal | 2 +- lib/Graphics/Rendering/Rect/CSS/Colour.hs | 203 +++++++++++++++++++++- 2 files changed, 197 insertions(+), 8 deletions(-) diff --git a/Mondrian.cabal b/Mondrian.cabal index cf9b37c..e1b2a91 100644 --- a/Mondrian.cabal +++ b/Mondrian.cabal @@ -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 diff --git a/lib/Graphics/Rendering/Rect/CSS/Colour.hs b/lib/Graphics/Rendering/Rect/CSS/Colour.hs index 75de2fb..35f367e 100644 --- a/lib/Graphics/Rendering/Rect/CSS/Colour.hs +++ b/lib/Graphics/Rendering/Rect/CSS/Colour.hs @@ -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 :. -- 2.30.2