content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE FlexibleContexts #-}
  module Codec.Picture.Tiff.Internal.Types
      ( BinaryParam( .. )
      , Endianness( .. )
      , TiffHeader( .. )
      , TiffPlanarConfiguration( .. )
      , TiffCompression( .. )
      , IfdType( .. )
      , TiffColorspace( .. )
      , TiffSampleFormat( .. )
      , ImageFileDirectory( .. )
      , ExtraSample( .. )
      , Predictor( .. )
  
      , planarConfgOfConstant
      , constantToPlaneConfiguration
      , unpackSampleFormat
      , packSampleFormat
      , word16OfTag
      , unpackPhotometricInterpretation
      , packPhotometricInterpretation
      , codeOfExtraSample
      , unPackCompression
      , packCompression 
      , predictorOfConstant
      ) where
  
  #if !MIN_VERSION_base(4,8,0)
  import Control.Applicative( (<$>), (<*>), pure )
  #endif
  
  import Control.DeepSeq( NFData(..) )
  import Control.Monad( forM_, when, replicateM, )
  import Data.Bits( (.&.), unsafeShiftR )
  import Data.Binary( Binary( .. ) )
  import Data.Binary.Get( Get
                        , getWord16le, getWord16be
                        , getWord32le, getWord32be
                        , bytesRead
                        , skip
                        , getByteString
                        )
  import Data.Binary.Put( Put
                        , putWord16le, putWord16be
                        , putWord32le, putWord32be
                        , putByteString
                        )
  import Data.Function( on )
  import Data.List( sortBy, mapAccumL )
  import qualified Data.Vector as V
  import qualified Data.ByteString as B
  import Data.Int( Int32 )
  import Data.Word( Word8, Word16, Word32 )
  import GHC.Generics( Generic )
  
  import Codec.Picture.Metadata.Exif
  {-import Debug.Trace-}
  
  data Endianness
    = EndianLittle
    | EndianBig
    deriving (Eq, Show)
  
  instance Binary Endianness where
    put EndianLittle = putWord16le 0x4949
    put EndianBig = putWord16le 0x4D4D
  
    get = do
      tag <- getWord16le
      case tag of
        0x4949 -> return EndianLittle
        0x4D4D -> return EndianBig
        _ -> fail "Invalid endian tag value"
  
  -- | Because having a polymorphic get with endianness is to nice
  -- to pass on, introducing this helper type class, which is just
  -- a superset of Binary, but formalising a parameter passing
  -- into it.
  class BinaryParam a b where
    getP :: a -> Get b
    putP :: a -> b -> Put
  
  data TiffHeader = TiffHeader
    { hdrEndianness :: !Endianness
    , hdrOffset     :: {-# UNPACK #-} !Word32
    }
    deriving (Eq, Show)
  
  instance BinaryParam Endianness Word16 where
    putP EndianLittle = putWord16le
    putP EndianBig = putWord16be
  
    getP EndianLittle = getWord16le
    getP EndianBig = getWord16be
  
  instance BinaryParam Endianness Int32 where
    putP en v = putP en $ (fromIntegral v :: Word32)
    getP en = fromIntegral <$> (getP en :: Get Word32) 
  
  instance BinaryParam Endianness Word32 where
    putP EndianLittle = putWord32le
    putP EndianBig = putWord32be
  
    getP EndianLittle = getWord32le
    getP EndianBig = getWord32be
  
  instance Binary TiffHeader where
    put hdr = do
      let endian = hdrEndianness hdr
      put endian
      putP endian (42 :: Word16)
      putP endian $ hdrOffset hdr
  
    get = do
      endian <- get
      magic <- getP endian
      let magicValue = 42 :: Word16
      when (magic /= magicValue)
           (fail "Invalid TIFF magic number")
      TiffHeader endian <$> getP endian
  
  data TiffPlanarConfiguration
    = PlanarConfigContig    -- = 1
    | PlanarConfigSeparate  -- = 2
  
  planarConfgOfConstant :: Word32 -> Get TiffPlanarConfiguration
  planarConfgOfConstant 0 = pure PlanarConfigContig
  planarConfgOfConstant 1 = pure PlanarConfigContig
  planarConfgOfConstant 2 = pure PlanarConfigSeparate
  planarConfgOfConstant v = fail $ "Unknown planar constant (" ++ show v ++ ")"
  
  constantToPlaneConfiguration :: TiffPlanarConfiguration -> Word16
  constantToPlaneConfiguration PlanarConfigContig = 1
  constantToPlaneConfiguration PlanarConfigSeparate = 2
  
  data TiffCompression
    = CompressionNone           -- 1
    | CompressionModifiedRLE    -- 2
    | CompressionLZW            -- 5
    | CompressionJPEG           -- 6
    | CompressionPackBit        -- 32273
  
  data IfdType
    = TypeByte
    | TypeAscii
    | TypeShort
    | TypeLong
    | TypeRational
    | TypeSByte
    | TypeUndefined
    | TypeSignedShort
    | TypeSignedLong
    | TypeSignedRational
    | TypeFloat
    | TypeDouble
    deriving (Eq, Show, Generic)
  instance NFData IfdType
  
  instance BinaryParam Endianness IfdType where
      getP endianness = getP endianness >>= conv where
        conv :: Word16 -> Get IfdType
        conv v = case v of
          1  -> return TypeByte
          2  -> return TypeAscii
          3  -> return TypeShort
          4  -> return TypeLong
          5  -> return TypeRational
          6  -> return TypeSByte
          7  -> return TypeUndefined
          8  -> return TypeSignedShort
          9  -> return TypeSignedLong
          10 -> return TypeSignedRational
          11 -> return TypeFloat
          12 -> return TypeDouble
          _  -> fail "Invalid TIF directory type"
  
      putP endianness = putP endianness . conv where
        conv :: IfdType -> Word16
        conv v = case v of
          TypeByte -> 1
          TypeAscii -> 2
          TypeShort -> 3
          TypeLong -> 4
          TypeRational -> 5
          TypeSByte -> 6
          TypeUndefined -> 7
          TypeSignedShort -> 8
          TypeSignedLong -> 9
          TypeSignedRational -> 10
          TypeFloat -> 11
          TypeDouble -> 12
  
  instance BinaryParam Endianness ExifTag where
    getP endianness = tagOfWord16 <$> getP endianness
    putP endianness = putP endianness . word16OfTag
  
  data Predictor
    = PredictorNone                   -- 1
    | PredictorHorizontalDifferencing -- 2
    deriving Eq
  
  predictorOfConstant :: Word32 -> Get Predictor
  predictorOfConstant 1 = pure PredictorNone
  predictorOfConstant 2 = pure PredictorHorizontalDifferencing
  predictorOfConstant v = fail $ "Unknown predictor (" ++ show v ++ ")"
  
  paddWrite :: B.ByteString -> Put
  paddWrite str = putByteString str >> padding where
    zero = 0 :: Word8
    padding = when (odd (B.length str)) $ put zero
  
  instance BinaryParam (Endianness, Int, ImageFileDirectory) ExifData where
    putP (endianness, _, _) = dump
      where
        dump ExifNone = pure ()
        dump (ExifLong _) = pure ()
        dump (ExifShort _) = pure ()
        dump (ExifIFD _) = pure ()
        dump (ExifString bstr) = paddWrite bstr
        dump (ExifUndefined bstr) = paddWrite bstr
        -- wrong if length == 2
        dump (ExifShorts shorts) = V.mapM_ (putP endianness) shorts
        dump (ExifLongs longs) = V.mapM_ (putP endianness) longs
        dump (ExifRational a b) = putP endianness a >> putP endianness b
        dump (ExifSignedRational a b) = putP endianness a >> putP endianness b
  
    getP (endianness, maxi, ifd) = fetcher ifd
      where
        align ImageFileDirectory { ifdOffset = offset } act = do
          readed <- bytesRead
          let delta = fromIntegral offset - readed
          if offset >= fromIntegral maxi || fromIntegral readed > offset then
            pure ExifNone
          else do
            skip $ fromIntegral delta
            act
  
        getE :: (BinaryParam Endianness a) => Get a
        getE = getP endianness
  
        getVec count = V.replicateM (fromIntegral count)
  
        immediateBytes ofs =
          let bytes = [fromIntegral $ (ofs .&. 0xFF000000) `unsafeShiftR` (3 * 8)
                      ,fromIntegral $ (ofs .&. 0x00FF0000) `unsafeShiftR` (2 * 8)
                      ,fromIntegral $ (ofs .&. 0x0000FF00) `unsafeShiftR` (1 * 8)
                      ,fromIntegral $  ofs .&. 0x000000FF
                      ]
          in case endianness of
               EndianLittle -> reverse bytes
               EndianBig    -> bytes
  
        fetcher ImageFileDirectory { ifdIdentifier = TagExifOffset
                                   , ifdType = TypeLong
                                   , ifdCount = 1 } = do
           align ifd $ do
              let byOffset = sortBy (compare `on` ifdOffset)
                  cleansIfds = fmap (cleanImageFileDirectory endianness)
              subIfds <- cleansIfds . byOffset <$> getP endianness
              cleaned <- fetchExtended endianness maxi $ sortBy (compare `on` ifdOffset) subIfds
              pure $ ExifIFD [(ifdIdentifier fd, ifdExtended fd) | fd <- cleaned]
           {-  
        fetcher ImageFileDirectory { ifdIdentifier = TagGPSInfo
                                   , ifdType = TypeLong
                                   , ifdCount = 1 } = do
           align ifd 
           subIfds <- fmap (cleanImageFileDirectory endianness) <$> getP endianness
           cleaned <- fetchExtended endianness subIfds
           pure $ ExifIFD [(ifdIdentifier fd, ifdExtended fd) | fd <- cleaned]
          -}
        fetcher ImageFileDirectory { ifdType = TypeUndefined, ifdCount = count } | count > 4 =
           align ifd $ ExifUndefined <$> getByteString (fromIntegral count)
        fetcher ImageFileDirectory { ifdType = TypeUndefined, ifdOffset = ofs } =
            pure . ExifUndefined . B.pack $ take (fromIntegral $ ifdCount ifd)
                (immediateBytes ofs)
        fetcher ImageFileDirectory { ifdType = TypeAscii, ifdCount = count } | count > 4 =
            align ifd $ ExifString <$> getByteString (fromIntegral count)
        fetcher ImageFileDirectory { ifdType = TypeAscii, ifdOffset = ofs } =
            pure . ExifString . B.pack $ take (fromIntegral $ ifdCount ifd)
                (immediateBytes ofs)
        fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 2, ifdOffset = ofs } =
            pure . ExifShorts $ V.fromListN 2 valList
              where high = fromIntegral $ ofs `unsafeShiftR` 16
                    low = fromIntegral $ ofs .&. 0xFFFF
                    valList = case endianness of
                      EndianLittle -> [low, high]
                      EndianBig -> [high, low]
        fetcher ImageFileDirectory { ifdType = TypeRational, ifdCount = 1 } = do
            align ifd $ ExifRational <$> getP EndianLittle <*> getP EndianLittle
        fetcher ImageFileDirectory { ifdType = TypeSignedRational, ifdCount = 1 } = do
            align ifd $ ExifSignedRational <$> getP EndianLittle <*> getP EndianLittle
        fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 1 } =
            pure . ExifShort . fromIntegral $ ifdOffset ifd
        fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = count } | count > 2 =
            align ifd $ ExifShorts <$> getVec count getE
        fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = 1 } =
            pure . ExifLong . fromIntegral $ ifdOffset ifd
        fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = count } | count > 1 =
            align ifd $ ExifLongs <$> getVec count getE
        fetcher _ = pure ExifNone
  
  cleanImageFileDirectory :: Endianness -> ImageFileDirectory -> ImageFileDirectory
  cleanImageFileDirectory EndianBig ifd@(ImageFileDirectory { ifdCount = 1 }) = aux $ ifdType ifd
    where
      aux TypeShort = ifd { ifdOffset = ifdOffset ifd `unsafeShiftR` 16 }
      aux _ = ifd
  cleanImageFileDirectory _ ifd = ifd
  
  fetchExtended :: Endianness -> Int -> [ImageFileDirectory] -> Get [ImageFileDirectory]
  fetchExtended endian maxi = mapM $ \ifd -> do
    v <- getP (endian, maxi, ifd)
    pure $ ifd { ifdExtended = v }
  
  -- | All the IFD must be written in order according to the tag
  -- value of the IFD. To avoid getting to much restriction in the
  -- serialization code, just sort it.
  orderIfdByTag :: [ImageFileDirectory] -> [ImageFileDirectory]
  orderIfdByTag = sortBy comparer where
    comparer a b = compare t1 t2 where
      t1 = word16OfTag $ ifdIdentifier a
      t2 = word16OfTag $ ifdIdentifier b
  
  -- | Given an official offset and a list of IFD, update the offset information
  -- of the IFD with extended data.
  setupIfdOffsets :: Word32 -> [ImageFileDirectory] -> (Word32, [ImageFileDirectory])
  setupIfdOffsets initialOffset lst = mapAccumL updater startExtended lst
    where ifdElementCount = fromIntegral $ length lst
          ifdSize = 12
          ifdCountSize = 2
          nextOffsetSize = 4
          startExtended = initialOffset
                       + ifdElementCount * ifdSize
                       + ifdCountSize + nextOffsetSize
  
          paddedSize blob = fromIntegral $ blobLength + padding where
            blobLength = B.length blob
            padding = if odd blobLength then 1 else 0
  
          updater ix ifd@(ImageFileDirectory { ifdIdentifier = TagExifOffset }) =
              (ix, ifd { ifdOffset = ix } )
          updater ix ifd@(ImageFileDirectory { ifdExtended = ExifUndefined b }) =
              (ix + paddedSize b, ifd { ifdOffset = ix } )
          updater ix ifd@(ImageFileDirectory { ifdExtended = ExifString b }) =
              (ix + paddedSize b, ifd { ifdOffset = ix } )
          updater ix ifd@(ImageFileDirectory { ifdExtended = ExifLongs v })
              | V.length v > 1 = ( ix + fromIntegral (V.length v * 4)
                                 , ifd { ifdOffset = ix } )
          updater ix ifd@(ImageFileDirectory { ifdExtended = ExifShorts v })
              | V.length v > 2 = ( ix + fromIntegral (V.length v * 2)
                               , ifd { ifdOffset = ix })
          updater ix ifd = (ix, ifd)
  
  instance BinaryParam B.ByteString (TiffHeader, [[ImageFileDirectory]]) where
    putP rawData (hdr, ifds) = do
      put hdr
      putByteString rawData
      let endianness = hdrEndianness hdr
          (_, offseted) = mapAccumL
              (\ix ifd -> setupIfdOffsets ix $ orderIfdByTag ifd)
              (hdrOffset hdr)
              ifds
      forM_ offseted $ \list -> do
          putP endianness list
          mapM_ (\field -> putP (endianness, (0::Int), field) $ ifdExtended field) list
  
    getP raw = do
      hdr <- get
      readed <- bytesRead
      skip . fromIntegral $ fromIntegral (hdrOffset hdr) - readed
      let endian = hdrEndianness hdr
          byOffset = sortBy (compare `on` ifdOffset)
          cleanIfds = fmap (cleanImageFileDirectory endian)
  
      ifd <-  cleanIfds . byOffset <$> getP endian
      cleaned <- fetchExtended endian (B.length raw) ifd
      return (hdr, [cleaned])
  
  data TiffSampleFormat
    = TiffSampleUint
    | TiffSampleInt
    | TiffSampleFloat
    | TiffSampleUnknown
    deriving Eq
  
  unpackSampleFormat :: Word32 -> Get TiffSampleFormat
  unpackSampleFormat v = case v of
    1 -> pure TiffSampleUint
    2 -> pure TiffSampleInt
    3 -> pure TiffSampleFloat
    4 -> pure TiffSampleUnknown
    vv -> fail $ "Undefined data format (" ++ show vv ++ ")"
  
  packSampleFormat :: TiffSampleFormat -> Word32
  packSampleFormat TiffSampleUint    = 1
  packSampleFormat TiffSampleInt     = 2
  packSampleFormat TiffSampleFloat   = 3
  packSampleFormat TiffSampleUnknown = 4
  
  data ImageFileDirectory = ImageFileDirectory
    { ifdIdentifier :: !ExifTag -- Word16
    , ifdType       :: !IfdType -- Word16
    , ifdCount      :: !Word32
    , ifdOffset     :: !Word32
    , ifdExtended   :: !ExifData
    }
    deriving (Eq, Show, Generic)
  instance NFData ImageFileDirectory
  
  instance BinaryParam Endianness ImageFileDirectory where
    getP endianness =
      ImageFileDirectory <$> getE <*> getE <*> getE <*> getE
                         <*> pure ExifNone
          where getE :: (BinaryParam Endianness a) => Get a
                getE = getP endianness
  
    putP endianness ifd = do
      let putE :: (BinaryParam Endianness a) => a -> Put
          putE = putP endianness
      putE $ ifdIdentifier ifd
      putE $ ifdType ifd
      putE $ ifdCount ifd
      putE $ ifdOffset ifd
  
  instance BinaryParam Endianness [ImageFileDirectory] where
    getP endianness = do
      count <- getP endianness :: Get Word16
      rez <- replicateM (fromIntegral count) $ getP endianness
      _ <- getP endianness :: Get Word32
      pure rez
  
  
    putP endianness lst = do
      let count = fromIntegral $ length lst :: Word16
      putP endianness count
      mapM_ (putP endianness) lst
      putP endianness (0 :: Word32)
  
  data TiffColorspace
    = TiffMonochromeWhite0 -- ^ 0
    | TiffMonochrome       -- ^ 1
    | TiffRGB              -- ^ 2
    | TiffPaleted          -- ^ 3
    | TiffTransparencyMask -- ^ 4
    | TiffCMYK             -- ^ 5
    | TiffYCbCr            -- ^ 6
    | TiffCIELab           -- ^ 8
  
  
  packPhotometricInterpretation :: TiffColorspace -> Word16
  packPhotometricInterpretation v = case v of
    TiffMonochromeWhite0 -> 0
    TiffMonochrome       -> 1
    TiffRGB              -> 2
    TiffPaleted          -> 3
    TiffTransparencyMask -> 4
    TiffCMYK             -> 5
    TiffYCbCr            -> 6
    TiffCIELab           -> 8
  
  unpackPhotometricInterpretation :: Word32 -> Get TiffColorspace
  unpackPhotometricInterpretation v = case v of
    0 -> pure TiffMonochromeWhite0
    1 -> pure TiffMonochrome
    2 -> pure TiffRGB
    3 -> pure TiffPaleted
    4 -> pure TiffTransparencyMask
    5 -> pure TiffCMYK
    6 -> pure TiffYCbCr
    8 -> pure TiffCIELab
    vv -> fail $ "Unrecognized color space " ++ show vv
  
  data ExtraSample
    = ExtraSampleUnspecified       -- ^ 0
    | ExtraSampleAssociatedAlpha   -- ^ 1
    | ExtraSampleUnassociatedAlpha -- ^ 2
  
  codeOfExtraSample :: ExtraSample -> Word16
  codeOfExtraSample v = case v of
    ExtraSampleUnspecified -> 0
    ExtraSampleAssociatedAlpha -> 1
    ExtraSampleUnassociatedAlpha -> 2
  
  unPackCompression :: Word32 -> Get TiffCompression
  unPackCompression v = case v of
    0 -> pure CompressionNone
    1 -> pure CompressionNone
    2 -> pure CompressionModifiedRLE
    5 -> pure CompressionLZW
    6 -> pure CompressionJPEG
    32773 -> pure CompressionPackBit
    vv -> fail $ "Unknown compression scheme " ++ show vv
  
  packCompression :: TiffCompression -> Word16
  packCompression v = case v of
    CompressionNone        -> 1
    CompressionModifiedRLE -> 2
    CompressionLZW         -> 5
    CompressionJPEG        -> 6
    CompressionPackBit     -> 32773
  
  