{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, CPP #-}
{-# LANGUAGE ViewPatterns      #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{- |
Module      : Text.Pandoc.ImageSize
Copyright   : Copyright (C) 2011-2020 John MacFarlane
License     : GNU GPL, version 2 or above

Maintainer  : John MacFarlane <jgm@berkeley.edu>
Stability   : alpha
Portability : portable

Functions for determining the size of a PNG, JPEG, or GIF image.
-}
module Text.Pandoc.ImageSize ( ImageType(..)
                             , imageType
                             , imageSize
                             , sizeInPixels
                             , sizeInPoints
                             , desiredSizeInPoints
                             , Dimension(..)
                             , Direction(..)
                             , dimension
                             , lengthToDim
                             , scaleDimension
                             , inInch
                             , inPixel
                             , inPoints
                             , inEm
                             , numUnit
                             , showInInch
                             , showInPixel
                             , showFl
                             ) where
import Data.ByteString (ByteString, unpack)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as BL
import Data.Char (isDigit)
import Control.Monad
import Data.Bits
import Data.Binary
import Data.Binary.Get
import Text.Pandoc.Shared (safeRead)
import Data.Default (Default)
import Numeric (showFFloat)
import Text.Pandoc.Definition
import Text.Pandoc.Options
import qualified Text.Pandoc.UTF8 as UTF8
import qualified Text.XML.Light as Xml
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Control.Monad.Except
import Control.Applicative
import Data.Maybe (fromMaybe)
import qualified Data.Attoparsec.ByteString.Char8 as A

-- quick and dirty functions to get image sizes
-- algorithms borrowed from wwwis.pl

data ImageType = Png | Gif | Jpeg | Svg | Pdf | Eps | Emf deriving Int -> ImageType -> ShowS
[ImageType] -> ShowS
ImageType -> String
(Int -> ImageType -> ShowS)
-> (ImageType -> String)
-> ([ImageType] -> ShowS)
-> Show ImageType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImageType] -> ShowS
$cshowList :: [ImageType] -> ShowS
show :: ImageType -> String
$cshow :: ImageType -> String
showsPrec :: Int -> ImageType -> ShowS
$cshowsPrec :: Int -> ImageType -> ShowS
Show
data Direction = Width | Height
instance Show Direction where
  show :: Direction -> String
show Direction
Width  = String
"width"
  show Direction
Height = String
"height"

data Dimension = Pixel Integer
               | Centimeter Double
               | Millimeter Double
               | Inch Double
               | Percent Double
               | Em Double
               deriving Dimension -> Dimension -> Bool
(Dimension -> Dimension -> Bool)
-> (Dimension -> Dimension -> Bool) -> Eq Dimension
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Dimension -> Dimension -> Bool
$c/= :: Dimension -> Dimension -> Bool
== :: Dimension -> Dimension -> Bool
$c== :: Dimension -> Dimension -> Bool
Eq

instance Show Dimension where
  show :: Dimension -> String
show (Pixel Integer
a)      = Integer -> String
forall a. Show a => a -> String
show Integer
a              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"px"
  show (Centimeter Double
a) = Text -> String
T.unpack (Double -> Text
forall a. RealFloat a => a -> Text
showFl Double
a) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"cm"
  show (Millimeter Double
a) = Text -> String
T.unpack (Double -> Text
forall a. RealFloat a => a -> Text
showFl Double
a) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"mm"
  show (Inch Double
a)       = Text -> String
T.unpack (Double -> Text
forall a. RealFloat a => a -> Text
showFl Double
a) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"in"
  show (Percent Double
a)    = Double -> String
forall a. Show a => a -> String
show Double
a              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"%"
  show (Em Double
a)         = Text -> String
T.unpack (Double -> Text
forall a. RealFloat a => a -> Text
showFl Double
a) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"em"

data ImageSize = ImageSize{
                     ImageSize -> Integer
pxX   :: Integer
                   , ImageSize -> Integer
pxY   :: Integer
                   , ImageSize -> Integer
dpiX  :: Integer
                   , ImageSize -> Integer
dpiY  :: Integer
                   } deriving (ReadPrec [ImageSize]
ReadPrec ImageSize
Int -> ReadS ImageSize
ReadS [ImageSize]
(Int -> ReadS ImageSize)
-> ReadS [ImageSize]
-> ReadPrec ImageSize
-> ReadPrec [ImageSize]
-> Read ImageSize
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ImageSize]
$creadListPrec :: ReadPrec [ImageSize]
readPrec :: ReadPrec ImageSize
$creadPrec :: ReadPrec ImageSize
readList :: ReadS [ImageSize]
$creadList :: ReadS [ImageSize]
readsPrec :: Int -> ReadS ImageSize
$creadsPrec :: Int -> ReadS ImageSize
Read, Int -> ImageSize -> ShowS
[ImageSize] -> ShowS
ImageSize -> String
(Int -> ImageSize -> ShowS)
-> (ImageSize -> String)
-> ([ImageSize] -> ShowS)
-> Show ImageSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImageSize] -> ShowS
$cshowList :: [ImageSize] -> ShowS
show :: ImageSize -> String
$cshow :: ImageSize -> String
showsPrec :: Int -> ImageSize -> ShowS
$cshowsPrec :: Int -> ImageSize -> ShowS
Show, ImageSize -> ImageSize -> Bool
(ImageSize -> ImageSize -> Bool)
-> (ImageSize -> ImageSize -> Bool) -> Eq ImageSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImageSize -> ImageSize -> Bool
$c/= :: ImageSize -> ImageSize -> Bool
== :: ImageSize -> ImageSize -> Bool
$c== :: ImageSize -> ImageSize -> Bool
Eq)
instance Default ImageSize where
  def :: ImageSize
def = Integer -> Integer -> Integer -> Integer -> ImageSize
ImageSize Integer
300 Integer
200 Integer
72 Integer
72

showFl :: (RealFloat a) => a -> T.Text
showFl :: a -> Text
showFl a
a = Text -> Text
removeExtra0s (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Maybe Int -> a -> ShowS
forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloat (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
5) a
a String
""

removeExtra0s :: T.Text -> T.Text
removeExtra0s :: Text -> Text
removeExtra0s Text
s = case (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'0') Text
s of
  (Text -> Maybe (Text, Char)
T.unsnoc -> Just (Text
xs, Char
'.')) -> Text
xs
  Text
xs                           -> Text
xs

imageType :: ByteString -> Maybe ImageType
imageType :: ByteString -> Maybe ImageType
imageType ByteString
img = case Int -> ByteString -> ByteString
B.take Int
4 ByteString
img of
                     ByteString
"\x89\x50\x4e\x47" -> ImageType -> Maybe ImageType
forall (m :: * -> *) a. Monad m => a -> m a
return ImageType
Png
                     ByteString
"\x47\x49\x46\x38" -> ImageType -> Maybe ImageType
forall (m :: * -> *) a. Monad m => a -> m a
return ImageType
Gif
                     ByteString
"\xff\xd8\xff\xe0" -> ImageType -> Maybe ImageType
forall (m :: * -> *) a. Monad m => a -> m a
return ImageType
Jpeg  -- JFIF
                     ByteString
"\xff\xd8\xff\xe1" -> ImageType -> Maybe ImageType
forall (m :: * -> *) a. Monad m => a -> m a
return ImageType
Jpeg  -- Exif
                     ByteString
"%PDF"             -> ImageType -> Maybe ImageType
forall (m :: * -> *) a. Monad m => a -> m a
return ImageType
Pdf
                     ByteString
"<svg"             -> ImageType -> Maybe ImageType
forall (m :: * -> *) a. Monad m => a -> m a
return ImageType
Svg
                     ByteString
"<?xm"
                       | ByteString -> Bool
findSvgTag ByteString
img
                                        -> ImageType -> Maybe ImageType
forall (m :: * -> *) a. Monad m => a -> m a
return ImageType
Svg
                     ByteString
"%!PS"
                       |  Int -> ByteString -> ByteString
B.take Int
4 (Int -> ByteString -> ByteString
B.drop Int
1 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
B.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
' ') ByteString
img) ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"EPSF"
                                        -> ImageType -> Maybe ImageType
forall (m :: * -> *) a. Monad m => a -> m a
return ImageType
Eps
                     ByteString
"\x01\x00\x00\x00"
                       | Int -> ByteString -> ByteString
B.take Int
4 (Int -> ByteString -> ByteString
B.drop Int
40 ByteString
img) ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
" EMF"
                                        -> ImageType -> Maybe ImageType
forall (m :: * -> *) a. Monad m => a -> m a
return ImageType
Emf
                     ByteString
_                  -> Maybe ImageType
forall (m :: * -> *) a. MonadPlus m => m a
mzero

findSvgTag :: ByteString -> Bool
findSvgTag :: ByteString -> Bool
findSvgTag ByteString
img = ByteString
"<svg" ByteString -> ByteString -> Bool
`B.isInfixOf` ByteString
img Bool -> Bool -> Bool
|| ByteString
"<SVG" ByteString -> ByteString -> Bool
`B.isInfixOf` ByteString
img

imageSize :: WriterOptions -> ByteString -> Either T.Text ImageSize
imageSize :: WriterOptions -> ByteString -> Either Text ImageSize
imageSize WriterOptions
opts ByteString
img =
  case ByteString -> Maybe ImageType
imageType ByteString
img of
       Just ImageType
Png  -> Text -> Maybe ImageSize -> Either Text ImageSize
forall a b. a -> Maybe b -> Either a b
mbToEither Text
"could not determine PNG size" (Maybe ImageSize -> Either Text ImageSize)
-> Maybe ImageSize -> Either Text ImageSize
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ImageSize
pngSize ByteString
img
       Just ImageType
Gif  -> Text -> Maybe ImageSize -> Either Text ImageSize
forall a b. a -> Maybe b -> Either a b
mbToEither Text
"could not determine GIF size" (Maybe ImageSize -> Either Text ImageSize)
-> Maybe ImageSize -> Either Text ImageSize
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ImageSize
gifSize ByteString
img
       Just ImageType
Jpeg -> ByteString -> Either Text ImageSize
jpegSize ByteString
img
       Just ImageType
Svg  -> Text -> Maybe ImageSize -> Either Text ImageSize
forall a b. a -> Maybe b -> Either a b
mbToEither Text
"could not determine SVG size" (Maybe ImageSize -> Either Text ImageSize)
-> Maybe ImageSize -> Either Text ImageSize
forall a b. (a -> b) -> a -> b
$ WriterOptions -> ByteString -> Maybe ImageSize
svgSize WriterOptions
opts ByteString
img
       Just ImageType
Eps  -> Text -> Maybe ImageSize -> Either Text ImageSize
forall a b. a -> Maybe b -> Either a b
mbToEither Text
"could not determine EPS size" (Maybe ImageSize -> Either Text ImageSize)
-> Maybe ImageSize -> Either Text ImageSize
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ImageSize
epsSize ByteString
img
       Just ImageType
Pdf  -> Text -> Maybe ImageSize -> Either Text ImageSize
forall a b. a -> Maybe b -> Either a b
mbToEither Text
"could not determine PDF size" (Maybe ImageSize -> Either Text ImageSize)
-> Maybe ImageSize -> Either Text ImageSize
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ImageSize
pdfSize ByteString
img
       Just ImageType
Emf  -> Text -> Maybe ImageSize -> Either Text ImageSize
forall a b. a -> Maybe b -> Either a b
mbToEither Text
"could not determine EMF size" (Maybe ImageSize -> Either Text ImageSize)
-> Maybe ImageSize -> Either Text ImageSize
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ImageSize
emfSize ByteString
img
       Maybe ImageType
Nothing   -> Text -> Either Text ImageSize
forall a b. a -> Either a b
Left Text
"could not determine image type"
  where mbToEither :: a -> Maybe b -> Either a b
mbToEither a
msg Maybe b
Nothing  = a -> Either a b
forall a b. a -> Either a b
Left a
msg
        mbToEither a
_   (Just b
x) = b -> Either a b
forall a b. b -> Either a b
Right b
x

defaultSize :: (Integer, Integer)
defaultSize :: (Integer, Integer)
defaultSize = (Integer
72, Integer
72)

sizeInPixels :: ImageSize -> (Integer, Integer)
sizeInPixels :: ImageSize -> (Integer, Integer)
sizeInPixels ImageSize
s = (ImageSize -> Integer
pxX ImageSize
s, ImageSize -> Integer
pxY ImageSize
s)

-- | Calculate (height, width) in points using the image file's dpi metadata,
-- using 72 Points == 1 Inch.
sizeInPoints :: ImageSize -> (Double, Double)
sizeInPoints :: ImageSize -> (Double, Double)
sizeInPoints ImageSize
s = (Double
pxXf Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
72 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
dpiXf, Double
pxYf Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
72 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
dpiYf)
  where
    pxXf :: Double
pxXf  = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Double) -> Integer -> Double
forall a b. (a -> b) -> a -> b
$ ImageSize -> Integer
pxX ImageSize
s
    pxYf :: Double
pxYf  = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Double) -> Integer -> Double
forall a b. (a -> b) -> a -> b
$ ImageSize -> Integer
pxY ImageSize
s
    dpiXf :: Double
dpiXf = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Double) -> Integer -> Double
forall a b. (a -> b) -> a -> b
$ ImageSize -> Integer
dpiX ImageSize
s
    dpiYf :: Double
dpiYf = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Double) -> Integer -> Double
forall a b. (a -> b) -> a -> b
$ ImageSize -> Integer
dpiY ImageSize
s

-- | Calculate (height, width) in points, considering the desired dimensions in the
-- attribute, while falling back on the image file's dpi metadata if no dimensions
-- are specified in the attribute (or only dimensions in percentages).
desiredSizeInPoints :: WriterOptions -> Attr -> ImageSize -> (Double, Double)
desiredSizeInPoints :: WriterOptions -> Attr -> ImageSize -> (Double, Double)
desiredSizeInPoints WriterOptions
opts Attr
attr ImageSize
s =
  case (Direction -> Maybe Double
getDim Direction
Width, Direction -> Maybe Double
getDim Direction
Height) of
    (Just Double
w, Just Double
h)   -> (Double
w, Double
h)
    (Just Double
w, Maybe Double
Nothing)  -> (Double
w, Double
w Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
ratio)
    (Maybe Double
Nothing, Just Double
h)  -> (Double
h Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ratio, Double
h)
    (Maybe Double
Nothing, Maybe Double
Nothing) -> ImageSize -> (Double, Double)
sizeInPoints ImageSize
s
  where
    ratio :: Double
ratio = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ImageSize -> Integer
pxX ImageSize
s) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ImageSize -> Integer
pxY ImageSize
s)
    getDim :: Direction -> Maybe Double
getDim Direction
dir = case Direction -> Attr -> Maybe Dimension
dimension Direction
dir Attr
attr of
                   Just (Percent Double
_) -> Maybe Double
forall a. Maybe a
Nothing
                   Just Dimension
dim         -> Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double) -> Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Dimension -> Double
inPoints WriterOptions
opts Dimension
dim
                   Maybe Dimension
Nothing          -> Maybe Double
forall a. Maybe a
Nothing

inPoints :: WriterOptions -> Dimension -> Double
inPoints :: WriterOptions -> Dimension -> Double
inPoints WriterOptions
opts Dimension
dim = Double
72 Double -> Double -> Double
forall a. Num a => a -> a -> a
* WriterOptions -> Dimension -> Double
inInch WriterOptions
opts Dimension
dim

inEm :: WriterOptions -> Dimension -> Double
inEm :: WriterOptions -> Dimension -> Double
inEm WriterOptions
opts Dimension
dim = (Double
64Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
11) Double -> Double -> Double
forall a. Num a => a -> a -> a
* WriterOptions -> Dimension -> Double
inInch WriterOptions
opts Dimension
dim

inInch :: WriterOptions -> Dimension -> Double
inInch :: WriterOptions -> Dimension -> Double
inInch WriterOptions
opts Dimension
dim =
  case Dimension
dim of
    (Pixel Integer
a)      -> Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
a Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WriterOptions -> Int
writerDpi WriterOptions
opts)
    (Centimeter Double
a) -> Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.3937007874
    (Millimeter Double
a) -> Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.03937007874
    (Inch Double
a)       -> Double
a
    (Percent Double
_)    -> Double
0
    (Em Double
a)         -> Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
11Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
64)

inPixel :: WriterOptions -> Dimension -> Integer
inPixel :: WriterOptions -> Dimension -> Integer
inPixel WriterOptions
opts Dimension
dim =
  case Dimension
dim of
    (Pixel Integer
a)      -> Integer
a
    (Centimeter Double
a) -> Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ Double
dpi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.3937007874 :: Integer
    (Millimeter Double
a) -> Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ Double
dpi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.03937007874 :: Integer
    (Inch Double
a)       -> Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ Double
dpi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
a :: Integer
    (Percent Double
_)    -> Integer
0
    (Em Double
a)         -> Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ Double
dpi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
11Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
64) :: Integer
  where
    dpi :: Double
dpi = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Int
writerDpi WriterOptions
opts

-- | Convert a Dimension to Text denoting its equivalent in inches, for example "2.00000".
-- Note: Dimensions in percentages are converted to the empty string.
showInInch :: WriterOptions -> Dimension -> T.Text
showInInch :: WriterOptions -> Dimension -> Text
showInInch WriterOptions
_ (Percent Double
_) = Text
""
showInInch WriterOptions
opts Dimension
dim = Double -> Text
forall a. RealFloat a => a -> Text
showFl (Double -> Text) -> Double -> Text
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Dimension -> Double
inInch WriterOptions
opts Dimension
dim

-- | Convert a Dimension to Text denoting its equivalent in pixels, for example "600".
-- Note: Dimensions in percentages are converted to the empty string.
showInPixel :: WriterOptions -> Dimension -> T.Text
showInPixel :: WriterOptions -> Dimension -> Text
showInPixel WriterOptions
_ (Percent Double
_) = Text
""
showInPixel WriterOptions
opts Dimension
dim = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> Integer -> String
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Dimension -> Integer
inPixel WriterOptions
opts Dimension
dim

-- | Maybe split a string into a leading number and trailing unit, e.g. "3cm" to Just (3.0, "cm")
numUnit :: T.Text -> Maybe (Double, T.Text)
numUnit :: Text -> Maybe (Double, Text)
numUnit Text
s =
  let (Text
nums, Text
unit) = (Char -> Bool) -> Text -> (Text, Text)
T.span (\Char
c -> Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| (Char
'.'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
c)) Text
s
  in (\Double
n -> (Double
n, Text
unit)) (Double -> (Double, Text)) -> Maybe Double -> Maybe (Double, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Double
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead Text
nums

-- | Scale a dimension by a factor.
scaleDimension :: Double -> Dimension -> Dimension
scaleDimension :: Double -> Dimension -> Dimension
scaleDimension Double
factor Dimension
dim =
  case Dimension
dim of
        Pixel Integer
x      -> Integer -> Dimension
Pixel (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ Double
factor Double -> Double -> Double
forall a. Num a => a -> a -> a
* Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x)
        Centimeter Double
x -> Double -> Dimension
Centimeter (Double
factor Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x)
        Millimeter Double
x -> Double -> Dimension
Millimeter (Double
factor Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x)
        Inch Double
x       -> Double -> Dimension
Inch (Double
factor Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x)
        Percent Double
x    -> Double -> Dimension
Percent (Double
factor Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x)
        Em Double
x         -> Double -> Dimension
Em (Double
factor Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x)

-- | Read a Dimension from an Attr attribute.
-- `dimension Width attr` might return `Just (Pixel 3)` or for example `Just (Centimeter 2.0)`, etc.
dimension :: Direction -> Attr -> Maybe Dimension
dimension :: Direction -> Attr -> Maybe Dimension
dimension Direction
dir (Text
_, [Text]
_, [(Text, Text)]
kvs) =
  case Direction
dir of
    Direction
Width  -> Text -> Maybe Dimension
extractDim Text
"width"
    Direction
Height -> Text -> Maybe Dimension
extractDim Text
"height"
  where
    extractDim :: Text -> Maybe Dimension
extractDim Text
key = Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
key [(Text, Text)]
kvs Maybe Text -> (Text -> Maybe Dimension) -> Maybe Dimension
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Dimension
lengthToDim

lengthToDim :: T.Text -> Maybe Dimension
lengthToDim :: Text -> Maybe Dimension
lengthToDim Text
s = Text -> Maybe (Double, Text)
numUnit Text
s Maybe (Double, Text)
-> ((Double, Text) -> Maybe Dimension) -> Maybe Dimension
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Double -> Text -> Maybe Dimension)
-> (Double, Text) -> Maybe Dimension
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Text -> Maybe Dimension
forall a. (Eq a, IsString a) => Double -> a -> Maybe Dimension
toDim
  where
    toDim :: Double -> a -> Maybe Dimension
toDim Double
a a
"cm"   = Dimension -> Maybe Dimension
forall a. a -> Maybe a
Just (Dimension -> Maybe Dimension) -> Dimension -> Maybe Dimension
forall a b. (a -> b) -> a -> b
$ Double -> Dimension
Centimeter Double
a
    toDim Double
a a
"mm"   = Dimension -> Maybe Dimension
forall a. a -> Maybe a
Just (Dimension -> Maybe Dimension) -> Dimension -> Maybe Dimension
forall a b. (a -> b) -> a -> b
$ Double -> Dimension
Millimeter Double
a
    toDim Double
a a
"in"   = Dimension -> Maybe Dimension
forall a. a -> Maybe a
Just (Dimension -> Maybe Dimension) -> Dimension -> Maybe Dimension
forall a b. (a -> b) -> a -> b
$ Double -> Dimension
Inch Double
a
    toDim Double
a a
"inch" = Dimension -> Maybe Dimension
forall a. a -> Maybe a
Just (Dimension -> Maybe Dimension) -> Dimension -> Maybe Dimension
forall a b. (a -> b) -> a -> b
$ Double -> Dimension
Inch Double
a
    toDim Double
a a
"%"    = Dimension -> Maybe Dimension
forall a. a -> Maybe a
Just (Dimension -> Maybe Dimension) -> Dimension -> Maybe Dimension
forall a b. (a -> b) -> a -> b
$ Double -> Dimension
Percent Double
a
    toDim Double
a a
"px"   = Dimension -> Maybe Dimension
forall a. a -> Maybe a
Just (Dimension -> Maybe Dimension) -> Dimension -> Maybe Dimension
forall a b. (a -> b) -> a -> b
$ Integer -> Dimension
Pixel (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
a::Integer)
    toDim Double
a a
""     = Dimension -> Maybe Dimension
forall a. a -> Maybe a
Just (Dimension -> Maybe Dimension) -> Dimension -> Maybe Dimension
forall a b. (a -> b) -> a -> b
$ Integer -> Dimension
Pixel (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
a::Integer)
    toDim Double
a a
"pt"   = Dimension -> Maybe Dimension
forall a. a -> Maybe a
Just (Dimension -> Maybe Dimension) -> Dimension -> Maybe Dimension
forall a b. (a -> b) -> a -> b
$ Double -> Dimension
Inch (Double
a Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
72)
    toDim Double
a a
"pc"   = Dimension -> Maybe Dimension
forall a. a -> Maybe a
Just (Dimension -> Maybe Dimension) -> Dimension -> Maybe Dimension
forall a b. (a -> b) -> a -> b
$ Double -> Dimension
Inch (Double
a Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
6)
    toDim Double
a a
"em"   = Dimension -> Maybe Dimension
forall a. a -> Maybe a
Just (Dimension -> Maybe Dimension) -> Dimension -> Maybe Dimension
forall a b. (a -> b) -> a -> b
$ Double -> Dimension
Em Double
a
    toDim Double
_ a
_      = Maybe Dimension
forall a. Maybe a
Nothing

epsSize :: ByteString -> Maybe ImageSize
epsSize :: ByteString -> Maybe ImageSize
epsSize ByteString
img = do
  let ls :: [ByteString]
ls = (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (ByteString
"%" ByteString -> ByteString -> Bool
`B.isPrefixOf`) ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
B.lines ByteString
img
  let ls' :: [ByteString]
ls' = (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
"%%BoundingBox:" ByteString -> ByteString -> Bool
`B.isPrefixOf`)) [ByteString]
ls
  case [ByteString]
ls' of
       []    -> Maybe ImageSize
forall (m :: * -> *) a. MonadPlus m => m a
mzero
       (ByteString
x:[ByteString]
_) -> case ByteString -> [ByteString]
B.words ByteString
x of
                     [ByteString
_, ByteString
_, ByteString
_, ByteString
ux, ByteString
uy] -> do
                        Integer
ux' <- Text -> Maybe Integer
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead (Text -> Maybe Integer) -> Text -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 ByteString
ux
                        Integer
uy' <- Text -> Maybe Integer
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead (Text -> Maybe Integer) -> Text -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 ByteString
uy
                        ImageSize -> Maybe ImageSize
forall (m :: * -> *) a. Monad m => a -> m a
return ImageSize :: Integer -> Integer -> Integer -> Integer -> ImageSize
ImageSize{
                            pxX :: Integer
pxX  = Integer
ux'
                          , pxY :: Integer
pxY  = Integer
uy'
                          , dpiX :: Integer
dpiX = Integer
72
                          , dpiY :: Integer
dpiY = Integer
72 }
                     [ByteString]
_ -> Maybe ImageSize
forall (m :: * -> *) a. MonadPlus m => m a
mzero

pdfSize :: ByteString -> Maybe ImageSize
pdfSize :: ByteString -> Maybe ImageSize
pdfSize ByteString
img =
  case Parser ImageSize -> ByteString -> Either String ImageSize
forall a. Parser a -> ByteString -> Either String a
A.parseOnly Parser ImageSize
pPdfSize ByteString
img of
    Left String
_   -> Maybe ImageSize
forall a. Maybe a
Nothing
    Right ImageSize
sz -> ImageSize -> Maybe ImageSize
forall a. a -> Maybe a
Just ImageSize
sz

pPdfSize :: A.Parser ImageSize
pPdfSize :: Parser ImageSize
pPdfSize = do
  (Char -> Bool) -> Parser ()
A.skipWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'/')
  Char -> Parser Word8
A.char8 Char
'/'
  (do ByteString -> Parser ByteString
A.string ByteString
"MediaBox"
      Parser ()
A.skipSpace
      Char -> Parser Word8
A.char8 Char
'['
      Parser ()
A.skipSpace
      [Integer
x1,Integer
y1,Integer
x2,Integer
y2] <- Int -> Parser ByteString Integer -> Parser ByteString [Integer]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
A.count Int
4 (Parser ByteString Integer -> Parser ByteString [Integer])
-> Parser ByteString Integer -> Parser ByteString [Integer]
forall a b. (a -> b) -> a -> b
$ do
        Parser ()
A.skipSpace
        String
raw <- Parser ByteString Char -> Parser ByteString String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 (Parser ByteString Char -> Parser ByteString String)
-> Parser ByteString Char -> Parser ByteString String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser ByteString Char
A.satisfy (\Char
c -> Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.')
        case Text -> Maybe Double
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead (Text -> Maybe Double) -> Text -> Maybe Double
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
raw of
          Just (Double
r :: Double) -> Integer -> Parser ByteString Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Parser ByteString Integer)
-> Integer -> Parser ByteString Integer
forall a b. (a -> b) -> a -> b
$ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
r
          Maybe Double
Nothing            -> Parser ByteString Integer
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      Parser ()
A.skipSpace
      Char -> Parser Word8
A.char8 Char
']'
      ImageSize -> Parser ImageSize
forall (m :: * -> *) a. Monad m => a -> m a
return (ImageSize -> Parser ImageSize) -> ImageSize -> Parser ImageSize
forall a b. (a -> b) -> a -> b
$ ImageSize :: Integer -> Integer -> Integer -> Integer -> ImageSize
ImageSize{
              pxX :: Integer
pxX  = Integer
x2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
x1
            , pxY :: Integer
pxY  = Integer
y2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
y1
            , dpiX :: Integer
dpiX = Integer
72
            , dpiY :: Integer
dpiY = Integer
72 }
   ) Parser ImageSize -> Parser ImageSize -> Parser ImageSize
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ImageSize
pPdfSize

pngSize :: ByteString -> Maybe ImageSize
pngSize :: ByteString -> Maybe ImageSize
pngSize ByteString
img = do
  let (ByteString
h, ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
8 ByteString
img
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ByteString
h ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"\x8a\x4d\x4e\x47\x0d\x0a\x1a\x0a" Bool -> Bool -> Bool
||
          ByteString
h ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"\x89\x50\x4e\x47\x0d\x0a\x1a\x0a"
  let (ByteString
i, ByteString
rest') = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
4 (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop Int
4 ByteString
rest
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ByteString
i ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"MHDR" Bool -> Bool -> Bool
|| ByteString
i ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"IHDR"
  let (ByteString
sizes, ByteString
rest'') = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
8 ByteString
rest'
  (Integer
x,Integer
y) <- case (Word8 -> Integer) -> [Word8] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> [Integer]) -> [Word8] -> [Integer]
forall a b. (a -> b) -> a -> b
$ByteString -> [Word8]
unpack ByteString
sizes of
                ([Integer
w1,Integer
w2,Integer
w3,Integer
w4,Integer
h1,Integer
h2,Integer
h3,Integer
h4] :: [Integer]) -> (Integer, Integer) -> Maybe (Integer, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return
                    (Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
w1 Int
24 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
w2 Int
16 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
w3 Int
8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
w4,
                     Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
h1 Int
24 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
h2 Int
16 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
h3 Int
8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
h4)
                [Integer]
_ -> Maybe (Integer, Integer)
forall a. Maybe a
Nothing -- "PNG parse error"
  (Integer
dpix, Integer
dpiy) <- ByteString -> Maybe (Integer, Integer)
findpHYs ByteString
rest''
  ImageSize -> Maybe ImageSize
forall (m :: * -> *) a. Monad m => a -> m a
return ImageSize :: Integer -> Integer -> Integer -> Integer -> ImageSize
ImageSize { pxX :: Integer
pxX  = Integer
x, pxY :: Integer
pxY = Integer
y, dpiX :: Integer
dpiX = Integer
dpix, dpiY :: Integer
dpiY = Integer
dpiy }

findpHYs :: ByteString -> Maybe (Integer, Integer)
findpHYs :: ByteString -> Maybe (Integer, Integer)
findpHYs ByteString
x
  | ByteString -> Bool
B.null ByteString
x Bool -> Bool -> Bool
|| ByteString
"IDAT" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
x = (Integer, Integer) -> Maybe (Integer, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
72,Integer
72)
  | ByteString
"pHYs" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
x =
    case (Word8 -> Integer) -> [Word8] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> [Integer]) -> [Word8] -> [Integer]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.take Int
9 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop Int
4 ByteString
x of
         [Integer
x1,Integer
x2,Integer
x3,Integer
x4,Integer
y1,Integer
y2,Integer
y3,Integer
y4,Integer
u] -> do
           let factor :: Integer -> Integer
factor = if Integer
u Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 -- dots per meter
                          then \Integer
z -> Integer
z Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
254 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
10000
                          else Integer -> Integer -> Integer
forall a b. a -> b -> a
const Integer
72
           (Integer, Integer) -> Maybe (Integer, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return
              ( Integer -> Integer
factor (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
x1 Int
24 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
x2 Int
16 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
x3 Int
8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
x4,
                Integer -> Integer
factor (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
y1 Int
24 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
y2 Int
16 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
y3 Int
8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
y4 )
         [Integer]
_ -> Maybe (Integer, Integer)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  | Bool
otherwise = ByteString -> Maybe (Integer, Integer)
findpHYs (ByteString -> Maybe (Integer, Integer))
-> ByteString -> Maybe (Integer, Integer)
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop Int
1 ByteString
x  -- read another byte

gifSize :: ByteString -> Maybe ImageSize
gifSize :: ByteString -> Maybe ImageSize
gifSize ByteString
img = do
  let (ByteString
h, ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
6 ByteString
img
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ByteString
h ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"GIF87a" Bool -> Bool -> Bool
|| ByteString
h ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"GIF89a"
  case (Word8 -> Integer) -> [Word8] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> [Integer]) -> [Word8] -> [Integer]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.take Int
4 ByteString
rest of
       [Integer
w2,Integer
w1,Integer
h2,Integer
h1] -> ImageSize -> Maybe ImageSize
forall (m :: * -> *) a. Monad m => a -> m a
return ImageSize :: Integer -> Integer -> Integer -> Integer -> ImageSize
ImageSize {
                          pxX :: Integer
pxX  = Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
w1 Int
8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
w2,
                          pxY :: Integer
pxY  = Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
h1 Int
8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
h2,
                          dpiX :: Integer
dpiX = Integer
72,
                          dpiY :: Integer
dpiY = Integer
72
                          }
       [Integer]
_             -> Maybe ImageSize
forall a. Maybe a
Nothing -- "GIF parse error"

svgSize :: WriterOptions -> ByteString -> Maybe ImageSize
svgSize :: WriterOptions -> ByteString -> Maybe ImageSize
svgSize WriterOptions
opts ByteString
img = do
  Element
doc <- String -> Maybe Element
forall s. XmlSource s => s -> Maybe Element
Xml.parseXMLDoc (String -> Maybe Element) -> String -> Maybe Element
forall a b. (a -> b) -> a -> b
$ ByteString -> String
UTF8.toString ByteString
img
  let dpi :: Integer
dpi = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Int
writerDpi WriterOptions
opts
  let dirToInt :: String -> Maybe Integer
dirToInt String
dir = do
        Dimension
dim <- (QName -> Bool) -> Element -> Maybe String
Xml.findAttrBy (QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String -> Maybe String -> QName
Xml.QName String
dir Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing) Element
doc Maybe String -> (String -> Maybe Dimension) -> Maybe Dimension
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Dimension
lengthToDim (Text -> Maybe Dimension)
-> (String -> Text) -> String -> Maybe Dimension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
        Integer -> Maybe Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Dimension -> Integer
inPixel WriterOptions
opts Dimension
dim
  Integer
w <- String -> Maybe Integer
dirToInt String
"width"
  Integer
h <- String -> Maybe Integer
dirToInt String
"height"
  ImageSize -> Maybe ImageSize
forall (m :: * -> *) a. Monad m => a -> m a
return ImageSize :: Integer -> Integer -> Integer -> Integer -> ImageSize
ImageSize {
    pxX :: Integer
pxX  = Integer
w
  , pxY :: Integer
pxY  = Integer
h
  , dpiX :: Integer
dpiX = Integer
dpi
  , dpiY :: Integer
dpiY = Integer
dpi
  }

emfSize :: ByteString -> Maybe ImageSize
emfSize :: ByteString -> Maybe ImageSize
emfSize ByteString
img =
  let
    parseheader :: ByteString
-> Either
     (ByteString, ByteOffset, String)
     (ByteString, ByteOffset, ImageSize)
parseheader = Get ImageSize
-> ByteString
-> Either
     (ByteString, ByteOffset, String)
     (ByteString, ByteOffset, ImageSize)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
runGetOrFail (Get ImageSize
 -> ByteString
 -> Either
      (ByteString, ByteOffset, String)
      (ByteString, ByteOffset, ImageSize))
-> Get ImageSize
-> ByteString
-> Either
     (ByteString, ByteOffset, String)
     (ByteString, ByteOffset, ImageSize)
forall a b. (a -> b) -> a -> b
$ do
      Int -> Get ()
skip Int
0x18             -- 0x00
      Word32
frameL <- Get Word32
getWord32le -- 0x18  measured in 1/100 of a millimetre
      Word32
frameT <- Get Word32
getWord32le -- 0x1C
      Word32
frameR <- Get Word32
getWord32le -- 0x20
      Word32
frameB <- Get Word32
getWord32le -- 0x24
      Int -> Get ()
skip Int
0x20             -- 0x28
      Word32
deviceX <- Get Word32
getWord32le  -- 0x48 pixels of reference device
      Word32
deviceY <- Get Word32
getWord32le  -- 0x4C
      Word32
mmX <- Get Word32
getWord32le      -- 0x50 real mm of reference device (always 320*240?)
      Word32
mmY <- Get Word32
getWord32le      -- 0x58
      -- end of header
      let
        w :: Word32
w = (Word32
deviceX Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* (Word32
frameR Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
frameL)) Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`quot` (Word32
mmX Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
100)
        h :: Word32
h = (Word32
deviceY Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* (Word32
frameB Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
frameT)) Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`quot` (Word32
mmY Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
100)
        dpiW :: Word32
dpiW = (Word32
deviceX Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
254) Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`quot` (Word32
mmX Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
10)
        dpiH :: Word32
dpiH = (Word32
deviceY Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
254) Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`quot` (Word32
mmY Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
10)
      ImageSize -> Get ImageSize
forall (m :: * -> *) a. Monad m => a -> m a
return (ImageSize -> Get ImageSize) -> ImageSize -> Get ImageSize
forall a b. (a -> b) -> a -> b
$ ImageSize :: Integer -> Integer -> Integer -> Integer -> ImageSize
ImageSize
        { pxX :: Integer
pxX = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w
        , pxY :: Integer
pxY = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
h
        , dpiX :: Integer
dpiX = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
dpiW
        , dpiY :: Integer
dpiY = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
dpiH
        }
  in
    case ByteString
-> Either
     (ByteString, ByteOffset, String)
     (ByteString, ByteOffset, ImageSize)
parseheader (ByteString
 -> Either
      (ByteString, ByteOffset, String)
      (ByteString, ByteOffset, ImageSize))
-> (ByteString -> ByteString)
-> ByteString
-> Either
     (ByteString, ByteOffset, String)
     (ByteString, ByteOffset, ImageSize)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict (ByteString
 -> Either
      (ByteString, ByteOffset, String)
      (ByteString, ByteOffset, ImageSize))
-> ByteString
-> Either
     (ByteString, ByteOffset, String)
     (ByteString, ByteOffset, ImageSize)
forall a b. (a -> b) -> a -> b
$ ByteString
img of
      Left (ByteString, ByteOffset, String)
_ -> Maybe ImageSize
forall a. Maybe a
Nothing
      Right (ByteString
_, ByteOffset
_, ImageSize
size) -> ImageSize -> Maybe ImageSize
forall a. a -> Maybe a
Just ImageSize
size


jpegSize :: ByteString -> Either T.Text ImageSize
jpegSize :: ByteString -> Either Text ImageSize
jpegSize ByteString
img =
  let (ByteString
hdr, ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
4 ByteString
img
  in if ByteString -> Int
B.length ByteString
rest Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
14
        then Text -> Either Text ImageSize
forall a b. a -> Either a b
Left Text
"unable to determine JPEG size"
        else case ByteString
hdr of
               ByteString
"\xff\xd8\xff\xe0" -> ByteString -> Either Text ImageSize
jfifSize ByteString
rest
               ByteString
"\xff\xd8\xff\xe1" -> ByteString -> Either Text ImageSize
exifSize ByteString
rest
               ByteString
_                  -> Text -> Either Text ImageSize
forall a b. a -> Either a b
Left Text
"unable to determine JPEG size"

jfifSize :: ByteString -> Either T.Text ImageSize
jfifSize :: ByteString -> Either Text ImageSize
jfifSize ByteString
rest =
  case (Word8 -> Integer) -> [Word8] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> [Integer]) -> [Word8] -> [Integer]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.take Int
5 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop Int
9 ByteString
rest of
    [Integer
dpiDensity,Integer
dpix1,Integer
dpix2,Integer
dpiy1,Integer
dpiy2] ->
      let factor :: Integer -> Integer
factor = case Integer
dpiDensity of
                        Integer
1 -> Integer -> Integer
forall a. a -> a
id
                        Integer
2 -> \Integer
x -> Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
254 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
10
                        Integer
_ -> Integer -> Integer -> Integer
forall a b. a -> b -> a
const Integer
72
          dpix :: Integer
dpix = Integer -> Integer
factor (Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
dpix1 Int
8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
dpix2)
          dpiy :: Integer
dpiy = Integer -> Integer
factor (Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
dpiy1 Int
8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
dpiy2)
      in case ByteString -> Either Text (Integer, Integer)
findJfifSize ByteString
rest of
         Left Text
msg    -> Text -> Either Text ImageSize
forall a b. a -> Either a b
Left Text
msg
         Right (Integer
w,Integer
h) -> ImageSize -> Either Text ImageSize
forall a b. b -> Either a b
Right ImageSize :: Integer -> Integer -> Integer -> Integer -> ImageSize
ImageSize { pxX :: Integer
pxX = Integer
w
                                        , pxY :: Integer
pxY = Integer
h
                                        , dpiX :: Integer
dpiX = Integer
dpix
                                        , dpiY :: Integer
dpiY = Integer
dpiy }
    [Integer]
_ -> Text -> Either Text ImageSize
forall a b. a -> Either a b
Left Text
"unable to determine JFIF size"

findJfifSize :: ByteString -> Either T.Text (Integer,Integer)
findJfifSize :: ByteString -> Either Text (Integer, Integer)
findJfifSize ByteString
bs =
  let bs' :: ByteString
bs' = (Char -> Bool) -> ByteString -> ByteString
B.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\xff') (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
B.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\xff') ByteString
bs
  in case ByteString -> Maybe (Char, ByteString)
B.uncons ByteString
bs' of
       Just (Char
c,ByteString
bs'') | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\xc0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xc3' ->
         case (Word8 -> Integer) -> [Word8] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> [Integer]) -> [Word8] -> [Integer]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.take Int
4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop Int
3 ByteString
bs'' of
              [Integer
h1,Integer
h2,Integer
w1,Integer
w2] -> (Integer, Integer) -> Either Text (Integer, Integer)
forall a b. b -> Either a b
Right (Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
w1 Int
8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
w2, Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
h1 Int
8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
h2)
              [Integer]
_             -> Text -> Either Text (Integer, Integer)
forall a b. a -> Either a b
Left Text
"JFIF parse error"
       Just (Char
_,ByteString
bs'') ->
         case (Word8 -> Int) -> [Word8] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> [Int]) -> [Word8] -> [Int]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.take Int
2 ByteString
bs'' of
              [Int
c1,Int
c2] ->
                let len :: Int
len = Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shift Int
c1 Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c2
                -- skip variables
                in  ByteString -> Either Text (Integer, Integer)
findJfifSize (ByteString -> Either Text (Integer, Integer))
-> ByteString -> Either Text (Integer, Integer)
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop Int
len ByteString
bs''
              [Int]
_       -> Text -> Either Text (Integer, Integer)
forall a b. a -> Either a b
Left Text
"JFIF parse error"
       Maybe (Char, ByteString)
Nothing -> Text -> Either Text (Integer, Integer)
forall a b. a -> Either a b
Left Text
"Did not find JFIF length record"

runGet' :: Get (Either T.Text a) -> BL.ByteString -> Either T.Text a
runGet' :: Get (Either Text a) -> ByteString -> Either Text a
runGet' Get (Either Text a)
p ByteString
bl =
#if MIN_VERSION_binary(0,7,0)
  case Get (Either Text a)
-> ByteString
-> Either
     (ByteString, ByteOffset, String)
     (ByteString, ByteOffset, Either Text a)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
runGetOrFail Get (Either Text a)
p ByteString
bl of
       Left (ByteString
_,ByteOffset
_,String
msg) -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
msg
       Right (ByteString
_,ByteOffset
_,Either Text a
x)  -> Either Text a
x
#else
  runGet p bl
#endif

exifSize :: ByteString -> Either T.Text ImageSize
exifSize :: ByteString -> Either Text ImageSize
exifSize ByteString
bs = Get (Either Text ImageSize) -> ByteString -> Either Text ImageSize
forall a. Get (Either Text a) -> ByteString -> Either Text a
runGet' Get (Either Text ImageSize)
header ByteString
bl
  where bl :: ByteString
bl = [ByteString] -> ByteString
BL.fromChunks [ByteString
bs]
        header :: Get (Either Text ImageSize)
header = ExceptT Text Get ImageSize -> Get (Either Text ImageSize)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text Get ImageSize -> Get (Either Text ImageSize))
-> ExceptT Text Get ImageSize -> Get (Either Text ImageSize)
forall a b. (a -> b) -> a -> b
$ ByteString -> ExceptT Text Get ImageSize
exifHeader ByteString
bl
-- NOTE:  It would be nicer to do
-- runGet ((Just <$> exifHeader) <|> return Nothing)
-- which would prevent pandoc from raising an error when an exif header can't
-- be parsed.  But we only get an Alternative instance for Get in binary 0.6,
-- and binary 0.5 ships with ghc 7.6.

exifHeader :: BL.ByteString -> ExceptT T.Text Get ImageSize
exifHeader :: ByteString -> ExceptT Text Get ImageSize
exifHeader ByteString
hdr = do
  Word16
_app1DataSize <- Get Word16 -> ExceptT Text Get Word16
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word16
getWord16be
  Word32
exifHdr <- Get Word32 -> ExceptT Text Get Word32
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word32
getWord32be
  Bool -> ExceptT Text Get () -> ExceptT Text Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
exifHdr Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x45786966) (ExceptT Text Get () -> ExceptT Text Get ())
-> ExceptT Text Get () -> ExceptT Text Get ()
forall a b. (a -> b) -> a -> b
$ Text -> ExceptT Text Get ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"Did not find exif header"
  Word16
zeros <- Get Word16 -> ExceptT Text Get Word16
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word16
getWord16be
  Bool -> ExceptT Text Get () -> ExceptT Text Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word16
zeros Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0) (ExceptT Text Get () -> ExceptT Text Get ())
-> ExceptT Text Get () -> ExceptT Text Get ()
forall a b. (a -> b) -> a -> b
$ Text -> ExceptT Text Get ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"Expected zeros after exif header"
  -- beginning of tiff header -- we read whole thing to use
  -- in getting data from offsets:
  let tiffHeader :: ByteString
tiffHeader = ByteOffset -> ByteString -> ByteString
BL.drop ByteOffset
8 ByteString
hdr
  Word16
byteAlign <- Get Word16 -> ExceptT Text Get Word16
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word16
getWord16be
  let bigEndian :: Bool
bigEndian = Word16
byteAlign Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0x4d4d
  let (Get Word16
getWord16, Get Word32
getWord32, Get Word64
getWord64) =
        if Bool
bigEndian
           then (Get Word16
getWord16be, Get Word32
getWord32be, Get Word64
getWord64be)
           else (Get Word16
getWord16le, Get Word32
getWord32le, Get Word64
getWord64le)
  let getRational :: Get Rational
getRational = do
        Word32
num <- Get Word32
getWord32
        Word32
den <- Get Word32
getWord32
        Rational -> Get Rational
forall (m :: * -> *) a. Monad m => a -> m a
return (Rational -> Get Rational) -> Rational -> Get Rational
forall a b. (a -> b) -> a -> b
$ Word32 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
num Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Word32 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
den
  Word16
tagmark <- Get Word16 -> ExceptT Text Get Word16
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word16
getWord16
  Bool -> ExceptT Text Get () -> ExceptT Text Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word16
tagmark Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0x002a) (ExceptT Text Get () -> ExceptT Text Get ())
-> ExceptT Text Get () -> ExceptT Text Get ()
forall a b. (a -> b) -> a -> b
$ Text -> ExceptT Text Get ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"Failed alignment sanity check"
  Word32
ifdOffset <- Get Word32 -> ExceptT Text Get Word32
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word32
getWord32
  Get () -> ExceptT Text Get ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Get () -> ExceptT Text Get ()) -> Get () -> ExceptT Text Get ()
forall a b. (a -> b) -> a -> b
$ Int -> Get ()
skip (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ifdOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8) -- skip to IDF
  Word16
numentries <- Get Word16 -> ExceptT Text Get Word16
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift  Get Word16
getWord16
  let ifdEntry :: ExceptT T.Text Get (TagType, DataFormat)
      ifdEntry :: ExceptT Text Get (TagType, DataFormat)
ifdEntry = do
       TagType
tag <- TagType -> Maybe TagType -> TagType
forall a. a -> Maybe a -> a
fromMaybe TagType
UnknownTagType (Maybe TagType -> TagType)
-> (Word16 -> Maybe TagType) -> Word16 -> TagType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word16 -> Map Word16 TagType -> Maybe TagType)
-> Map Word16 TagType -> Word16 -> Maybe TagType
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word16 -> Map Word16 TagType -> Maybe TagType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map Word16 TagType
tagTypeTable
                (Word16 -> TagType)
-> ExceptT Text Get Word16 -> ExceptT Text Get TagType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16 -> ExceptT Text Get Word16
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word16
getWord16
       Word16
dataFormat <- Get Word16 -> ExceptT Text Get Word16
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word16
getWord16
       Word32
numComponents <- Get Word32 -> ExceptT Text Get Word32
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word32
getWord32
       (Get DataFormat
fmt, Word32
bytesPerComponent) <-
             case Word16
dataFormat of
                  Word16
1  -> (Get DataFormat, Word32)
-> ExceptT Text Get (Get DataFormat, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> DataFormat
UnsignedByte (Word8 -> DataFormat) -> Get Word8 -> Get DataFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8, Word32
1)
                  Word16
2  -> (Get DataFormat, Word32)
-> ExceptT Text Get (Get DataFormat, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> DataFormat
AsciiString (ByteString -> DataFormat) -> Get ByteString -> Get DataFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                ByteOffset -> Get ByteString
getLazyByteString
                                (Word32 -> ByteOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
numComponents), Word32
1)
                  Word16
3  -> (Get DataFormat, Word32)
-> ExceptT Text Get (Get DataFormat, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word16 -> DataFormat
UnsignedShort (Word16 -> DataFormat) -> Get Word16 -> Get DataFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16, Word32
2)
                  Word16
4  -> (Get DataFormat, Word32)
-> ExceptT Text Get (Get DataFormat, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> DataFormat
UnsignedLong (Word32 -> DataFormat) -> Get Word32 -> Get DataFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32, Word32
4)
                  Word16
5  -> (Get DataFormat, Word32)
-> ExceptT Text Get (Get DataFormat, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Rational -> DataFormat
UnsignedRational (Rational -> DataFormat) -> Get Rational -> Get DataFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Rational
getRational, Word32
8)
                  Word16
6  -> (Get DataFormat, Word32)
-> ExceptT Text Get (Get DataFormat, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> DataFormat
SignedByte (Word8 -> DataFormat) -> Get Word8 -> Get DataFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8, Word32
1)
                  Word16
7  -> (Get DataFormat, Word32)
-> ExceptT Text Get (Get DataFormat, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> DataFormat
Undefined (ByteString -> DataFormat) -> Get ByteString -> Get DataFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteOffset -> Get ByteString
getLazyByteString
                                (Word32 -> ByteOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
numComponents), Word32
1)
                  Word16
8  -> (Get DataFormat, Word32)
-> ExceptT Text Get (Get DataFormat, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word16 -> DataFormat
SignedShort (Word16 -> DataFormat) -> Get Word16 -> Get DataFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16, Word32
2)
                  Word16
9  -> (Get DataFormat, Word32)
-> ExceptT Text Get (Get DataFormat, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> DataFormat
SignedLong (Word32 -> DataFormat) -> Get Word32 -> Get DataFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32, Word32
4)
                  Word16
10 -> (Get DataFormat, Word32)
-> ExceptT Text Get (Get DataFormat, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Rational -> DataFormat
SignedRational (Rational -> DataFormat) -> Get Rational -> Get DataFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Rational
getRational, Word32
8)
                  Word16
11 -> (Get DataFormat, Word32)
-> ExceptT Text Get (Get DataFormat, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> DataFormat
SingleFloat (Word32 -> DataFormat) -> Get Word32 -> Get DataFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32 {- TODO -}, Word32
4)
                  Word16
12 -> (Get DataFormat, Word32)
-> ExceptT Text Get (Get DataFormat, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> DataFormat
DoubleFloat (Word64 -> DataFormat) -> Get Word64 -> Get DataFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64 {- TODO -}, Word32
8)
                  Word16
_  -> Text -> ExceptT Text Get (Get DataFormat, Word32)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ExceptT Text Get (Get DataFormat, Word32))
-> Text -> ExceptT Text Get (Get DataFormat, Word32)
forall a b. (a -> b) -> a -> b
$ Text
"Unknown data format " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Word16 -> String
forall a. Show a => a -> String
show Word16
dataFormat)
       let totalBytes :: Int
totalBytes = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ Word32
numComponents Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
bytesPerComponent
       DataFormat
payload <- if Int
totalBytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
4 -- data is right here
                     then Get DataFormat -> ExceptT Text Get DataFormat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Get DataFormat -> ExceptT Text Get DataFormat)
-> Get DataFormat -> ExceptT Text Get DataFormat
forall a b. (a -> b) -> a -> b
$ Get DataFormat
fmt Get DataFormat -> Get () -> Get DataFormat
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Int -> Get ()
skip (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
totalBytes)
                     else do  -- get data from offset
                          Word32
offs <- Get Word32 -> ExceptT Text Get Word32
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word32
getWord32
                          let bytesAtOffset :: ByteString
bytesAtOffset =
                                 ByteOffset -> ByteString -> ByteString
BL.take (Int -> ByteOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
totalBytes)
                                 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteOffset -> ByteString -> ByteString
BL.drop (Word32 -> ByteOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
offs) ByteString
tiffHeader
                          case Get (Either Text DataFormat)
-> ByteString -> Either Text DataFormat
forall a. Get (Either Text a) -> ByteString -> Either Text a
runGet' (DataFormat -> Either Text DataFormat
forall a b. b -> Either a b
Right (DataFormat -> Either Text DataFormat)
-> Get DataFormat -> Get (Either Text DataFormat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get DataFormat
fmt) ByteString
bytesAtOffset of
                               Left Text
msg -> Text -> ExceptT Text Get DataFormat
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
msg
                               Right DataFormat
x  -> DataFormat -> ExceptT Text Get DataFormat
forall (m :: * -> *) a. Monad m => a -> m a
return DataFormat
x
       (TagType, DataFormat) -> ExceptT Text Get (TagType, DataFormat)
forall (m :: * -> *) a. Monad m => a -> m a
return (TagType
tag, DataFormat
payload)
  [(TagType, DataFormat)]
entries <- Int
-> ExceptT Text Get (TagType, DataFormat)
-> ExceptT Text Get [(TagType, DataFormat)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
numentries) ExceptT Text Get (TagType, DataFormat)
ifdEntry
  [(TagType, DataFormat)]
subentries <- case TagType -> [(TagType, DataFormat)] -> Maybe DataFormat
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TagType
ExifOffset [(TagType, DataFormat)]
entries of
                      Just (UnsignedLong Word32
offset') -> do
                        ByteOffset
pos <- Get ByteOffset -> ExceptT Text Get ByteOffset
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get ByteOffset
bytesRead
                        Get () -> ExceptT Text Get ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Get () -> ExceptT Text Get ()) -> Get () -> ExceptT Text Get ()
forall a b. (a -> b) -> a -> b
$ Int -> Get ()
skip (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
offset' Int -> Int -> Int
forall a. Num a => a -> a -> a
- (ByteOffset -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteOffset
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8))
                        Word16
numsubentries <- Get Word16 -> ExceptT Text Get Word16
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word16
getWord16
                        Int
-> ExceptT Text Get (TagType, DataFormat)
-> ExceptT Text Get [(TagType, DataFormat)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
numsubentries) ExceptT Text Get (TagType, DataFormat)
ifdEntry
                      Maybe DataFormat
_ -> [(TagType, DataFormat)] -> ExceptT Text Get [(TagType, DataFormat)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  let allentries :: [(TagType, DataFormat)]
allentries = [(TagType, DataFormat)]
entries [(TagType, DataFormat)]
-> [(TagType, DataFormat)] -> [(TagType, DataFormat)]
forall a. [a] -> [a] -> [a]
++ [(TagType, DataFormat)]
subentries
  (Integer
wdth, Integer
hght) <- case (TagType -> [(TagType, DataFormat)] -> Maybe DataFormat
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TagType
ExifImageWidth [(TagType, DataFormat)]
allentries,
                        TagType -> [(TagType, DataFormat)] -> Maybe DataFormat
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TagType
ExifImageHeight [(TagType, DataFormat)]
allentries) of
                       (Just (UnsignedLong Word32
w), Just (UnsignedLong Word32
h)) ->
                         (Integer, Integer) -> ExceptT Text Get (Integer, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w, Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
h)
                       (Maybe DataFormat, Maybe DataFormat)
_ -> (Integer, Integer) -> ExceptT Text Get (Integer, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer, Integer)
defaultSize
                            -- we return a default width and height when
                            -- the exif header doesn't contain these
  let resfactor :: Rational
resfactor = case TagType -> [(TagType, DataFormat)] -> Maybe DataFormat
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TagType
ResolutionUnit [(TagType, DataFormat)]
allentries of
                        Just (UnsignedShort Word16
1) -> Rational
100 Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
254
                        Maybe DataFormat
_ -> Rational
1
  let xres :: Integer
xres = case TagType -> [(TagType, DataFormat)] -> Maybe DataFormat
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TagType
XResolution [(TagType, DataFormat)]
allentries of
                  Just (UnsignedRational Rational
x) -> Rational -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
resfactor)
                  Maybe DataFormat
_ -> Integer
72
  let yres :: Integer
yres = case TagType -> [(TagType, DataFormat)] -> Maybe DataFormat
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TagType
YResolution [(TagType, DataFormat)]
allentries of
                  Just (UnsignedRational Rational
y) -> Rational -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational
y Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
resfactor)
                  Maybe DataFormat
_ -> Integer
72
  ImageSize -> ExceptT Text Get ImageSize
forall (m :: * -> *) a. Monad m => a -> m a
return ImageSize :: Integer -> Integer -> Integer -> Integer -> ImageSize
ImageSize{
                    pxX :: Integer
pxX  = Integer
wdth
                  , pxY :: Integer
pxY  = Integer
hght
                  , dpiX :: Integer
dpiX = Integer
xres
                  , dpiY :: Integer
dpiY = Integer
yres }

data DataFormat = UnsignedByte Word8
                | AsciiString BL.ByteString
                | UnsignedShort Word16
                | UnsignedLong Word32
                | UnsignedRational Rational
                | SignedByte Word8
                | Undefined BL.ByteString
                | SignedShort Word16
                | SignedLong Word32
                | SignedRational Rational
                | SingleFloat Word32
                | DoubleFloat Word64
                deriving (Int -> DataFormat -> ShowS
[DataFormat] -> ShowS
DataFormat -> String
(Int -> DataFormat -> ShowS)
-> (DataFormat -> String)
-> ([DataFormat] -> ShowS)
-> Show DataFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DataFormat] -> ShowS
$cshowList :: [DataFormat] -> ShowS
show :: DataFormat -> String
$cshow :: DataFormat -> String
showsPrec :: Int -> DataFormat -> ShowS
$cshowsPrec :: Int -> DataFormat -> ShowS
Show)

data TagType = ImageDescription
             | Make
             | Model
             | Orientation
             | XResolution
             | YResolution
             | ResolutionUnit
             | Software
             | DateTime
             | WhitePoint
             | PrimaryChromaticities
             | YCbCrCoefficients
             | YCbCrPositioning
             | ReferenceBlackWhite
             | Copyright
             | ExifOffset
             | ExposureTime
             | FNumber
             | ExposureProgram
             | ISOSpeedRatings
             | ExifVersion
             | DateTimeOriginal
             | DateTimeDigitized
             | ComponentConfiguration
             | CompressedBitsPerPixel
             | ShutterSpeedValue
             | ApertureValue
             | BrightnessValue
             | ExposureBiasValue
             | MaxApertureValue
             | SubjectDistance
             | MeteringMode
             | LightSource
             | Flash
             | FocalLength
             | MakerNote
             | UserComment
             | FlashPixVersion
             | ColorSpace
             | ExifImageWidth
             | ExifImageHeight
             | RelatedSoundFile
             | ExifInteroperabilityOffset
             | FocalPlaneXResolution
             | FocalPlaneYResolution
             | FocalPlaneResolutionUnit
             | SensingMethod
             | FileSource
             | SceneType
             | UnknownTagType
             deriving (Int -> TagType -> ShowS
[TagType] -> ShowS
TagType -> String
(Int -> TagType -> ShowS)
-> (TagType -> String) -> ([TagType] -> ShowS) -> Show TagType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TagType] -> ShowS
$cshowList :: [TagType] -> ShowS
show :: TagType -> String
$cshow :: TagType -> String
showsPrec :: Int -> TagType -> ShowS
$cshowsPrec :: Int -> TagType -> ShowS
Show, TagType -> TagType -> Bool
(TagType -> TagType -> Bool)
-> (TagType -> TagType -> Bool) -> Eq TagType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagType -> TagType -> Bool
$c/= :: TagType -> TagType -> Bool
== :: TagType -> TagType -> Bool
$c== :: TagType -> TagType -> Bool
Eq, Eq TagType
Eq TagType
-> (TagType -> TagType -> Ordering)
-> (TagType -> TagType -> Bool)
-> (TagType -> TagType -> Bool)
-> (TagType -> TagType -> Bool)
-> (TagType -> TagType -> Bool)
-> (TagType -> TagType -> TagType)
-> (TagType -> TagType -> TagType)
-> Ord TagType
TagType -> TagType -> Bool
TagType -> TagType -> Ordering
TagType -> TagType -> TagType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TagType -> TagType -> TagType
$cmin :: TagType -> TagType -> TagType
max :: TagType -> TagType -> TagType
$cmax :: TagType -> TagType -> TagType
>= :: TagType -> TagType -> Bool
$c>= :: TagType -> TagType -> Bool
> :: TagType -> TagType -> Bool
$c> :: TagType -> TagType -> Bool
<= :: TagType -> TagType -> Bool
$c<= :: TagType -> TagType -> Bool
< :: TagType -> TagType -> Bool
$c< :: TagType -> TagType -> Bool
compare :: TagType -> TagType -> Ordering
$ccompare :: TagType -> TagType -> Ordering
$cp1Ord :: Eq TagType
Ord)

tagTypeTable :: M.Map Word16 TagType
tagTypeTable :: Map Word16 TagType
tagTypeTable = [(Word16, TagType)] -> Map Word16 TagType
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (Word16
0x010e, TagType
ImageDescription)
  , (Word16
0x010f, TagType
Make)
  , (Word16
0x0110, TagType
Model)
  , (Word16
0x0112, TagType
Orientation)
  , (Word16
0x011a, TagType
XResolution)
  , (Word16
0x011b, TagType
YResolution)
  , (Word16
0x0128, TagType
ResolutionUnit)
  , (Word16
0x0131, TagType
Software)
  , (Word16
0x0132, TagType
DateTime)
  , (Word16
0x013e, TagType
WhitePoint)
  , (Word16
0x013f, TagType
PrimaryChromaticities)
  , (Word16
0x0211, TagType
YCbCrCoefficients)
  , (Word16
0x0213, TagType
YCbCrPositioning)
  , (Word16
0x0214, TagType
ReferenceBlackWhite)
  , (Word16
0x8298, TagType
Copyright)
  , (Word16
0x8769, TagType
ExifOffset)
  , (Word16
0x829a, TagType
ExposureTime)
  , (Word16
0x829d, TagType
FNumber)
  , (Word16
0x8822, TagType
ExposureProgram)
  , (Word16
0x8827, TagType
ISOSpeedRatings)
  , (Word16
0x9000, TagType
ExifVersion)
  , (Word16
0x9003, TagType
DateTimeOriginal)
  , (Word16
0x9004, TagType
DateTimeDigitized)
  , (Word16
0x9101, TagType
ComponentConfiguration)
  , (Word16
0x9102, TagType
CompressedBitsPerPixel)
  , (Word16
0x9201, TagType
ShutterSpeedValue)
  , (Word16
0x9202, TagType
ApertureValue)
  , (Word16
0x9203, TagType
BrightnessValue)
  , (Word16
0x9204, TagType
ExposureBiasValue)
  , (Word16
0x9205, TagType
MaxApertureValue)
  , (Word16
0x9206, TagType
SubjectDistance)
  , (Word16
0x9207, TagType
MeteringMode)
  , (Word16
0x9208, TagType
LightSource)
  , (Word16
0x9209, TagType
Flash)
  , (Word16
0x920a, TagType
FocalLength)
  , (Word16
0x927c, TagType
MakerNote)
  , (Word16
0x9286, TagType
UserComment)
  , (Word16
0xa000, TagType
FlashPixVersion)
  , (Word16
0xa001, TagType
ColorSpace)
  , (Word16
0xa002, TagType
ExifImageWidth)
  , (Word16
0xa003, TagType
ExifImageHeight)
  , (Word16
0xa004, TagType
RelatedSoundFile)
  , (Word16
0xa005, TagType
ExifInteroperabilityOffset)
  , (Word16
0xa20e, TagType
FocalPlaneXResolution)
  , (Word16
0xa20f, TagType
FocalPlaneYResolution)
  , (Word16
0xa210, TagType
FocalPlaneResolutionUnit)
  , (Word16
0xa217, TagType
SensingMethod)
  , (Word16
0xa300, TagType
FileSource)
  , (Word16
0xa301, TagType
SceneType)
  ]