{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
module Codec.Picture.Metadata(
Metadatas
, Keys( .. )
, Value( .. )
, Elem( .. )
, SourceFormat( .. )
, ColorSpace( .. )
, Codec.Picture.Metadata.lookup
, empty
, insert
, delete
, singleton
, foldl'
, Codec.Picture.Metadata.foldMap
, mkDpiMetadata
, mkSizeMetadata
, basicMetadata
, simpleMetadata
, extractExifMetas
, dotsPerMeterToDotPerInch
, dotPerInchToDotsPerMeter
, dotsPerCentiMeterToDotPerInch
) where
#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
data SourceFormat
= SourceJpeg
| SourceGif
| SourceBitmap
| SourceTiff
| SourcePng
| SourceHDR
| SourceTGA
deriving (SourceFormat -> SourceFormat -> Bool
(SourceFormat -> SourceFormat -> Bool)
-> (SourceFormat -> SourceFormat -> Bool) -> Eq SourceFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SourceFormat -> SourceFormat -> Bool
$c/= :: SourceFormat -> SourceFormat -> Bool
== :: SourceFormat -> SourceFormat -> Bool
$c== :: SourceFormat -> SourceFormat -> Bool
Eq, Int -> SourceFormat -> ShowS
[SourceFormat] -> ShowS
SourceFormat -> String
(Int -> SourceFormat -> ShowS)
-> (SourceFormat -> String)
-> ([SourceFormat] -> ShowS)
-> Show SourceFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SourceFormat] -> ShowS
$cshowList :: [SourceFormat] -> ShowS
show :: SourceFormat -> String
$cshow :: SourceFormat -> String
showsPrec :: Int -> SourceFormat -> ShowS
$cshowsPrec :: Int -> SourceFormat -> ShowS
Show)
instance NFData SourceFormat where
rnf :: SourceFormat -> ()
rnf SourceFormat
a = SourceFormat
a SourceFormat -> () -> ()
`seq` ()
data ColorSpace = SRGB
| WindowsBitmapColorSpace !B.ByteString
| ICCProfile !B.ByteString
deriving (ColorSpace -> ColorSpace -> Bool
(ColorSpace -> ColorSpace -> Bool)
-> (ColorSpace -> ColorSpace -> Bool) -> Eq ColorSpace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ColorSpace -> ColorSpace -> Bool
$c/= :: ColorSpace -> ColorSpace -> Bool
== :: ColorSpace -> ColorSpace -> Bool
$c== :: ColorSpace -> ColorSpace -> Bool
Eq, Int -> ColorSpace -> ShowS
[ColorSpace] -> ShowS
ColorSpace -> String
(Int -> ColorSpace -> ShowS)
-> (ColorSpace -> String)
-> ([ColorSpace] -> ShowS)
-> Show ColorSpace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ColorSpace] -> ShowS
$cshowList :: [ColorSpace] -> ShowS
show :: ColorSpace -> String
$cshow :: ColorSpace -> String
showsPrec :: Int -> ColorSpace -> ShowS
$cshowsPrec :: Int -> ColorSpace -> ShowS
Show)
instance NFData ColorSpace where
rnf :: ColorSpace -> ()
rnf ColorSpace
v = ColorSpace
v ColorSpace -> () -> ()
`seq` ()
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
:: 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)
data Value
= Int !Int
| Double !Double
| String !String
deriving (Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq, Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show)
instance NFData Value where
rnf :: Value -> ()
rnf Value
v = Value
v Value -> () -> ()
`seq` ()
data Elem k =
forall a. (Show a, NFData a) => !(k a) :=> a
deriving instance Show (Elem Keys)
instance NFData (Elem Keys) where
rnf :: Elem Keys -> ()
rnf (Keys a
_ :=> a
v) = a -> ()
forall a. NFData a => a -> ()
rnf a
v () -> () -> ()
`seq` ()
keyEq :: Keys a -> Keys b -> Maybe (Equiv a b)
keyEq :: Keys a -> Keys b -> Maybe (Equiv a b)
keyEq Keys a
a Keys b
b = case (Keys a
a, Keys b
b) of
(Keys a
Gamma, Keys b
Gamma) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Keys a
ColorSpace, Keys b
ColorSpace) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Keys a
DpiX, Keys b
DpiX) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Keys a
DpiY, Keys b
DpiY) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Keys a
Width, Keys b
Width) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Keys a
Height, Keys b
Height) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Keys a
Title, Keys b
Title) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Keys a
Description, Keys b
Description) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Keys a
Author, Keys b
Author) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Keys a
Copyright, Keys b
Copyright) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Keys a
Software, Keys b
Software) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Keys a
Comment, Keys b
Comment) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Keys a
Disclaimer, Keys b
Disclaimer) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Keys a
Source, Keys b
Source) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Keys a
Warning, Keys b
Warning) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Keys a
Format, Keys b
Format) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Unknown String
v1, Unknown String
v2) | String
v1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v2 -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Exif ExifTag
t1, Exif ExifTag
t2) | ExifTag
t1 ExifTag -> ExifTag -> Bool
forall a. Eq a => a -> a -> Bool
== ExifTag
t2 -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Keys a, Keys b)
_ -> Maybe (Equiv a b)
forall a. Maybe a
Nothing
newtype Metadatas = Metadatas
{ Metadatas -> [Elem Keys]
getMetadatas :: [Elem Keys]
}
deriving (Int -> Metadatas -> ShowS
[Metadatas] -> ShowS
Metadatas -> String
(Int -> Metadatas -> ShowS)
-> (Metadatas -> String)
-> ([Metadatas] -> ShowS)
-> Show Metadatas
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Metadatas] -> ShowS
$cshowList :: [Metadatas] -> ShowS
show :: Metadatas -> String
$cshow :: Metadatas -> String
showsPrec :: Int -> Metadatas -> ShowS
$cshowsPrec :: Int -> Metadatas -> ShowS
Show, Metadatas -> ()
(Metadatas -> ()) -> NFData Metadatas
forall a. (a -> ()) -> NFData a
rnf :: Metadatas -> ()
$crnf :: Metadatas -> ()
NFData)
instance Monoid Metadatas where
mempty :: Metadatas
mempty = Metadatas
empty
#if !MIN_VERSION_base(4,11,0)
mappend = union
#else
instance Semigroup Metadatas where
<> :: Metadatas -> Metadatas -> Metadatas
(<>) = Metadatas -> Metadatas -> Metadatas
union
#endif
union :: Metadatas -> Metadatas -> Metadatas
union :: Metadatas -> Metadatas -> Metadatas
union Metadatas
m1 = (Metadatas -> Elem Keys -> Metadatas)
-> Metadatas -> [Elem Keys] -> Metadatas
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' Metadatas -> Elem Keys -> Metadatas
go Metadatas
m1 ([Elem Keys] -> Metadatas)
-> (Metadatas -> [Elem Keys]) -> Metadatas -> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Metadatas -> [Elem Keys]
getMetadatas where
go :: Metadatas -> Elem Keys -> Metadatas
go Metadatas
acc el :: Elem Keys
el@(Keys a
k :=> a
_) = [Elem Keys] -> Metadatas
Metadatas ([Elem Keys] -> Metadatas) -> [Elem Keys] -> Metadatas
forall a b. (a -> b) -> a -> b
$ Elem Keys
el Elem Keys -> [Elem Keys] -> [Elem Keys]
forall a. a -> [a] -> [a]
: Metadatas -> [Elem Keys]
getMetadatas (Keys a -> Metadatas -> Metadatas
forall a. Keys a -> Metadatas -> Metadatas
delete Keys a
k Metadatas
acc)
foldl' :: (acc -> Elem Keys -> acc) -> acc -> Metadatas -> acc
foldl' :: (acc -> Elem Keys -> acc) -> acc -> Metadatas -> acc
foldl' acc -> Elem Keys -> acc
f acc
initAcc = (acc -> Elem Keys -> acc) -> acc -> [Elem Keys] -> acc
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' acc -> Elem Keys -> acc
f acc
initAcc ([Elem Keys] -> acc)
-> (Metadatas -> [Elem Keys]) -> Metadatas -> acc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Metadatas -> [Elem Keys]
getMetadatas
foldMap :: Monoid m => (Elem Keys -> m) -> Metadatas -> m
foldMap :: (Elem Keys -> m) -> Metadatas -> m
foldMap Elem Keys -> m
f = (m -> Elem Keys -> m) -> m -> Metadatas -> m
forall acc. (acc -> Elem Keys -> acc) -> acc -> Metadatas -> acc
foldl' (\m
acc Elem Keys
v -> m
acc m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` Elem Keys -> m
f Elem Keys
v) m
forall a. Monoid a => a
mempty
delete :: Keys a -> Metadatas -> Metadatas
delete :: Keys a -> Metadatas -> Metadatas
delete Keys a
k = [Elem Keys] -> Metadatas
Metadatas ([Elem Keys] -> Metadatas)
-> (Metadatas -> [Elem Keys]) -> Metadatas -> Metadatas
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Elem Keys] -> [Elem Keys]
go ([Elem Keys] -> [Elem Keys])
-> (Metadatas -> [Elem Keys]) -> Metadatas -> [Elem Keys]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Metadatas -> [Elem Keys]
getMetadatas where
go :: [Elem Keys] -> [Elem Keys]
go [] = []
go (el :: Elem Keys
el@(Keys a
k2 :=> a
_) : [Elem Keys]
rest) = case Keys a -> Keys a -> Maybe (Equiv a a)
forall a b. Keys a -> Keys b -> Maybe (Equiv a b)
keyEq Keys a
k Keys a
k2 of
Maybe (Equiv a a)
Nothing -> Elem Keys
el Elem Keys -> [Elem Keys] -> [Elem Keys]
forall a. a -> [a] -> [a]
: [Elem Keys] -> [Elem Keys]
go [Elem Keys]
rest
Just Equiv a a
Refl -> [Elem Keys]
rest
extractExifMetas :: Metadatas -> [(ExifTag, ExifData)]
= [Elem Keys] -> [(ExifTag, ExifData)]
go ([Elem Keys] -> [(ExifTag, ExifData)])
-> (Metadatas -> [Elem Keys]) -> Metadatas -> [(ExifTag, ExifData)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Metadatas -> [Elem Keys]
getMetadatas where
go :: [Elem Keys] -> [(ExifTag, ExifData)]
go :: [Elem Keys] -> [(ExifTag, ExifData)]
go [] = []
go ((Keys a
k :=> a
v) : [Elem Keys]
rest) =
case Keys a
k of
Exif ExifTag
t -> (ExifTag
t, a
v) (ExifTag, a) -> [(ExifTag, a)] -> [(ExifTag, a)]
forall a. a -> [a] -> [a]
: [Elem Keys] -> [(ExifTag, ExifData)]
go [Elem Keys]
rest
Keys a
_ -> [Elem Keys] -> [(ExifTag, ExifData)]
go [Elem Keys]
rest
lookup :: Keys a -> Metadatas -> Maybe a
lookup :: Keys a -> Metadatas -> Maybe a
lookup Keys a
k = [Elem Keys] -> Maybe a
go ([Elem Keys] -> Maybe a)
-> (Metadatas -> [Elem Keys]) -> Metadatas -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Metadatas -> [Elem Keys]
getMetadatas where
go :: [Elem Keys] -> Maybe a
go [] = Maybe a
forall a. Maybe a
Nothing
go ((Keys a
k2 :=> a
v) : [Elem Keys]
rest) = case Keys a -> Keys a -> Maybe (Equiv a a)
forall a b. Keys a -> Keys b -> Maybe (Equiv a b)
keyEq Keys a
k Keys a
k2 of
Maybe (Equiv a a)
Nothing -> [Elem Keys] -> Maybe a
go [Elem Keys]
rest
Just Equiv a a
Refl -> a -> Maybe a
forall a. a -> Maybe a
Just a
v
insert :: (Show a, NFData a) => Keys a -> a -> Metadatas -> Metadatas
insert :: Keys a -> a -> Metadatas -> Metadatas
insert Keys a
k a
val Metadatas
metas =
[Elem Keys] -> Metadatas
Metadatas ([Elem Keys] -> Metadatas) -> [Elem Keys] -> Metadatas
forall a b. (a -> b) -> a -> b
$ (Keys a
k Keys a -> a -> Elem Keys
forall (k :: * -> *) a. (Show a, NFData a) => k a -> a -> Elem k
:=> a
val) Elem Keys -> [Elem Keys] -> [Elem Keys]
forall a. a -> [a] -> [a]
: Metadatas -> [Elem Keys]
getMetadatas (Keys a -> Metadatas -> Metadatas
forall a. Keys a -> Metadatas -> Metadatas
delete Keys a
k Metadatas
metas)
singleton :: (Show a, NFData a) => Keys a -> a -> Metadatas
singleton :: Keys a -> a -> Metadatas
singleton Keys a
k a
val = [Elem Keys] -> Metadatas
Metadatas [Keys a
k Keys a -> a -> Elem Keys
forall (k :: * -> *) a. (Show a, NFData a) => k a -> a -> Elem k
:=> a
val]
empty :: Metadatas
empty :: Metadatas
empty = [Elem Keys] -> Metadatas
Metadatas [Elem Keys]
forall a. Monoid a => a
mempty
dotsPerMeterToDotPerInch :: Word -> Word
dotsPerMeterToDotPerInch :: Word -> Word
dotsPerMeterToDotPerInch Word
z = Word
z Word -> Word -> Word
forall a. Num a => a -> a -> a
* Word
254 Word -> Word -> Word
forall a. Integral a => a -> a -> a
`div` Word
10000
dotPerInchToDotsPerMeter :: Word -> Word
dotPerInchToDotsPerMeter :: Word -> Word
dotPerInchToDotsPerMeter Word
z = (Word
z Word -> Word -> Word
forall a. Num a => a -> a -> a
* Word
10000) Word -> Word -> Word
forall a. Integral a => a -> a -> a
`div` Word
254
dotsPerCentiMeterToDotPerInch :: Word -> Word
dotsPerCentiMeterToDotPerInch :: Word -> Word
dotsPerCentiMeterToDotPerInch Word
z = Word
z Word -> Word -> Word
forall a. Num a => a -> a -> a
* Word
254 Word -> Word -> Word
forall a. Integral a => a -> a -> a
`div` Word
100
mkDpiMetadata :: Word -> Metadatas
mkDpiMetadata :: Word -> Metadatas
mkDpiMetadata Word
w =
[Elem Keys] -> Metadatas
Metadatas [Keys Word
DpiY Keys Word -> Word -> Elem Keys
forall (k :: * -> *) a. (Show a, NFData a) => k a -> a -> Elem k
:=> Word
w, Keys Word
DpiX Keys Word -> Word -> Elem Keys
forall (k :: * -> *) a. (Show a, NFData a) => k a -> a -> Elem k
:=> Word
w]
mkSizeMetadata :: Integral n => n -> n -> Metadatas
mkSizeMetadata :: n -> n -> Metadatas
mkSizeMetadata n
w n
h =
[Elem Keys] -> Metadatas
Metadatas [ Keys Word
Width Keys Word -> Word -> Elem Keys
forall (k :: * -> *) a. (Show a, NFData a) => k a -> a -> Elem k
:=> n -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral n
w, Keys Word
Height Keys Word -> Word -> Elem Keys
forall (k :: * -> *) a. (Show a, NFData a) => k a -> a -> Elem k
:=> n -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral n
h ]
basicMetadata :: Integral nSize => SourceFormat -> nSize -> nSize -> Metadatas
basicMetadata :: SourceFormat -> nSize -> nSize -> Metadatas
basicMetadata SourceFormat
f nSize
w nSize
h =
[Elem Keys] -> Metadatas
Metadatas [ Keys SourceFormat
Format Keys SourceFormat -> SourceFormat -> Elem Keys
forall (k :: * -> *) a. (Show a, NFData a) => k a -> a -> Elem k
:=> SourceFormat
f
, Keys Word
Width Keys Word -> Word -> Elem Keys
forall (k :: * -> *) a. (Show a, NFData a) => k a -> a -> Elem k
:=> nSize -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral nSize
w
, Keys Word
Height Keys Word -> Word -> Elem Keys
forall (k :: * -> *) a. (Show a, NFData a) => k a -> a -> Elem k
:=> nSize -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral nSize
h
]
simpleMetadata :: (Integral nSize, Integral nDpi)
=> SourceFormat -> nSize -> nSize -> nDpi -> nDpi -> Metadatas
simpleMetadata :: SourceFormat -> nSize -> nSize -> nDpi -> nDpi -> Metadatas
simpleMetadata SourceFormat
f nSize
w nSize
h nDpi
dpiX nDpi
dpiY =
[Elem Keys] -> Metadatas
Metadatas [ Keys SourceFormat
Format Keys SourceFormat -> SourceFormat -> Elem Keys
forall (k :: * -> *) a. (Show a, NFData a) => k a -> a -> Elem k
:=> SourceFormat
f
, Keys Word
Width Keys Word -> Word -> Elem Keys
forall (k :: * -> *) a. (Show a, NFData a) => k a -> a -> Elem k
:=> nSize -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral nSize
w
, Keys Word
Height Keys Word -> Word -> Elem Keys
forall (k :: * -> *) a. (Show a, NFData a) => k a -> a -> Elem k
:=> nSize -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral nSize
h
, Keys Word
DpiX Keys Word -> Word -> Elem Keys
forall (k :: * -> *) a. (Show a, NFData a) => k a -> a -> Elem k
:=> nDpi -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral nDpi
dpiX
, Keys Word
DpiY Keys Word -> Word -> Elem Keys
forall (k :: * -> *) a. (Show a, NFData a) => k a -> a -> Elem k
:=> nDpi -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral nDpi
dpiY
]