{-# 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
(Color -> Color -> Bool) -> (Color -> Color -> Bool) -> Eq Color
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
Eq Color =>
(Color -> Color -> Ordering)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Bool)
-> (Color -> Color -> Color)
-> (Color -> Color -> Color)
-> Ord 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
$cp1Ord :: Eq Color
Ord, Int -> Color -> ShowS
[Color] -> ShowS
Color -> String
(Int -> Color -> ShowS)
-> (Color -> String) -> ([Color] -> ShowS) -> Show Color
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]
(Int -> ReadS Color)
-> ReadS [Color]
-> ReadPrec Color
-> ReadPrec [Color]
-> Read 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 r :: Word8
r g :: Word8
g b :: Word8
b) = [Word8] -> DotCode
hexColor [Word8
r,Word8
g,Word8
b]
unqtDot (RGBA r :: Word8
r g :: Word8
g b :: Word8
b a :: Word8
a) = [Word8] -> DotCode
hexColor [Word8
r,Word8
g,Word8
b,Word8
a]
unqtDot (HSV h :: Double
h s :: Double
s v :: Double
v) = DotCodeM [Doc] -> DotCode
forall (m :: * -> *). Functor m => m [Doc] -> m Doc
hcat (DotCodeM [Doc] -> DotCode)
-> (DotCodeM [Doc] -> DotCodeM [Doc]) -> DotCodeM [Doc] -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCode -> DotCodeM [Doc] -> DotCodeM [Doc]
forall (m :: * -> *). Applicative m => m Doc -> m [Doc] -> m [Doc]
punctuate DotCode
forall (m :: * -> *). Applicative m => m Doc
comma (DotCodeM [Doc] -> DotCode) -> DotCodeM [Doc] -> DotCode
forall a b. (a -> b) -> a -> b
$ (Double -> DotCode) -> [Double] -> DotCodeM [Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Double -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot [Double
h,Double
s,Double
v]
unqtDot (SVGColor name :: SVGColor
name) = Bool -> SVGColor -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
False SVGColor
name
unqtDot (X11Color name :: X11Color
name) = Bool -> X11Color -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
False X11Color
name
unqtDot (BrewerColor bc :: BrewerColor
bc) = Bool -> BrewerColor -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
False BrewerColor
bc
toDot :: Color -> DotCode
toDot (X11Color name :: X11Color
name) = Bool -> X11Color -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True X11Color
name
toDot (SVGColor name :: SVGColor
name) = Bool -> SVGColor -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True SVGColor
name
toDot (BrewerColor bc :: BrewerColor
bc) = Bool -> BrewerColor -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True BrewerColor
bc
toDot c :: Color
c = DotCode -> DotCode
forall (m :: * -> *). Functor m => m Doc -> m Doc
dquotes (DotCode -> DotCode) -> DotCode -> DotCode
forall a b. (a -> b) -> a -> b
$ Color -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot Color
c
unqtListToDot :: [Color] -> DotCode
unqtListToDot = DotCodeM [Doc] -> DotCode
forall (m :: * -> *). Functor m => m [Doc] -> m Doc
hcat (DotCodeM [Doc] -> DotCode)
-> ([Color] -> DotCodeM [Doc]) -> [Color] -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCode -> DotCodeM [Doc] -> DotCodeM [Doc]
forall (m :: * -> *). Applicative m => m Doc -> m [Doc] -> m [Doc]
punctuate DotCode
forall (m :: * -> *). Applicative m => m Doc
colon (DotCodeM [Doc] -> DotCodeM [Doc])
-> ([Color] -> DotCodeM [Doc]) -> [Color] -> DotCodeM [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Color -> DotCode) -> [Color] -> DotCodeM [Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Color -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot
listToDot :: [Color] -> DotCode
listToDot [X11Color name :: X11Color
name] = Bool -> X11Color -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True X11Color
name
listToDot [SVGColor name :: SVGColor
name] = Bool -> SVGColor -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True SVGColor
name
listToDot [BrewerColor bc :: BrewerColor
bc] = Bool -> BrewerColor -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True BrewerColor
bc
listToDot cs :: [Color]
cs = DotCode -> DotCode
forall (m :: * -> *). Functor m => m Doc -> m Doc
dquotes (DotCode -> DotCode) -> DotCode -> DotCode
forall a b. (a -> b) -> a -> b
$ [Color] -> DotCode
forall a. PrintDot a => [a] -> DotCode
unqtListToDot [Color]
cs
hexColor :: [Word8] -> DotCode
hexColor :: [Word8] -> DotCode
hexColor = DotCode -> DotCode -> DotCode
forall a. Semigroup a => a -> a -> a
(<>) (Char -> DotCode
forall (m :: * -> *). Applicative m => Char -> m Doc
char '#') (DotCode -> DotCode) -> ([Word8] -> DotCode) -> [Word8] -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCodeM [Doc] -> DotCode
forall (m :: * -> *). Functor m => m [Doc] -> m Doc
hcat (DotCodeM [Doc] -> DotCode)
-> ([Word8] -> DotCodeM [Doc]) -> [Word8] -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> DotCode) -> [Word8] -> DotCodeM [Doc]
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 w :: Word8
w = Text -> DotCode
forall (m :: * -> *). Applicative m => Text -> m Doc
text (Text -> DotCode) -> Text -> DotCode
forall a b. (a -> b) -> a -> b
$ Text
padding Text -> Text -> Text
`T.append` Text
simple
where
simple :: Text
simple = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word8 -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex Word8
w ""
padding :: Text
padding = Int64 -> Text -> Text
T.replicate Int64
count (Char -> Text
T.singleton '0')
count :: Int64
count = 2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64 -> Word8 -> Int64
forall t t. (Num t, Integral t) => t -> t -> t
findCols 1 Word8
w
findCols :: t -> t -> t
findCols c :: t
c n :: t
n
| t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< 16 = t
c
| Bool
otherwise = t -> t -> t
findCols (t
ct -> t -> t
forall a. Num a => a -> a -> a
+1) (t
n t -> t -> t
forall a. Integral a => a -> a -> a
`div` 16)
instance ParseDot Color where
parseUnqt :: Parse Color
parseUnqt = [Parse Color] -> Parse Color
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ Parse Color
parseHexBased
, Parse Color
parseHSV
, BrewerColor -> Bool -> Parse Color
forall nc. NamedColor nc => nc -> Bool -> Parse Color
parseNC (BrewerColor
forall a. HasCallStack => a
undefined :: BrewerColor) Bool
False
, SVGColor -> Bool -> Parse Color
forall nc. NamedColor nc => nc -> Bool -> Parse Color
parseNC (SVGColor
forall a. HasCallStack => a
undefined :: SVGColor) Bool
False
, Bool -> Parse Color
parseX11Color Bool
False
]
Parse Color -> Parse Color -> Parse Color
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
String -> Parse Color
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Could not parse Color"
where
parseHexBased :: Parse Color
parseHexBased
= Char -> Parse Char
character '#' Parse Char -> Parse Color -> Parse Color
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
do [Word8]
cs <- Parser GraphvizState Word8 -> Parser GraphvizState [Word8]
forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 Parser GraphvizState Word8
forall s. Parser s Word8
parse2Hex
Color -> Parse Color
forall (m :: * -> *) a. Monad m => a -> m a
return (Color -> Parse Color) -> Color -> Parse Color
forall a b. (a -> b) -> a -> b
$ case [Word8]
cs of
[r :: Word8
r,g :: Word8
g,b :: Word8
b] -> Word8 -> Word8 -> Word8 -> Color
RGB Word8
r Word8
g Word8
b
[r :: Word8
r,g :: Word8
g,b :: Word8
b,a :: Word8
a] -> Word8 -> Word8 -> Word8 -> Word8 -> Color
RGBA Word8
r Word8
g Word8
b Word8
a
_ -> GraphvizException -> Color
forall a e. Exception e => e -> a
throw (GraphvizException -> Color)
-> (String -> GraphvizException) -> String -> Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GraphvizException
NotDotCode
(String -> Color) -> String -> Color
forall a b. (a -> b) -> a -> b
$ "Not a valid hex Color specification: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Word8] -> String
forall a. Show a => a -> String
show [Word8]
cs
parseHSV :: Parse Color
parseHSV = Double -> Double -> Double -> Color
HSV (Double -> Double -> Double -> Color)
-> Parser GraphvizState Double
-> Parser GraphvizState (Double -> Double -> Color)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser GraphvizState Double
forall a. ParseDot a => Parse a
parseUnqt
Parser GraphvizState (Double -> Double -> Color)
-> Parser GraphvizState ()
-> Parser GraphvizState (Double -> Double -> Color)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser GraphvizState ()
parseSep
Parser GraphvizState (Double -> Double -> Color)
-> Parser GraphvizState Double
-> Parser GraphvizState (Double -> Color)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser GraphvizState Double
forall a. ParseDot a => Parse a
parseUnqt
Parser GraphvizState (Double -> Color)
-> Parser GraphvizState ()
-> Parser GraphvizState (Double -> Color)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser GraphvizState ()
parseSep
Parser GraphvizState (Double -> Color)
-> Parser GraphvizState Double -> Parse Color
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser GraphvizState Double
forall a. ParseDot a => Parse a
parseUnqt
parseSep :: Parser GraphvizState ()
parseSep = Char -> Parse Char
character ',' Parse Char -> Parser GraphvizState () -> Parser GraphvizState ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser GraphvizState ()
whitespace Parser GraphvizState ()
-> Parser GraphvizState () -> Parser GraphvizState ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser GraphvizState ()
whitespace1
parse2Hex :: Parser s Word8
parse2Hex = do Char
c1 <- (Char -> Bool) -> Parser s Char
forall s. (Char -> Bool) -> Parser s Char
satisfy Char -> Bool
isHexDigit
Char
c2 <- (Char -> Bool) -> Parser s Char
forall s. (Char -> Bool) -> Parser s Char
satisfy Char -> Bool
isHexDigit
let [(n :: Word8
n, [])] = ReadS Word8
forall a. (Eq a, Num a) => ReadS a
readHex [Char
c1, Char
c2]
Word8 -> Parser s Word8
forall (m :: * -> *) a. Monad m => a -> m a
return Word8
n
parse :: Parse Color
parse = Parse Color -> Parse Color
forall a. Parse a -> Parse a
quotedParse Parse Color
forall a. ParseDot a => Parse a
parseUnqt
Parse Color -> Parse Color -> Parse Color
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
[Parse Color] -> Parse Color
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ BrewerColor -> Bool -> Parse Color
forall nc. NamedColor nc => nc -> Bool -> Parse Color
parseNC (BrewerColor
forall a. HasCallStack => a
undefined :: BrewerColor) Bool
True
, SVGColor -> Bool -> Parse Color
forall nc. NamedColor nc => nc -> Bool -> Parse Color
parseNC (SVGColor
forall a. HasCallStack => a
undefined :: SVGColor) Bool
True
, Bool -> Parse Color
parseX11Color Bool
True
]
Parse Color -> Parse Color -> Parse Color
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
String -> Parse Color
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Could not parse Color"
parseUnqtList :: Parse [Color]
parseUnqtList = Parse Color -> Parse Char -> Parse [Color]
forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
sepBy1 Parse Color
forall a. ParseDot a => Parse a
parseUnqt (Char -> Parse Char
character ':')
Parse [Color] -> Parse [Color] -> Parse [Color]
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
do ColorScheme
cs <- Parser GraphvizState ColorScheme
forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
String -> Parse [Color]
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad (String -> Parse [Color]) -> String -> Parse [Color]
forall a b. (a -> b) -> a -> b
$ "Error parsing list of Colors with color scheme of "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ ColorScheme -> String
forall a. Show a => a -> String
show ColorScheme
cs
parseList :: Parse [Color]
parseList = (Color -> [Color]) -> Parse Color -> Parse [Color]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Color -> [Color] -> [Color]
forall a. a -> [a] -> [a]
:[])
([Parse Color] -> Parse Color
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ BrewerColor -> Bool -> Parse Color
forall nc. NamedColor nc => nc -> Bool -> Parse Color
parseNC (BrewerColor
forall a. HasCallStack => a
undefined :: BrewerColor) Bool
True
, SVGColor -> Bool -> Parse Color
forall nc. NamedColor nc => nc -> Bool -> Parse Color
parseNC (SVGColor
forall a. HasCallStack => a
undefined :: SVGColor) Bool
True
, Bool -> Parse Color
parseX11Color Bool
True
]
)
Parse [Color] -> Parse [Color] -> Parse [Color]
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
Parse [Color] -> Parse [Color]
forall a. Parse a -> Parse a
quotedParse Parse [Color]
forall a. ParseDot a => Parse [a]
parseUnqtList
Parse [Color] -> Parse [Color] -> Parse [Color]
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
do ColorScheme
cs <- Parser GraphvizState ColorScheme
forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
String -> Parse [Color]
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad (String -> Parse [Color]) -> String -> Parse [Color]
forall a b. (a -> b) -> a -> b
$ "Error parsing list of Colors with color scheme of "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ ColorScheme -> String
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
(WeightedColor -> WeightedColor -> Bool)
-> (WeightedColor -> WeightedColor -> Bool) -> Eq WeightedColor
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
Eq WeightedColor =>
(WeightedColor -> WeightedColor -> Ordering)
-> (WeightedColor -> WeightedColor -> Bool)
-> (WeightedColor -> WeightedColor -> Bool)
-> (WeightedColor -> WeightedColor -> Bool)
-> (WeightedColor -> WeightedColor -> Bool)
-> (WeightedColor -> WeightedColor -> WeightedColor)
-> (WeightedColor -> WeightedColor -> WeightedColor)
-> Ord 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
$cp1Ord :: Eq WeightedColor
Ord, Int -> WeightedColor -> ShowS
[WeightedColor] -> ShowS
WeightedColor -> String
(Int -> WeightedColor -> ShowS)
-> (WeightedColor -> String)
-> ([WeightedColor] -> ShowS)
-> Show WeightedColor
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]
(Int -> ReadS WeightedColor)
-> ReadS [WeightedColor]
-> ReadPrec WeightedColor
-> ReadPrec [WeightedColor]
-> Read 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` Maybe Double
forall a. Maybe a
Nothing)
toColorList :: [Color] -> ColorList
toColorList :: [Color] -> [WeightedColor]
toColorList = (Color -> WeightedColor) -> [Color] -> [WeightedColor]
forall a b. (a -> b) -> [a] -> [b]
map Color -> WeightedColor
toWC
instance PrintDot WeightedColor where
unqtDot :: WeightedColor -> DotCode
unqtDot (WC c :: Color
c mw :: Maybe Double
mw) = Color -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot Color
c
DotCode -> DotCode -> DotCode
forall a. Semigroup a => a -> a -> a
<> DotCode -> (Double -> DotCode) -> Maybe Double -> DotCode
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DotCode
forall (m :: * -> *). Applicative m => m Doc
empty ((DotCode
forall (m :: * -> *). Applicative m => m Doc
semiDotCode -> DotCode -> DotCode
forall a. Semigroup a => a -> a -> a
<>) (DotCode -> DotCode) -> (Double -> DotCode) -> Double -> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot) Maybe Double
mw
toDot :: WeightedColor -> DotCode
toDot (WC c :: Color
c Nothing) = Color -> DotCode
forall a. PrintDot a => a -> DotCode
toDot Color
c
toDot wc :: WeightedColor
wc = DotCode -> DotCode
forall (m :: * -> *). Functor m => m Doc -> m Doc
dquotes (DotCode -> DotCode) -> DotCode -> DotCode
forall a b. (a -> b) -> a -> b
$ WeightedColor -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot WeightedColor
wc
unqtListToDot :: [WeightedColor] -> DotCode
unqtListToDot = DotCodeM [Doc] -> DotCode
forall (m :: * -> *). Functor m => m [Doc] -> m Doc
hcat (DotCodeM [Doc] -> DotCode)
-> ([WeightedColor] -> DotCodeM [Doc])
-> [WeightedColor]
-> DotCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCode -> DotCodeM [Doc] -> DotCodeM [Doc]
forall (m :: * -> *). Applicative m => m Doc -> m [Doc] -> m [Doc]
punctuate DotCode
forall (m :: * -> *). Applicative m => m Doc
colon (DotCodeM [Doc] -> DotCodeM [Doc])
-> ([WeightedColor] -> DotCodeM [Doc])
-> [WeightedColor]
-> DotCodeM [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WeightedColor -> DotCode) -> [WeightedColor] -> DotCodeM [Doc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM WeightedColor -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot
listToDot :: [WeightedColor] -> DotCode
listToDot [wc :: WeightedColor
wc] = WeightedColor -> DotCode
forall a. PrintDot a => a -> DotCode
toDot WeightedColor
wc
listToDot wcs :: [WeightedColor]
wcs = DotCode -> DotCode
forall (m :: * -> *). Functor m => m Doc -> m Doc
dquotes (DotCode -> DotCode) -> DotCode -> DotCode
forall a b. (a -> b) -> a -> b
$ [WeightedColor] -> DotCode
forall a. PrintDot a => [a] -> DotCode
unqtListToDot [WeightedColor]
wcs
instance ParseDot WeightedColor where
parseUnqt :: Parse WeightedColor
parseUnqt = Color -> Maybe Double -> WeightedColor
WC (Color -> Maybe Double -> WeightedColor)
-> Parse Color
-> Parser GraphvizState (Maybe Double -> WeightedColor)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse Color
forall a. ParseDot a => Parse a
parseUnqt Parser GraphvizState (Maybe Double -> WeightedColor)
-> Parser GraphvizState (Maybe Double) -> Parse WeightedColor
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser GraphvizState Double -> Parser GraphvizState (Maybe Double)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parse Char
character ';' Parse Char
-> Parser GraphvizState Double -> Parser GraphvizState Double
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser GraphvizState Double
forall a. ParseDot a => Parse a
parseUnqt)
parse :: Parse WeightedColor
parse = Parse WeightedColor -> Parse WeightedColor
forall a. Parse a -> Parse a
quotedParse Parse WeightedColor
forall a. ParseDot a => Parse a
parseUnqt
Parse WeightedColor -> Parse WeightedColor -> Parse WeightedColor
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
(Color -> WeightedColor
toWC (Color -> WeightedColor) -> Parse Color -> Parse WeightedColor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse Color
forall a. ParseDot a => Parse a
parse)
parseUnqtList :: Parse [WeightedColor]
parseUnqtList = Parse WeightedColor -> Parse Char -> Parse [WeightedColor]
forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
sepBy1 Parse WeightedColor
forall a. ParseDot a => Parse a
parseUnqt (Char -> Parse Char
character ':')
Parse [WeightedColor]
-> Parse [WeightedColor] -> Parse [WeightedColor]
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
do ColorScheme
cs <- Parser GraphvizState ColorScheme
forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
String -> Parse [WeightedColor]
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad (String -> Parse [WeightedColor])
-> String -> Parse [WeightedColor]
forall a b. (a -> b) -> a -> b
$ "Error parsing a ColorList with color scheme of "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ ColorScheme -> String
forall a. Show a => a -> String
show ColorScheme
cs
parseList :: Parse [WeightedColor]
parseList = Parse [WeightedColor] -> Parse [WeightedColor]
forall a. Parse a -> Parse a
quotedParse Parse [WeightedColor]
forall a. ParseDot a => Parse [a]
parseUnqtList
Parse [WeightedColor]
-> Parse [WeightedColor] -> Parse [WeightedColor]
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
((WeightedColor -> [WeightedColor] -> [WeightedColor]
forall a. a -> [a] -> [a]
:[]) (WeightedColor -> [WeightedColor])
-> (Color -> WeightedColor) -> Color -> [WeightedColor]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> WeightedColor
toWC (Color -> [WeightedColor]) -> Parse Color -> Parse [WeightedColor]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse Color
forall a. ParseDot a => Parse a
parse)
Parse [WeightedColor]
-> Parse [WeightedColor] -> Parse [WeightedColor]
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
do ColorScheme
cs <- Parser GraphvizState ColorScheme
forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
String -> Parse [WeightedColor]
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad (String -> Parse [WeightedColor])
-> String -> Parse [WeightedColor]
forall a b. (a -> b) -> a -> b
$ "Error parsing ColorList with color scheme of "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ ColorScheme -> String
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 :: nc -> WeightedColor
toWColor = Color -> WeightedColor
toWC (Color -> WeightedColor) -> (nc -> Color) -> nc -> WeightedColor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. nc -> Color
forall nc. NamedColor nc => nc -> Color
toColor
parseNC :: (NamedColor nc) => nc -> Bool -> Parse Color
parseNC :: nc -> Bool -> Parse Color
parseNC nc :: nc
nc q :: Bool
q = (nc -> Color) -> Parser GraphvizState nc -> Parse Color
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (nc -> Color
forall nc. NamedColor nc => nc -> Color
toColor (nc -> Color) -> (nc -> nc) -> nc -> Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (nc -> nc -> nc
forall a. a -> a -> a
`asTypeOf` nc
nc))
(Parser GraphvizState nc -> Parse Color)
-> Parser GraphvizState nc -> Parse Color
forall a b. (a -> b) -> a -> b
$ Bool -> Parser GraphvizState nc
forall nc. NamedColor nc => Bool -> Parse nc
parseNC' Bool
q
instance NamedColor BrewerColor where
colorScheme :: BrewerColor -> ColorScheme
colorScheme (BC bs :: BrewerScheme
bs _) = BrewerScheme -> ColorScheme
Brewer BrewerScheme
bs
toColor :: BrewerColor -> Color
toColor = BrewerColor -> Color
BrewerColor
printNC :: Bool -> BrewerColor -> DotCode
printNC = (BrewerColor -> Word8) -> Bool -> BrewerColor -> DotCode
forall nc lv.
(NamedColor nc, PrintDot lv) =>
(nc -> lv) -> Bool -> nc -> DotCode
printNamedColor (\ (BC _ l :: Word8
l) -> Word8
l)
parseNC' :: Bool -> Parse BrewerColor
parseNC' = (ColorScheme -> Maybe BrewerScheme)
-> Parse BrewerScheme
-> (BrewerScheme -> Bool)
-> (BrewerScheme -> Word8 -> BrewerColor)
-> Bool
-> Parse BrewerColor
forall lv cs nc.
ParseDot lv =>
(ColorScheme -> Maybe cs)
-> Parse cs -> (cs -> Bool) -> (cs -> lv -> nc) -> Bool -> Parse nc
parseNamedColor ColorScheme -> Maybe BrewerScheme
mBCS Parse BrewerScheme
forall a. ParseDot a => Parse a
parseUnqt (Bool -> BrewerScheme -> Bool
forall a b. a -> b -> a
const Bool
True) BrewerScheme -> Word8 -> BrewerColor
BC
where
mBCS :: ColorScheme -> Maybe BrewerScheme
mBCS (Brewer bs :: BrewerScheme
bs) = BrewerScheme -> Maybe BrewerScheme
forall a. a -> Maybe a
Just BrewerScheme
bs
mBCS _ = Maybe BrewerScheme
forall a. Maybe a
Nothing
instance NamedColor X11Color where
colorScheme :: X11Color -> ColorScheme
colorScheme = ColorScheme -> X11Color -> ColorScheme
forall a b. a -> b -> a
const ColorScheme
X11
toColor :: X11Color -> Color
toColor = X11Color -> Color
X11Color
printNC :: Bool -> X11Color -> DotCode
printNC = (X11Color -> X11Color) -> Bool -> X11Color -> DotCode
forall nc lv.
(NamedColor nc, PrintDot lv) =>
(nc -> lv) -> Bool -> nc -> DotCode
printNamedColor X11Color -> X11Color
forall a. a -> a
id
parseNC' :: Bool -> Parse X11Color
parseNC' = (ColorScheme -> Maybe ColorScheme)
-> Parser GraphvizState ColorScheme
-> (ColorScheme -> Bool)
-> (ColorScheme -> X11Color -> X11Color)
-> Bool
-> Parse X11Color
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 -> Parser GraphvizState ColorScheme
parseColorScheme Bool
False) (Maybe ColorScheme -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ColorScheme -> Bool)
-> (ColorScheme -> Maybe ColorScheme) -> ColorScheme -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColorScheme -> Maybe ColorScheme
mX11) ((X11Color -> X11Color) -> ColorScheme -> X11Color -> X11Color
forall a b. a -> b -> a
const X11Color -> X11Color
forall a. a -> a
id)
where
mX11 :: ColorScheme -> Maybe ColorScheme
mX11 X11 = ColorScheme -> Maybe ColorScheme
forall a. a -> Maybe a
Just ColorScheme
X11
mX11 _ = Maybe ColorScheme
forall a. Maybe a
Nothing
instance NamedColor SVGColor where
colorScheme :: SVGColor -> ColorScheme
colorScheme = ColorScheme -> SVGColor -> ColorScheme
forall a b. a -> b -> a
const ColorScheme
SVG
toColor :: SVGColor -> Color
toColor = SVGColor -> Color
SVGColor
printNC :: Bool -> SVGColor -> DotCode
printNC = (SVGColor -> SVGColor) -> Bool -> SVGColor -> DotCode
forall nc lv.
(NamedColor nc, PrintDot lv) =>
(nc -> lv) -> Bool -> nc -> DotCode
printNamedColor SVGColor -> SVGColor
forall a. a -> a
id
parseNC' :: Bool -> Parse SVGColor
parseNC' = (ColorScheme -> Maybe ColorScheme)
-> Parser GraphvizState ColorScheme
-> (ColorScheme -> Bool)
-> (ColorScheme -> SVGColor -> SVGColor)
-> Bool
-> Parse SVGColor
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 -> Parser GraphvizState ColorScheme
parseColorScheme Bool
False) (Maybe ColorScheme -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ColorScheme -> Bool)
-> (ColorScheme -> Maybe ColorScheme) -> ColorScheme -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColorScheme -> Maybe ColorScheme
mSVG) ((SVGColor -> SVGColor) -> ColorScheme -> SVGColor -> SVGColor
forall a b. a -> b -> a
const SVGColor -> SVGColor
forall a. a -> a
id)
where
mSVG :: ColorScheme -> Maybe ColorScheme
mSVG SVG = ColorScheme -> Maybe ColorScheme
forall a. a -> Maybe a
Just ColorScheme
SVG
mSVG _ = Maybe ColorScheme
forall a. Maybe a
Nothing
printNamedColor :: (NamedColor nc, PrintDot lv) => (nc -> lv)
-> Bool -> nc -> DotCode
printNamedColor :: (nc -> lv) -> Bool -> nc -> DotCode
printNamedColor fl :: nc -> lv
fl q :: Bool
q c :: nc
c = do ColorScheme
currentCS <- DotCodeM ColorScheme
forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
if ColorScheme
cs ColorScheme -> ColorScheme -> Bool
forall a. Eq a => a -> a -> Bool
== ColorScheme
currentCS
then ((lv -> DotCode) -> (lv -> DotCode) -> Bool -> lv -> DotCode
forall a. a -> a -> Bool -> a
bool lv -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot lv -> DotCode
forall a. PrintDot a => a -> DotCode
toDot Bool
q) lv
lv
else (DotCode -> DotCode)
-> (DotCode -> DotCode) -> Bool -> DotCode -> DotCode
forall a. a -> a -> Bool -> a
bool DotCode -> DotCode
forall a. a -> a
id DotCode -> DotCode
forall (m :: * -> *). Functor m => m Doc -> m Doc
dquotes Bool
q
(DotCode -> DotCode) -> DotCode -> DotCode
forall a b. (a -> b) -> a -> b
$ DotCode
fslash DotCode -> DotCode -> DotCode
forall a. Semigroup a => a -> a -> a
<> Bool -> ColorScheme -> DotCode
printColorScheme Bool
False ColorScheme
cs
DotCode -> DotCode -> DotCode
forall a. Semigroup a => a -> a -> a
<> DotCode
fslash DotCode -> DotCode -> DotCode
forall a. Semigroup a => a -> a -> a
<> lv -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot lv
lv
where
cs :: ColorScheme
cs = nc -> ColorScheme
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 :: (ColorScheme -> Maybe cs)
-> Parse cs -> (cs -> Bool) -> (cs -> lv -> nc) -> Bool -> Parse nc
parseNamedColor gcs :: ColorScheme -> Maybe cs
gcs parseCS :: Parse cs
parseCS vcs :: cs -> Bool
vcs mkC :: cs -> lv -> nc
mkC q :: Bool
q
= do Just cs :: cs
cs <- ColorScheme -> Maybe cs
gcs (ColorScheme -> Maybe cs)
-> Parser GraphvizState ColorScheme
-> Parser GraphvizState (Maybe cs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser GraphvizState ColorScheme
forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
lv
lv <- Parse lv -> Parse lv -> Bool -> Parse lv
forall a. a -> a -> Bool -> a
bool Parse lv
forall a. ParseDot a => Parse a
parseUnqt Parse lv
forall a. ParseDot a => Parse a
parse Bool
q
Parse lv -> Parse lv -> Parse lv
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
Parse lv -> Parse lv
forall a. Parse a -> Parse a
mQts (String -> Parser GraphvizState ()
string "//" Parser GraphvizState () -> Parse lv -> Parse lv
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parse lv
forall a. ParseDot a => Parse a
parseUnqt)
nc -> Parse nc
forall (m :: * -> *) a. Monad m => a -> m a
return (nc -> Parse nc) -> nc -> Parse nc
forall a b. (a -> b) -> a -> b
$ cs -> lv -> nc
mkC cs
cs lv
lv
Parse nc -> Parse nc -> Parse nc
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
Parse nc -> Parse nc
forall a. Parse a -> Parse a
mQts ( do Char -> Parse Char
character '/'
cs
cs <- Parse cs
parseCS
Char -> Parse Char
character '/'
if cs -> Bool
vcs cs
cs
then cs -> lv -> nc
mkC cs
cs (lv -> nc) -> Parse lv -> Parse nc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse lv
forall a. ParseDot a => Parse a
parseUnqt
else String -> Parse nc
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Explicit colorscheme not as expected."
)
where
mQts :: Parse a -> Parse a
mQts = (Parse a -> Parse a)
-> (Parse a -> Parse a) -> Bool -> Parse a -> Parse a
forall a. a -> a -> Bool -> a
bool Parse a -> Parse a
forall a. a -> a
id Parse a -> Parse a
forall a. Parse a -> Parse a
quotedParse Bool
q
parseX11Color :: Bool -> Parse Color
parseX11Color :: Bool -> Parse Color
parseX11Color q :: Bool
q = X11Color -> Color
X11Color
(X11Color -> Color) -> Parse X11Color -> Parse Color
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Parse X11Color
forall nc. NamedColor nc => Bool -> Parse nc
parseNC' Bool
q
Parse X11Color -> Parse X11Color -> Parse X11Color
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
(Parse X11Color -> Parse X11Color)
-> (Parse X11Color -> Parse X11Color)
-> Bool
-> Parse X11Color
-> Parse X11Color
forall a. a -> a -> Bool -> a
bool Parse X11Color -> Parse X11Color
forall a. a -> a
id Parse X11Color -> Parse X11Color
forall a. Parse a -> Parse a
quotedParse Bool
q (Char -> Parse Char
character '/' Parse Char -> Parse X11Color -> Parse X11Color
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parse X11Color
forall a. ParseDot a => Parse a
parseUnqt)
Parse X11Color -> Parse X11Color -> Parse X11Color
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
do ColorScheme
cs <- Parser GraphvizState ColorScheme
forall (m :: * -> *). GraphvizStateM m => m ColorScheme
getColorScheme
case ColorScheme
cs of
Brewer{} -> Parse X11Color -> Parse X11Color -> Bool -> Parse X11Color
forall a. a -> a -> Bool -> a
bool Parse X11Color
forall a. ParseDot a => Parse a
parseUnqt Parse X11Color
forall a. ParseDot a => Parse a
parse Bool
q
_ -> String -> Parse X11Color
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Unable to parse an X11 color within Brewer"
toColour :: Color -> Maybe (AlphaColour Double)
toColour :: Color -> Maybe (AlphaColour Double)
toColour (RGB r :: Word8
r g :: Word8
g b :: Word8
b) = AlphaColour Double -> Maybe (AlphaColour Double)
forall a. a -> Maybe a
Just (AlphaColour Double -> Maybe (AlphaColour Double))
-> (Colour Double -> AlphaColour Double)
-> Colour Double
-> Maybe (AlphaColour Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Colour Double -> AlphaColour Double
forall a. Num a => Colour a -> AlphaColour a
opaque (Colour Double -> Maybe (AlphaColour Double))
-> Colour Double -> Maybe (AlphaColour Double)
forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> Word8 -> Colour Double
forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 Word8
r Word8
g Word8
b
toColour (RGBA r :: Word8
r g :: Word8
g b :: Word8
b a :: Word8
a) = AlphaColour Double -> Maybe (AlphaColour Double)
forall a. a -> Maybe a
Just (AlphaColour Double -> Maybe (AlphaColour Double))
-> (Double -> AlphaColour Double)
-> Double
-> Maybe (AlphaColour Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Colour Double -> Double -> AlphaColour Double
forall a. Num a => Colour a -> a -> AlphaColour a
withOpacity (Word8 -> Word8 -> Word8 -> Colour Double
forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 Word8
r Word8
g Word8
b) (Double -> Maybe (AlphaColour Double))
-> Double -> Maybe (AlphaColour Double)
forall a b. (a -> b) -> a -> b
$ Word8 -> Double
toOpacity Word8
a
toColour (HSV h :: Double
h s :: Double
s v :: Double
v) = AlphaColour Double -> Maybe (AlphaColour Double)
forall a. a -> Maybe a
Just (AlphaColour Double -> Maybe (AlphaColour Double))
-> (RGB Double -> AlphaColour Double)
-> RGB Double
-> Maybe (AlphaColour Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Colour Double -> AlphaColour Double
forall a. Num a => Colour a -> AlphaColour a
opaque (Colour Double -> AlphaColour Double)
-> (RGB Double -> Colour Double)
-> RGB Double
-> AlphaColour Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double -> Colour Double)
-> RGB Double -> Colour Double
forall a b. (a -> a -> a -> b) -> RGB a -> b
uncurryRGB Double -> Double -> Double -> Colour Double
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB (RGB Double -> Maybe (AlphaColour Double))
-> RGB Double -> Maybe (AlphaColour Double)
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> RGB Double
forall a. (RealFrac a, Ord a) => a -> a -> a -> RGB a
hsv (Double
hDouble -> Double -> Double
forall a. Num a => a -> a -> a
*360) Double
s Double
v
toColour (X11Color c :: X11Color
c) = AlphaColour Double -> Maybe (AlphaColour Double)
forall a. a -> Maybe a
Just (AlphaColour Double -> Maybe (AlphaColour Double))
-> AlphaColour Double -> Maybe (AlphaColour Double)
forall a b. (a -> b) -> a -> b
$ X11Color -> AlphaColour Double
x11Colour X11Color
c
toColour (SVGColor c :: SVGColor
c) = AlphaColour Double -> Maybe (AlphaColour Double)
forall a. a -> Maybe a
Just (AlphaColour Double -> Maybe (AlphaColour Double))
-> (Colour Double -> AlphaColour Double)
-> Colour Double
-> Maybe (AlphaColour Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Colour Double -> AlphaColour Double
forall a. Num a => Colour a -> AlphaColour a
opaque (Colour Double -> Maybe (AlphaColour Double))
-> Colour Double -> Maybe (AlphaColour Double)
forall a b. (a -> b) -> a -> b
$ SVGColor -> Colour Double
svgColour SVGColor
c
toColour BrewerColor{} = Maybe (AlphaColour Double)
forall a. Maybe a
Nothing
toOpacity :: Word8 -> Double
toOpacity :: Word8 -> Double
toOpacity a :: Word8
a = Word8 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
a Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
maxWord
fromColour :: Colour Double -> Color
fromColour :: Colour Double -> Color
fromColour = (Word8 -> Word8 -> Word8 -> Color) -> RGB Word8 -> Color
forall a b. (a -> a -> a -> b) -> RGB a -> b
uncurryRGB Word8 -> Word8 -> Word8 -> Color
RGB (RGB Word8 -> Color)
-> (Colour Double -> RGB Word8) -> Colour Double -> Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Colour Double -> RGB Word8
forall b. (RealFrac b, Floating b) => Colour b -> RGB Word8
toSRGB24
fromAColour :: AlphaColour Double -> Color
fromAColour :: AlphaColour Double -> Color
fromAColour ac :: AlphaColour Double
ac
| Double
a Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = X11Color -> Color
X11Color X11Color
Transparent
| Bool
otherwise = Word8 -> Color
rgb (Word8 -> Color) -> Word8 -> Color
forall a b. (a -> b) -> a -> b
$ Double -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
round Double
a'
where
a :: Double
a = AlphaColour Double -> Double
forall a. AlphaColour a -> a
alphaChannel AlphaColour Double
ac
a' :: Double
a' = Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
maxWord
rgb :: Word8 -> Color
rgb = (Word8 -> Word8 -> Word8 -> Word8 -> Color)
-> RGB Word8 -> Word8 -> Color
forall a b. (a -> a -> a -> b) -> RGB a -> b
uncurryRGB Word8 -> Word8 -> Word8 -> Word8 -> Color
RGBA (RGB Word8 -> Word8 -> Color) -> RGB Word8 -> Word8 -> Color
forall a b. (a -> b) -> a -> b
$ Colour Double -> RGB Word8
forall b. (RealFrac b, Floating b) => Colour b -> RGB Word8
toSRGB24 Colour Double
colour
colour :: Colour Double
colour = Double -> Colour Double -> Colour Double
forall (f :: * -> *) a. (ColourOps f, Num a) => a -> f a -> f a
darken (Double -> Double
forall a. Fractional a => a -> a
recip Double
a) (AlphaColour Double
ac AlphaColour Double -> Colour Double -> Colour Double
forall (f :: * -> *) a.
(ColourOps f, Num a) =>
AlphaColour a -> f a -> f a
`over` Colour Double
forall a. Num a => Colour a
black)
maxWord :: Double
maxWord :: Double
maxWord = Word8 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
forall a. Bounded a => a
maxBound :: Word8)