Metadata.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
-- | This module expose a common "metadata" storage for various image
-- type. Different format can generate different metadatas, and write
-- only a part of them.
--
-- Since version 3.2.5
--
module Codec.Picture.Metadata( -- * Types
                               Metadatas
                             , Keys( .. )
                             , Value( .. )
                             , Elem( .. )
                             , SourceFormat( .. )
                             , ColorSpace( .. )

                               -- * Functions
                             , Codec.Picture.Metadata.lookup
                             , empty
                             , insert
                             , delete
                             , singleton

                               -- * Folding
                             , foldl'
                             , Codec.Picture.Metadata.foldMap

                              -- * Helper functions
                             , mkDpiMetadata
                             , mkSizeMetadata
                             , basicMetadata
                             , simpleMetadata
                             , extractExifMetas

                               -- * Conversion functions
                             , dotsPerMeterToDotPerInch
                             , dotPerInchToDotsPerMeter 
                             , dotsPerCentiMeterToDotPerInch
                             ) where

import Prelude hiding (Foldable(..))

#if !MIN_VERSION_base(4,8,0)
import Data.Monoid( Monoid, mempty, mappend )
import Data.Word( Word )
#endif


import Control.DeepSeq( NFData( .. ) )
import qualified Data.ByteString as B
import qualified Data.Foldable as F

import Codec.Picture.Metadata.Exif

#if MIN_VERSION_base(4,7,0)
import Data.Typeable( (:~:)( Refl ) )
type Equiv = (:~:)
#else
data Equiv a b where
    Refl :: Equiv a a
#endif

-- | Type describing the original file format of the file.
data SourceFormat
  = SourceJpeg
  | SourceGif
  | SourceBitmap
  | SourceTiff
  | SourcePng
  | SourceHDR
  | SourceTGA
  deriving (Eq, Show)

instance NFData SourceFormat where
  rnf a = a `seq` ()

-- | The same color values may result in slightly different colors on different
-- devices. To get consistent colors across multiple devices we need a way of
-- mapping color values from a source device into their equivalents on the
-- target device.
--
-- The solution is essentially to define, for each device, a family of mappings
-- that convert between device colors and standard CIEXYZ or CIELAB colors. The
-- collection of mappings for a device is known as the 'color-profile' of that
-- device, and each color-profile can be thought of as describing a
-- 'color-space'.
--
-- If we know the color-space of the input pixels, and the color space of the
-- output device, then we can convert the colors in the image to their
-- equivalents on the output device.
--
-- JuicyPixels does not parse color-profiles or attempt to perform color
-- correction.
--
-- The following color space types are recognised:
--
--   * sRGB: Standard RGB color space.
--   * Windows BMP color space: Color space information embedded within a V4
--         Windows BMP file.
--   * ICC profile: An ICC color profile.
data ColorSpace = SRGB
                | WindowsBitmapColorSpace !B.ByteString
                | ICCProfile !B.ByteString
                deriving (Eq, Show)

instance NFData ColorSpace where
  rnf v = v `seq` ()

-- | Store various additional information about an image. If
-- something is not recognized, it can be stored in an unknown tag.
--
--   * 'DpiX' Dot per inch on this x axis.
--
--   * 'DpiY' Dot per inch on this y axis.
--
--   * 'Width' Image width in pixel. Relying on the metadata for this
--          information can avoid the full decompression of the image.
--          Ignored for image writing.
--
--   * 'Height' Image height in pixels. Relying on the metadata for this
--          information can void the full decompression of the image.
--          Ignored for image writing.
--
--   * 'ColorProfile' An unparsed ICC color profile. Currently only supported by
--          the Bitmap format.
--
--   * 'Unknown' unlikely to be decoded, but useful for metadata writing
--
--   * 'Exif' Exif tag and associated data.
--
data Keys a where
  Gamma       :: Keys Double
  ColorSpace  :: Keys ColorSpace
  Format      :: Keys SourceFormat
  DpiX        :: Keys Word
  DpiY        :: Keys Word
  Width       :: Keys Word
  Height      :: Keys Word
  Title       :: Keys String
  Description :: Keys String
  Author      :: Keys String
  Copyright   :: Keys String
  Software    :: Keys String
  Comment     :: Keys String
  Disclaimer  :: Keys String
  Source      :: Keys String
  Warning     :: Keys String
  Exif        :: !ExifTag -> Keys ExifData
  Unknown     :: !String -> Keys Value

deriving instance Show (Keys a)
deriving instance Eq (Keys a)
{-deriving instance Ord (Keys a)-}

-- | Encode values for unknown information
data Value
  = Int    !Int
  | Double !Double
  | String !String
  deriving (Eq, Show)

instance NFData Value where
  rnf v = v `seq` () -- everything is strict, so it's OK

-- | Element describing a metadata and it's (typed) associated
-- value.
data Elem k =
  forall a. (Show a, NFData a) => !(k a) :=> a

deriving instance Show (Elem Keys)

instance NFData (Elem Keys) where
  rnf (_ :=> v) = rnf v `seq` ()

keyEq :: Keys a -> Keys b -> Maybe (Equiv a b)
keyEq a b = case (a, b) of
  (Gamma, Gamma) -> Just Refl
  (ColorSpace, ColorSpace) -> Just Refl
  (DpiX, DpiX) -> Just Refl
  (DpiY, DpiY) -> Just Refl
  (Width, Width) -> Just Refl
  (Height, Height) -> Just Refl
  (Title, Title) -> Just Refl
  (Description, Description) -> Just Refl
  (Author, Author) -> Just Refl
  (Copyright, Copyright) -> Just Refl
  (Software, Software) -> Just Refl
  (Comment, Comment) -> Just Refl
  (Disclaimer, Disclaimer) -> Just Refl
  (Source, Source) -> Just Refl
  (Warning, Warning) -> Just Refl
  (Format, Format) -> Just Refl
  (Unknown v1, Unknown v2) | v1 == v2 -> Just Refl
  (Exif t1, Exif t2) | t1 == t2 -> Just Refl
  _ -> Nothing

-- | Dependent storage used for metadatas.
-- All metadatas of a given kind are unique within
-- this container.
    --
-- The current data structure is based on list,
-- so bad performances can be expected.
newtype Metadatas = Metadatas
  { getMetadatas :: [Elem Keys]
  }
  deriving (Show, NFData)

instance Monoid Metadatas where
  mempty = empty
#if !MIN_VERSION_base(4,11,0)
  mappend = union
#else
instance Semigroup Metadatas where
  (<>) = union
#endif

-- | Right based union
union :: Metadatas -> Metadatas -> Metadatas
union m1 = F.foldl' go m1 . getMetadatas where
  go acc el@(k :=> _) = Metadatas $ el : getMetadatas (delete k acc)

-- | Strict left fold of the metadatas
foldl' :: (acc -> Elem Keys -> acc) -> acc -> Metadatas -> acc
foldl' f initAcc = F.foldl' f initAcc . getMetadatas

-- | foldMap equivalent for metadatas.
foldMap :: Monoid m => (Elem Keys -> m) -> Metadatas -> m
foldMap f = foldl' (\acc v -> acc `mappend` f v) mempty

-- | Remove an element of the given keys from the metadatas.
-- If not present does nothing.
delete :: Keys a -> Metadatas -> Metadatas
delete k = Metadatas . go . getMetadatas where
  go [] = []
  go (el@(k2 :=> _) : rest) = case keyEq k k2 of
    Nothing -> el : go rest
    Just Refl -> rest

-- | Extract all Exif specific metadatas
extractExifMetas :: Metadatas -> [(ExifTag, ExifData)]
extractExifMetas = go . getMetadatas where
  go :: [Elem Keys] -> [(ExifTag, ExifData)]
  go [] = []
  go ((k :=> v) : rest) =
    case k of
      Exif t -> (t, v) : go rest
      _ -> go rest

-- | Search a metadata with the given key.
lookup :: Keys a -> Metadatas -> Maybe a
lookup k = go . getMetadatas where
  go [] = Nothing
  go ((k2 :=> v) : rest) = case keyEq k k2 of
    Nothing -> go rest
    Just Refl -> Just v

-- | Insert an element in the metadatas, if an element with
-- the same key is present, it is overwritten.
insert :: (Show a, NFData a) => Keys a -> a -> Metadatas -> Metadatas
insert k val metas =
  Metadatas $ (k :=> val) : getMetadatas (delete k metas)

-- | Create metadatas with a single element.
singleton :: (Show a, NFData a) => Keys a -> a -> Metadatas
singleton k val = Metadatas [k :=> val]

-- | Empty metadatas. Favor 'mempty'
empty :: Metadatas
empty = Metadatas mempty

-- | Conversion from dpm to dpi
dotsPerMeterToDotPerInch :: Word -> Word
dotsPerMeterToDotPerInch z = z * 254 `div` 10000

-- | Conversion from dpi to dpm
dotPerInchToDotsPerMeter :: Word -> Word
dotPerInchToDotsPerMeter z = (z * 10000) `div` 254

-- | Conversion dpcm -> dpi
dotsPerCentiMeterToDotPerInch :: Word -> Word
dotsPerCentiMeterToDotPerInch z = z * 254 `div` 100

-- | Create metadatas indicating the resolution, with DpiX == DpiY
mkDpiMetadata :: Word -> Metadatas
mkDpiMetadata w =
  Metadatas [DpiY :=> w, DpiX :=> w]

-- | Create metadatas holding width and height information.
mkSizeMetadata :: Integral n => n -> n -> Metadatas
mkSizeMetadata w h = 
  Metadatas [ Width :=> fromIntegral w, Height :=> fromIntegral h ]

-- | Create simple metadatas with Format, Width & Height
basicMetadata :: Integral nSize => SourceFormat -> nSize -> nSize -> Metadatas
basicMetadata f w h =
  Metadatas [ Format :=> f
            , Width :=> fromIntegral w
            , Height :=> fromIntegral h
            ]

-- | Create simple metadatas with Format, Width, Height, DpiX & DpiY
simpleMetadata :: (Integral nSize, Integral nDpi)
               => SourceFormat -> nSize -> nSize -> nDpi -> nDpi -> Metadatas
simpleMetadata f w h dpiX dpiY =
  Metadatas [ Format :=> f
            , Width :=> fromIntegral w
            , Height :=> fromIntegral h
            , DpiX :=> fromIntegral dpiX
            , DpiY :=> fromIntegral dpiY
            ]