    {-# 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