{-# 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 a :: SourceFormat
a = SourceFormat
a SourceFormat -> () -> ()
forall a b. a -> b -> b
`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 v :: ColorSpace
v = ColorSpace
v ColorSpace -> () -> ()
forall a b. a -> b -> b
`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 v :: Value
v = Value
v Value -> () -> ()
forall a b. a -> b -> b
`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 (_ :=> v :: a
v) = a -> ()
forall a. NFData a => a -> ()
rnf a
v () -> () -> ()
forall a b. a -> b -> b
`seq` ()
keyEq :: Keys a -> Keys b -> Maybe (Equiv a b)
keyEq :: Keys a -> Keys b -> Maybe (Equiv a b)
keyEq a :: Keys a
a b :: Keys b
b = case (Keys a
a, Keys b
b) of
(Gamma, Gamma) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(ColorSpace, ColorSpace) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(DpiX, DpiX) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(DpiY, DpiY) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Width, Width) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Height, Height) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Title, Title) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Description, Description) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Author, Author) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Copyright, Copyright) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Software, Software) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Comment, Comment) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Disclaimer, Disclaimer) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Source, Source) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Warning, Warning) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Format, Format) -> (a :~: a) -> Maybe (a :~: a)
forall a. a -> Maybe a
Just a :~: a
forall k (a :: k). a :~: a
Refl
(Unknown v1 :: String
v1, Unknown v2 :: 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 t1 :: ExifTag
t1, Exif t2 :: 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
_ -> 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 m1 :: 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 acc :: Metadatas
acc el :: Elem Keys
el@(k :: Keys a
k :=> _) = [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' f :: acc -> Elem Keys -> acc
f initAcc :: 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 f :: Elem Keys -> m
f = (m -> Elem Keys -> m) -> m -> Metadatas -> m
forall acc. (acc -> Elem Keys -> acc) -> acc -> Metadatas -> acc
foldl' (\acc :: m
acc v :: 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 k :: 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@(k2 :: Keys a
k2 :=> _) : rest :: [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
Nothing -> Elem Keys
el Elem Keys -> [Elem Keys] -> [Elem Keys]
forall a. a -> [a] -> [a]
: [Elem Keys] -> [Elem Keys]
go [Elem Keys]
rest
Just 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 ((k :: Keys a
k :=> v :: a
v) : rest :: [Elem Keys]
rest) =
case Keys a
k of
Exif t :: 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
_ -> [Elem Keys] -> [(ExifTag, ExifData)]
go [Elem Keys]
rest
lookup :: Keys a -> Metadatas -> Maybe a
lookup :: Keys a -> Metadatas -> Maybe a
lookup k :: 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 ((k2 :: Keys a
k2 :=> v :: a
v) : rest :: [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
Nothing -> [Elem Keys] -> Maybe a
go [Elem Keys]
rest
Just 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 k :: Keys a
k val :: a
val metas :: 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 k :: Keys a
k val :: 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 z :: Word
z = Word
z Word -> Word -> Word
forall a. Num a => a -> a -> a
* 254 Word -> Word -> Word
forall a. Integral a => a -> a -> a
`div` 10000
dotPerInchToDotsPerMeter :: Word -> Word
dotPerInchToDotsPerMeter :: Word -> Word
dotPerInchToDotsPerMeter z :: Word
z = (Word
z Word -> Word -> Word
forall a. Num a => a -> a -> a
* 10000) Word -> Word -> Word
forall a. Integral a => a -> a -> a
`div` 254
dotsPerCentiMeterToDotPerInch :: Word -> Word
dotsPerCentiMeterToDotPerInch :: Word -> Word
dotsPerCentiMeterToDotPerInch z :: Word
z = Word
z Word -> Word -> Word
forall a. Num a => a -> a -> a
* 254 Word -> Word -> Word
forall a. Integral a => a -> a -> a
`div` 100
mkDpiMetadata :: Word -> Metadatas
mkDpiMetadata :: Word -> Metadatas
mkDpiMetadata w :: 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 w :: n
w h :: 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 f :: SourceFormat
f w :: nSize
w h :: 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 f :: SourceFormat
f w :: nSize
w h :: nSize
h dpiX :: nDpi
dpiX dpiY :: 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
]