{-# 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
(Color -> Color -> Bool) -> (Color -> Color -> Bool) -> Eq Color
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Color -> Color -> Bool
== :: Color -> Color -> Bool
$c/= :: Color -> Color -> Bool
/= :: 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
$ccompare :: Color -> Color -> Ordering
compare :: Color -> Color -> Ordering
$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
>= :: Color -> Color -> Bool
$cmax :: Color -> Color -> Color
max :: Color -> Color -> Color
$cmin :: Color -> Color -> Color
min :: Color -> Color -> 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
$cshowsPrec :: Int -> Color -> ShowS
showsPrec :: Int -> Color -> ShowS
$cshow :: Color -> String
show :: Color -> String
$cshowList :: [Color] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS Color
readsPrec :: Int -> ReadS Color
$creadList :: ReadS [Color]
readList :: ReadS [Color]
$creadPrec :: ReadPrec Color
readPrec :: ReadPrec Color
$creadListPrec :: ReadPrec [Color]
readListPrec :: ReadPrec [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)     = 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Double -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot [Double
h,Double
s,Double
v]
  unqtDot (SVGColor SVGColor
name)  = Bool -> SVGColor -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
False SVGColor
name
  unqtDot (X11Color X11Color
name)  = Bool -> X11Color -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
False X11Color
name
  unqtDot (BrewerColor BrewerColor
bc) = Bool -> BrewerColor -> DotCode
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)  = Bool -> X11Color -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True X11Color
name
  toDot (SVGColor SVGColor
name)  = Bool -> SVGColor -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True SVGColor
name
  toDot (BrewerColor BrewerColor
bc) = Bool -> BrewerColor -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True BrewerColor
bc
  toDot 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Color -> DotCode
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]  = Bool -> X11Color -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True X11Color
name
  listToDot [SVGColor SVGColor
name]  = Bool -> SVGColor -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True SVGColor
name
  listToDot [BrewerColor BrewerColor
bc] = Bool -> BrewerColor -> DotCode
forall nc. NamedColor nc => Bool -> nc -> DotCode
printNC Bool
True BrewerColor
bc
  listToDot [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 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Word8 -> DotCode
word8Doc

word8Doc   :: Word8 -> DotCode
word8Doc :: Word8 -> DotCode
word8Doc 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 => 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 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64 -> Word8 -> Int64
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 t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
16 = t
c
      | Bool
otherwise = t -> t -> t
findCols (t
ct -> t -> t
forall a. Num a => a -> a -> a
+t
1) (t
n t -> t -> t
forall a. Integral a => a -> a -> a
`div` t
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
                      -- Have to parse BrewerColor first, as some of them may appear to be X11 colors
                    , 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 a. String -> Parser GraphvizState a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Could not parse Color"
    where
      parseHexBased :: Parse Color
parseHexBased
          = Char -> Parse Char
character Char
'#' Parse Char -> Parse Color -> Parse Color
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
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 a. a -> Parser GraphvizState a
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
                          [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]
_ -> 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
$ String
"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 a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState a
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 a b.
Parser GraphvizState (a -> b)
-> Parser GraphvizState a -> Parser GraphvizState b
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 a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState a
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 a b.
Parser GraphvizState (a -> b)
-> Parser GraphvizState a -> Parser GraphvizState b
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 Char
',' Parse Char -> Parser GraphvizState () -> Parser GraphvizState ()
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser GraphvizState ()
whitespace Parser GraphvizState ()
-> Parser GraphvizState () -> Parser GraphvizState ()
forall a.
Parser GraphvizState a
-> Parser GraphvizState a -> Parser GraphvizState a
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 [(Word8
n, [])] = ReadS Word8
forall a. (Eq a, Num a) => ReadS a
readHex [Char
c1, Char
c2]
                     Word8 -> Parser s Word8
forall a. a -> Parser s a
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` -- These three might not need to be quoted
          [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 a. String -> Parser GraphvizState a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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 Char
':')
                  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
$ String
"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 a b.
(a -> b) -> Parser GraphvizState a -> Parser GraphvizState b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Color -> [Color] -> [Color]
forall a. a -> [a] -> [a]
:[])
              -- Potentially unquoted single color
              ([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
$ String
"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

-- | 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
(WeightedColor -> WeightedColor -> Bool)
-> (WeightedColor -> WeightedColor -> Bool) -> Eq WeightedColor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WeightedColor -> WeightedColor -> Bool
== :: WeightedColor -> WeightedColor -> Bool
$c/= :: WeightedColor -> WeightedColor -> Bool
/= :: 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
$ccompare :: WeightedColor -> WeightedColor -> Ordering
compare :: WeightedColor -> WeightedColor -> Ordering
$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
>= :: WeightedColor -> WeightedColor -> Bool
$cmax :: WeightedColor -> WeightedColor -> WeightedColor
max :: WeightedColor -> WeightedColor -> WeightedColor
$cmin :: WeightedColor -> WeightedColor -> WeightedColor
min :: WeightedColor -> WeightedColor -> 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
$cshowsPrec :: Int -> WeightedColor -> ShowS
showsPrec :: Int -> WeightedColor -> ShowS
$cshow :: WeightedColor -> String
show :: WeightedColor -> String
$cshowList :: [WeightedColor] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS WeightedColor
readsPrec :: Int -> ReadS WeightedColor
$creadList :: ReadS [WeightedColor]
readList :: ReadS [WeightedColor]
$creadPrec :: ReadPrec WeightedColor
readPrec :: ReadPrec WeightedColor
$creadListPrec :: ReadPrec [WeightedColor]
readListPrec :: ReadPrec [WeightedColor]
Read)

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

-- | For a list of colors without weightings.
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 Color
c 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 Color
c Maybe Double
Nothing) = Color -> DotCode
forall a. PrintDot a => a -> DotCode
toDot Color
c
  toDot 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM WeightedColor -> DotCode
forall a. PrintDot a => a -> DotCode
unqtDot

  -- Might not need quoting
  listToDot :: [WeightedColor] -> DotCode
listToDot [WeightedColor
wc] = WeightedColor -> DotCode
forall a. PrintDot a => a -> DotCode
toDot WeightedColor
wc
  listToDot [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 a b.
Parser GraphvizState (a -> b)
-> Parser GraphvizState a -> Parser GraphvizState b
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 Char
';' Parse Char
-> Parser GraphvizState Double -> Parser GraphvizState Double
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
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`
          -- Using parse rather than parseUnqt as there shouldn't be
          -- any quotes, but to avoid copy-pasting the oneOf block.
          (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 Char
':')
                  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
$ String
"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)
              -- Potentially unquoted un-weighted single color
              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
$ String
"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

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

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

-- 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 = (nc -> Color) -> Parser GraphvizState nc -> Parse Color
forall a b.
(a -> b) -> Parser GraphvizState a -> Parser GraphvizState b
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 BrewerScheme
bs Word8
_) = 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 BrewerScheme
_ 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 BrewerScheme
bs) = BrewerScheme -> Maybe BrewerScheme
forall a. a -> Maybe a
Just BrewerScheme
bs
          mBCS ColorScheme
_           = 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 ColorScheme
X11 = ColorScheme -> Maybe ColorScheme
forall a. a -> Maybe a
Just ColorScheme
X11
          mX11 ColorScheme
_   = 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 ColorScheme
SVG = ColorScheme -> Maybe ColorScheme
forall a. a -> Maybe a
Just ColorScheme
SVG
          mSVG ColorScheme
_   = Maybe 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 <- 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 :: 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 (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 <- Parser GraphvizState lv
-> Parser GraphvizState lv -> Bool -> Parser GraphvizState lv
forall a. a -> a -> Bool -> a
bool Parser GraphvizState lv
forall a. ParseDot a => Parse a
parseUnqt Parser GraphvizState lv
forall a. ParseDot a => Parse a
parse Bool
q
               Parser GraphvizState lv
-> Parser GraphvizState lv -> Parser GraphvizState lv
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
               Parser GraphvizState lv -> Parser GraphvizState lv
forall a. Parse a -> Parse a
mQts (String -> Parser GraphvizState ()
string String
"//" Parser GraphvizState ()
-> Parser GraphvizState lv -> Parser GraphvizState lv
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser GraphvizState lv
forall a. ParseDot a => Parse a
parseUnqt)
         nc -> Parser GraphvizState nc
forall a. a -> Parser GraphvizState a
forall (m :: * -> *) a. Monad m => a -> m a
return (nc -> Parser GraphvizState nc) -> nc -> Parser GraphvizState nc
forall a b. (a -> b) -> a -> b
$ cs -> lv -> nc
mkC cs
cs lv
lv
      Parser GraphvizState nc
-> Parser GraphvizState nc -> Parser GraphvizState nc
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
      Parser GraphvizState nc -> Parser GraphvizState nc
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 (lv -> nc) -> Parser GraphvizState lv -> Parser GraphvizState nc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  Parser GraphvizState lv
forall a. ParseDot a => Parse a
parseUnqt
                   else String -> Parser GraphvizState nc
forall a. String -> Parser GraphvizState a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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

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

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

parseX11Color   :: Bool -> Parse Color
parseX11Color :: Bool -> Parse Color
parseX11Color 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 Char
'/' Parse Char -> Parse X11Color -> Parse X11Color
forall a b.
Parser GraphvizState a
-> Parser GraphvizState b -> Parser GraphvizState b
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`
                      -- Can use X11 colors within brewer colorscheme.
                      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
                           ColorScheme
_        -> String -> Parse X11Color
forall a. String -> Parser GraphvizState a
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)    = 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 Word8
r Word8
g Word8
b 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
-- Colour expects the hue to be an angle, so multiply by 360
toColour (HSV Double
h Double
s 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
*Double
360) Double
s Double
v
toColour (X11Color 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 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 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

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

-- | 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 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
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 b. Integral b => Double -> b
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 a. Num a => a -> Colour a -> Colour a
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 a. Num a => AlphaColour a -> Colour a -> Colour a
forall (f :: * -> *) a.
(ColourOps f, Num a) =>
AlphaColour a -> f a -> f a
`over` Colour Double
forall a. Num a => Colour a
black)

-- | The 'maxBound' of a 'Word8' value.
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)