{-# LANGUAGE OverloadedStrings #-}

{- |
   Module      : Data.GraphViz.Attributes.Colors
   Description : Specification of Color-related types and functions.
   Copyright   : (c) Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   This module defines the various colors, etc. for Graphviz.  For
   information on colors in general, see:
     <http://graphviz.org/doc/info/attrs.html#k:color>
   For named colors, see:
     <http://graphviz.org/doc/info/colors.html>

   Note that the ColorBrewer Color Schemes (shortened to just
   \"Brewer\" for the rest of this module) are covered by the
   following license (also available in the LICENSE file of this
   library):
     <http://graphviz.org/doc/info/colors.html#brewer_license>
-}
module Data.GraphViz.Attributes.Colors
       ( -- * Color schemes.
         ColorScheme(..)
         -- * Colors
       , Color(..)
       , ColorList
       , WeightedColor(..)
       , toWC
       , toColorList
       , NamedColor(toColor)
       , toWColor
         -- * Conversion to\/from @Colour@.
       , toColour
       , fromColour
       , fromAColour
       ) where

import Data.GraphViz.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)

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

-- | Defining a color for use with Graphviz.  Note that named colors
--   have been split up into 'X11Color's and those based upon the
--   Brewer color schemes.
data Color = RGB { red   :: Word8
                 , green :: Word8
                 , blue  :: Word8
                 }
           | RGBA { red   :: Word8
                  , green :: Word8
                  , blue  :: Word8
                  , alpha :: Word8
                  }
             -- | The 'hue', 'saturation' and 'value' values must all
             --   be @0 <= x <=1@.
           | HSV { hue        :: Double
                 , saturation :: Double
                 , value      :: Double
                 }
           | X11Color X11Color
           | SVGColor SVGColor
           | BrewerColor BrewerColor
           deriving (Eq, Ord, Show, Read)

instance PrintDot Color where
  unqtDot (RGB  r g b)     = hexColor [r,g,b]
  unqtDot (RGBA r g b a)   = hexColor [r,g,b,a]
  unqtDot (HSV  h s v)     = hcat . punctuate comma $ mapM unqtDot [h,s,v]
  unqtDot (SVGColor name)  = printNC False name
  unqtDot (X11Color name)  = printNC False name
  unqtDot (BrewerColor bc) = printNC False bc

  -- Some cases might not need quotes.
  toDot (X11Color name)  = printNC True name
  toDot (SVGColor name)  = printNC True name
  toDot (BrewerColor bc) = printNC True bc
  toDot c                = dquotes $ unqtDot c

  unqtListToDot = hcat . punctuate colon . mapM unqtDot

  -- These three might not need to be quoted if they're on their own.
  listToDot [X11Color name]  = printNC True name
  listToDot [SVGColor name]  = printNC True name
  listToDot [BrewerColor bc] = printNC True bc
  listToDot cs               = dquotes $ unqtListToDot cs

hexColor :: [Word8] -> DotCode
hexColor = (<>) (char '#') . hcat . mapM word8Doc

word8Doc   :: Word8 -> DotCode
word8Doc w = text $ padding `T.append` simple
  where
    simple = T.pack $ showHex w ""
    padding = T.replicate count (T.singleton '0')
    count = 2 - findCols 1 w
    findCols c n
      | n < 16 = c
      | otherwise = findCols (c+1) (n `div` 16)

instance ParseDot Color where
  parseUnqt = oneOf [ parseHexBased
                    , parseHSV
                      -- Have to parse BrewerColor first, as some of them may appear to be X11 colors
                    , parseNC (undefined :: BrewerColor) False
                    , parseNC (undefined :: SVGColor) False
                    , parseX11Color False
                    ]
              `onFail`
              fail "Could not parse Color"
    where
      parseHexBased
          = character '#' *>
            do cs <- many1 parse2Hex
               return $ case cs of
                          [r,g,b] -> RGB r g b
                          [r,g,b,a] -> RGBA r g b a
                          _ -> throw . NotDotCode
                               $ "Not a valid hex Color specification: "
                                  ++ show cs
      parseHSV = HSV <$> parseUnqt
                     <*  parseSep
                     <*> parseUnqt
                     <*  parseSep
                     <*> parseUnqt
      parseSep = character ',' *> whitespace <|> whitespace1

      parse2Hex = do c1 <- satisfy isHexDigit
                     c2 <- satisfy isHexDigit
                     let [(n, [])] = readHex [c1, c2]
                     return n

  parse = quotedParse parseUnqt
          `onFail` -- These three might not need to be quoted
          oneOf [ parseNC (undefined :: BrewerColor) True
                , parseNC (undefined :: SVGColor) True
                , parseX11Color True
                ]
          `onFail`
          fail "Could not parse Color"

  parseUnqtList = sepBy1 parseUnqt (character ':')
                  `onFail`
                  do cs <- getColorScheme
                     failBad $ "Error parsing list of Colors with color scheme of "
                               ++ show cs

  parseList = fmap (:[])
              -- Potentially unquoted single color
              (oneOf [ parseNC (undefined :: BrewerColor) True
                     , parseNC (undefined :: SVGColor) True
                     , parseX11Color True
                     ]
              )
              `onFail`
              quotedParse parseUnqtList
              `onFail`
              do cs <- getColorScheme
                 failBad $ "Error parsing list of Colors with color scheme of "
                           ++ show cs

-- | The sum of the optional weightings /must/ sum to at most @1@.
type ColorList = [WeightedColor]

-- | A 'Color' tagged with an optional weighting.
data WeightedColor = WC { wColor    :: Color
                          -- | Must be in range @0 <= W <= 1@.
                        , weighting :: Maybe Double
                        }
                   deriving (Eq, Ord, Show, Read)

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

-- | For a list of colors without weightings.
toColorList :: [Color] -> ColorList
toColorList = map toWC

instance PrintDot WeightedColor where
  unqtDot (WC c mw) = unqtDot c
                      <> maybe empty ((semi<>) . unqtDot) mw

  toDot (WC c Nothing) = toDot c
  toDot wc             = dquotes $ unqtDot wc

  unqtListToDot = hcat . punctuate colon . mapM unqtDot

  -- Might not need quoting
  listToDot [wc] = toDot wc
  listToDot wcs  = dquotes $ unqtListToDot wcs

instance ParseDot WeightedColor where
  parseUnqt = WC <$> parseUnqt <*> optional (character ';' *> parseUnqt)

  parse = quotedParse parseUnqt
          `onFail`
          -- Using parse rather than parseUnqt as there shouldn't be
          -- any quotes, but to avoid copy-pasting the oneOf block.
          (toWC <$> parse)

  parseUnqtList = sepBy1 parseUnqt (character ':')
                  `onFail`
                  do cs <- getColorScheme
                     failBad $ "Error parsing a ColorList with color scheme of "
                               ++ show cs

  parseList = quotedParse parseUnqtList
              `onFail`
              ((:[]) . toWC <$> parse)
              -- Potentially unquoted un-weighted single color
              `onFail`
              do cs <- getColorScheme
                 failBad $ "Error parsing ColorList with color scheme of "
                           ++ show cs

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

-- | More easily convert named colors to an overall 'Color' value.
class NamedColor nc where
    colorScheme :: nc -> ColorScheme

    toColor :: nc -> Color

    printNC :: Bool -> nc -> DotCode

    -- | Bool is for whether quoting is needed.
    parseNC' :: Bool -> Parse nc

toWColor :: (NamedColor nc) => nc -> WeightedColor
toWColor = toWC . toColor

-- First value just used for type
parseNC :: (NamedColor nc) => nc -> Bool -> Parse Color
parseNC nc q = fmap (toColor . (`asTypeOf` nc))
               $ parseNC' q

instance NamedColor BrewerColor where
    colorScheme (BC bs _) = Brewer bs

    toColor = BrewerColor

    printNC = printNamedColor (\ (BC _ l) -> l)

    parseNC' = parseNamedColor mBCS parseUnqt (const True) BC
        where
          mBCS (Brewer bs) = Just bs
          mBCS _           = Nothing

instance NamedColor X11Color where
    colorScheme = const X11

    toColor = X11Color

    printNC = printNamedColor id

    parseNC' = parseNamedColor mX11 (parseColorScheme False) (isJust . mX11) (const id)
        where
          mX11 X11 = Just X11
          mX11 _   = Nothing

instance NamedColor SVGColor where
    colorScheme = const SVG

    toColor = SVGColor

    printNC = printNamedColor id

    parseNC' = parseNamedColor mSVG (parseColorScheme False) (isJust . mSVG) (const id)
        where
          mSVG SVG = Just SVG
          mSVG _   = Nothing

printNamedColor :: (NamedColor nc, PrintDot lv) => (nc -> lv)
                   -> Bool -> nc -> DotCode
printNamedColor fl q c = do currentCS <- getColorScheme
                            if cs == currentCS
                               then (bool unqtDot toDot q) lv
                               else bool id dquotes q
                                    $ fslash <> printColorScheme False cs
                                      <> fslash <> unqtDot lv
    where
      cs = colorScheme c
      lv = fl c

parseNamedColor :: (NamedColor nc, ParseDot lv)
                   => (ColorScheme -> Maybe cs) -> Parse cs -> (cs -> Bool)
                   -> (cs -> lv -> nc) -> Bool -> Parse nc
parseNamedColor gcs parseCS vcs mkC q
    = do Just cs <- gcs <$> getColorScheme
         lv <- bool parseUnqt parse q
               `onFail`
               mQts (string "//" *> parseUnqt)
         return $ mkC cs lv
      `onFail`
      mQts ( do character '/'
                cs <- parseCS
                character '/'
                if vcs cs
                   then mkC cs <$>  parseUnqt
                   else fail "Explicit colorscheme not as expected."
           )
    where
      mQts = bool id quotedParse q

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

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

parseX11Color   :: Bool -> Parse Color
parseX11Color q = X11Color
                  <$> parseNC' q
                      `onFail`
                      bool id quotedParse q (character '/' *> parseUnqt)
                      `onFail`
                      -- Can use X11 colors within brewer colorscheme.
                      do cs <- getColorScheme
                         case cs of
                           Brewer{} -> bool parseUnqt parse q
                           _        -> fail "Unable to parse an X11 color within Brewer"

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

-- | Attempt to convert a 'Color' into a 'Colour' value with an alpha
--   channel.  The use of 'Maybe' is because the RGB values of the
--   'BrewerColor's haven't been stored here (primarily for licensing
--   reasons).
toColour                :: Color -> Maybe (AlphaColour Double)
toColour (RGB r g b)    = Just . opaque $ sRGB24 r g b
toColour (RGBA r g b a) = Just . withOpacity (sRGB24 r g b) $ toOpacity a
-- Colour expects the hue to be an angle, so multiply by 360
toColour (HSV h s v)    = Just . opaque . uncurryRGB sRGB $ hsv (h*360) s v
toColour (X11Color c)   = Just $ x11Colour c
toColour (SVGColor c)   = Just . opaque $ svgColour c
toColour BrewerColor{}  = Nothing

toOpacity   :: Word8 -> Double
toOpacity a = fromIntegral a / maxWord

-- | Convert a 'Colour' value to an 'RGB' 'Color'.
fromColour :: Colour Double -> Color
fromColour = uncurryRGB RGB . toSRGB24

-- | Convert an 'AlphaColour' to an 'RGBA' 'Color'.  The exception to
--   this is for any 'AlphaColour' which has @alphaChannel ac == 0@;
--   these are converted to @X11Color 'Transparent'@ (note that the
--   'Show' instance for such an 'AlphaColour' is @\"transparent\"@).
fromAColour :: AlphaColour Double -> Color
fromAColour ac
  | a == 0    = X11Color Transparent
  | otherwise = rgb $ round a'
  where
    a = alphaChannel ac
    a' = a * maxWord
    rgb = uncurryRGB RGBA $ toSRGB24 colour
    colour = darken (recip a) (ac `over` black)

-- | The 'maxBound' of a 'Word8' value.
maxWord :: Double
maxWord = fromIntegral (maxBound :: Word8)