{-# LANGUAGE OverloadedStrings #-}
module Graphics.SvgTree.ColorParser
  ( colorParser
  , colorSerializer
  , textureParser
  , textureSerializer
  , urlRef
  ) where

import           Control.Applicative          ((<|>))
import           Data.Attoparsec.Text         (Parser, char, digit, inClass,
                                               letter, many1, option, satisfy,
                                               scientific, skipSpace, string,
                                               takeWhile1)
import           Data.Bits                    (unsafeShiftL, (.|.))

import           Codec.Picture                (PixelRGBA8 (..))
import           Data.Functor
import qualified Data.Map                     as M
import           Data.Scientific              (toRealFloat)
import           Data.Word                    (Word8)
import           Graphics.SvgTree.NamedColors
import           Graphics.SvgTree.Types
import           Text.Printf                  (printf)

commaWsp :: Parser ()
commaWsp :: Parser ()
commaWsp = Parser ()
skipSpace Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option () (Text -> Parser Text
string Text
"," Parser Text -> () -> Parser ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ())
                     Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace


num :: Parser Double
num :: Parser Double
num = Double -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> Double) -> Parser Double -> Parser Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser ()
skipSpace Parser () -> Parser Double -> Parser Double
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Double
plusMinus Parser Double -> Parser () -> Parser Double
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace)
  where doubleNumber :: Parser Double
        doubleNumber :: Parser Double
doubleNumber = Scientific -> Double
forall a. RealFloat a => Scientific -> a
toRealFloat (Scientific -> Double) -> Parser Text Scientific -> Parser Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Scientific
scientific

        plusMinus :: Parser Double
plusMinus = Double -> Double
forall a. Num a => a -> a
negate (Double -> Double) -> Parser Text -> Parser Text (Double -> Double)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
string Text
"-" Parser Text (Double -> Double) -> Parser Double -> Parser Double
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Double
doubleNumber
                 Parser Double -> Parser Double -> Parser Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text
string Text
"+" Parser Text -> Parser Double -> Parser Double
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Double
doubleNumber
                 Parser Double -> Parser Double -> Parser Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Double
doubleNumber

colorSerializer :: PixelRGBA8 -> String
colorSerializer :: PixelRGBA8 -> String
colorSerializer (PixelRGBA8 Pixel8
r Pixel8
g Pixel8
b Pixel8
_) = String -> Pixel8 -> Pixel8 -> Pixel8 -> String
forall r. PrintfType r => String -> r
printf String
"#%02X%02X%02X" Pixel8
r Pixel8
g Pixel8
b

colorParser :: Parser PixelRGBA8
colorParser :: Parser PixelRGBA8
colorParser = Parser PixelRGBA8
rgbColor
           Parser PixelRGBA8 -> Parser PixelRGBA8 -> Parser PixelRGBA8
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Parser Text
string Text
"#" Parser Text -> Parser PixelRGBA8 -> Parser PixelRGBA8
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser PixelRGBA8
color Parser PixelRGBA8 -> Parser PixelRGBA8 -> Parser PixelRGBA8
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser PixelRGBA8
colorReduced))
           Parser PixelRGBA8 -> Parser PixelRGBA8 -> Parser PixelRGBA8
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser PixelRGBA8
namedColor
  where
    charRange :: Char -> Char -> Parser Text b
charRange Char
c1 Char
c2 =
        (\Char
c -> Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> Int -> b
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c1) (Char -> b) -> Parser Text Char -> Parser Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Char
satisfy (\Char
v -> Char
c1 Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
v Bool -> Bool -> Bool
&& Char
v Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c2)
    black :: PixelRGBA8
black = Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 Pixel8
0 Pixel8
0 Pixel8
0 Pixel8
255

    hexChar :: Parser Word8
    hexChar :: Parser Pixel8
hexChar = Char -> Char -> Parser Pixel8
forall b. Num b => Char -> Char -> Parser Text b
charRange Char
'0' Char
'9'
           Parser Pixel8 -> Parser Pixel8 -> Parser Pixel8
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Pixel8 -> Pixel8 -> Pixel8
forall a. Num a => a -> a -> a
+ Pixel8
10) (Pixel8 -> Pixel8) -> Parser Pixel8 -> Parser Pixel8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Char -> Parser Pixel8
forall b. Num b => Char -> Char -> Parser Text b
charRange Char
'a' Char
'f')
           Parser Pixel8 -> Parser Pixel8 -> Parser Pixel8
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Pixel8 -> Pixel8 -> Pixel8
forall a. Num a => a -> a -> a
+ Pixel8
10) (Pixel8 -> Pixel8) -> Parser Pixel8 -> Parser Pixel8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Char -> Parser Pixel8
forall b. Num b => Char -> Char -> Parser Text b
charRange Char
'A' Char
'F')

    namedColor :: Parser PixelRGBA8
namedColor = do
      Text
str <- (Char -> Bool) -> Parser Text
takeWhile1 (String -> Char -> Bool
inClass String
"a-z")
      PixelRGBA8 -> Parser PixelRGBA8
forall (m :: * -> *) a. Monad m => a -> m a
return (PixelRGBA8 -> Parser PixelRGBA8)
-> PixelRGBA8 -> Parser PixelRGBA8
forall a b. (a -> b) -> a -> b
$ PixelRGBA8 -> Text -> Map Text PixelRGBA8 -> PixelRGBA8
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault PixelRGBA8
black Text
str Map Text PixelRGBA8
svgNamedColors

    percentToWord :: a -> b
percentToWord a
v = a -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
v a -> a -> a
forall a. Num a => a -> a -> a
* (a
255 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
100)

    numPercent :: Parser Pixel8
numPercent = ((Double -> Pixel8
forall a b. (RealFrac a, Integral b) => a -> b
percentToWord (Double -> Pixel8) -> Parser Double -> Parser Pixel8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Double
num) Parser Pixel8 -> Parser Text -> Parser Pixel8
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text
string Text
"%")
              Parser Pixel8 -> Parser Pixel8 -> Parser Pixel8
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Double -> Pixel8
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Pixel8) -> Parser Double -> Parser Pixel8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Double
num)

    hexByte :: Parser Pixel8
hexByte = (\Pixel8
h1 Pixel8
h2 -> Pixel8
h1 Pixel8 -> Int -> Pixel8
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
4 Pixel8 -> Pixel8 -> Pixel8
forall a. Bits a => a -> a -> a
.|. Pixel8
h2)
           (Pixel8 -> Pixel8 -> Pixel8)
-> Parser Pixel8 -> Parser Text (Pixel8 -> Pixel8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Pixel8
hexChar Parser Text (Pixel8 -> Pixel8) -> Parser Pixel8 -> Parser Pixel8
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Pixel8
hexChar

    color :: Parser PixelRGBA8
color = (\Pixel8
r Pixel8
g Pixel8
b -> Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 Pixel8
r Pixel8
g Pixel8
b Pixel8
255)
         (Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8)
-> Parser Pixel8 -> Parser Text (Pixel8 -> Pixel8 -> PixelRGBA8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Pixel8
hexByte Parser Text (Pixel8 -> Pixel8 -> PixelRGBA8)
-> Parser Pixel8 -> Parser Text (Pixel8 -> PixelRGBA8)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Pixel8
hexByte Parser Text (Pixel8 -> PixelRGBA8)
-> Parser Pixel8 -> Parser PixelRGBA8
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Pixel8
hexByte
    rgbColor :: Parser PixelRGBA8
rgbColor = (\Pixel8
r Pixel8
g Pixel8
b -> Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 Pixel8
r Pixel8
g Pixel8
b Pixel8
255)
            (Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8)
-> Parser Pixel8 -> Parser Text (Pixel8 -> Pixel8 -> PixelRGBA8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser Text
string Text
"rgb(" Parser Text -> Parser Pixel8 -> Parser Pixel8
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Pixel8
numPercent)
            Parser Text (Pixel8 -> Pixel8 -> PixelRGBA8)
-> Parser Pixel8 -> Parser Text (Pixel8 -> PixelRGBA8)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser ()
commaWsp Parser () -> Parser Pixel8 -> Parser Pixel8
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Pixel8
numPercent)
            Parser Text (Pixel8 -> PixelRGBA8)
-> Parser Pixel8 -> Parser PixelRGBA8
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser ()
commaWsp Parser () -> Parser Pixel8 -> Parser Pixel8
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Pixel8
numPercent Parser Pixel8 -> Parser () -> Parser Pixel8
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace Parser Pixel8 -> Parser Text -> Parser Pixel8
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text
string Text
")")

    colorReduced :: Parser PixelRGBA8
colorReduced =
        (\Pixel8
r Pixel8
g Pixel8
b -> Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 (Pixel8
r Pixel8 -> Pixel8 -> Pixel8
forall a. Num a => a -> a -> a
* Pixel8
17) (Pixel8
g Pixel8 -> Pixel8 -> Pixel8
forall a. Num a => a -> a -> a
* Pixel8
17) (Pixel8
b Pixel8 -> Pixel8 -> Pixel8
forall a. Num a => a -> a -> a
* Pixel8
17) Pixel8
255)
        (Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8)
-> Parser Pixel8 -> Parser Text (Pixel8 -> Pixel8 -> PixelRGBA8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Pixel8
hexChar Parser Text (Pixel8 -> Pixel8 -> PixelRGBA8)
-> Parser Pixel8 -> Parser Text (Pixel8 -> PixelRGBA8)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Pixel8
hexChar Parser Text (Pixel8 -> PixelRGBA8)
-> Parser Pixel8 -> Parser PixelRGBA8
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Pixel8
hexChar


textureSerializer :: Texture -> String
textureSerializer :: Texture -> String
textureSerializer (ColorRef PixelRGBA8
px)    = PixelRGBA8 -> String
colorSerializer PixelRGBA8
px
textureSerializer (TextureRef String
str) = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"url(#%s)" String
str
textureSerializer Texture
FillNone         = String
"none"

urlRef :: Parser String
urlRef :: Parser String
urlRef = Text -> Parser Text
string Text
"url(" Parser Text -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace Parser () -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
       Char -> Parser Text Char
char Char
'#' Parser Text Char -> Parser String -> Parser String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Char -> Parser String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 (Parser Text Char
letter Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Char
digit Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Text Char
char Char
'_' Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Text Char
char Char
'.' Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Text Char
char Char
'-' Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Text Char
char Char
':')
       Parser String -> Parser () -> Parser String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace Parser String -> Parser Text Char -> Parser String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char Char
')' Parser String -> Parser () -> Parser String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace


textureParser :: Parser Texture
textureParser :: Parser Texture
textureParser =
  Parser Texture
none Parser Texture -> Parser Texture -> Parser Texture
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> Texture
TextureRef (String -> Texture) -> Parser String -> Parser Texture
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
urlRef)
       Parser Texture -> Parser Texture -> Parser Texture
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (PixelRGBA8 -> Texture
ColorRef (PixelRGBA8 -> Texture) -> Parser PixelRGBA8 -> Parser Texture
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PixelRGBA8
colorParser)
  where
    none :: Parser Texture
none = Texture
FillNone Texture -> Parser Text -> Parser Texture
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
string Text
"none"