{-# LANGUAGE CPP, 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.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

-- -----------------------------------------------------------------------------

-- | 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 { Color -> Word8
red   :: Word8
                 , Color -> Word8
green :: Word8
                 , Color -> Word8
blue  :: Word8
                 }
           | RGBA { red   :: Word8
                  , green :: Word8
                  , blue  :: Word8
                  , Color -> Word8
alpha :: Word8
                  }
             -- | The 'hue', 'saturation' and 'value' values must all
             --   be @0 <= x <=1@.
           | 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

  -- Some cases might not need quotes.
  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

  -- These three might not need to be quoted if they're on their own.
  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
                      -- Have to parse BrewerColor first, as some of them may appear to be X11 colors
                    , 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` -- These three might not need to be quoted
          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]
:[])
              -- Potentially unquoted single color
              (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

-- | 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 { WeightedColor -> Color
wColor    :: Color
                          -- | Must be in range @0 <= W <= 1@.
                        , 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)

-- | For colors without weightings.
toWC :: Color -> WeightedColor
toWC :: Color -> WeightedColor
toWC = (Color -> Maybe Double -> WeightedColor
`WC` forall a. Maybe a
Nothing)

-- | For a list of colors without weightings.
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

  -- Might not need quoting
  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`
          -- Using parse rather than parseUnqt as there shouldn't be
          -- any quotes, but to avoid copy-pasting the oneOf block.
          (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)
              -- Potentially unquoted un-weighted single color
              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

-- -----------------------------------------------------------------------------

-- | 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 :: 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

-- First value just used for type
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

-- -----------------------------------------------------------------------------

-- X11 has a special case when parsing: '/yyyy'

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`
                      -- Can use X11 colors within brewer colorscheme.
                      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"

-- -----------------------------------------------------------------------------

-- | 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 :: 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
-- Colour expects the hue to be an angle, so multiply by 360
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

-- | Convert a 'Colour' value to an 'RGB' 'Color'.
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

-- | 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 :: 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)

-- | The 'maxBound' of a 'Word8' value.
maxWord :: Double
maxWord :: Double
maxWord = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word8)