{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
{- |

This module defines the types for 'AdobeStageExchange' and a suitable
'Binary' instance. All the get/put helper functions are also exported,
but, in general, you will just want the types and the 'Binary'
instance.

-}
module Data.AdobeSwatchExchange where

import Control.Applicative            ((<$>))
import Control.Monad                  (replicateM)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Char                      (chr, ord)
import Data.Data                      (Data, Typeable)
import Data.Word                      (Word16)
import Data.Binary.IEEE754            (getFloat32be, putFloat32be)
import Numeric                        (showHex)
import Data.Binary                    (Binary(..))
import Data.Binary.Get                ( Get, getByteString, getWord8, getWord16be, getWord32be, runGet )
import Data.Binary.Put                ( Put, putByteString, putWord8, putWord16be, putWord32be, runPut )

{-
But to summarize, look for the following elements (in no particular order):
- header
- version
- "block count"
- blocks
- color group start
- color group end
- swatches
- "zero block"

- strings

For swatch "blocks"
- swatch header
- block length
- swatch name
- color space
- color component values (single-precision floats)
- swatch attributes

The only thing to really watch out for is that the count near the beginning is *not* the swatch count, but the number of "blocks" in the file, which also includes color group information.

File signature 4*char (ASEF)
Version 2*int8 (1.0)
Number of blocks 1*int16
Blocks
Block type (0xc001 ⇒ Group start, 0xc002 ⇒ Group end, 0x0001 ⇒ Color entry)
Block length 1*int16
Group/Color name 0-terminated string of length (int16) double-byte characters
Color model 4*char (CMYK, RGB, LAB or Gray)
Color values CMYK ⇒ 4*float16 / RGB & LAB ⇒ 3*float16 / Gray ⇒ 1*float16
Color type 1*int8 (0 ⇒ Global, 1 ⇒ Spot, 2 ⇒ Normal)

-}

-- | A color
data Color
    = CYMK Float Float Float Float
    | RGB Float Float Float
    | LAB Float Float Float
    | Gray Float
    deriving (Eq, Ord, Read, Show, Data, Typeable)

-- | color type
data ColorType
    = Global
    | Spot
    | Normal
    deriving (Eq, Ord, Read, Show, Data, Typeable)

-- | A named color
data ColorEntry = ColorEntry
    { colorName :: String
    , color     :: Color
    , colorType :: ColorType
    }
    deriving (Eq, Ord, Read, Show, Data, Typeable)

-- | An Adobe Swatch Exchange block
data ASEBlock
    = GroupStart { groupName :: String }
    | GroupEnd
    | CE ColorEntry
    deriving (Eq, Ord, Read, Show, Data, Typeable)

-- | AdobeSwatchExchange
data AdobeSwatchExchange = AdobeSwatchExchange
    { version :: (Word16, Word16)
    , blocks  :: [ASEBlock]
    }
    deriving (Eq, Ord, Read, Show, Data, Typeable)

-- | get the ASEF file signature
getFileSig :: Get ()
getFileSig =
    do bs <- getByteString 4
       case bs of
         "ASEF" -> return ()
         _ -> fail $ "Invalid file signature: " ++ show bs

putFileSig :: Put
putFileSig = putByteString "ASEF"

getVersion :: Get (Word16, Word16)
getVersion =
    do maj <- getWord16be
       min <- getWord16be
       return (maj, min)

putVersion :: (Word16, Word16) -> Put
putVersion (maj, min) =
    do putWord16be maj
       putWord16be min

getBlock :: Get ASEBlock
getBlock =
    do blockType <- getWord16be
       case blockType of
         0xc001 -> do bl <- getWord32be
                      n <- getName
                      return (GroupStart n)
         0xc002 -> do bl <- getWord32be
                      return GroupEnd
         0x0001 -> CE <$> getColorEntry
         _      -> fail $ "Unknown block type: " ++ (showHex blockType "")

putBlock :: ASEBlock -> Put
putBlock (GroupStart groupName) =
    do putWord16be 0xc001
       putWord32be $ blName groupName
       putName groupName
putBlock GroupEnd =
    do putWord16be 0xc002
       putWord32be 0
putBlock (CE colorEntry) =
    do putWord16be 0x0001
       putColorEntry colorEntry

getName :: Get String
getName =
    do nameLength  <- getWord16be
       doubleChars <- replicateM ((fromIntegral nameLength) - 1) getWord16be
       _ <- getWord16be
       return $ map (chr . fromIntegral) doubleChars

putName :: String -> Put
putName nm =
    do putWord16be $ (fromIntegral (length nm) + 1)
       mapM_ (putWord16be . fromIntegral . ord) nm
       putWord16be 0

blName :: (Integral a) => String -> a
blName nm =
    fromIntegral (2 + (length nm * 2) + 2)

getColor :: Get Color
getColor =
    do modelString <- map (chr . fromIntegral) <$> replicateM 4 getWord8
       case modelString of
         "CYMK" -> do c <- getFloat32be
                      y <- getFloat32be
                      m <- getFloat32be
                      k <- getFloat32be
                      return $ CYMK c y m k
         "RGB " -> do r <- getFloat32be
                      g <- getFloat32be
                      b <- getFloat32be
                      return $ RGB r g b
         "LAB " -> do l <- getFloat32be
                      a <- getFloat32be
                      b <- getFloat32be
                      return $ LAB l a b
         "Gray" -> do g <- getFloat32be
                      return $ Gray g
         _      -> fail $ "Unknown color model: " ++ modelString

putColor :: Color -> Put
putColor (CYMK c y m k) =
    do mapM_ (putWord8 . fromIntegral . ord) "CYMK"
       putFloat32be c
       putFloat32be y
       putFloat32be m
       putFloat32be k
putColor (RGB r g b) =
    do mapM_ (putWord8 . fromIntegral . ord) "RGB "
       putFloat32be r
       putFloat32be g
       putFloat32be b
putColor (LAB l a b) =
    do mapM_ (putWord8 . fromIntegral . ord) "LAB "
       putFloat32be l
       putFloat32be a
       putFloat32be b
putColor (Gray g) =
    do mapM_ (putWord8 . fromIntegral . ord) "Gray"
       putFloat32be g

blColor :: (Integral a) => Color -> a
blColor (CYMK {}) = 20
blColor (RGB {})  = 16
blColor (LAB {})  = 16
blColor (Gray {}) = 8

getColorType :: Get ColorType
getColorType =
    do ct <- getWord16be
       case ct of
         0 -> return Global
         1 -> return Spot
         2 -> return Normal
         _ -> fail $ "Unknown color type: " ++ show ct

putColorType :: ColorType -> Put
putColorType Global = putWord16be 0
putColorType Spot   = putWord16be 1
putColorType Normal = putWord16be 2

instance Binary ColorType where
    put = putColorType
    get = getColorType

blColorType :: (Integral a) => a
blColorType = fromIntegral 2

getColorEntry :: Get ColorEntry
getColorEntry =
    do bl    <- getWord32be
       nm    <- getName
       color <- getColor
       typ   <- getColorType
       return $ ColorEntry { colorName = nm
                           , color     = color
                           , colorType = typ
                           }

putColorEntry :: ColorEntry -> Put
putColorEntry (ColorEntry cn c ct) =
    do putWord32be (blName cn + blColor c + blColorType)
       putName cn
       putColor c
       putColorType ct

instance Binary ColorEntry where
    put = putColorEntry
    get = getColorEntry

getASE :: Get AdobeSwatchExchange
getASE =
    do getFileSig
       v <- getVersion
       numBlocks <- getWord32be
       bs <- replicateM (fromIntegral numBlocks) getBlock -- unsafe-ish if there are billions of blocks
       return $ AdobeSwatchExchange { version = v
                                    , blocks  = bs
                                    }

putASE :: AdobeSwatchExchange -> Put
putASE (AdobeSwatchExchange v blks) =
    do putFileSig
       putVersion v
       putWord32be (fromIntegral $ length blks)
       mapM_ putBlock blks

instance Binary AdobeSwatchExchange where
    put = putASE
    get = getASE

-- | Convert a 'Color' to an RGB hex value.
colorToHex :: Color -> String
colorToHex (RGB r g b) =
    showString "#" .
    showHex' (round (r * 255)) .
    showHex' (round (g * 255)) .
    showHex' (round (b * 255)) $ ""
    where
      showHex' n
        | n < 10 = showString "0" . showHex n
        | otherwise  = showHex n
colorToHex c =
    error $ "Alas! We have not written the code to convert " ++ show c ++ " to the RGB color space."