{-# 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(..)
       , NamedColor(toColor)
         -- * Conversion to\/from @Colour@.
       , toColour
       , fromColour
       , fromAColour
       ) where

import Data.GraphViz.Parsing
import Data.GraphViz.Printing
import Data.GraphViz.State
import Data.GraphViz.Attributes.ColorScheme(ColorScheme(..))
import Data.GraphViz.Attributes.Colors.X11(X11Color(Transparent), x11Colour)
import Data.GraphViz.Attributes.Colors.SVG(SVGColor, svgColour)
import Data.GraphViz.Attributes.Colors.Brewer(BrewerColor(..))
import Data.GraphViz.Util(bool)
import Data.GraphViz.Exception

import Data.Colour( AlphaColour, opaque, withOpacity
                  , over, black, alphaChannel, darken)
import Data.Colour.SRGB(Colour, sRGB, sRGB24, toSRGB24)
import Data.Colour.RGBSpace(uncurryRGB)
import Data.Colour.RGBSpace.HSV(hsv)

import Data.Char(isHexDigit)
import Numeric(showHex, readHex)
import Data.Maybe(isJust)
import Data.Word(Word8)
import qualified Data.Text.Lazy as T
import Control.Monad(liftM)

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

-- | 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
                    ]
    where
      parseHexBased
          = do character '#'
               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 = do h <- parse
                    parseSep
                    s <- parse
                    parseSep
                    v <- parse
                    return $ HSV h s v
      parseSep = oneOf [ string ","
                       , 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
                ]

  parseUnqtList = sepBy1 parseUnqt (character ':')

  parseList = liftM (:[])
              -- Unquoted single color
              (oneOf [ parseNC (undefined :: BrewerColor) True
                     , parseNC (undefined :: SVGColor) True
                     , parseX11Color True
                     ]
              )
              `onFail`
              quotedParse parseUnqtList

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

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

    toColor :: nc -> Color

    printNC :: Bool -> nc -> DotCode

    parseNC' :: Bool -> Parse nc

-- First value just used for type
parseNC :: (NamedColor nc) => nc -> Bool -> Parse Color
parseNC nc q = fmap (toColor . flip 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 `fmap` 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 do lv <- parseUnqt
                           return $ mkC cs lv
                   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 = fmap 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)