graphviz-2999.15.0.0: Data/GraphViz/Attributes/Colors.hs
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Data.GraphViz.Attributes.Colors
Description : Specification of Color-related types and functions.
Copyright : (c) Ivan Lazar Miljenovic
License : 3-Clause BSD-style
Maintainer : Ivan.Miljenovic@gmail.com
This module defines the various colors, etc. for Graphviz. For
information on colors in general, see:
<http://graphviz.org/doc/info/attrs.html#k:color>
For named colors, see:
<http://graphviz.org/doc/info/colors.html>
Note that the ColorBrewer Color Schemes (shortened to just
\"Brewer\" for the rest of this module) are covered by the
following license (also available in the LICENSE file of this
library):
<http://graphviz.org/doc/info/colors.html#brewer_license>
-}
module Data.GraphViz.Attributes.Colors
( -- * Color schemes.
ColorScheme(..)
-- * Colors
, Color(..)
, NamedColor(toColor)
-- * Conversion to\/from @Colour@.
, toColour
, fromColour
, fromAColour
) where
import Data.GraphViz.Parsing
import Data.GraphViz.Printing
import Data.GraphViz.State
import Data.GraphViz.Attributes.ColorScheme(ColorScheme(..))
import Data.GraphViz.Attributes.Colors.X11(X11Color(Transparent), x11Colour)
import Data.GraphViz.Attributes.Colors.SVG(SVGColor, svgColour)
import Data.GraphViz.Attributes.Colors.Brewer(BrewerColor(..))
import Data.GraphViz.Util(bool)
import Data.GraphViz.Exception
import Data.Colour( AlphaColour, opaque, withOpacity
, over, black, alphaChannel, darken)
import Data.Colour.SRGB(Colour, sRGB, sRGB24, toSRGB24)
import Data.Colour.RGBSpace(uncurryRGB)
import Data.Colour.RGBSpace.HSV(hsv)
import Data.Char(isHexDigit)
import Numeric(showHex, readHex)
import Data.Maybe(isJust)
import Data.Word(Word8)
import qualified Data.Text.Lazy as T
-- -----------------------------------------------------------------------------
-- | Defining a color for use with Graphviz. Note that named colors
-- have been split up into 'X11Color's and those based upon the
-- Brewer color schemes.
data Color = RGB { red :: Word8
, green :: Word8
, blue :: Word8
}
| RGBA { red :: Word8
, green :: Word8
, blue :: Word8
, alpha :: Word8
}
-- | The 'hue', 'saturation' and 'value' values must all
-- be @0 <= x <=1@.
| HSV { hue :: Double
, saturation :: Double
, value :: Double
}
| X11Color X11Color
| SVGColor SVGColor
| BrewerColor BrewerColor
deriving (Eq, Ord, Show, Read)
instance PrintDot Color where
unqtDot (RGB r g b) = hexColor [r,g,b]
unqtDot (RGBA r g b a) = hexColor [r,g,b,a]
unqtDot (HSV h s v) = hcat . punctuate comma $ mapM unqtDot [h,s,v]
unqtDot (SVGColor name) = printNC False name
unqtDot (X11Color name) = printNC False name
unqtDot (BrewerColor bc) = printNC False bc
-- Some cases might not need quotes.
toDot (X11Color name) = printNC True name
toDot (SVGColor name) = printNC True name
toDot (BrewerColor bc) = printNC True bc
toDot c = dquotes $ unqtDot c
unqtListToDot = hcat . punctuate colon . mapM unqtDot
-- These three might not need to be quoted if they're on their own.
listToDot [X11Color name] = printNC True name
listToDot [SVGColor name] = printNC True name
listToDot [BrewerColor bc] = printNC True bc
listToDot cs = dquotes $ unqtListToDot cs
hexColor :: [Word8] -> DotCode
hexColor = (<>) (char '#') . hcat . mapM word8Doc
word8Doc :: Word8 -> DotCode
word8Doc w = text $ padding `T.append` simple
where
simple = T.pack $ showHex w ""
padding = T.replicate count (T.singleton '0')
count = 2 - findCols 1 w
findCols c n
| n < 16 = c
| otherwise = findCols (c+1) (n `div` 16)
instance ParseDot Color where
parseUnqt = oneOf [ parseHexBased
, parseHSV
-- Have to parse BrewerColor first, as some of them may appear to be X11 colors
, parseNC (undefined :: BrewerColor) False
, parseNC (undefined :: SVGColor) False
, parseX11Color False
]
`onFail`
fail "Could not parse Color"
where
parseHexBased
= do character '#'
cs <- many1 parse2Hex
return $ case cs of
[r,g,b] -> RGB r g b
[r,g,b,a] -> RGBA r g b a
_ -> throw . NotDotCode
$ "Not a valid hex Color specification: "
++ show cs
parseHSV = HSV <$> parse
<* parseSep
<*> parse
<* parseSep
<*> parse
parseSep = oneOf [ string "," *> whitespace
, whitespace1
]
parse2Hex = do c1 <- satisfy isHexDigit
c2 <- satisfy isHexDigit
let [(n, [])] = readHex [c1, c2]
return n
parse = quotedParse parseUnqt
`onFail` -- These three might not need to be quoted
oneOf [ parseNC (undefined :: BrewerColor) True
, parseNC (undefined :: SVGColor) True
, parseX11Color True
]
`onFail`
fail "Could not parse Color"
parseUnqtList = sepBy1 parseUnqt (character ':')
`onFail`
do cs <- getColorScheme
failBad $ "Error parsing list of Colors with color scheme of "
++ show cs
parseList = fmap (:[])
-- Unquoted single color
(oneOf [ parseNC (undefined :: BrewerColor) True
, parseNC (undefined :: SVGColor) True
, parseX11Color True
]
)
`onFail`
quotedParse parseUnqtList
`onFail`
do cs <- getColorScheme
failBad $ "Error parsing list of Colors with color scheme of "
++ show cs
-- -----------------------------------------------------------------------------
-- | More easily convert named colors to an overall 'Color' value.
class NamedColor nc where
colorScheme :: nc -> ColorScheme
toColor :: nc -> Color
printNC :: Bool -> nc -> DotCode
-- | Bool is for whether quoting is needed.
parseNC' :: Bool -> Parse nc
-- First value just used for type
parseNC :: (NamedColor nc) => nc -> Bool -> Parse Color
parseNC nc q = fmap (toColor . flip asTypeOf nc)
$ parseNC' q
instance NamedColor BrewerColor where
colorScheme (BC bs _) = Brewer bs
toColor = BrewerColor
printNC = printNamedColor (\ (BC _ l) -> l)
parseNC' = parseNamedColor mBCS parseUnqt (const True) BC
where
mBCS (Brewer bs) = Just bs
mBCS _ = Nothing
instance NamedColor X11Color where
colorScheme = const X11
toColor = X11Color
printNC = printNamedColor id
parseNC' = parseNamedColor mX11 (parseColorScheme False) (isJust . mX11) (const id)
where
mX11 X11 = Just X11
mX11 _ = Nothing
instance NamedColor SVGColor where
colorScheme = const SVG
toColor = SVGColor
printNC = printNamedColor id
parseNC' = parseNamedColor mSVG (parseColorScheme False) (isJust . mSVG) (const id)
where
mSVG SVG = Just SVG
mSVG _ = Nothing
printNamedColor :: (NamedColor nc, PrintDot lv) => (nc -> lv)
-> Bool -> nc -> DotCode
printNamedColor fl q c = do currentCS <- getColorScheme
if cs == currentCS
then (bool unqtDot toDot q) lv
else bool id dquotes q
$ fslash <> printColorScheme False cs
<> fslash <> unqtDot lv
where
cs = colorScheme c
lv = fl c
parseNamedColor :: (NamedColor nc, ParseDot lv)
=> (ColorScheme -> Maybe cs) -> Parse cs -> (cs -> Bool)
-> (cs -> lv -> nc) -> Bool -> Parse nc
parseNamedColor gcs parseCS vcs mkC q
= do Just cs <- gcs <$> getColorScheme
lv <- bool parseUnqt parse q
`onFail`
mQts (string "//" *> parseUnqt)
return $ mkC cs lv
`onFail`
mQts ( do character '/'
cs <- parseCS
character '/'
if vcs cs
then mkC cs <$> parseUnqt
else fail "Explicit colorscheme not as expected."
)
where
mQts = bool id quotedParse q
-- -----------------------------------------------------------------------------
-- X11 has a special case when parsing: '/yyyy'
parseX11Color :: Bool -> Parse Color
parseX11Color q = X11Color
<$> parseNC' q
`onFail`
bool id quotedParse q (character '/' *> parseUnqt)
`onFail`
-- Can use X11 colors within brewer colorscheme.
do cs <- getColorScheme
case cs of
Brewer{} -> bool parseUnqt parse q
_ -> fail "Unable to parse an X11 color within Brewer"
-- -----------------------------------------------------------------------------
-- | Attempt to convert a 'Color' into a 'Colour' value with an alpha
-- channel. The use of 'Maybe' is because the RGB values of the
-- 'BrewerColor's haven't been stored here (primarily for licensing
-- reasons).
toColour :: Color -> Maybe (AlphaColour Double)
toColour (RGB r g b) = Just . opaque $ sRGB24 r g b
toColour (RGBA r g b a) = Just . withOpacity (sRGB24 r g b) $ toOpacity a
-- Colour expects the hue to be an angle, so multiply by 360
toColour (HSV h s v) = Just . opaque . uncurryRGB sRGB $ hsv (h*360) s v
toColour (X11Color c) = Just $ x11Colour c
toColour (SVGColor c) = Just . opaque $ svgColour c
toColour BrewerColor{} = Nothing
toOpacity :: Word8 -> Double
toOpacity a = fromIntegral a / maxWord
-- | Convert a 'Colour' value to an 'RGB' 'Color'.
fromColour :: Colour Double -> Color
fromColour = uncurryRGB RGB . toSRGB24
-- | Convert an 'AlphaColour' to an 'RGBA' 'Color'. The exception to
-- this is for any 'AlphaColour' which has @alphaChannel ac == 0@;
-- these are converted to @X11Color 'Transparent'@ (note that the
-- 'Show' instance for such an 'AlphaColour' is @\"transparent\"@).
fromAColour :: AlphaColour Double -> Color
fromAColour ac
| a == 0 = X11Color Transparent
| otherwise = rgb $ round a'
where
a = alphaChannel ac
a' = a * maxWord
rgb = uncurryRGB RGBA $ toSRGB24 colour
colour = darken (recip a) (ac `over` black)
-- | The 'maxBound' of a 'Word8' value.
maxWord :: Double
maxWord = fromIntegral (maxBound :: Word8)