{-# 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
exifOffsetIfd = $WImageFileDirectory :: ExifTag
-> IfdType -> Word32 -> Word32 -> ExifData -> ImageFileDirectory
ImageFileDirectory
  { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
TagExifOffset
  , ifdCount :: Word32
ifdCount = 1
  , ifdType :: IfdType
ifdType = IfdType
TypeLong
  , ifdOffset :: Word32
ifdOffset = 0
  , ifdExtended :: ExifData
ifdExtended = ExifData
ExifNone
  }

typeOfData :: ExifData -> IfdType
typeOfData :: ExifData -> IfdType
typeOfData d :: ExifData
d = case ExifData
d of
  ExifNone -> [Char] -> IfdType
forall a. HasCallStack => [Char] -> a
error "Impossible - typeOfData : ExifNone"
  ExifIFD _exifs :: [(ExifTag, ExifData)]
_exifs -> [Char] -> IfdType
forall a. HasCallStack => [Char] -> a
error "Impossible - typeOfData : ExifIFD"
  ExifLong _l :: Word32
_l -> IfdType
TypeLong
  ExifLongs _l :: Vector Word32
_l -> IfdType
TypeLong
  ExifShort _s :: Word16
_s -> IfdType
TypeShort
  ExifShorts _s :: Vector Word16
_s -> IfdType
TypeShort
  ExifString _str :: ByteString
_str -> IfdType
TypeAscii
  ExifUndefined _undef :: ByteString
_undef -> IfdType
TypeUndefined
  ExifRational _r1 :: Word32
_r1 _r2 :: Word32
_r2 -> IfdType
TypeRational
  ExifSignedRational _sr1 :: Int32
_sr1 _sr2 :: Int32
_sr2 -> IfdType
TypeSignedRational

makeIfd :: ExifTag -> ExifData -> ImageFileDirectory
makeIfd :: ExifTag -> ExifData -> ImageFileDirectory
makeIfd t :: ExifTag
t (ExifShort v :: Word16
v) = $WImageFileDirectory :: ExifTag
-> IfdType -> Word32 -> Word32 -> ExifData -> ImageFileDirectory
ImageFileDirectory
  { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
  , ifdType :: IfdType
ifdType = IfdType
TypeShort
  , ifdCount :: Word32
ifdCount = 1
  , ifdOffset :: Word32
ifdOffset = Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
v Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 16
  , ifdExtended :: ExifData
ifdExtended = ExifData
ExifNone
  }
makeIfd t :: ExifTag
t (ExifLong v :: Word32
v) = $WImageFileDirectory :: ExifTag
-> IfdType -> Word32 -> Word32 -> ExifData -> ImageFileDirectory
ImageFileDirectory 
  { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
  , ifdType :: IfdType
ifdType = IfdType
TypeLong
  , ifdCount :: Word32
ifdCount = 1
  , ifdOffset :: Word32
ifdOffset = Word32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
v
  , ifdExtended :: ExifData
ifdExtended = ExifData
ExifNone
  }
makeIfd t :: ExifTag
t d :: ExifData
d@(ExifShorts v :: Vector Word16
v)
  | Word32
size Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 2 = $WImageFileDirectory :: ExifTag
-> IfdType -> Word32 -> Word32 -> ExifData -> ImageFileDirectory
ImageFileDirectory
    { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
    , ifdType :: IfdType
ifdType = IfdType
TypeShort
    , ifdCount :: Word32
ifdCount = 2
    , ifdOffset :: Word32
ifdOffset = Word32
combined
    , ifdExtended :: ExifData
ifdExtended = ExifData
ExifNone
    }
  | Bool
otherwise = $WImageFileDirectory :: ExifTag
-> IfdType -> Word32 -> Word32 -> ExifData -> ImageFileDirectory
ImageFileDirectory
    { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
    , ifdType :: IfdType
ifdType = IfdType
TypeShort
    , ifdCount :: Word32
ifdCount = Word32
size
    , ifdOffset :: Word32
ifdOffset = 0
    , ifdExtended :: ExifData
ifdExtended = ExifData
d
    }
  where
    size :: Word32
size = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Vector Word16 -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
F.length Vector Word16
v
    at :: Int -> b
at i :: Int
i = Word16 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> b) -> Word16 -> b
forall a b. (a -> b) -> a -> b
$ Vector Word16
v Vector Word16 -> Int -> Word16
forall (v :: * -> *) a. Vector v a => v a -> Int -> a
V.! Int
i
    combined :: Word32
combined = (Int -> Word32
forall b. Num b => Int -> b
at 0  Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Int -> Word32
forall b. Num b => Int -> b
at 1
makeIfd t :: ExifTag
t d :: ExifData
d@(ExifLongs v :: Vector Word32
v)
  | Word32
size Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = $WImageFileDirectory :: ExifTag
-> IfdType -> Word32 -> Word32 -> ExifData -> ImageFileDirectory
ImageFileDirectory
    { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
    , ifdType :: IfdType
ifdType = IfdType
TypeLong
    , ifdCount :: Word32
ifdCount = 1
    , ifdOffset :: Word32
ifdOffset = Vector Word32
v Vector Word32 -> Int -> Word32
forall (v :: * -> *) a. Vector v a => v a -> Int -> a
V.! 0
    , ifdExtended :: ExifData
ifdExtended = ExifData
ExifNone
    }
  | Bool
otherwise = $WImageFileDirectory :: ExifTag
-> IfdType -> Word32 -> Word32 -> ExifData -> ImageFileDirectory
ImageFileDirectory
    { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
    , ifdType :: IfdType
ifdType = IfdType
TypeLong
    , ifdCount :: Word32
ifdCount = Word32
size
    , ifdOffset :: Word32
ifdOffset = 0
    , ifdExtended :: ExifData
ifdExtended = ExifData
d
    }
  where size :: Word32
size = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Vector Word32 -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
F.length Vector Word32
v
makeIfd t :: ExifTag
t s :: ExifData
s@(ExifString str :: ByteString
str) = $WImageFileDirectory :: ExifTag
-> IfdType -> Word32 -> Word32 -> ExifData -> ImageFileDirectory
ImageFileDirectory
    { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
    , ifdType :: IfdType
ifdType = IfdType
TypeAscii
    , ifdCount :: Word32
ifdCount = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BC.length ByteString
str
    , ifdOffset :: Word32
ifdOffset = 0
    , ifdExtended :: ExifData
ifdExtended = ExifData
s
    }
makeIfd t :: ExifTag
t s :: ExifData
s@(ExifUndefined str :: ByteString
str)
  | Word32
size Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> 4 = $WImageFileDirectory :: ExifTag
-> IfdType -> Word32 -> Word32 -> ExifData -> ImageFileDirectory
ImageFileDirectory
    { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
    , ifdType :: IfdType
ifdType = IfdType
TypeUndefined
    , ifdCount :: Word32
ifdCount = Word32
size
    , ifdOffset :: Word32
ifdOffset = 0
    , ifdExtended :: ExifData
ifdExtended = ExifData
s
    }
  | Bool
otherwise = $WImageFileDirectory :: ExifTag
-> IfdType -> Word32 -> Word32 -> ExifData -> ImageFileDirectory
ImageFileDirectory
    { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
    , ifdType :: IfdType
ifdType = IfdType
TypeUndefined
    , ifdCount :: Word32
ifdCount = Word32
size
    , ifdOffset :: Word32
ifdOffset = Word32
ofs
    , ifdExtended :: ExifData
ifdExtended = ExifData
ExifNone
    }
  where
    size :: Word32
size = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BC.length ByteString
str
    at :: Int -> p
at ix :: Int
ix
      | Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ix Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
size = Word8 -> p
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> p) -> Word8 -> p
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> Word8
B.index ByteString
str Int
ix Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftL` (4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- (8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
ix))
      | Bool
otherwise = 0
    ofs :: Word32
ofs = Int -> Word32
forall b. Num b => Int -> b
at 0 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Int -> Word32
forall b. Num b => Int -> b
at 1 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Int -> Word32
forall b. Num b => Int -> b
at 2 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Int -> Word32
forall b. Num b => Int -> b
at 3
makeIfd t :: ExifTag
t d :: ExifData
d = $WImageFileDirectory :: ExifTag
-> IfdType -> Word32 -> Word32 -> ExifData -> ImageFileDirectory
ImageFileDirectory
  { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
t
  , ifdType :: IfdType
ifdType = ExifData -> IfdType
typeOfData ExifData
d
  , ifdCount :: Word32
ifdCount = 1
  , ifdOffset :: Word32
ifdOffset = 0
  , ifdExtended :: ExifData
ifdExtended = ExifData
d
  }

encodeTiffStringMetadata :: Metadatas -> [ImageFileDirectory]
encodeTiffStringMetadata :: Metadatas -> [ImageFileDirectory]
encodeTiffStringMetadata metas :: Metadatas
metas = (ImageFileDirectory -> ImageFileDirectory -> Ordering)
-> [ImageFileDirectory] -> [ImageFileDirectory]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Word16 -> Word16 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Word16 -> Word16 -> Ordering)
-> (ImageFileDirectory -> Word16)
-> ImageFileDirectory
-> ImageFileDirectory
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ExifTag -> Word16
word16OfTag (ExifTag -> Word16)
-> (ImageFileDirectory -> ExifTag) -> ImageFileDirectory -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImageFileDirectory -> ExifTag
ifdIdentifier) ([ImageFileDirectory] -> [ImageFileDirectory])
-> [ImageFileDirectory] -> [ImageFileDirectory]
forall a b. (a -> b) -> a -> b
$ [ImageFileDirectory]
allTags where
  keyStr :: ExifTag -> Keys [Char] -> f ImageFileDirectory
keyStr tag :: ExifTag
tag k :: Keys [Char]
k = case Keys [Char] -> Metadatas -> Maybe [Char]
forall a. Keys a -> Metadatas -> Maybe a
Met.lookup Keys [Char]
k Metadatas
metas of
    Nothing -> f ImageFileDirectory
forall a. Monoid a => a
mempty
    Just v :: [Char]
v -> ImageFileDirectory -> f ImageFileDirectory
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ImageFileDirectory -> f ImageFileDirectory)
-> (ByteString -> ImageFileDirectory)
-> ByteString
-> f ImageFileDirectory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExifTag -> ExifData -> ImageFileDirectory
makeIfd ExifTag
tag (ExifData -> ImageFileDirectory)
-> (ByteString -> ExifData) -> ByteString -> ImageFileDirectory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ExifData
ExifString (ByteString -> f ImageFileDirectory)
-> ByteString -> f ImageFileDirectory
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
BC.pack [Char]
v
  allTags :: [ImageFileDirectory]
allTags = [ImageFileDirectory]
copyright [ImageFileDirectory]
-> [ImageFileDirectory] -> [ImageFileDirectory]
forall a. Semigroup a => a -> a -> a
<> [ImageFileDirectory]
artist [ImageFileDirectory]
-> [ImageFileDirectory] -> [ImageFileDirectory]
forall a. Semigroup a => a -> a -> a
<> [ImageFileDirectory]
title [ImageFileDirectory]
-> [ImageFileDirectory] -> [ImageFileDirectory]
forall a. Semigroup a => a -> a -> a
<> [ImageFileDirectory]
description [ImageFileDirectory]
-> [ImageFileDirectory] -> [ImageFileDirectory]
forall a. Semigroup a => a -> a -> a
<> [ImageFileDirectory]
software [ImageFileDirectory]
-> [ImageFileDirectory] -> [ImageFileDirectory]
forall a. Semigroup a => a -> a -> a
<> [ImageFileDirectory]
allPureExif

  allPureExif :: [ImageFileDirectory]
allPureExif = ((ExifTag, ExifData) -> ImageFileDirectory)
-> [(ExifTag, ExifData)] -> [ImageFileDirectory]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ExifTag -> ExifData -> ImageFileDirectory)
-> (ExifTag, ExifData) -> ImageFileDirectory
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ExifTag -> ExifData -> ImageFileDirectory
makeIfd) ([(ExifTag, ExifData)] -> [ImageFileDirectory])
-> [(ExifTag, ExifData)] -> [ImageFileDirectory]
forall a b. (a -> b) -> a -> b
$ Metadatas -> [(ExifTag, ExifData)]
extractExifMetas Metadatas
metas

  copyright :: [ImageFileDirectory]
copyright = ExifTag -> Keys [Char] -> [ImageFileDirectory]
forall (f :: * -> *).
(Monoid (f ImageFileDirectory), Applicative f) =>
ExifTag -> Keys [Char] -> f ImageFileDirectory
keyStr ExifTag
TagCopyright Keys [Char]
Met.Copyright
  artist :: [ImageFileDirectory]
artist = ExifTag -> Keys [Char] -> [ImageFileDirectory]
forall (f :: * -> *).
(Monoid (f ImageFileDirectory), Applicative f) =>
ExifTag -> Keys [Char] -> f ImageFileDirectory
keyStr ExifTag
TagArtist Keys [Char]
Met.Author
  title :: [ImageFileDirectory]
title = ExifTag -> Keys [Char] -> [ImageFileDirectory]
forall (f :: * -> *).
(Monoid (f ImageFileDirectory), Applicative f) =>
ExifTag -> Keys [Char] -> f ImageFileDirectory
keyStr ExifTag
TagDocumentName Keys [Char]
Met.Title
  description :: [ImageFileDirectory]
description = ExifTag -> Keys [Char] -> [ImageFileDirectory]
forall (f :: * -> *).
(Monoid (f ImageFileDirectory), Applicative f) =>
ExifTag -> Keys [Char] -> f ImageFileDirectory
keyStr ExifTag
TagImageDescription Keys [Char]
Met.Description
  software :: [ImageFileDirectory]
software = ExifTag -> Keys [Char] -> [ImageFileDirectory]
forall (f :: * -> *).
(Monoid (f ImageFileDirectory), Applicative f) =>
ExifTag -> Keys [Char] -> f ImageFileDirectory
keyStr ExifTag
TagSoftware Keys [Char]
Met.Software

extractTiffStringMetadata :: [ImageFileDirectory] -> Metadatas
extractTiffStringMetadata :: [ImageFileDirectory] -> Metadatas
extractTiffStringMetadata = Keys SourceFormat -> SourceFormat -> Metadatas -> Metadatas
forall a.
(Show a, NFData a) =>
Keys a -> a -> Metadatas -> Metadatas
Met.insert Keys SourceFormat
Met.Format SourceFormat
Met.SourceTiff (Metadatas -> Metadatas)
-> ([ImageFileDirectory] -> Metadatas)
-> [ImageFileDirectory]
-> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImageFileDirectory -> Metadatas)
-> [ImageFileDirectory] -> Metadatas
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ImageFileDirectory -> Metadatas
go where
  strMeta :: Keys [Char] -> ByteString -> Metadatas
strMeta k :: Keys [Char]
k = Keys [Char] -> [Char] -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton Keys [Char]
k ([Char] -> Metadatas)
-> (ByteString -> [Char]) -> ByteString -> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
BC.unpack
  exif :: ImageFileDirectory -> Metadatas
exif ifd :: ImageFileDirectory
ifd =
    Keys ExifData -> ExifData -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton (ExifTag -> Keys ExifData
Met.Exif (ExifTag -> Keys ExifData) -> ExifTag -> Keys ExifData
forall a b. (a -> b) -> a -> b
$ ImageFileDirectory -> ExifTag
ifdIdentifier ImageFileDirectory
ifd) (ExifData -> Metadatas) -> ExifData -> Metadatas
forall a b. (a -> b) -> a -> b
$ ImageFileDirectory -> ExifData
ifdExtended ImageFileDirectory
ifd
  inserter :: Metadatas -> (ExifTag, ExifData) -> Metadatas
inserter acc :: Metadatas
acc (k :: ExifTag
k, v :: ExifData
v) = Keys ExifData -> ExifData -> Metadatas -> Metadatas
forall a.
(Show a, NFData a) =>
Keys a -> a -> Metadatas -> Metadatas
Met.insert (ExifTag -> Keys ExifData
Met.Exif ExifTag
k) ExifData
v Metadatas
acc
  exifShort :: ImageFileDirectory -> Metadatas
exifShort ifd :: ImageFileDirectory
ifd =
    Keys ExifData -> ExifData -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton (ExifTag -> Keys ExifData
Met.Exif (ExifTag -> Keys ExifData) -> ExifTag -> Keys ExifData
forall a b. (a -> b) -> a -> b
$ ImageFileDirectory -> ExifTag
ifdIdentifier ImageFileDirectory
ifd) (ExifData -> Metadatas)
-> (Word32 -> ExifData) -> Word32 -> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word16 -> ExifData
ExifShort (Word16 -> ExifData) -> (Word32 -> Word16) -> Word32 -> ExifData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Word32 -> Metadatas) -> Word32 -> Metadatas
forall a b. (a -> b) -> a -> b
$ ImageFileDirectory -> Word32
ifdOffset ImageFileDirectory
ifd

  go :: ImageFileDirectory -> Metadatas
  go :: ImageFileDirectory -> Metadatas
go ifd :: ImageFileDirectory
ifd = case (ImageFileDirectory -> ExifTag
ifdIdentifier ImageFileDirectory
ifd, ImageFileDirectory -> ExifData
ifdExtended ImageFileDirectory
ifd) of
    (TagArtist, ExifString v :: ByteString
v) -> Keys [Char] -> ByteString -> Metadatas
strMeta Keys [Char]
Met.Author ByteString
v
    (TagBitsPerSample, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagColorMap, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagCompression, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagCopyright, ExifString v :: ByteString
v) -> Keys [Char] -> ByteString -> Metadatas
strMeta Keys [Char]
Met.Copyright ByteString
v
    (TagDocumentName, ExifString v :: ByteString
v) -> Keys [Char] -> ByteString -> Metadatas
strMeta Keys [Char]
Met.Title ByteString
v
    (TagExifOffset, ExifIFD lst :: [(ExifTag, ExifData)]
lst) -> (Metadatas -> (ExifTag, ExifData) -> Metadatas)
-> Metadatas -> [(ExifTag, ExifData)] -> Metadatas
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' Metadatas -> (ExifTag, ExifData) -> Metadatas
inserter Metadatas
forall a. Monoid a => a
mempty [(ExifTag, ExifData)]
lst
    (TagImageDescription, ExifString v :: ByteString
v) -> Keys [Char] -> ByteString -> Metadatas
strMeta Keys [Char]
Met.Description ByteString
v
    (TagImageLength, _) -> Keys Word -> Word -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton Keys Word
Met.Height (Word -> Metadatas) -> (Word32 -> Word) -> Word32 -> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Metadatas) -> Word32 -> Metadatas
forall a b. (a -> b) -> a -> b
$ ImageFileDirectory -> Word32
ifdOffset ImageFileDirectory
ifd
    (TagImageWidth, _) -> Keys Word -> Word -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton Keys Word
Met.Width (Word -> Metadatas) -> (Word32 -> Word) -> Word32 -> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Metadatas) -> Word32 -> Metadatas
forall a b. (a -> b) -> a -> b
$ ImageFileDirectory -> Word32
ifdOffset ImageFileDirectory
ifd
    (TagJPEGACTables, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagJPEGDCTables, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagJPEGInterchangeFormat, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagJPEGInterchangeFormatLength, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagJPEGLosslessPredictors, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagJPEGPointTransforms, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagJPEGQTables, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagJPEGRestartInterval, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagJpegProc, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagModel, v :: ExifData
v) -> Keys ExifData -> ExifData -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton (ExifTag -> Keys ExifData
Met.Exif ExifTag
TagModel) ExifData
v
    (TagMake, v :: ExifData
v) -> Keys ExifData -> ExifData -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton (ExifTag -> Keys ExifData
Met.Exif ExifTag
TagMake) ExifData
v
    (TagOrientation, _) -> ImageFileDirectory -> Metadatas
exifShort ImageFileDirectory
ifd
    (TagResolutionUnit, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagRowPerStrip, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagSamplesPerPixel, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagSoftware, ExifString v :: ByteString
v) -> Keys [Char] -> ByteString -> Metadatas
strMeta Keys [Char]
Met.Software ByteString
v
    (TagStripByteCounts, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagStripOffsets, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagTileByteCount, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagTileLength, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagTileOffset, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagTileWidth, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagUnknown _, _) -> ImageFileDirectory -> Metadatas
exif ImageFileDirectory
ifd
    (TagXResolution, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagYCbCrCoeff, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagYCbCrPositioning, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagYCbCrSubsampling, _) -> Metadatas
forall a. Monoid a => a
mempty
    (TagYResolution, _) -> Metadatas
forall a. Monoid a => a
mempty
    _ -> Metadatas
forall a. Monoid a => a
mempty

byTag :: ExifTag -> ImageFileDirectory -> Bool
byTag :: ExifTag -> ImageFileDirectory -> Bool
byTag t :: ExifTag
t ifd :: ImageFileDirectory
ifd = ImageFileDirectory -> ExifTag
ifdIdentifier ImageFileDirectory
ifd ExifTag -> ExifTag -> Bool
forall a. Eq a => a -> a -> Bool
== ExifTag
t

data TiffResolutionUnit
  = ResolutionUnitUnknown
  | ResolutionUnitInch
  | ResolutionUnitCentimeter

unitOfIfd :: ImageFileDirectory -> TiffResolutionUnit
unitOfIfd :: ImageFileDirectory -> TiffResolutionUnit
unitOfIfd ifd :: ImageFileDirectory
ifd = case (ImageFileDirectory -> IfdType
ifdType ImageFileDirectory
ifd, ImageFileDirectory -> Word32
ifdOffset ImageFileDirectory
ifd) of
  (TypeShort, 1) -> TiffResolutionUnit
ResolutionUnitUnknown
  (TypeShort, 2) -> TiffResolutionUnit
ResolutionUnitInch
  (TypeShort, 3) -> TiffResolutionUnit
ResolutionUnitCentimeter
  _ -> TiffResolutionUnit
ResolutionUnitUnknown

extractTiffDpiMetadata :: [ImageFileDirectory] -> Metadatas
extractTiffDpiMetadata :: [ImageFileDirectory] -> Metadatas
extractTiffDpiMetadata lst :: [ImageFileDirectory]
lst = Metadatas
go where
  go :: Metadatas
go = case ImageFileDirectory -> TiffResolutionUnit
unitOfIfd (ImageFileDirectory -> TiffResolutionUnit)
-> Maybe ImageFileDirectory -> Maybe TiffResolutionUnit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ImageFileDirectory -> Bool)
-> [ImageFileDirectory] -> Maybe ImageFileDirectory
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (ExifTag -> ImageFileDirectory -> Bool
byTag ExifTag
TagResolutionUnit) [ImageFileDirectory]
lst of
    Nothing -> Metadatas
forall a. Monoid a => a
mempty
    Just ResolutionUnitUnknown -> Metadatas
forall a. Monoid a => a
mempty
    Just ResolutionUnitCentimeter -> (Word -> Word) -> Metadatas -> Metadatas
forall b. Num b => (b -> Word) -> Metadatas -> Metadatas
findDpis Word -> Word
Met.dotsPerCentiMeterToDotPerInch Metadatas
forall a. Monoid a => a
mempty
    Just ResolutionUnitInch -> (Word -> Word) -> Metadatas -> Metadatas
forall b. Num b => (b -> Word) -> Metadatas -> Metadatas
findDpis Word -> Word
forall a. a -> a
id Metadatas
forall a. Monoid a => a
mempty

  findDpis :: (b -> Word) -> Metadatas -> Metadatas
findDpis toDpi :: b -> Word
toDpi =
     Keys Word -> ExifTag -> (b -> Word) -> Metadatas -> Metadatas
forall a b.
(Show a, NFData a, Num b) =>
Keys a -> ExifTag -> (b -> a) -> Metadatas -> Metadatas
findDpi Keys Word
Met.DpiX ExifTag
TagXResolution b -> Word
toDpi (Metadatas -> Metadatas)
-> (Metadatas -> Metadatas) -> Metadatas -> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Keys Word -> ExifTag -> (b -> Word) -> Metadatas -> Metadatas
forall a b.
(Show a, NFData a, Num b) =>
Keys a -> ExifTag -> (b -> a) -> Metadatas -> Metadatas
findDpi Keys Word
Met.DpiY ExifTag
TagYResolution b -> Word
toDpi

  findDpi :: Keys a -> ExifTag -> (b -> a) -> Metadatas -> Metadatas
findDpi k :: Keys a
k tag :: ExifTag
tag toDpi :: b -> a
toDpi metas :: Metadatas
metas = case (ImageFileDirectory -> Bool)
-> [ImageFileDirectory] -> Maybe ImageFileDirectory
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (ExifTag -> ImageFileDirectory -> Bool
byTag ExifTag
tag) [ImageFileDirectory]
lst of
    Nothing -> Metadatas
metas
    Just ImageFileDirectory { ifdExtended :: ImageFileDirectory -> ExifData
ifdExtended = ExifRational num :: Word32
num den :: Word32
den } ->
      Keys a -> a -> Metadatas -> Metadatas
forall a.
(Show a, NFData a) =>
Keys a -> a -> Metadatas -> Metadatas
Met.insert Keys a
k (b -> a
toDpi (b -> a) -> (Word32 -> b) -> Word32 -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> a) -> Word32 -> a
forall a b. (a -> b) -> a -> b
$ Word32
num Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` Word32
den) Metadatas
metas
    Just _ -> Metadatas
metas

extractTiffMetadata :: [ImageFileDirectory] -> Metadatas
extractTiffMetadata :: [ImageFileDirectory] -> Metadatas
extractTiffMetadata lst :: [ImageFileDirectory]
lst = [ImageFileDirectory] -> Metadatas
extractTiffDpiMetadata [ImageFileDirectory]
lst Metadatas -> Metadatas -> Metadatas
forall a. Semigroup a => a -> a -> a
<> [ImageFileDirectory] -> Metadatas
extractTiffStringMetadata [ImageFileDirectory]
lst