{-# 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 Width  = "width"
  show Height = "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 a :: Integer
a)      = Integer -> String
forall a. Show a => a -> String
show Integer
a              String -> ShowS
forall a. [a] -> [a] -> [a]
++ "px"
  show (Centimeter a :: Double
a) = Text -> String
T.unpack (Double -> Text
forall a. RealFloat a => a -> Text
showFl Double
a) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "cm"
  show (Millimeter a :: Double
a) = Text -> String
T.unpack (Double -> Text
forall a. RealFloat a => a -> Text
showFl Double
a) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "mm"
  show (Inch a :: Double
a)       = Text -> String
T.unpack (Double -> Text
forall a. RealFloat a => a -> Text
showFl Double
a) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "in"
  show (Percent a :: Double
a)    = Double -> String
forall a. Show a => a -> String
show Double
a              String -> ShowS
forall a. [a] -> [a] -> [a]
++ "%"
  show (Em a :: Double
a)         = Text -> String
T.unpack (Double -> Text
forall a. RealFloat a => a -> Text
showFl Double
a) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "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 300 200 72 72

showFl :: (RealFloat a) => a -> T.Text
showFl :: a -> Text
showFl a :: 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 5) a
a ""

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

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

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

imageSize :: WriterOptions -> ByteString -> Either T.Text ImageSize
imageSize :: WriterOptions -> ByteString -> Either Text ImageSize
imageSize opts :: WriterOptions
opts img :: ByteString
img =
  case ByteString -> Maybe ImageType
imageType ByteString
img of
       Just Png  -> Text -> Maybe ImageSize -> Either Text ImageSize
forall a b. a -> Maybe b -> Either a b
mbToEither "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 Gif  -> Text -> Maybe ImageSize -> Either Text ImageSize
forall a b. a -> Maybe b -> Either a b
mbToEither "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 Jpeg -> ByteString -> Either Text ImageSize
jpegSize ByteString
img
       Just Svg  -> Text -> Maybe ImageSize -> Either Text ImageSize
forall a b. a -> Maybe b -> Either a b
mbToEither "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 Eps  -> Text -> Maybe ImageSize -> Either Text ImageSize
forall a b. a -> Maybe b -> Either a b
mbToEither "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 Pdf  -> Text -> Maybe ImageSize -> Either Text ImageSize
forall a b. a -> Maybe b -> Either a b
mbToEither "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 Emf  -> Text -> Maybe ImageSize -> Either Text ImageSize
forall a b. a -> Maybe b -> Either a b
mbToEither "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
       Nothing   -> Text -> Either Text ImageSize
forall a b. a -> Either a b
Left "could not determine image type"
  where mbToEither :: a -> Maybe b -> Either a b
mbToEither msg :: a
msg Nothing  = a -> Either a b
forall a b. a -> Either a b
Left a
msg
        mbToEither _   (Just x :: b
x) = b -> Either a b
forall a b. b -> Either a b
Right b
x

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

sizeInPixels :: ImageSize -> (Integer, Integer)
sizeInPixels :: ImageSize -> (Integer, Integer)
sizeInPixels s :: 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 s :: ImageSize
s = (Double
pxXf Double -> Double -> Double
forall a. Num a => a -> a -> a
* 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
* 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 opts :: WriterOptions
opts attr :: Attr
attr s :: ImageSize
s =
  case (Direction -> Maybe Double
getDim Direction
Width, Direction -> Maybe Double
getDim Direction
Height) of
    (Just w :: Double
w, Just h :: Double
h)   -> (Double
w, Double
h)
    (Just w :: Double
w, Nothing)  -> (Double
w, Double
w Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
ratio)
    (Nothing, Just h :: Double
h)  -> (Double
h Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ratio, Double
h)
    (Nothing, 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 dir :: Direction
dir = case Direction -> Attr -> Maybe Dimension
dimension Direction
dir Attr
attr of
                   Just (Percent _) -> Maybe Double
forall a. Maybe a
Nothing
                   Just dim :: 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
                   Nothing          -> Maybe Double
forall a. Maybe a
Nothing

inPoints :: WriterOptions -> Dimension -> Double
inPoints :: WriterOptions -> Dimension -> Double
inPoints opts :: WriterOptions
opts dim :: Dimension
dim = 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 opts :: WriterOptions
opts dim :: Dimension
dim = (64Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/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 opts :: WriterOptions
opts dim :: Dimension
dim =
  case Dimension
dim of
    (Pixel a :: 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 a :: Double
a) -> Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* 0.3937007874
    (Millimeter a :: Double
a) -> Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* 0.03937007874
    (Inch a :: Double
a)       -> Double
a
    (Percent _)    -> 0
    (Em a :: Double
a)         -> Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* (11Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/64)

inPixel :: WriterOptions -> Dimension -> Integer
inPixel :: WriterOptions -> Dimension -> Integer
inPixel opts :: WriterOptions
opts dim :: Dimension
dim =
  case Dimension
dim of
    (Pixel a :: Integer
a)      -> Integer
a
    (Centimeter a :: 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
* 0.3937007874 :: Integer
    (Millimeter a :: 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
* 0.03937007874 :: Integer
    (Inch a :: 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 _)    -> 0
    (Em a :: 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
* (11Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/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 _ (Percent _) = ""
showInInch opts :: WriterOptions
opts dim :: 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 _ (Percent _) = ""
showInPixel opts :: WriterOptions
opts dim :: 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 s :: Text
s =
  let (nums :: Text
nums, unit :: Text
unit) = (Char -> Bool) -> Text -> (Text, Text)
T.span (\c :: Char
c -> Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| ('.'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
c)) Text
s
  in (\n :: 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 factor :: Double
factor dim :: Dimension
dim =
  case Dimension
dim of
        Pixel x :: 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 x :: Double
x -> Double -> Dimension
Centimeter (Double
factor Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x)
        Millimeter x :: Double
x -> Double -> Dimension
Millimeter (Double
factor Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x)
        Inch x :: Double
x       -> Double -> Dimension
Inch (Double
factor Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x)
        Percent x :: Double
x    -> Double -> Dimension
Percent (Double
factor Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x)
        Em x :: 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 dir :: Direction
dir (_, _, kvs :: [(Text, Text)]
kvs) =
  case Direction
dir of
    Width  -> Text -> Maybe Dimension
extractDim "width"
    Height -> Text -> Maybe Dimension
extractDim "height"
  where
    extractDim :: Text -> Maybe Dimension
extractDim key :: 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 s :: 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 a :: Double
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 a :: Double
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 a :: Double
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 a :: Double
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 a :: Double
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 a :: Double
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 a :: Double
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 a :: Double
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
/ 72)
    toDim a :: Double
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
/ 6)
    toDim a :: Double
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 _ _      = Maybe Dimension
forall a. Maybe a
Nothing

epsSize :: ByteString -> Maybe ImageSize
epsSize :: ByteString -> Maybe ImageSize
epsSize img :: ByteString
img = do
  let ls :: [ByteString]
ls = (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ("%" 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
. ("%%BoundingBox:" ByteString -> ByteString -> Bool
`B.isPrefixOf`)) [ByteString]
ls
  case [ByteString]
ls' of
       []    -> Maybe ImageSize
forall (m :: * -> *) a. MonadPlus m => m a
mzero
       (x :: ByteString
x:_) -> case ByteString -> [ByteString]
B.words ByteString
x of
                     [_, _, _, ux :: ByteString
ux, uy :: 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 = 72
                          , dpiY :: Integer
dpiY = 72 }
                     _ -> Maybe ImageSize
forall (m :: * -> *) a. MonadPlus m => m a
mzero

pdfSize :: ByteString -> Maybe ImageSize
pdfSize :: ByteString -> Maybe ImageSize
pdfSize img :: 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 _   -> Maybe ImageSize
forall a. Maybe a
Nothing
    Right sz :: 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 -> Parser Word8
A.char8 '/'
  (do ByteString -> Parser ByteString
A.string "MediaBox"
      Parser ()
A.skipSpace
      Char -> Parser Word8
A.char8 '['
      Parser ()
A.skipSpace
      [x1 :: Integer
x1,y1 :: Integer
y1,x2 :: Integer
x2,y2 :: Integer
y2] <- Int -> Parser ByteString Integer -> Parser ByteString [Integer]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
A.count 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 (\c :: Char
c -> Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.')
        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
          Nothing            -> Parser ByteString Integer
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      Parser ()
A.skipSpace
      Char -> Parser Word8
A.char8 ']'
      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 = 72
            , dpiY :: Integer
dpiY = 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 img :: ByteString
img = do
  let (h :: ByteString
h, rest :: ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt 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
== "\x8a\x4d\x4e\x47\x0d\x0a\x1a\x0a" Bool -> Bool -> Bool
||
          ByteString
h ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "\x89\x50\x4e\x47\x0d\x0a\x1a\x0a"
  let (i :: ByteString
i, rest' :: ByteString
rest') = Int -> ByteString -> (ByteString, ByteString)
B.splitAt 4 (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop 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
== "MHDR" Bool -> Bool -> Bool
|| ByteString
i ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "IHDR"
  let (sizes :: ByteString
sizes, rest'' :: ByteString
rest'') = Int -> ByteString -> (ByteString, ByteString)
B.splitAt 8 ByteString
rest'
  (x :: Integer
x,y :: 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
                ([w1 :: Integer
w1,w2 :: Integer
w2,w3 :: Integer
w3,w4 :: Integer
w4,h1 :: Integer
h1,h2 :: Integer
h2,h3 :: Integer
h3,h4 :: 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 24 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
w2 16 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
w3 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 24 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
h2 16 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
h3 8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
h4)
                _ -> Maybe (Integer, Integer)
forall a. Maybe a
Nothing -- "PNG parse error"
  (dpix :: Integer
dpix, dpiy :: 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 x :: ByteString
x
  | ByteString -> Bool
B.null ByteString
x Bool -> Bool -> Bool
|| "IDAT" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
x = (Integer, Integer) -> Maybe (Integer, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (72,72)
  | "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 9 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop 4 ByteString
x of
         [x1 :: Integer
x1,x2 :: Integer
x2,x3 :: Integer
x3,x4 :: Integer
x4,y1 :: Integer
y1,y2 :: Integer
y2,y3 :: Integer
y3,y4 :: Integer
y4,u :: Integer
u] -> do
           let factor :: Integer -> Integer
factor = if Integer
u Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 1 -- dots per meter
                          then \z :: Integer
z -> Integer
z Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 254 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` 10000
                          else Integer -> Integer -> Integer
forall a b. a -> b -> a
const 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 24 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
x2 16 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
x3 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 24 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
y2 16 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
y3 8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
y4 )
         _ -> 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 1 ByteString
x  -- read another byte

gifSize :: ByteString -> Maybe ImageSize
gifSize :: ByteString -> Maybe ImageSize
gifSize img :: ByteString
img = do
  let (h :: ByteString
h, rest :: ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt 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
== "GIF87a" Bool -> Bool -> Bool
|| ByteString
h ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== "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 4 ByteString
rest of
       [w2 :: Integer
w2,w1 :: Integer
w1,h2 :: Integer
h2,h1 :: 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 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 8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
h2,
                          dpiX :: Integer
dpiX = 72,
                          dpiY :: Integer
dpiY = 72
                          }
       _             -> Maybe ImageSize
forall a. Maybe a
Nothing -- "GIF parse error"

svgSize :: WriterOptions -> ByteString -> Maybe ImageSize
svgSize :: WriterOptions -> ByteString -> Maybe ImageSize
svgSize opts :: WriterOptions
opts img :: 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 dir :: 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 "width"
  Integer
h <- String -> Maybe Integer
dirToInt "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 img :: 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 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 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
* 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
* 100)
        dpiW :: Word32
dpiW = (Word32
deviceX Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* 254) Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`quot` (Word32
mmX Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* 10)
        dpiH :: Word32
dpiH = (Word32
deviceY Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* 254) Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`quot` (Word32
mmY Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* 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 _ -> Maybe ImageSize
forall a. Maybe a
Nothing
      Right (_, _, size :: 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 img :: ByteString
img =
  let (hdr :: ByteString
hdr, rest :: ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt 4 ByteString
img
  in if ByteString -> Int
B.length ByteString
rest Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 14
        then Text -> Either Text ImageSize
forall a b. a -> Either a b
Left "unable to determine JPEG size"
        else case ByteString
hdr of
               "\xff\xd8\xff\xe0" -> ByteString -> Either Text ImageSize
jfifSize ByteString
rest
               "\xff\xd8\xff\xe1" -> ByteString -> Either Text ImageSize
exifSize ByteString
rest
               _                  -> Text -> Either Text ImageSize
forall a b. a -> Either a b
Left "unable to determine JPEG size"

jfifSize :: ByteString -> Either T.Text ImageSize
jfifSize :: ByteString -> Either Text ImageSize
jfifSize rest :: 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 5 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop 9 ByteString
rest of
    [dpiDensity :: Integer
dpiDensity,dpix1 :: Integer
dpix1,dpix2 :: Integer
dpix2,dpiy1 :: Integer
dpiy1,dpiy2 :: Integer
dpiy2] ->
      let factor :: Integer -> Integer
factor = case Integer
dpiDensity of
                        1 -> Integer -> Integer
forall a. a -> a
id
                        2 -> \x :: Integer
x -> Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 254 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` 10
                        _ -> Integer -> Integer -> Integer
forall a b. a -> b -> a
const 72
          dpix :: Integer
dpix = Integer -> Integer
factor (Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shift Integer
dpix1 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 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 msg :: Text
msg    -> Text -> Either Text ImageSize
forall a b. a -> Either a b
Left Text
msg
         Right (w :: Integer
w,h :: 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 }
    _ -> Text -> Either Text ImageSize
forall a b. a -> Either a b
Left "unable to determine JFIF size"

findJfifSize :: ByteString -> Either T.Text (Integer,Integer)
findJfifSize :: ByteString -> Either Text (Integer, Integer)
findJfifSize bs :: ByteString
bs =
  let bs' :: ByteString
bs' = (Char -> Bool) -> ByteString -> ByteString
B.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='\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
/='\xff') ByteString
bs
  in case ByteString -> Maybe (Char, ByteString)
B.uncons ByteString
bs' of
       Just (c :: Char
c,bs'' :: ByteString
bs'') | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '\xc0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '\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 4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop 3 ByteString
bs'' of
              [h1 :: Integer
h1,h2 :: Integer
h2,w1 :: Integer
w1,w2 :: 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 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 8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
h2)
              _             -> Text -> Either Text (Integer, Integer)
forall a b. a -> Either a b
Left "JFIF parse error"
       Just (_,bs'' :: 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 2 ByteString
bs'' of
              [c1 :: Int
c1,c2 :: Int
c2] ->
                let len :: Int
len = Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shift Int
c1 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''
              _       -> Text -> Either Text (Integer, Integer)
forall a b. a -> Either a b
Left "JFIF parse error"
       Nothing -> Text -> Either Text (Integer, Integer)
forall a b. a -> Either a b
Left "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' p :: Get (Either Text a)
p bl :: 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 (_,_,msg :: 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 (_,_,x :: 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 bs :: 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 hdr :: 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
== 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 "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
== 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 "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 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
== 0x4d4d
  let (getWord16 :: Get Word16
getWord16, getWord32 :: Get Word32
getWord32, getWord64 :: 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
== 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 "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
- 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
       (fmt :: Get DataFormat
fmt, bytesPerComponent :: Word32
bytesPerComponent) <-
             case Word16
dataFormat of
                  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, 1)
                  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), 1)
                  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, 2)
                  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, 4)
                  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, 8)
                  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, 1)
                  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), 1)
                  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, 2)
                  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, 4)
                  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, 8)
                  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 -}, 4)
                  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 -}, 8)
                  _  -> 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
$ "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
<= 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 (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 msg :: Text
msg -> Text -> ExceptT Text Get DataFormat
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
msg
                               Right x :: 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 offset' :: 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
- 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
                      _ -> [(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
  (wdth :: Integer
wdth, hght :: 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 w :: Word32
w), Just (UnsignedLong h :: 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)
                       _ -> (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 1) -> 100 Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ 254
                        _ -> 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 x :: 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)
                  _ -> 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 y :: 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)
                  _ -> 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
  [ (0x010e, TagType
ImageDescription)
  , (0x010f, TagType
Make)
  , (0x0110, TagType
Model)
  , (0x0112, TagType
Orientation)
  , (0x011a, TagType
XResolution)
  , (0x011b, TagType
YResolution)
  , (0x0128, TagType
ResolutionUnit)
  , (0x0131, TagType
Software)
  , (0x0132, TagType
DateTime)
  , (0x013e, TagType
WhitePoint)
  , (0x013f, TagType
PrimaryChromaticities)
  , (0x0211, TagType
YCbCrCoefficients)
  , (0x0213, TagType
YCbCrPositioning)
  , (0x0214, TagType
ReferenceBlackWhite)
  , (0x8298, TagType
Copyright)
  , (0x8769, TagType
ExifOffset)
  , (0x829a, TagType
ExposureTime)
  , (0x829d, TagType
FNumber)
  , (0x8822, TagType
ExposureProgram)
  , (0x8827, TagType
ISOSpeedRatings)
  , (0x9000, TagType
ExifVersion)
  , (0x9003, TagType
DateTimeOriginal)
  , (0x9004, TagType
DateTimeDigitized)
  , (0x9101, TagType
ComponentConfiguration)
  , (0x9102, TagType
CompressedBitsPerPixel)
  , (0x9201, TagType
ShutterSpeedValue)
  , (0x9202, TagType
ApertureValue)
  , (0x9203, TagType
BrightnessValue)
  , (0x9204, TagType
ExposureBiasValue)
  , (0x9205, TagType
MaxApertureValue)
  , (0x9206, TagType
SubjectDistance)
  , (0x9207, TagType
MeteringMode)
  , (0x9208, TagType
LightSource)
  , (0x9209, TagType
Flash)
  , (0x920a, TagType
FocalLength)
  , (0x927c, TagType
MakerNote)
  , (0x9286, TagType
UserComment)
  , (0xa000, TagType
FlashPixVersion)
  , (0xa001, TagType
ColorSpace)
  , (0xa002, TagType
ExifImageWidth)
  , (0xa003, TagType
ExifImageHeight)
  , (0xa004, TagType
RelatedSoundFile)
  , (0xa005, TagType
ExifInteroperabilityOffset)
  , (0xa20e, TagType
FocalPlaneXResolution)
  , (0xa20f, TagType
FocalPlaneYResolution)
  , (0xa210, TagType
FocalPlaneResolutionUnit)
  , (0xa217, TagType
SensingMethod)
  , (0xa300, TagType
FileSource)
  , (0xa301, TagType
SceneType)
  ]