graphviz-2999.16.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(..)
, ColorList
, WeightedColor(..)
, toWC
, toColorList
, NamedColor(toColor)
, toWColor
-- * 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 (:[])
-- Potentially 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
-- | The sum of the optional weightings /must/ sum to at most @1@.
type ColorList = [WeightedColor]
-- | A 'Color' tagged with an optional weighting.
data WeightedColor = WC { wColor :: Color
-- | Must be in range @0 <= W <= 1@.
, weighting :: Maybe Double
}
deriving (Eq, Ord, Show, Read)
-- | For colors without weightings.
toWC :: Color -> WeightedColor
toWC = (`WC` Nothing)
-- | For a list of colors without weightings.
toColorList :: [Color] -> ColorList
toColorList = map toWC
instance PrintDot WeightedColor where
unqtDot (WC c mw) = unqtDot c
<> maybe empty ((semi<>) . unqtDot) mw
toDot (WC c Nothing) = toDot c
toDot wc = dquotes $ unqtDot wc
unqtListToDot = hcat . punctuate colon . mapM unqtDot
-- Might not need quoting
listToDot [wc] = toDot wc
listToDot wcs = dquotes $ unqtListToDot wcs
instance ParseDot WeightedColor where
parseUnqt = WC <$> parseUnqt <*> optional (character ';' *> parseUnqt)
parse = quotedParse parseUnqt
`onFail`
-- Using parse rather than parseUnqt as there shouldn't be
-- any quotes, but to avoid copy-pasting the oneOf block.
(toWC <$> parse)
parseUnqtList = sepBy1 parseUnqt (character ':')
`onFail`
do cs <- getColorScheme
failBad $ "Error parsing a ColorList with color scheme of "
++ show cs
parseList = ((:[]) . toWC <$> parse)
-- Potentially unquoted un-weighted single color
`onFail`
quotedParse parseUnqtList
`onFail`
do cs <- getColorScheme
failBad $ "Error parsing ColorList 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
toWColor :: (NamedColor nc) => nc -> WeightedColor
toWColor = toWC . toColor
-- First value just used for type
parseNC :: (NamedColor nc) => nc -> Bool -> Parse Color
parseNC nc q = fmap (toColor . (`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)