{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
module Graphics.Rendering.Rect.CSS.Colour(parseColour) where

import Data.Colour (Colour, AlphaColour, withOpacity, opaque, transparent)
import Data.Colour.SRGB (sRGB, sRGB24)
import Data.Colour.Names
import Data.Colour.RGBSpace.HSL (hsl)
import Data.Colour.RGBSpace (uncurryRGB)
import Data.Colour.SRGB.Linear (rgb)

import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Data.Scientific (toRealFloat)
import qualified Data.Text as Txt

import Data.Word (Word8)
import Data.Bits (toIntegralSized)
import Data.Char (isHexDigit, toLower, isUpper)
import Data.List (elemIndex)
import Debug.Trace (trace) -- For warning messages.

hsl' h s l = uncurryRGB rgb $ hsl h s l

data ColourPallet = ColourPallet { foreground :: AlphaColour Double }

parseColour :: ColourPallet -> [Token] -> Maybe ([Token], AlphaColour Double)
parseColour _ (Function "rgb":Percentage _ r:Comma:
        Percentage _ g:Comma:Percentage _ b:RightParen:toks) =
    Just (toks, opaque $ sRGB (pc r) (pc g) (pc b))
parseColour _ (Function "rgba":Percentage _ r:Comma:
        Percentage _ g:Comma:Percentage _ b:Comma:a':RightParen:toks)
    | a' /= Ident "none", Just a <- f' a' =
        Just (toks, sRGB (pc r) (pc g) (pc b) `withOpacity` a)
parseColour _ (Function "rgb":Number _ (NVInteger r):Comma:
        Number _ (NVInteger g):Comma:Number _ (NVInteger b):RightParen:toks) =
    Just (toks, opaque $ sRGB24 (w r) (w g) (w b))
parseColour _ (Function "rgba":Number _ (NVInteger r):Comma:
        Number _ (NVInteger g):Comma:Number _ (NVInteger b):Comma:
        a':RightParen:toks) | a' /= Ident "none", Just a <- f' a' =
    Just (toks, sRGB24 (w r) (w g) (w b) `withOpacity` a)

parseColour _ (Function "rgb":r':g':b':RightParen:toks)
    | Just r <- w' r', Just g <- w' g', Just b <- w' b' =
        Just (toks, opaque $ sRGB24 r g b)
parseColour _ (Function "rgb":r':g':b':Delim '/':a':RightParen:toks)
    | Just r <- w' r', Just g <- w' g', Just b <- w' b', Just a <- f' a' =
        Just (toks, sRGB24 r g b `withOpacity` a)
parseColour _ (Hash _ v@(r0 :. r1 :. g0 :. g1 :. b0 :. b1 :. ""):toks)
    | Txt.all isHexDigit v = Just (toks, opaque $ sRGBhex r0 r1 g0 g1 b0 b1)
parseColour _ (Hash _ v@(r0 :. r1 :. g0 :. g1 :. b0 :. b1 :. a0 :. a1 :. ""):toks)
    | Txt.all isHexDigit v =
        Just (toks, sRGBhex r0 r1 g0 g1 b0 b1 `withOpacity` h' a0 a1)
parseColour _ (Hash _ v@(r:.g:.b:.""):toks) | Txt.all isHexDigit v =
    Just (toks, opaque $ sRGBhex r r g g b b)
parseColour _ (Hash _ v@(r:.g:.b:.a:.""):toks) | Txt.all isHexDigit v =
    Just (toks, sRGBhex r r g g b b `withOpacity` h' a a)

parseColour _ (Ident x:toks) | Just x' <- inner $ Txt.toLower x =
    Just (toks, opaque x')
  where
    -- NOTE: Some of these colour names are inconsistant or even offensive.
    -- There are historical reasons for this labelling.
    -- https://www.youtube.com/watch?v=HmStJQzclHc
    inner "aliceblue" = Just aliceblue
    inner "antiquewhite" = Just antiquewhite
    inner "aqua" = Just aqua
    inner "aquamarine" = Just aquamarine
    inner "azure" = Just azure
    inner "beige" = Just beige
    inner "bisque" = Just bisque
    inner "black" = Just black
    inner "blanchedalmond" = Just blanchedalmond
    inner "blue" = Just blue
    inner "blueviolet" = Just blueviolet
    inner "brown" = Just brown
    inner "burlywood" = Just burlywood
    inner "cadetblue" = Just cadetblue
    inner "chartreuse" = Just chartreuse
    inner "chocolate" = Just chocolate
    inner "coral" = Just coral
    inner "cornflowerblue" = Just cornflowerblue
    inner "cornsilk" = Just cornsilk
    inner "crimson" = Just crimson
    inner "cyan" = Just cyan
    inner "darkblue" = Just darkblue
    inner "darkcyan" = Just darkcyan
    inner "darkgoldenrod" = Just darkgoldenrod
    inner "darkgray" = Just darkgray
    inner "darkgrey" = Just darkgrey
    inner "darkgreen" = Just darkgreen
    inner "darkkhaki" = Just darkkhaki
    inner "darkmagenta" = Just darkmagenta
    inner "darkolivegreen" = Just darkolivegreen
    inner "darkorange" = Just darkorange
    inner "darkorchid" = Just darkorchid
    inner "darkred" = Just darkred
    inner "darksalmon" = Just darksalmon
    inner "darkseagreen" = Just darkseagreen
    inner "darkslateblue" = Just darkslateblue
    inner "darkslategray" = Just darkslategray
    inner "darkslategrey" = Just darkslategrey
    inner "darkturquoise" = Just darkturquoise
    inner "darkviolet" = Just darkviolet
    inner "deeppink" = Just deeppink
    inner "deepskyblue" = Just deepskyblue
    inner "dimgray" = Just dimgray
    inner "dimgrey" = Just dimgrey
    inner "dodgerblue" = Just dodgerblue
    inner "firebrick" = Just firebrick
    inner "floralwhite" = Just floralwhite
    inner "forestgreen" = Just forestgreen
    inner "fuchsia" = Just fuchsia
    inner "gainsboro" = Just gainsboro
    inner "ghostwhite" = Just ghostwhite
    inner "gold" = Just gold
    inner "goldenrod" = Just goldenrod
    inner "gray" = Just gray
    inner "grey" = Just grey
    inner "green" = Just green
    inner "greenyellow" = Just greenyellow
    inner "honeydew" = Just honeydew
    inner "hotpink" = Just hotpink
    inner "indianred" = Just indianred
    inner "indigo" = Just indigo
    inner "ivory" = Just ivory
    inner "khaki" = Just khaki
    inner "lavender" = Just lavender
    inner "lavenderblush" = Just lavenderblush
    inner "lawngreen" = Just lawngreen
    inner "lemonchiffon" = Just lemonchiffon
    inner "lightblue" = Just lightblue
    inner "lightcoral" = Just lightcoral
    inner "lightcyan" = Just lightcyan
    inner "lightgoldenrodyellow" = Just lightgoldenrodyellow
    inner "lightgray" = Just lightgray
    inner "lightgrey" = Just lightgrey
    inner "lightgreen" = Just lightgreen
    inner "lightpink" = Just lightpink
    inner "lightsalmon" = Just lightsalmon
    inner "lightseagreen" = Just lightseagreen
    inner "lightskyblue" = Just lightskyblue
    inner "lightslategray" = Just lightslategray
    inner "lightslategrey" = Just lightslategrey
    inner "lightsteelblue" = Just lightsteelblue
    inner "lightyellow" = Just lightyellow
    inner "lime" = Just lime
    inner "limegreen" = Just limegreen
    inner "linen" = Just linen
    inner "magenta" = Just magenta
    inner "maroon" = Just maroon
    inner "mediumaquamarine" = Just mediumaquamarine
    inner "mediumblue" = Just mediumblue
    inner "mediumorchid" = Just mediumorchid
    inner "mediumpurple" = Just mediumpurple
    inner "mediumseagreen" = Just mediumseagreen
    inner "mediumslateblue" = Just mediumslateblue
    inner "mediumspringgreen" = Just mediumspringgreen
    inner "mediumturquoise" = Just mediumturquoise
    inner "mediumvioletred" = Just mediumvioletred
    inner "midnightblue" = Just midnightblue
    inner "mintcream" = Just mintcream
    inner "mistyrose" = Just mistyrose
    inner "moccasin" = Just moccasin
    inner "navajowhite" = Just navajowhite
    inner "navy" = Just navy
    inner "oldlace" = Just oldlace
    inner "olive" = Just olive
    inner "olivedrab" = Just olivedrab
    inner "orange" = Just orange
    inner "orangered" = Just orangered
    inner "orchid" = Just orchid
    inner "palegoldenrod" = Just palegoldenrod
    inner "palegreen" = Just palegreen
    inner "paleturquoise" = Just paleturquoise
    inner "palevioletred" = Just palevioletred
    inner "papayawhip" = Just papayawhip
    inner "peachpuff" = Just peachpuff
    inner "peru" = Just peru
    inner "pink" = Just pink
    inner "plum" = Just plum
    inner "powderblue" = Just powderblue
    inner "purple" = Just purple
    -- Named after CSS pioneer Eric Meyer's late daughter
    inner "rebeccapurple" = Just $ sRGB 102 51 153
    inner "red" = Just red
    inner "rosybrown" = Just rosybrown
    inner "royalblue" = Just royalblue
    inner "saddlebrown" = Just saddlebrown
    inner "salmon" = Just salmon
    inner "sandybrown" = Just sandybrown
    inner "seagreen" = Just seagreen
    inner "seashell" = Just seashell
    inner "sienna" = Just sienna
    inner "silver" = Just silver
    inner "skyblue" = Just skyblue
    inner "slateblue" = Just slateblue
    inner "slategray" = Just slategray
    inner "slategrey" = Just slategrey
    inner "snow" = Just snow
    inner "springgreen" = Just springgreen
    inner "steelblue" = Just steelblue
    inner "tan" = Just Data.Colour.Names.tan
    inner "teal" = Just teal
    inner "thistle" = Just thistle
    inner "tomato" = Just tomato
    inner "turquoise" = Just turquoise
    inner "violet" = Just violet
    inner "wheat" = Just wheat
    inner "white" = Just white
    inner "whitesmoke" = Just whitesmoke
    inner "yellow" = Just yellow
    inner "yellowgreen" = Just yellowgreen
    inner _ = Nothing
parseColour _ (Ident x:toks) | Txt.toLower x == "transparent" =
    Just (toks, transparent)
-- FIXME: Add infrastructure to prioritize resolving `color`
parseColour ColourPallet { foreground = ret } (Ident x:toks)
    | Txt.toLower x == "currentcolor" = Just (toks, ret)

parseColour _ (Function "hsl":h':Comma:
        Percentage _ s:Comma:Percentage _ l:RightParen:toks) | Just h <- d h' =
    Just (toks, opaque $ hsl' h (pc s) (pc l))
parseColour _ (Function "hsl":h':Comma:Percentage _ s:Comma:Percentage _ l:
        Comma:a':RightParen:toks) | Just h <- d h', Just a <- f' a' =
    Just (toks, hsl' h (pc s) (pc l) `withOpacity` a)
parseColour _ (Function "hsla":h':Comma:Percentage _ s:Comma:Percentage _ l:
        Comma:a':RightParen:toks) | Just h <- d h', Just a <- f' a' =
    Just (toks, hsl' h (pc s) (pc l) `withOpacity` a)
parseColour _ (Function "hsl":h':s':l':RightParen:toks)
    | Just h <- d' h', Just s <- pc' s', Just l <- pc' l' =
        Just (toks, opaque $ hsl' h s l)
parseColour _ (Function "hsl":h':s':l':Delim '/':a':RightParen:toks)
    | Just h <- d' h', Just s <- pc' s', Just l <- pc' l', Just a <- f' a' =
        Just (toks, hsl' h s l `withOpacity` a)

parseColour _ _ = Nothing

sRGBhex :: Char -> Char -> Char -> Char -> Char -> Char -> Colour Double
sRGBhex r0 r1 g0 g1 b0 b1 = sRGB24 (h r0 r1) (h g0 g1) (h b0 b1)

h :: Char -> Char -> Word8
h a b
    | Just a' <- toLower a `elemIndex` digits,
        Just b' <- toLower b `elemIndex` digits = toEnum a'*16 + toEnum b'
    | otherwise = trace (a:b:" Invalid hexcode!") 0 -- Should already be checked!
  where
    digits = "0123456789abcdef"
h' :: Char -> Char -> Double
h' a b = fromIntegral (h a b) / 255

pc :: NumericValue -> Double
pc x = f x / 100
pc' :: Token -> Maybe Double
pc' (Ident "none") = Just 0
pc' (Percentage _ x) = Just $ pc x
pc' _ = Nothing

f :: NumericValue -> Double
f (NVInteger x) = fromIntegral x
f (NVNumber x) = toRealFloat x
f' :: Token -> Maybe Double
f' (Ident "none") = Just 0
f' (Percentage _ x) = Just $ pc x
f' (Number _ x) = Just $ f x
f' _ = Nothing

w :: Integer -> Word8
w = fromInteger
w' :: Token -> Maybe Word8
w' (Ident "none") = Just 0
w' (Number _ (NVInteger x)) | x >= 0 && x <= 255 = Just $ fromIntegral $ w x
w' (Percentage _ x) = Just $ toEnum $ fromEnum (pc x * 255)
w' _ = Nothing

d', d :: Token -> Maybe Double
d (Dimension _ x "deg") = Just $ f x
d (Dimension _ x "grad") = Just $ f x / 400 * 360
d (Dimension _ x "rad") = Just $ f x / pi * 180
d (Dimension _ x "turn") = Just $ f x * 360
d (Number _ x) = Just $ f x
d _ = Nothing
d' (Ident "none") = Just 0
d' x = d x

-- Copied from css-syntax.
pattern (:.) :: Char -> Txt.Text -> Txt.Text
pattern x :. xs <- (Txt.uncons -> Just (x, xs))

infixr 5 :.