{-# LANGUAGE CPP, OverloadedStrings #-}
module Data.GraphViz.Attributes.Colors
(
ColorScheme(..)
, Color(..)
, ColorList
, WeightedColor(..)
, toWC
, toColorList
, NamedColor(toColor)
, toWColor
, toColour
, fromColour
, fromAColour
) where
import Data.GraphViz.Attributes.Colors.Brewer (BrewerColor(..))
import Data.GraphViz.Attributes.Colors.SVG (SVGColor, svgColour)
import Data.GraphViz.Attributes.Colors.X11 (X11Color(Transparent), x11Colour)
import Data.GraphViz.Attributes.ColorScheme (ColorScheme(..))
import Data.GraphViz.Exception
import Data.GraphViz.Internal.State
import Data.GraphViz.Internal.Util (bool)
import Data.GraphViz.Parsing
import Data.GraphViz.Printing
import Data.Colour (AlphaColour, alphaChannel, black, darken,
opaque, over, withOpacity)
import Data.Colour.RGBSpace (uncurryRGB)
import Data.Colour.RGBSpace.HSV (hsv)
import Data.Colour.SRGB (Colour, sRGB, sRGB24, toSRGB24)
import Data.Char (isHexDigit)
import Data.Maybe (isJust)
import qualified Data.Text.Lazy as T
import Data.Word (Word8)
import Numeric (readHex, showHex)
#if !MIN_VERSION_base (4,13,0)
import Data.Monoid ((<>))
#endif
data Color = RGB { Color -> Word8
red :: Word8
, Color -> Word8
green :: Word8
, Color -> Word8
blue :: Word8
}
| RGBA { red :: Word8
, green :: Word8
, blue :: Word8
, Color -> Word8
alpha :: Word8
}
| HSV { Color -> Double
hue :: Double
, Color -> Double
saturation :: Double
, Color -> Double
value :: Double
}
| X11Color X11Color
| SVGColor SVGColor
| BrewerColor BrewerColor
deriving (Color -> Color -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Color -> Color -> Bool
$c/= :: Color -> Color -> Bool
== :: Color -> Color -> Bool
$c== :: Color -> Color -> Bool
Eq, Eq Color
Color -> Color -> Bool
Color -> Color -> Ordering
Color -> Color -> Color
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Color -> Color -> Color
$cmin :: Color -> Color -> Color
max :: Color -> Color -> Color
$cmax :: Color -> Color -> Color
>= :: Color -> Color -> Bool
$c>= :: Color -> Color -> Bool
> :: Color -> Color -> Bool
$c> :: Color -> Color -> Bool
<= :: Color -> Color -> Bool
$c<= :: Color -> Color -> Bool
< :: Color -> Color -> Bool
$c< :: Color -> Color -> Bool
compare :: Color -> Color -> Ordering
$ccompare :: Color -> Color -> Ordering
Ord, Int -> Color -> ShowS
[Color] -> ShowS
Color -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Color] -> ShowS
$cshowList :: [Color] -> ShowS
show :: Color -> String
$cshow :: Color -> String
showsPrec :: Int -> Color -> ShowS
$cshowsPrec :: Int -> Color -> ShowS
Show, ReadPrec [Color]
ReadPrec Color
Int -> ReadS Color
ReadS [Color]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Color]
$creadListPrec :: ReadPrec [Color]
readPrec :: ReadPrec Color
$creadPrec :: ReadPrec Color
readList :: ReadS [Color]
$creadList :: ReadS [Color]
readsPrec :: Int -> ReadS Color
$creadsPrec :: Int -> ReadS Color
Read)
instance PrintDot Color where
unqtDot :: Color -> DotCode
unqtDot (RGB Word8
r Word8
g Word8
b) = [Word8] -> DotCode
hexColor [Word8
r,Word8
g,Word8
b]
unqtDot (RGBA Word8
r Word8
g Word8
b Word8
a) = [Word8] -> DotCode
hexColor [Word8
r,Word8
g,Word8
b,Word8
a]
unqtDot (HSV Double
h Double
s Double
v) = forall (m :: * -> *). Functor m => m [Doc] -> m Doc
hcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Applicative m => m Doc -> m [Doc] -> m [Doc]
punctuate forall (m :: * -> *). Applicative m => m Doc
comma forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. PrintDot a => a -> DotCode
unqtDot [Double
h,Double
s,Double
v]
unqtDot (SVGColor SVGColor
name) = forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
False SVGColor
name
unqtDot (X11Color X11Color
name) = forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
False X11Color
name
unqtDot (BrewerColor BrewerColor
bc) = forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
False BrewerColor
bc
toDot :: Color -> DotCode
toDot (X11Color X11Color
name) = forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True X11Color
name
toDot (SVGColor SVGColor
name) = forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True SVGColor
name
toDot (BrewerColor BrewerColor
bc) = forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True BrewerColor
bc
toDot Color
c = forall (m :: * -> *). Functor m => m Doc -> m Doc
dquotes forall a b. (a -> b) -> a -> b
$ forall a. PrintDot a => a -> DotCode
unqtDot Color
c
unqtListToDot :: [Color] -> DotCode
unqtListToDot = forall (m :: * -> *). Functor m => m [Doc] -> m Doc
hcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Applicative m => m Doc -> m [Doc] -> m [Doc]
punctuate forall (m :: * -> *). Applicative m => m Doc
colon forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. PrintDot a => a -> DotCode
unqtDot
listToDot :: [Color] -> DotCode
listToDot [X11Color X11Color
name] = forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True X11Color
name
listToDot [SVGColor SVGColor
name] = forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True SVGColor
name
listToDot [BrewerColor BrewerColor
bc] = forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True BrewerColor
bc
listToDot [Color]
cs = forall (m :: * -> *). Functor m => m Doc -> m Doc
dquotes forall a b. (a -> b) -> a -> b
$ forall a. PrintDot a => [a] -> DotCode
unqtListToDot [Color]
cs
hexColor :: [Word8] -> DotCode
hexColor :: [Word8] -> DotCode
hexColor = forall a. Semigroup a => a -> a -> a
(<>) (forall (m :: * -> *). Applicative m => Char -> m Doc
char Char
'#') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Functor m => m [Doc] -> m Doc
hcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Word8 -> DotCode
word8Doc
word8Doc :: Word8 -> DotCode
word8Doc :: Word8 -> DotCode
word8Doc Word8
w = forall (m :: * -> *). Applicative m => Text -> m Doc
text forall a b. (a -> b) -> a -> b
$ Text
padding Text -> Text -> Text
`T.append` Text
simple
where
simple :: Text
simple = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. (Integral a, Show a) => a -> ShowS
showHex Word8
w String
""
padding :: Text
padding = Int64 -> Text -> Text
T.replicate Int64
count (Char -> Text
T.singleton Char
'0')
count :: Int64
count = Int64
2 forall a. Num a => a -> a -> a
- forall {t} {t}. (Num t, Integral t) => t -> t -> t
findCols Int64
1 Word8
w
findCols :: t -> t -> t
findCols t
c t
n
| t
n forall a. Ord a => a -> a -> Bool
< t
16 = t
c
| Bool
otherwise = t -> t -> t
findCols (t
cforall a. Num a => a -> a -> a
+t
1) (t
n forall a. Integral a => a -> a -> a
`div` t
16)
instance ParseDot Color where
parseUnqt :: Parse Color
parseUnqt = forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ Parse Color
parseHexBased
, Parse Color
parseHSV
, forall nc. NamedColor nc => nc -> Bool -> Parse Color
parseNC (forall a. HasCallStack => a
undefined :: BrewerColor) Bool
False
, forall nc. NamedColor nc => nc -> Bool -> Parse Color
parseNC (forall a. HasCallStack => a
undefined :: SVGColor) Bool
False
, Bool -> Parse Color
parseX11Color Bool
False
]
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Could not parse Color"
where
parseHexBased :: Parse Color
parseHexBased
= Char -> Parse Char
character Char
'#' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
do [Word8]
cs <- forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 forall {s}. Parser s Word8
parse2Hex
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [Word8]
cs of
[Word8
r,Word8
g,Word8
b] -> Word8 -> Word8 -> Word8 -> Color
RGB Word8
r Word8
g Word8
b
[Word8
r,Word8
g,Word8
b,Word8
a] -> Word8 -> Word8 -> Word8 -> Word8 -> Color
RGBA Word8
r Word8
g Word8
b Word8
a
[Word8]
_ -> forall a e. Exception e => e -> a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GraphvizException
NotDotCode
forall a b. (a -> b) -> a -> b
$ String
"Not a valid hex Color specification: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Word8]
cs
parseHSV :: Parse Color
parseHSV = Double -> Double -> Double -> Color
HSV forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ParseDot a => Parse a
parseUnqt
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser GraphvizState ()
parseSep
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. ParseDot a => Parse a
parseUnqt
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser GraphvizState ()
parseSep
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. ParseDot a => Parse a
parseUnqt
parseSep :: Parser GraphvizState ()
parseSep = Char -> Parse Char
character Char
',' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser GraphvizState ()
whitespace forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser GraphvizState ()
whitespace1
parse2Hex :: Parser s Word8
parse2Hex = do Char
c1 <- forall s. (Char -> Bool) -> Parser s Char
satisfy Char -> Bool
isHexDigit
Char
c2 <- forall s. (Char -> Bool) -> Parser s Char
satisfy Char -> Bool
isHexDigit
let [(Word8
n, [])] = forall a. (Eq a, Num a) => ReadS a
readHex [Char
c1, Char
c2]
forall (m :: * -> *) a. Monad m => a -> m a
return Word8
n
parse :: Parse Color
parse = forall a. Parse a -> Parse a
quotedParse forall a. ParseDot a => Parse a
parseUnqt
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ forall nc. NamedColor nc => nc -> Bool -> Parse Color
parseNC (forall a. HasCallStack => a
undefined :: BrewerColor) Bool
True
, forall nc. NamedColor nc => nc -> Bool -> Parse Color
parseNC (forall a. HasCallStack => a
undefined :: SVGColor) Bool
True
, Bool -> Parse Color
parseX11Color Bool
True
]
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Could not parse Color"
parseUnqtList :: Parse [Color]
parseUnqtList = forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
sepBy1 forall a. ParseDot a => Parse a
parseUnqt (Char -> Parse Char
character Char
':')
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
do ColorScheme
cs <- forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad forall a b. (a -> b) -> a -> b
$ String
"Error parsing list of Colors with color scheme of "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ColorScheme
cs
parseList :: Parse [Color]
parseList = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[])
(forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ forall nc. NamedColor nc => nc -> Bool -> Parse Color
parseNC (forall a. HasCallStack => a
undefined :: BrewerColor) Bool
True
, forall nc. NamedColor nc => nc -> Bool -> Parse Color
parseNC (forall a. HasCallStack => a
undefined :: SVGColor) Bool
True
, Bool -> Parse Color
parseX11Color Bool
True
]
)
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
forall a. Parse a -> Parse a
quotedParse forall a. ParseDot a => Parse [a]
parseUnqtList
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
do ColorScheme
cs <- forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad forall a b. (a -> b) -> a -> b
$ String
"Error parsing list of Colors with color scheme of "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ColorScheme
cs
type ColorList = [WeightedColor]
data WeightedColor = WC { WeightedColor -> Color
wColor :: Color
, WeightedColor -> Maybe Double
weighting :: Maybe Double
}
deriving (WeightedColor -> WeightedColor -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WeightedColor -> WeightedColor -> Bool
$c/= :: WeightedColor -> WeightedColor -> Bool
== :: WeightedColor -> WeightedColor -> Bool
$c== :: WeightedColor -> WeightedColor -> Bool
Eq, Eq WeightedColor
WeightedColor -> WeightedColor -> Bool
WeightedColor -> WeightedColor -> Ordering
WeightedColor -> WeightedColor -> WeightedColor
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: WeightedColor -> WeightedColor -> WeightedColor
$cmin :: WeightedColor -> WeightedColor -> WeightedColor
max :: WeightedColor -> WeightedColor -> WeightedColor
$cmax :: WeightedColor -> WeightedColor -> WeightedColor
>= :: WeightedColor -> WeightedColor -> Bool
$c>= :: WeightedColor -> WeightedColor -> Bool
> :: WeightedColor -> WeightedColor -> Bool
$c> :: WeightedColor -> WeightedColor -> Bool
<= :: WeightedColor -> WeightedColor -> Bool
$c<= :: WeightedColor -> WeightedColor -> Bool
< :: WeightedColor -> WeightedColor -> Bool
$c< :: WeightedColor -> WeightedColor -> Bool
compare :: WeightedColor -> WeightedColor -> Ordering
$ccompare :: WeightedColor -> WeightedColor -> Ordering
Ord, Int -> WeightedColor -> ShowS
[WeightedColor] -> ShowS
WeightedColor -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WeightedColor] -> ShowS
$cshowList :: [WeightedColor] -> ShowS
show :: WeightedColor -> String
$cshow :: WeightedColor -> String
showsPrec :: Int -> WeightedColor -> ShowS
$cshowsPrec :: Int -> WeightedColor -> ShowS
Show, ReadPrec [WeightedColor]
ReadPrec WeightedColor
Int -> ReadS WeightedColor
ReadS [WeightedColor]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WeightedColor]
$creadListPrec :: ReadPrec [WeightedColor]
readPrec :: ReadPrec WeightedColor
$creadPrec :: ReadPrec WeightedColor
readList :: ReadS [WeightedColor]
$creadList :: ReadS [WeightedColor]
readsPrec :: Int -> ReadS WeightedColor
$creadsPrec :: Int -> ReadS WeightedColor
Read)
toWC :: Color -> WeightedColor
toWC :: Color -> WeightedColor
toWC = (Color -> Maybe Double -> WeightedColor
`WC` forall a. Maybe a
Nothing)
toColorList :: [Color] -> ColorList
toColorList :: [Color] -> [WeightedColor]
toColorList = forall a b. (a -> b) -> [a] -> [b]
map Color -> WeightedColor
toWC
instance PrintDot WeightedColor where
unqtDot :: WeightedColor -> DotCode
unqtDot (WC Color
c Maybe Double
mw) = forall a. PrintDot a => a -> DotCode
unqtDot Color
c
forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *). Applicative m => m Doc
empty ((forall (m :: * -> *). Applicative m => m Doc
semiforall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PrintDot a => a -> DotCode
unqtDot) Maybe Double
mw
toDot :: WeightedColor -> DotCode
toDot (WC Color
c Maybe Double
Nothing) = forall a. PrintDot a => a -> DotCode
toDot Color
c
toDot WeightedColor
wc = forall (m :: * -> *). Functor m => m Doc -> m Doc
dquotes forall a b. (a -> b) -> a -> b
$ forall a. PrintDot a => a -> DotCode
unqtDot WeightedColor
wc
unqtListToDot :: [WeightedColor] -> DotCode
unqtListToDot = forall (m :: * -> *). Functor m => m [Doc] -> m Doc
hcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Applicative m => m Doc -> m [Doc] -> m [Doc]
punctuate forall (m :: * -> *). Applicative m => m Doc
colon forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. PrintDot a => a -> DotCode
unqtDot
listToDot :: [WeightedColor] -> DotCode
listToDot [WeightedColor
wc] = forall a. PrintDot a => a -> DotCode
toDot WeightedColor
wc
listToDot [WeightedColor]
wcs = forall (m :: * -> *). Functor m => m Doc -> m Doc
dquotes forall a b. (a -> b) -> a -> b
$ forall a. PrintDot a => [a] -> DotCode
unqtListToDot [WeightedColor]
wcs
instance ParseDot WeightedColor where
parseUnqt :: Parse WeightedColor
parseUnqt = Color -> Maybe Double -> WeightedColor
WC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ParseDot a => Parse a
parseUnqt forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parse Char
character Char
';' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. ParseDot a => Parse a
parseUnqt)
parse :: Parse WeightedColor
parse = forall a. Parse a -> Parse a
quotedParse forall a. ParseDot a => Parse a
parseUnqt
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
(Color -> WeightedColor
toWC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ParseDot a => Parse a
parse)
parseUnqtList :: Parse [WeightedColor]
parseUnqtList = forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
sepBy1 forall a. ParseDot a => Parse a
parseUnqt (Char -> Parse Char
character Char
':')
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
do ColorScheme
cs <- forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad forall a b. (a -> b) -> a -> b
$ String
"Error parsing a ColorList with color scheme of "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ColorScheme
cs
parseList :: Parse [WeightedColor]
parseList = forall a. Parse a -> Parse a
quotedParse forall a. ParseDot a => Parse [a]
parseUnqtList
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> WeightedColor
toWC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ParseDot a => Parse a
parse)
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
do ColorScheme
cs <- forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad forall a b. (a -> b) -> a -> b
$ String
"Error parsing ColorList with color scheme of "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ColorScheme
cs
class NamedColor nc where
colorScheme :: nc -> ColorScheme
toColor :: nc -> Color
printNC :: Bool -> nc -> DotCode
parseNC' :: Bool -> Parse nc
toWColor :: (NamedColor nc) => nc -> WeightedColor
toWColor :: forall nc. NamedColor nc => nc -> WeightedColor
toWColor = Color -> WeightedColor
toWC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall nc. NamedColor nc => nc -> Color
toColor
parseNC :: (NamedColor nc) => nc -> Bool -> Parse Color
parseNC :: forall nc. NamedColor nc => nc -> Bool -> Parse Color
parseNC nc
nc Bool
q = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall nc. NamedColor nc => nc -> Color
toColor forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> a -> a
`asTypeOf` nc
nc))
forall a b. (a -> b) -> a -> b
$ forall nc. NamedColor nc => Bool -> Parse nc
parseNC' Bool
q
instance NamedColor BrewerColor where
colorScheme :: BrewerColor -> ColorScheme
colorScheme (BC BrewerScheme
bs Word8
_) = BrewerScheme -> ColorScheme
Brewer BrewerScheme
bs
toColor :: BrewerColor -> Color
toColor = BrewerColor -> Color
BrewerColor
printNC :: Bool -> BrewerColor -> DotCode
printNC = forall nc lv.
(NamedColor nc, PrintDot lv) =>
(nc -> lv) -> Bool -> nc -> DotCode
printNamedColor (\ (BC BrewerScheme
_ Word8
l) -> Word8
l)
parseNC' :: Bool -> Parse BrewerColor
parseNC' = forall lv cs nc.
ParseDot lv =>
(ColorScheme -> Maybe cs)
-> Parse cs -> (cs -> Bool) -> (cs -> lv -> nc) -> Bool -> Parse nc
parseNamedColor ColorScheme -> Maybe BrewerScheme
mBCS forall a. ParseDot a => Parse a
parseUnqt (forall a b. a -> b -> a
const Bool
True) BrewerScheme -> Word8 -> BrewerColor
BC
where
mBCS :: ColorScheme -> Maybe BrewerScheme
mBCS (Brewer BrewerScheme
bs) = forall a. a -> Maybe a
Just BrewerScheme
bs
mBCS ColorScheme
_ = forall a. Maybe a
Nothing
instance NamedColor X11Color where
colorScheme :: X11Color -> ColorScheme
colorScheme = forall a b. a -> b -> a
const ColorScheme
X11
toColor :: X11Color -> Color
toColor = X11Color -> Color
X11Color
printNC :: Bool -> X11Color -> DotCode
printNC = forall nc lv.
(NamedColor nc, PrintDot lv) =>
(nc -> lv) -> Bool -> nc -> DotCode
printNamedColor forall a. a -> a
id
parseNC' :: Bool -> Parse X11Color
parseNC' = forall lv cs nc.
ParseDot lv =>
(ColorScheme -> Maybe cs)
-> Parse cs -> (cs -> Bool) -> (cs -> lv -> nc) -> Bool -> Parse nc
parseNamedColor ColorScheme -> Maybe ColorScheme
mX11 (Bool -> Parse ColorScheme
parseColorScheme Bool
False) (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColorScheme -> Maybe ColorScheme
mX11) (forall a b. a -> b -> a
const forall a. a -> a
id)
where
mX11 :: ColorScheme -> Maybe ColorScheme
mX11 ColorScheme
X11 = forall a. a -> Maybe a
Just ColorScheme
X11
mX11 ColorScheme
_ = forall a. Maybe a
Nothing
instance NamedColor SVGColor where
colorScheme :: SVGColor -> ColorScheme
colorScheme = forall a b. a -> b -> a
const ColorScheme
SVG
toColor :: SVGColor -> Color
toColor = SVGColor -> Color
SVGColor
printNC :: Bool -> SVGColor -> DotCode
printNC = forall nc lv.
(NamedColor nc, PrintDot lv) =>
(nc -> lv) -> Bool -> nc -> DotCode
printNamedColor forall a. a -> a
id
parseNC' :: Bool -> Parse SVGColor
parseNC' = forall lv cs nc.
ParseDot lv =>
(ColorScheme -> Maybe cs)
-> Parse cs -> (cs -> Bool) -> (cs -> lv -> nc) -> Bool -> Parse nc
parseNamedColor ColorScheme -> Maybe ColorScheme
mSVG (Bool -> Parse ColorScheme
parseColorScheme Bool
False) (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColorScheme -> Maybe ColorScheme
mSVG) (forall a b. a -> b -> a
const forall a. a -> a
id)
where
mSVG :: ColorScheme -> Maybe ColorScheme
mSVG ColorScheme
SVG = forall a. a -> Maybe a
Just ColorScheme
SVG
mSVG ColorScheme
_ = forall a. Maybe a
Nothing
printNamedColor :: (NamedColor nc, PrintDot lv) => (nc -> lv)
-> Bool -> nc -> DotCode
printNamedColor :: forall nc lv.
(NamedColor nc, PrintDot lv) =>
(nc -> lv) -> Bool -> nc -> DotCode
printNamedColor nc -> lv
fl Bool
q nc
c = do ColorScheme
currentCS <- forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
if ColorScheme
cs forall a. Eq a => a -> a -> Bool
== ColorScheme
currentCS
then (forall a. a -> a -> Bool -> a
bool forall a. PrintDot a => a -> DotCode
unqtDot forall a. PrintDot a => a -> DotCode
toDot Bool
q) lv
lv
else forall a. a -> a -> Bool -> a
bool forall a. a -> a
id forall (m :: * -> *). Functor m => m Doc -> m Doc
dquotes Bool
q
forall a b. (a -> b) -> a -> b
$ DotCode
fslash forall a. Semigroup a => a -> a -> a
<> Bool -> ColorScheme -> DotCode
printColorScheme Bool
False ColorScheme
cs
forall a. Semigroup a => a -> a -> a
<> DotCode
fslash forall a. Semigroup a => a -> a -> a
<> forall a. PrintDot a => a -> DotCode
unqtDot lv
lv
where
cs :: ColorScheme
cs = forall nc. NamedColor nc => nc -> ColorScheme
colorScheme nc
c
lv :: lv
lv = nc -> lv
fl nc
c
parseNamedColor :: (ParseDot lv)
=> (ColorScheme -> Maybe cs) -> Parse cs -> (cs -> Bool)
-> (cs -> lv -> nc) -> Bool -> Parse nc
parseNamedColor :: forall lv cs nc.
ParseDot lv =>
(ColorScheme -> Maybe cs)
-> Parse cs -> (cs -> Bool) -> (cs -> lv -> nc) -> Bool -> Parse nc
parseNamedColor ColorScheme -> Maybe cs
gcs Parse cs
parseCS cs -> Bool
vcs cs -> lv -> nc
mkC Bool
q
= do Just cs
cs <- ColorScheme -> Maybe cs
gcs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
lv
lv <- forall a. a -> a -> Bool -> a
bool forall a. ParseDot a => Parse a
parseUnqt forall a. ParseDot a => Parse a
parse Bool
q
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
forall a. Parse a -> Parse a
mQts (String -> Parser GraphvizState ()
string String
"//" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. ParseDot a => Parse a
parseUnqt)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ cs -> lv -> nc
mkC cs
cs lv
lv
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
forall a. Parse a -> Parse a
mQts ( do Char -> Parse Char
character Char
'/'
cs
cs <- Parse cs
parseCS
Char -> Parse Char
character Char
'/'
if cs -> Bool
vcs cs
cs
then cs -> lv -> nc
mkC cs
cs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ParseDot a => Parse a
parseUnqt
else forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Explicit colorscheme not as expected."
)
where
mQts :: Parse a -> Parse a
mQts = forall a. a -> a -> Bool -> a
bool forall a. a -> a
id forall a. Parse a -> Parse a
quotedParse Bool
q
parseX11Color :: Bool -> Parse Color
parseX11Color :: Bool -> Parse Color
parseX11Color Bool
q = X11Color -> Color
X11Color
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall nc. NamedColor nc => Bool -> Parse nc
parseNC' Bool
q
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
forall a. a -> a -> Bool -> a
bool forall a. a -> a
id forall a. Parse a -> Parse a
quotedParse Bool
q (Char -> Parse Char
character Char
'/' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. ParseDot a => Parse a
parseUnqt)
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
do ColorScheme
cs <- forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
case ColorScheme
cs of
Brewer{} -> forall a. a -> a -> Bool -> a
bool forall a. ParseDot a => Parse a
parseUnqt forall a. ParseDot a => Parse a
parse Bool
q
ColorScheme
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to parse an X11 color within Brewer"
toColour :: Color -> Maybe (AlphaColour Double)
toColour :: Color -> Maybe (AlphaColour Double)
toColour (RGB Word8
r Word8
g Word8
b) = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Colour a -> AlphaColour a
opaque forall a b. (a -> b) -> a -> b
$ forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 Word8
r Word8
g Word8
b
toColour (RGBA Word8
r Word8
g Word8
b Word8
a) = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Colour a -> a -> AlphaColour a
withOpacity (forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 Word8
r Word8
g Word8
b) forall a b. (a -> b) -> a -> b
$ Word8 -> Double
toOpacity Word8
a
toColour (HSV Double
h Double
s Double
v) = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Colour a -> AlphaColour a
opaque forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> a -> a -> b) -> RGB a -> b
uncurryRGB forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB forall a b. (a -> b) -> a -> b
$ forall a. (RealFrac a, Ord a) => a -> a -> a -> RGB a
hsv (Double
hforall a. Num a => a -> a -> a
*Double
360) Double
s Double
v
toColour (X11Color X11Color
c) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ X11Color -> AlphaColour Double
x11Colour X11Color
c
toColour (SVGColor SVGColor
c) = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Colour a -> AlphaColour a
opaque forall a b. (a -> b) -> a -> b
$ SVGColor -> Colour Double
svgColour SVGColor
c
toColour BrewerColor{} = forall a. Maybe a
Nothing
toOpacity :: Word8 -> Double
toOpacity :: Word8 -> Double
toOpacity Word8
a = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
a forall a. Fractional a => a -> a -> a
/ Double
maxWord
fromColour :: Colour Double -> Color
fromColour :: Colour Double -> Color
fromColour = forall a b. (a -> a -> a -> b) -> RGB a -> b
uncurryRGB Word8 -> Word8 -> Word8 -> Color
RGB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. (RealFrac b, Floating b) => Colour b -> RGB Word8
toSRGB24
fromAColour :: AlphaColour Double -> Color
fromAColour :: AlphaColour Double -> Color
fromAColour AlphaColour Double
ac
| Double
a forall a. Eq a => a -> a -> Bool
== Double
0 = X11Color -> Color
X11Color X11Color
Transparent
| Bool
otherwise = Word8 -> Color
rgb forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
round Double
a'
where
a :: Double
a = forall a. AlphaColour a -> a
alphaChannel AlphaColour Double
ac
a' :: Double
a' = Double
a forall a. Num a => a -> a -> a
* Double
maxWord
rgb :: Word8 -> Color
rgb = forall a b. (a -> a -> a -> b) -> RGB a -> b
uncurryRGB Word8 -> Word8 -> Word8 -> Word8 -> Color
RGBA forall a b. (a -> b) -> a -> b
$ forall b. (RealFrac b, Floating b) => Colour b -> RGB Word8
toSRGB24 Colour Double
colour
colour :: Colour Double
colour = forall (f :: * -> *) a. (ColourOps f, Num a) => a -> f a -> f a
darken (forall a. Fractional a => a -> a
recip Double
a) (AlphaColour Double
ac forall (f :: * -> *) a.
(ColourOps f, Num a) =>
AlphaColour a -> f a -> f a
`over` forall a. Num a => Colour a
black)
maxWord :: Double
maxWord :: Double
maxWord = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word8)