content: {-# LANGUAGE CPP #-}
  module Codec.Picture.Tiff.Internal.Metadata
      ( extractTiffMetadata
      , encodeTiffStringMetadata
      , exifOffsetIfd
      ) where
  
  #if !MIN_VERSION_base(4,8,0)
  import Data.Monoid( mempty )
  import Data.Foldable( foldMap )
  import Control.Applicative( (<$>) )
  #endif
  
  import Data.Bits( unsafeShiftL, (.|.) )
  import Data.Foldable( find )
  import Data.List( sortBy )
  import Data.Function( on )
  import qualified Data.Foldable as F
  #if !MIN_VERSION_base(4,11,0)
  import Data.Monoid( (<>) )
  #endif
  import Codec.Picture.Metadata( Metadatas )
  import qualified Data.ByteString as B
  import qualified Data.ByteString.Char8 as BC
  import qualified Codec.Picture.Metadata as Met
  import qualified Data.Vector.Generic as V
  import Codec.Picture.Tiff.Internal.Types
  import Codec.Picture.Metadata( extractExifMetas )
  import Codec.Picture.Metadata.Exif
  
  exifOffsetIfd :: ImageFileDirectory
  exifOffsetIfd = ImageFileDirectory
    { ifdIdentifier = TagExifOffset
    , ifdCount = 1
    , ifdType = TypeLong
    , ifdOffset = 0
    , ifdExtended = ExifNone
    }
  
  typeOfData :: ExifData -> IfdType
  typeOfData d = case d of
    ExifNone -> error "Impossible - typeOfData : ExifNone"
    ExifIFD _exifs -> error "Impossible - typeOfData : ExifIFD"
    ExifLong _l -> TypeLong
    ExifLongs _l -> TypeLong
    ExifShort _s -> TypeShort
    ExifShorts _s -> TypeShort
    ExifString _str -> TypeAscii
    ExifUndefined _undef -> TypeUndefined
    ExifRational _r1 _r2 -> TypeRational
    ExifSignedRational _sr1 _sr2 -> TypeSignedRational
  
  makeIfd :: ExifTag -> ExifData -> ImageFileDirectory
  makeIfd t (ExifShort v) = ImageFileDirectory
    { ifdIdentifier = t
    , ifdType = TypeShort
    , ifdCount = 1
    , ifdOffset = fromIntegral v `unsafeShiftL` 16
    , ifdExtended = ExifNone
    }
  makeIfd t (ExifLong v) = ImageFileDirectory 
    { ifdIdentifier = t
    , ifdType = TypeLong
    , ifdCount = 1
    , ifdOffset = fromIntegral v
    , ifdExtended = ExifNone
    }
  makeIfd t d@(ExifShorts v)
    | size == 2 = ImageFileDirectory
      { ifdIdentifier = t
      , ifdType = TypeShort
      , ifdCount = 2
      , ifdOffset = combined
      , ifdExtended = ExifNone
      }
    | otherwise = ImageFileDirectory
      { ifdIdentifier = t
      , ifdType = TypeShort
      , ifdCount = size
      , ifdOffset = 0
      , ifdExtended = d
      }
    where
      size = fromIntegral $ F.length v
      at i = fromIntegral $ v V.! i
      combined = (at 0  `unsafeShiftL` 16) .|. at 1
  makeIfd t d@(ExifLongs v)
    | size == 1 = ImageFileDirectory
      { ifdIdentifier = t
      , ifdType = TypeLong
      , ifdCount = 1
      , ifdOffset = v V.! 0
      , ifdExtended = ExifNone
      }
    | otherwise = ImageFileDirectory
      { ifdIdentifier = t
      , ifdType = TypeLong
      , ifdCount = size
      , ifdOffset = 0
      , ifdExtended = d
      }
    where size = fromIntegral $ F.length v
  makeIfd t s@(ExifString str) = ImageFileDirectory
      { ifdIdentifier = t
      , ifdType = TypeAscii
      , ifdCount = fromIntegral $ BC.length str
      , ifdOffset = 0
      , ifdExtended = s
      }
  makeIfd t s@(ExifUndefined str)
    | size > 4 = ImageFileDirectory
      { ifdIdentifier = t
      , ifdType = TypeUndefined
      , ifdCount = size
      , ifdOffset = 0
      , ifdExtended = s
      }
    | otherwise = ImageFileDirectory
      { ifdIdentifier = t
      , ifdType = TypeUndefined
      , ifdCount = size
      , ifdOffset = ofs
      , ifdExtended = ExifNone
      }
    where
      size = fromIntegral $ BC.length str
      at ix
        | fromIntegral ix < size = fromIntegral $ B.index str ix `unsafeShiftL` (4 - (8 * ix))
        | otherwise = 0
      ofs = at 0 .|. at 1 .|. at 2 .|. at 3
  makeIfd t d = ImageFileDirectory
    { ifdIdentifier = t
    , ifdType = typeOfData d
    , ifdCount = 1
    , ifdOffset = 0
    , ifdExtended = d
    }
  
  encodeTiffStringMetadata :: Metadatas -> [ImageFileDirectory]
  encodeTiffStringMetadata metas = sortBy (compare `on` word16OfTag . ifdIdentifier) $ allTags where
    keyStr tag k = case Met.lookup k metas of
      Nothing -> mempty
      Just v -> pure . makeIfd tag . ExifString $ BC.pack v
    allTags = copyright <> artist <> title <> description <> software <> allPureExif
  
    allPureExif = fmap (uncurry makeIfd) $ extractExifMetas metas
  
    copyright = keyStr TagCopyright Met.Copyright
    artist = keyStr TagArtist Met.Author
    title = keyStr TagDocumentName Met.Title
    description = keyStr TagImageDescription Met.Description
    software = keyStr TagSoftware Met.Software
  
  extractTiffStringMetadata :: [ImageFileDirectory] -> Metadatas
  extractTiffStringMetadata = Met.insert Met.Format Met.SourceTiff . foldMap go where
    strMeta k = Met.singleton k . BC.unpack
    exif ifd =
      Met.singleton (Met.Exif $ ifdIdentifier ifd) $ ifdExtended ifd
    inserter acc (k, v) = Met.insert (Met.Exif k) v acc
    exifShort ifd =
      Met.singleton (Met.Exif $ ifdIdentifier ifd) . (ExifShort . fromIntegral) $ ifdOffset ifd
  
    go :: ImageFileDirectory -> Metadatas
    go ifd = case (ifdIdentifier ifd, ifdExtended ifd) of
      (TagArtist, ExifString v) -> strMeta Met.Author v
      (TagBitsPerSample, _) -> mempty
      (TagColorMap, _) -> mempty
      (TagCompression, _) -> mempty
      (TagCopyright, ExifString v) -> strMeta Met.Copyright v
      (TagDocumentName, ExifString v) -> strMeta Met.Title v
      (TagExifOffset, ExifIFD lst) -> F.foldl' inserter mempty lst
      (TagImageDescription, ExifString v) -> strMeta Met.Description v
      (TagImageLength, _) -> Met.singleton Met.Height . fromIntegral $ ifdOffset ifd
      (TagImageWidth, _) -> Met.singleton Met.Width . fromIntegral $ ifdOffset ifd
      (TagJPEGACTables, _) -> mempty
      (TagJPEGDCTables, _) -> mempty
      (TagJPEGInterchangeFormat, _) -> mempty
      (TagJPEGInterchangeFormatLength, _) -> mempty
      (TagJPEGLosslessPredictors, _) -> mempty
      (TagJPEGPointTransforms, _) -> mempty
      (TagJPEGQTables, _) -> mempty
      (TagJPEGRestartInterval, _) -> mempty
      (TagJpegProc, _) -> mempty
      (TagModel, v) -> Met.singleton (Met.Exif TagModel) v
      (TagMake, v) -> Met.singleton (Met.Exif TagMake) v
      (TagOrientation, _) -> exifShort ifd
      (TagResolutionUnit, _) -> mempty
      (TagRowPerStrip, _) -> mempty
      (TagSamplesPerPixel, _) -> mempty
      (TagSoftware, ExifString v) -> strMeta Met.Software v
      (TagStripByteCounts, _) -> mempty
      (TagStripOffsets, _) -> mempty
      (TagTileByteCount, _) -> mempty
      (TagTileLength, _) -> mempty
      (TagTileOffset, _) -> mempty
      (TagTileWidth, _) -> mempty
      (TagUnknown _, _) -> exif ifd
      (TagXResolution, _) -> mempty
      (TagYCbCrCoeff, _) -> mempty
      (TagYCbCrPositioning, _) -> mempty
      (TagYCbCrSubsampling, _) -> mempty
      (TagYResolution, _) -> mempty
      _ -> mempty
  
  byTag :: ExifTag -> ImageFileDirectory -> Bool
  byTag t ifd = ifdIdentifier ifd == t
  
  data TiffResolutionUnit
    = ResolutionUnitUnknown
    | ResolutionUnitInch
    | ResolutionUnitCentimeter
  
  unitOfIfd :: ImageFileDirectory -> TiffResolutionUnit
  unitOfIfd ifd = case (ifdType ifd, ifdOffset ifd) of
    (TypeShort, 1) -> ResolutionUnitUnknown
    (TypeShort, 2) -> ResolutionUnitInch
    (TypeShort, 3) -> ResolutionUnitCentimeter
    _ -> ResolutionUnitUnknown
  
  extractTiffDpiMetadata :: [ImageFileDirectory] -> Metadatas
  extractTiffDpiMetadata lst = go where
    go = case unitOfIfd <$> find (byTag TagResolutionUnit) lst of
      Nothing -> mempty
      Just ResolutionUnitUnknown -> mempty
      Just ResolutionUnitCentimeter -> findDpis Met.dotsPerCentiMeterToDotPerInch mempty
      Just ResolutionUnitInch -> findDpis id mempty
  
    findDpis toDpi =
       findDpi Met.DpiX TagXResolution toDpi . findDpi Met.DpiY TagYResolution toDpi
  
    findDpi k tag toDpi metas = case find (byTag tag) lst of
      Nothing -> metas
      Just ImageFileDirectory { ifdExtended = ExifRational num den } ->
        Met.insert k (toDpi . fromIntegral $ num `div` den) metas
      Just _ -> metas
  
  extractTiffMetadata :: [ImageFileDirectory] -> Metadatas
  extractTiffMetadata lst = extractTiffDpiMetadata lst <> extractTiffStringMetadata lst
  
  