{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE CPP #-}
-- | Module implementing TIFF decoding.

--

-- Supported compression schemes:

--

--   * Uncompressed

--

--   * PackBits

--

--   * LZW

--

-- Supported bit depth:

--

--   * 2 bits

--

--   * 4 bits

--

--   * 8 bits

--

--   * 16 bits

--

module Codec.Picture.Tiff( decodeTiff
                         , decodeTiffWithMetadata
                         , decodeTiffWithPaletteAndMetadata
                         , TiffSaveable
                         , encodeTiff
                         , writeTiff
                         ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( (<$>), (<*>), pure )
import Data.Monoid( mempty )
#endif

import Control.Arrow( first )
import Control.Monad( when, foldM_, unless, forM_ )
import Control.Monad.ST( ST, runST )
import Control.Monad.Writer.Strict( execWriter, tell, Writer )
import Data.Int( Int8 )
import Data.Word( Word8, Word16, Word32 )
import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR )
import Data.Binary.Get( Get )
import Data.Binary.Put( runPut )

import qualified Data.Vector as V
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Storable.Mutable as M
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as Lb
import qualified Data.ByteString.Unsafe as BU

import Foreign.Storable( sizeOf )

import Codec.Picture.Metadata.Exif
import Codec.Picture.Metadata( Metadatas )
import Codec.Picture.InternalHelper
import Codec.Picture.BitWriter
import Codec.Picture.Types
import Codec.Picture.Gif.Internal.LZW
import Codec.Picture.Tiff.Internal.Types
import Codec.Picture.Tiff.Internal.Metadata
import Codec.Picture.VectorByteConversion( toByteString )

data TiffInfo = TiffInfo
  { TiffInfo -> TiffHeader
tiffHeader             :: TiffHeader
  , TiffInfo -> Pixel32
tiffWidth              :: Word32
  , TiffInfo -> Pixel32
tiffHeight             :: Word32
  , TiffInfo -> TiffColorspace
tiffColorspace         :: TiffColorspace
  , TiffInfo -> Pixel32
tiffSampleCount        :: Word32
  , TiffInfo -> Pixel32
tiffRowPerStrip        :: Word32
  , TiffInfo -> TiffPlanarConfiguration
tiffPlaneConfiguration :: TiffPlanarConfiguration
  , TiffInfo -> [TiffSampleFormat]
tiffSampleFormat       :: [TiffSampleFormat]
  , TiffInfo -> Vector Pixel32
tiffBitsPerSample      :: V.Vector Word32
  , TiffInfo -> TiffCompression
tiffCompression        :: TiffCompression
  , TiffInfo -> Vector Pixel32
tiffStripSize          :: V.Vector Word32
  , TiffInfo -> Vector Pixel32
tiffOffsets            :: V.Vector Word32
  , TiffInfo -> Maybe (Image PixelRGB16)
tiffPalette            :: Maybe (Image PixelRGB16)
  , TiffInfo -> Vector Pixel32
tiffYCbCrSubsampling   :: V.Vector Word32
  , TiffInfo -> Maybe ExtraSample
tiffExtraSample        :: Maybe ExtraSample
  , TiffInfo -> Predictor
tiffPredictor          :: Predictor
  , TiffInfo -> Metadatas
tiffMetadatas          :: Metadatas
  }

unLong :: String -> ExifData -> Get (V.Vector Word32)
unLong :: String -> ExifData -> Get (Vector Pixel32)
unLong String
_ (ExifLong Pixel32
v)   = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Vector a
V.singleton Pixel32
v
unLong String
_ (ExifShort Pixel16
v)  = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Vector a
V.singleton (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel16
v)
unLong String
_ (ExifShorts Vector Pixel16
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> Vector a -> Vector b
V.map forall a b. (Integral a, Num b) => a -> b
fromIntegral Vector Pixel16
v
unLong String
_ (ExifLongs Vector Pixel32
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Vector Pixel32
v
unLong String
errMessage ExifData
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
errMessage

findIFD :: String -> ExifTag -> [ImageFileDirectory]
        -> Get ImageFileDirectory
findIFD :: String -> ExifTag -> [ImageFileDirectory] -> Get ImageFileDirectory
findIFD String
errorMessage ExifTag
tag [ImageFileDirectory]
lst =
  case [ImageFileDirectory
v | ImageFileDirectory
v <- [ImageFileDirectory]
lst, ImageFileDirectory -> ExifTag
ifdIdentifier ImageFileDirectory
v forall a. Eq a => a -> a -> Bool
== ExifTag
tag] of
    [] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
errorMessage
    (ImageFileDirectory
x:[ImageFileDirectory]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ImageFileDirectory
x

findPalette :: [ImageFileDirectory] -> Get (Maybe (Image PixelRGB16))
findPalette :: [ImageFileDirectory] -> Get (Maybe (Image PixelRGB16))
findPalette [ImageFileDirectory]
ifds =
    case [ImageFileDirectory
v | ImageFileDirectory
v <- [ImageFileDirectory]
ifds, ImageFileDirectory -> ExifTag
ifdIdentifier ImageFileDirectory
v forall a. Eq a => a -> a -> Bool
== ExifTag
TagColorMap] of
        (ImageFileDirectory { ifdExtended :: ImageFileDirectory -> ExifData
ifdExtended = ExifShorts Vector Pixel16
vec }:[ImageFileDirectory]
_) ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
pixelCount Int
1 forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Int -> (Int -> a) -> Vector a
VS.generate (forall a. Vector a -> Int
V.length Vector Pixel16
vec) Int -> Pixel16
axx
                where pixelCount :: Int
pixelCount = forall a. Vector a -> Int
V.length Vector Pixel16
vec forall a. Integral a => a -> a -> a
`div` Int
3
                      axx :: Int -> Pixel16
axx Int
v = Vector Pixel16
vec forall a. Vector a -> Int -> a
`V.unsafeIndex` (Int
idx forall a. Num a => a -> a -> a
+ Int
color forall a. Num a => a -> a -> a
* Int
pixelCount)
                          where (Int
idx, Int
color) = Int
v forall a. Integral a => a -> a -> (a, a)
`divMod` Int
3

        [ImageFileDirectory]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

findIFDData :: String -> ExifTag -> [ImageFileDirectory] -> Get Word32
findIFDData :: String -> ExifTag -> [ImageFileDirectory] -> Get Pixel32
findIFDData String
msg ExifTag
tag [ImageFileDirectory]
lst = ImageFileDirectory -> Pixel32
ifdOffset forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ExifTag -> [ImageFileDirectory] -> Get ImageFileDirectory
findIFD String
msg ExifTag
tag [ImageFileDirectory]
lst

findIFDDefaultData :: Word32 -> ExifTag -> [ImageFileDirectory] -> Get Word32
findIFDDefaultData :: Pixel32 -> ExifTag -> [ImageFileDirectory] -> Get Pixel32
findIFDDefaultData Pixel32
d ExifTag
tag [ImageFileDirectory]
lst =
    case [ImageFileDirectory
v | ImageFileDirectory
v <- [ImageFileDirectory]
lst, ImageFileDirectory -> ExifTag
ifdIdentifier ImageFileDirectory
v forall a. Eq a => a -> a -> Bool
== ExifTag
tag] of
        [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Pixel32
d
        (ImageFileDirectory
x:[ImageFileDirectory]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ImageFileDirectory -> Pixel32
ifdOffset ImageFileDirectory
x

findIFDExt :: String -> ExifTag -> [ImageFileDirectory] -> Get ExifData
findIFDExt :: String -> ExifTag -> [ImageFileDirectory] -> Get ExifData
findIFDExt String
msg ExifTag
tag [ImageFileDirectory]
lst = do
    ImageFileDirectory
val <- String -> ExifTag -> [ImageFileDirectory] -> Get ImageFileDirectory
findIFD String
msg ExifTag
tag [ImageFileDirectory]
lst
    case ImageFileDirectory
val of
      ImageFileDirectory
        { ifdCount :: ImageFileDirectory -> Pixel32
ifdCount = Pixel32
1, ifdOffset :: ImageFileDirectory -> Pixel32
ifdOffset = Pixel32
ofs, ifdType :: ImageFileDirectory -> IfdType
ifdType = IfdType
TypeShort } ->
               forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Pixel16 -> ExifData
ExifShorts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Vector a
V.singleton forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
ofs
      ImageFileDirectory
        { ifdCount :: ImageFileDirectory -> Pixel32
ifdCount = Pixel32
1, ifdOffset :: ImageFileDirectory -> Pixel32
ifdOffset = Pixel32
ofs, ifdType :: ImageFileDirectory -> IfdType
ifdType = IfdType
TypeLong } ->
               forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Pixel32 -> ExifData
ExifLongs  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Vector a
V.singleton forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
ofs
      ImageFileDirectory { ifdExtended :: ImageFileDirectory -> ExifData
ifdExtended = ExifData
v } -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ExifData
v


findIFDExtDefaultData :: [Word32] -> ExifTag -> [ImageFileDirectory]
                      -> Get [Word32]
findIFDExtDefaultData :: [Pixel32] -> ExifTag -> [ImageFileDirectory] -> Get [Pixel32]
findIFDExtDefaultData [Pixel32]
d ExifTag
tag [ImageFileDirectory]
lst =
    case [ImageFileDirectory
v | ImageFileDirectory
v <- [ImageFileDirectory]
lst, ImageFileDirectory -> ExifTag
ifdIdentifier ImageFileDirectory
v forall a. Eq a => a -> a -> Bool
== ExifTag
tag] of
        [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Pixel32]
d
        (ImageFileDirectory { ifdExtended :: ImageFileDirectory -> ExifData
ifdExtended = ExifData
ExifNone }:[ImageFileDirectory]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return [Pixel32]
d
        (ImageFileDirectory
x:[ImageFileDirectory]
_) -> forall a. Vector a -> [a]
V.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ExifData -> Get (Vector Pixel32)
unLong String
errorMessage (ImageFileDirectory -> ExifData
ifdExtended ImageFileDirectory
x)
            where errorMessage :: String
errorMessage =
                    String
"Can't parse tag " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ExifTag
tag forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ImageFileDirectory -> ExifData
ifdExtended ImageFileDirectory
x)

-- It's temporary, remove once tiff decoding is better

-- handled.

{-  
instance Show (Image PixelRGB16) where
    show _ = "Image PixelRGB16"
-}
copyByteString :: B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32)
               -> ST s Int
copyByteString :: forall s.
ByteString
-> STVector s Pixel8
-> Int
-> Int
-> (Pixel32, Pixel32)
-> ST s Int
copyByteString ByteString
str STVector s Pixel8
vec Int
stride Int
startWrite (Pixel32
from, Pixel32
count) = Int -> Int -> ST s Int
inner Int
startWrite Int
fromi
  where fromi :: Int
fromi = forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
from
        maxi :: Int
maxi = Int
fromi forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
count

        inner :: Int -> Int -> ST s Int
inner Int
writeIdx Int
i | Int
i forall a. Ord a => a -> a -> Bool
>= Int
maxi = forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
writeIdx
        inner Int
writeIdx Int
i = do
            let v :: Pixel8
v = ByteString
str ByteString -> Int -> Pixel8
`BU.unsafeIndex` Int
i
            (STVector s Pixel8
vec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) Pixel8
v
            Int -> Int -> ST s Int
inner (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
stride) forall a b. (a -> b) -> a -> b
$ Int
i forall a. Num a => a -> a -> a
+ Int
1

unpackPackBit :: B.ByteString -> M.STVector s Word8 -> Int -> Int
              -> (Word32, Word32)
              -> ST s Int
unpackPackBit :: forall s.
ByteString
-> STVector s Pixel8
-> Int
-> Int
-> (Pixel32, Pixel32)
-> ST s Int
unpackPackBit ByteString
str STVector s Pixel8
outVec Int
stride Int
writeIndex (Pixel32
offset, Pixel32
size) = Int -> Int -> ST s Int
loop Int
fromi Int
writeIndex
  where fromi :: Int
fromi = forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
offset
        maxi :: Int
maxi = Int
fromi forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
size

        replicateByte :: Int -> Pixel8 -> Int -> ST s Int
replicateByte Int
writeIdx Pixel8
_     Int
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
writeIdx
        replicateByte Int
writeIdx Pixel8
v Int
count = do
            (STVector s Pixel8
outVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) Pixel8
v
            Int -> Pixel8 -> Int -> ST s Int
replicateByte (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
stride) Pixel8
v forall a b. (a -> b) -> a -> b
$ Int
count forall a. Num a => a -> a -> a
- Int
1

        loop :: Int -> Int -> ST s Int
loop Int
i Int
writeIdx | Int
i forall a. Ord a => a -> a -> Bool
>= Int
maxi = forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
writeIdx
        loop Int
i Int
writeIdx = ST s Int
choice
          {-where v = fromIntegral (str `BU.unsafeIndex` i) :: Int8-}
          where v :: Int8
v = forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString
str HasCallStack => ByteString -> Int -> Pixel8
`B.index` Int
i) :: Int8

                choice :: ST s Int
choice
                    -- data

                    | Int8
0    forall a. Ord a => a -> a -> Bool
<= Int8
v =
                        forall s.
ByteString
-> STVector s Pixel8
-> Int
-> Int
-> (Pixel32, Pixel32)
-> ST s Int
copyByteString ByteString
str STVector s Pixel8
outVec Int
stride Int
writeIdx
                                        (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
i forall a. Num a => a -> a -> a
+ Int
1, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
v forall a. Num a => a -> a -> a
+ Pixel32
1)
                            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Int -> ST s Int
loop (Int
i forall a. Num a => a -> a -> a
+ Int
2 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
v)
                    -- run

                    | -Int8
127 forall a. Ord a => a -> a -> Bool
<= Int8
v = do
                        {-let nextByte = str `BU.unsafeIndex` (i + 1)-}
                        let nextByte :: Pixel8
nextByte = ByteString
str HasCallStack => ByteString -> Int -> Pixel8
`B.index` (Int
i forall a. Num a => a -> a -> a
+ Int
1)
                            count :: Int
count = forall a. Num a => a -> a
negate (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
v) forall a. Num a => a -> a -> a
+ Int
1 :: Int
                        Int -> Pixel8 -> Int -> ST s Int
replicateByte Int
writeIdx Pixel8
nextByte Int
count
                            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Int -> ST s Int
loop (Int
i forall a. Num a => a -> a -> a
+ Int
2)

                    -- noop

                    | Bool
otherwise = Int -> Int -> ST s Int
loop Int
writeIdx forall a b. (a -> b) -> a -> b
$ Int
i forall a. Num a => a -> a -> a
+ Int
1

uncompressAt :: TiffCompression
             -> B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32)
             -> ST s Int
uncompressAt :: forall s.
TiffCompression
-> ByteString
-> STVector s Pixel8
-> Int
-> Int
-> (Pixel32, Pixel32)
-> ST s Int
uncompressAt TiffCompression
CompressionNone = forall s.
ByteString
-> STVector s Pixel8
-> Int
-> Int
-> (Pixel32, Pixel32)
-> ST s Int
copyByteString
uncompressAt TiffCompression
CompressionPackBit = forall s.
ByteString
-> STVector s Pixel8
-> Int
-> Int
-> (Pixel32, Pixel32)
-> ST s Int
unpackPackBit
uncompressAt TiffCompression
CompressionLZW =  \ByteString
str STVector s Pixel8
outVec Int
_stride Int
writeIndex (Pixel32
offset, Pixel32
size) -> do
    let toDecode :: ByteString
toDecode = Int -> ByteString -> ByteString
B.take (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
size) forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
offset) ByteString
str
    forall s a. BoolReader s a -> ST s a
runBoolReader forall a b. (a -> b) -> a -> b
$ forall s. ByteString -> STVector s Pixel8 -> Int -> BoolReader s ()
decodeLzwTiff ByteString
toDecode STVector s Pixel8
outVec Int
writeIndex
    forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
uncompressAt TiffCompression
_ = forall a. HasCallStack => String -> a
error String
"Unhandled compression"

class Unpackable a where
    type StorageType a :: *

    outAlloc :: a -> Int -> ST s (M.STVector s (StorageType a))

    -- | Final image and size, return offset and vector

    allocTempBuffer :: a  -> M.STVector s (StorageType a) -> Int
                    -> ST s (M.STVector s Word8)

    offsetStride :: a -> Int -> Int -> (Int, Int)

    mergeBackTempBuffer :: a    -- ^ Type witness, just for the type checker.

                        -> Endianness
                        -> M.STVector s Word8 -- ^ Temporary buffer handling decompression.

                        -> Int  -- ^ Line size in pixels

                        -> Int  -- ^ Write index, in bytes

                        -> Word32  -- ^ size, in bytes

                        -> Int  -- ^ Stride

                        -> M.STVector s (StorageType a) -- ^ Final buffer

                        -> ST s ()

-- | The Word8 instance is just a passthrough, to avoid

-- copying memory twice

instance Unpackable Word8 where
  type StorageType Word8 = Word8

  offsetStride :: Pixel8 -> Int -> Int -> (Int, Int)
offsetStride Pixel8
_ Int
i Int
stride = (Int
i, Int
stride)
  allocTempBuffer :: forall s.
Pixel8
-> STVector s (StorageType Pixel8)
-> Int
-> ST s (STVector s Pixel8)
allocTempBuffer Pixel8
_ STVector s (StorageType Pixel8)
buff Int
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure STVector s (StorageType Pixel8)
buff
  mergeBackTempBuffer :: forall s.
Pixel8
-> Endianness
-> STVector s Pixel8
-> Int
-> Int
-> Pixel32
-> Int
-> STVector s (StorageType Pixel8)
-> ST s ()
mergeBackTempBuffer Pixel8
_ Endianness
_ STVector s Pixel8
_ Int
_ Int
_ Pixel32
_ Int
_ STVector s (StorageType Pixel8)
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  outAlloc :: forall s. Pixel8 -> Int -> ST s (STVector s (StorageType Pixel8))
outAlloc Pixel8
_ Int
count = forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
M.replicate Int
count Pixel8
0 -- M.new


instance Unpackable Word16 where
  type StorageType Word16 = Word16

  offsetStride :: Pixel16 -> Int -> Int -> (Int, Int)
offsetStride Pixel16
_ Int
_ Int
_ = (Int
0, Int
1)
  outAlloc :: forall s. Pixel16 -> Int -> ST s (STVector s (StorageType Pixel16))
outAlloc Pixel16
_ = forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new
  allocTempBuffer :: forall s.
Pixel16
-> STVector s (StorageType Pixel16)
-> Int
-> ST s (STVector s Pixel8)
allocTempBuffer Pixel16
_ STVector s (StorageType Pixel16)
_ Int
s = forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new forall a b. (a -> b) -> a -> b
$ Int
s forall a. Num a => a -> a -> a
* Int
2
  mergeBackTempBuffer :: forall s.
Pixel16
-> Endianness
-> STVector s Pixel8
-> Int
-> Int
-> Pixel32
-> Int
-> STVector s (StorageType Pixel16)
-> ST s ()
mergeBackTempBuffer Pixel16
_ Endianness
EndianLittle STVector s Pixel8
tempVec Int
_ Int
index Pixel32
size Int
stride STVector s (StorageType Pixel16)
outVec =
        Int -> Int -> ST s ()
looperLe Int
index Int
0
    where looperLe :: Int -> Int -> ST s ()
looperLe Int
_ Int
readIndex | Int
readIndex forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
size = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          looperLe Int
writeIndex Int
readIndex = do
              Pixel8
v1 <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` Int
readIndex
              Pixel8
v2 <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` (Int
readIndex forall a. Num a => a -> a -> a
+ Int
1)
              let finalValue :: Pixel16
finalValue =
                    (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v2 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
8) forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v1
              (STVector s (StorageType Pixel16)
outVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` Int
writeIndex) Pixel16
finalValue

              Int -> Int -> ST s ()
looperLe (Int
writeIndex forall a. Num a => a -> a -> a
+ Int
stride) (Int
readIndex forall a. Num a => a -> a -> a
+ Int
2)
  mergeBackTempBuffer Pixel16
_ Endianness
EndianBig STVector s Pixel8
tempVec Int
_ Int
index Pixel32
size Int
stride STVector s (StorageType Pixel16)
outVec =
         Int -> Int -> ST s ()
looperBe Int
index Int
0
    where looperBe :: Int -> Int -> ST s ()
looperBe Int
_ Int
readIndex | Int
readIndex forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
size = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          looperBe Int
writeIndex Int
readIndex = do
              Pixel8
v1 <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` Int
readIndex
              Pixel8
v2 <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` (Int
readIndex forall a. Num a => a -> a -> a
+ Int
1)
              let finalValue :: Pixel16
finalValue =
                    (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v1 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
8) forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v2
              (STVector s (StorageType Pixel16)
outVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` Int
writeIndex) Pixel16
finalValue

              Int -> Int -> ST s ()
looperBe (Int
writeIndex forall a. Num a => a -> a -> a
+ Int
stride) (Int
readIndex forall a. Num a => a -> a -> a
+ Int
2)

instance Unpackable Word32 where
  type StorageType Word32 = Word32

  offsetStride :: Pixel32 -> Int -> Int -> (Int, Int)
offsetStride Pixel32
_ Int
_ Int
_ = (Int
0, Int
1)
  outAlloc :: forall s. Pixel32 -> Int -> ST s (STVector s (StorageType Pixel32))
outAlloc Pixel32
_ = forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new
  allocTempBuffer :: forall s.
Pixel32
-> STVector s (StorageType Pixel32)
-> Int
-> ST s (STVector s Pixel8)
allocTempBuffer Pixel32
_ STVector s (StorageType Pixel32)
_ Int
s = forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new forall a b. (a -> b) -> a -> b
$ Int
s forall a. Num a => a -> a -> a
* Int
4
  mergeBackTempBuffer :: forall s.
Pixel32
-> Endianness
-> STVector s Pixel8
-> Int
-> Int
-> Pixel32
-> Int
-> STVector s (StorageType Pixel32)
-> ST s ()
mergeBackTempBuffer Pixel32
_ Endianness
EndianLittle STVector s Pixel8
tempVec Int
_ Int
index Pixel32
size Int
stride STVector s (StorageType Pixel32)
outVec =
        Int -> Int -> ST s ()
looperLe Int
index Int
0
    where looperLe :: Int -> Int -> ST s ()
looperLe Int
_ Int
readIndex | Int
readIndex forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
size = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          looperLe Int
writeIndex Int
readIndex = do
              Pixel8
v1 <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` Int
readIndex
              Pixel8
v2 <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` (Int
readIndex forall a. Num a => a -> a -> a
+ Int
1)
              Pixel8
v3 <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` (Int
readIndex forall a. Num a => a -> a -> a
+ Int
2)
              Pixel8
v4 <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` (Int
readIndex forall a. Num a => a -> a -> a
+ Int
3)
              let finalValue :: Pixel32
finalValue =
                    (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v4 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
24) forall a. Bits a => a -> a -> a
.|.
                    (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v3 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
16) forall a. Bits a => a -> a -> a
.|.
                    (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v2 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
8) forall a. Bits a => a -> a -> a
.|.
                    forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v1
              (STVector s (StorageType Pixel32)
outVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` Int
writeIndex) Pixel32
finalValue

              Int -> Int -> ST s ()
looperLe (Int
writeIndex forall a. Num a => a -> a -> a
+ Int
stride) (Int
readIndex forall a. Num a => a -> a -> a
+ Int
4)
  mergeBackTempBuffer Pixel32
_ Endianness
EndianBig STVector s Pixel8
tempVec Int
_ Int
index Pixel32
size Int
stride STVector s (StorageType Pixel32)
outVec =
         Int -> Int -> ST s ()
looperBe Int
index Int
0
    where looperBe :: Int -> Int -> ST s ()
looperBe Int
_ Int
readIndex | Int
readIndex forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
size = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          looperBe Int
writeIndex Int
readIndex = do
              Pixel8
v1 <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` Int
readIndex
              Pixel8
v2 <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` (Int
readIndex forall a. Num a => a -> a -> a
+ Int
1)
              Pixel8
v3 <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` (Int
readIndex forall a. Num a => a -> a -> a
+ Int
2)
              Pixel8
v4 <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` (Int
readIndex forall a. Num a => a -> a -> a
+ Int
3)
              let finalValue :: Pixel32
finalValue =
                    (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v1 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
24) forall a. Bits a => a -> a -> a
.|.
                    (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v2 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
16) forall a. Bits a => a -> a -> a
.|.
                    (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v3 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
8) forall a. Bits a => a -> a -> a
.|.
                    forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v4
              (STVector s (StorageType Pixel32)
outVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` Int
writeIndex) Pixel32
finalValue

              Int -> Int -> ST s ()
looperBe (Int
writeIndex forall a. Num a => a -> a -> a
+ Int
stride) (Int
readIndex forall a. Num a => a -> a -> a
+ Int
4)

instance Unpackable Float where
  type StorageType Float = Float

  offsetStride :: PixelF -> Int -> Int -> (Int, Int)
offsetStride PixelF
_ Int
_ Int
_ = (Int
0, Int
1)
  outAlloc :: forall s. PixelF -> Int -> ST s (STVector s (StorageType PixelF))
outAlloc PixelF
_ = forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new
  allocTempBuffer :: forall s.
PixelF
-> STVector s (StorageType PixelF)
-> Int
-> ST s (STVector s Pixel8)
allocTempBuffer PixelF
_ STVector s (StorageType PixelF)
_ Int
s = forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new forall a b. (a -> b) -> a -> b
$ Int
s forall a. Num a => a -> a -> a
* Int
4
  mergeBackTempBuffer :: forall s. Float
                      -> Endianness
                      -> M.STVector s Word8
                      -> Int
                      -> Int
                      -> Word32
                      -> Int
                      -> M.STVector s (StorageType Float)
                      -> ST s ()
  mergeBackTempBuffer :: forall s.
PixelF
-> Endianness
-> STVector s Pixel8
-> Int
-> Int
-> Pixel32
-> Int
-> STVector s (StorageType PixelF)
-> ST s ()
mergeBackTempBuffer PixelF
_ Endianness
endianness STVector s Pixel8
tempVec Int
lineSize Int
index Pixel32
size Int
stride STVector s (StorageType PixelF)
outVec =
        let outVecWord32 :: M.STVector s Word32
            outVecWord32 :: STVector s Pixel32
outVecWord32 = forall a b s.
(Storable a, Storable b) =>
MVector s a -> MVector s b
M.unsafeCast STVector s (StorageType PixelF)
outVec
        in forall a s.
Unpackable a =>
a
-> Endianness
-> STVector s Pixel8
-> Int
-> Int
-> Pixel32
-> Int
-> STVector s (StorageType a)
-> ST s ()
mergeBackTempBuffer (Pixel32
0 :: Word32)
                               Endianness
endianness
                               STVector s Pixel8
tempVec
                               Int
lineSize
                               Int
index
                               Pixel32
size
                               Int
stride
                               STVector s Pixel32
outVecWord32

data Pack4 = Pack4

instance Unpackable Pack4 where
  type StorageType Pack4 = Word8
  allocTempBuffer :: forall s.
Pack4
-> STVector s (StorageType Pack4)
-> Int
-> ST s (STVector s Pixel8)
allocTempBuffer Pack4
_ STVector s (StorageType Pack4)
_ = forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new
  offsetStride :: Pack4 -> Int -> Int -> (Int, Int)
offsetStride Pack4
_ Int
_ Int
_ = (Int
0, Int
1)
  outAlloc :: forall s. Pack4 -> Int -> ST s (STVector s (StorageType Pack4))
outAlloc Pack4
_ = forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new
  mergeBackTempBuffer :: forall s.
Pack4
-> Endianness
-> STVector s Pixel8
-> Int
-> Int
-> Pixel32
-> Int
-> STVector s (StorageType Pack4)
-> ST s ()
mergeBackTempBuffer Pack4
_ Endianness
_ STVector s Pixel8
tempVec Int
lineSize Int
index Pixel32
size Int
stride STVector s (StorageType Pack4)
outVec =
        Int -> Int -> Int -> ST s ()
inner Int
0 Int
index Int
pxCount
    where pxCount :: Int
pxCount = Int
lineSize forall a. Integral a => a -> a -> a
`div` Int
stride

          maxWrite :: Int
maxWrite = forall a s. Storable a => MVector s a -> Int
M.length STVector s (StorageType Pack4)
outVec
          inner :: Int -> Int -> Int -> ST s ()
inner Int
readIdx Int
writeIdx Int
_
                | Int
readIdx forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
size Bool -> Bool -> Bool
|| Int
writeIdx forall a. Ord a => a -> a -> Bool
>= Int
maxWrite = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          inner Int
readIdx Int
writeIdx Int
line
                | Int
line forall a. Ord a => a -> a -> Bool
<= Int
0 = Int -> Int -> Int -> ST s ()
inner Int
readIdx (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
line forall a. Num a => a -> a -> a
* Int
stride) Int
pxCount
          inner Int
readIdx Int
writeIdx Int
line = do
            Pixel8
v <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` Int
readIdx
            let high :: Pixel8
high = (Pixel8
v forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) forall a. Bits a => a -> a -> a
.&. Pixel8
0xF
                low :: Pixel8
low = Pixel8
v forall a. Bits a => a -> a -> a
.&. Pixel8
0xF
            (STVector s (StorageType Pack4)
outVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` Int
writeIdx) Pixel8
high
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
stride forall a. Ord a => a -> a -> Bool
< Int
maxWrite) forall a b. (a -> b) -> a -> b
$
                 (STVector s (StorageType Pack4)
outVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
stride)) Pixel8
low

            Int -> Int -> Int -> ST s ()
inner (Int
readIdx forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
2 forall a. Num a => a -> a -> a
* Int
stride) (Int
line forall a. Num a => a -> a -> a
- Int
2)

data Pack2 = Pack2

instance Unpackable Pack2 where
  type StorageType Pack2 = Word8
  allocTempBuffer :: forall s.
Pack2
-> STVector s (StorageType Pack2)
-> Int
-> ST s (STVector s Pixel8)
allocTempBuffer Pack2
_ STVector s (StorageType Pack2)
_ = forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new
  offsetStride :: Pack2 -> Int -> Int -> (Int, Int)
offsetStride Pack2
_ Int
_ Int
_ = (Int
0, Int
1)
  outAlloc :: forall s. Pack2 -> Int -> ST s (STVector s (StorageType Pack2))
outAlloc Pack2
_ = forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new
  mergeBackTempBuffer :: forall s.
Pack2
-> Endianness
-> STVector s Pixel8
-> Int
-> Int
-> Pixel32
-> Int
-> STVector s (StorageType Pack2)
-> ST s ()
mergeBackTempBuffer Pack2
_ Endianness
_ STVector s Pixel8
tempVec Int
lineSize Int
index Pixel32
size Int
stride STVector s (StorageType Pack2)
outVec =
        Int -> Int -> Int -> ST s ()
inner Int
0 Int
index Int
pxCount
    where pxCount :: Int
pxCount = Int
lineSize forall a. Integral a => a -> a -> a
`div` Int
stride

          maxWrite :: Int
maxWrite = forall a s. Storable a => MVector s a -> Int
M.length STVector s (StorageType Pack2)
outVec
          inner :: Int -> Int -> Int -> ST s ()
inner Int
readIdx Int
writeIdx Int
_
                | Int
readIdx forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
size Bool -> Bool -> Bool
|| Int
writeIdx forall a. Ord a => a -> a -> Bool
>= Int
maxWrite = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          inner Int
readIdx Int
writeIdx Int
line
                | Int
line forall a. Ord a => a -> a -> Bool
<= Int
0 = Int -> Int -> Int -> ST s ()
inner Int
readIdx (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
line forall a. Num a => a -> a -> a
* Int
stride) Int
pxCount
          inner Int
readIdx Int
writeIdx Int
line = do
            Pixel8
v <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` Int
readIdx
            let v0 :: Pixel8
v0 = (Pixel8
v forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
6) forall a. Bits a => a -> a -> a
.&. Pixel8
0x3
                v1 :: Pixel8
v1 = (Pixel8
v forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) forall a. Bits a => a -> a -> a
.&. Pixel8
0x3
                v2 :: Pixel8
v2 = (Pixel8
v forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
2) forall a. Bits a => a -> a -> a
.&. Pixel8
0x3
                v3 :: Pixel8
v3 = Pixel8
v forall a. Bits a => a -> a -> a
.&. Pixel8
0x3

            (STVector s (StorageType Pack2)
outVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` Int
writeIdx) Pixel8
v0
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
1 forall a. Num a => a -> a -> a
* Int
stride forall a. Ord a => a -> a -> Bool
< Int
maxWrite) forall a b. (a -> b) -> a -> b
$
                 (STVector s (StorageType Pack2)
outVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
stride)) Pixel8
v1

            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
2 forall a. Num a => a -> a -> a
* Int
stride forall a. Ord a => a -> a -> Bool
< Int
maxWrite) forall a b. (a -> b) -> a -> b
$
                 (STVector s (StorageType Pack2)
outVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
stride forall a. Num a => a -> a -> a
* Int
2)) Pixel8
v2

            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
3 forall a. Num a => a -> a -> a
* Int
stride forall a. Ord a => a -> a -> Bool
< Int
maxWrite) forall a b. (a -> b) -> a -> b
$
                 (STVector s (StorageType Pack2)
outVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
stride forall a. Num a => a -> a -> a
* Int
3)) Pixel8
v3

            Int -> Int -> Int -> ST s ()
inner (Int
readIdx forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
4 forall a. Num a => a -> a -> a
* Int
stride) (Int
line forall a. Num a => a -> a -> a
- Int
4)

data Pack12 = Pack12

instance Unpackable Pack12 where
  type StorageType Pack12 = Word16
  allocTempBuffer :: forall s.
Pack12
-> STVector s (StorageType Pack12)
-> Int
-> ST s (STVector s Pixel8)
allocTempBuffer Pack12
_ STVector s (StorageType Pack12)
_ = forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new
  offsetStride :: Pack12 -> Int -> Int -> (Int, Int)
offsetStride Pack12
_ Int
_ Int
_ = (Int
0, Int
1)
  outAlloc :: forall s. Pack12 -> Int -> ST s (STVector s (StorageType Pack12))
outAlloc Pack12
_ = forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new
  mergeBackTempBuffer :: forall s.
Pack12
-> Endianness
-> STVector s Pixel8
-> Int
-> Int
-> Pixel32
-> Int
-> STVector s (StorageType Pack12)
-> ST s ()
mergeBackTempBuffer Pack12
_ Endianness
_ STVector s Pixel8
tempVec Int
lineSize Int
index Pixel32
size Int
stride STVector s (StorageType Pack12)
outVec =
        Int -> Int -> Int -> ST s ()
inner Int
0 Int
index Int
pxCount
    where pxCount :: Int
pxCount = Int
lineSize forall a. Integral a => a -> a -> a
`div` Int
stride

          maxWrite :: Int
maxWrite = forall a s. Storable a => MVector s a -> Int
M.length STVector s (StorageType Pack12)
outVec
          inner :: Int -> Int -> Int -> ST s ()
inner Int
readIdx Int
writeIdx Int
_
                | Int
readIdx forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
size Bool -> Bool -> Bool
|| Int
writeIdx forall a. Ord a => a -> a -> Bool
>= Int
maxWrite = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          inner Int
readIdx Int
writeIdx Int
line
                | Int
line forall a. Ord a => a -> a -> Bool
<= Int
0 = Int -> Int -> Int -> ST s ()
inner Int
readIdx (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
line forall a. Num a => a -> a -> a
* Int
stride) Int
pxCount
          inner Int
readIdx Int
writeIdx Int
line = do
            Pixel8
v0 <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` Int
readIdx
            Pixel8
v1 <- if Int
readIdx forall a. Num a => a -> a -> a
+ Int
1 forall a. Ord a => a -> a -> Bool
< forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
size
                then STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
1)
                else forall (f :: * -> *) a. Applicative f => a -> f a
pure Pixel8
0
            Pixel8
v2 <- if Int
readIdx forall a. Num a => a -> a -> a
+ Int
2 forall a. Ord a => a -> a -> Bool
< forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
size
                then STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
2)
                else forall (f :: * -> *) a. Applicative f => a -> f a
pure Pixel8
0

            let high0 :: Pixel16
high0 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v0 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
4
                low0 :: Pixel16
low0 = (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v1 forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) forall a. Bits a => a -> a -> a
.&. Pixel16
0xF

                p0 :: Pixel16
p0 = Pixel16
high0 forall a. Bits a => a -> a -> a
.|. Pixel16
low0

                high1 :: Pixel16
high1 = (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v1 forall a. Bits a => a -> a -> a
.&. Pixel16
0xF) forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
8
                low1 :: Pixel16
low1 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v2
                p1 :: Pixel16
p1 = Pixel16
high1 forall a. Bits a => a -> a -> a
.|. Pixel16
low1

            (STVector s (StorageType Pack12)
outVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` Int
writeIdx) Pixel16
p0
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
1 forall a. Num a => a -> a -> a
* Int
stride forall a. Ord a => a -> a -> Bool
< Int
maxWrite) forall a b. (a -> b) -> a -> b
$
                 (STVector s (StorageType Pack12)
outVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
stride)) Pixel16
p1

            Int -> Int -> Int -> ST s ()
inner (Int
readIdx forall a. Num a => a -> a -> a
+ Int
3) (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
2 forall a. Num a => a -> a -> a
* Int
stride) (Int
line forall a. Num a => a -> a -> a
- Int
2)

data YCbCrSubsampling = YCbCrSubsampling
    { YCbCrSubsampling -> Int
ycbcrWidth        :: !Int
    , YCbCrSubsampling -> Int
ycbcrHeight       :: !Int
    , YCbCrSubsampling -> Int
ycbcrImageWidth   :: !Int
    , YCbCrSubsampling -> Int
ycbcrStripHeight  :: !Int
    }

instance Unpackable YCbCrSubsampling where
  type StorageType YCbCrSubsampling = Word8

  offsetStride :: YCbCrSubsampling -> Int -> Int -> (Int, Int)
offsetStride YCbCrSubsampling
_ Int
_ Int
_ = (Int
0, Int
1)
  outAlloc :: forall s.
YCbCrSubsampling
-> Int -> ST s (STVector s (StorageType YCbCrSubsampling))
outAlloc YCbCrSubsampling
_ = forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new
  allocTempBuffer :: forall s.
YCbCrSubsampling
-> STVector s (StorageType YCbCrSubsampling)
-> Int
-> ST s (STVector s Pixel8)
allocTempBuffer YCbCrSubsampling
_ STVector s (StorageType YCbCrSubsampling)
_ = forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new
  mergeBackTempBuffer :: forall s.
YCbCrSubsampling
-> Endianness
-> STVector s Pixel8
-> Int
-> Int
-> Pixel32
-> Int
-> STVector s (StorageType YCbCrSubsampling)
-> ST s ()
mergeBackTempBuffer YCbCrSubsampling
subSampling Endianness
_ STVector s Pixel8
tempVec Int
_ Int
index Pixel32
size Int
_ STVector s (StorageType YCbCrSubsampling)
outVec =
      forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ Int -> (Int, Int) -> ST s Int
unpacker Int
0 [(Int
bx, Int
by) | Int
by <- [Int
0, Int
h .. Int
lineCount forall a. Num a => a -> a -> a
- Int
1]
                                  , Int
bx <- [Int
0, Int
w .. Int
imgWidth forall a. Num a => a -> a -> a
- Int
1]]
    where w :: Int
w = YCbCrSubsampling -> Int
ycbcrWidth YCbCrSubsampling
subSampling
          h :: Int
h = YCbCrSubsampling -> Int
ycbcrHeight YCbCrSubsampling
subSampling
          imgWidth :: Int
imgWidth = YCbCrSubsampling -> Int
ycbcrImageWidth YCbCrSubsampling
subSampling
          lineCount :: Int
lineCount = YCbCrSubsampling -> Int
ycbcrStripHeight YCbCrSubsampling
subSampling

          lumaCount :: Int
lumaCount = Int
w forall a. Num a => a -> a -> a
* Int
h
          blockSize :: Int
blockSize = Int
lumaCount forall a. Num a => a -> a -> a
+ Int
2

          maxOut :: Int
maxOut = forall a s. Storable a => MVector s a -> Int
M.length STVector s (StorageType YCbCrSubsampling)
outVec

          unpacker :: Int -> (Int, Int) -> ST s Int
unpacker Int
readIdx (Int, Int)
_ | Int
readIdx forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
size forall a. Num a => a -> a -> a
* Int
3 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
readIdx
          unpacker Int
readIdx (Int
bx, Int
by) = do
              Pixel8
cb <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
lumaCount)
              Pixel8
cr <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
lumaCount forall a. Num a => a -> a -> a
+ Int
1)

              let pixelIndices :: [Int]
pixelIndices =
                        [Int
index forall a. Num a => a -> a -> a
+ ((Int
by forall a. Num a => a -> a -> a
+ Int
y) forall a. Num a => a -> a -> a
* Int
imgWidth forall a. Num a => a -> a -> a
+ Int
bx forall a. Num a => a -> a -> a
+ Int
x) forall a. Num a => a -> a -> a
* Int
3 | Int
y <- [Int
0 .. Int
h forall a. Num a => a -> a -> a
- Int
1], Int
x <- [Int
0 .. Int
w forall a. Num a => a -> a -> a
- Int
1]]

                  writer :: Int -> Int -> ST s Int
writer Int
readIndex Int
writeIdx | Int
writeIdx forall a. Num a => a -> a -> a
+ Int
3 forall a. Ord a => a -> a -> Bool
> Int
maxOut = forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
readIndex
                  writer Int
readIndex Int
writeIdx = do
                    Pixel8
y <- STVector s Pixel8
tempVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.read` Int
readIndex
                    (STVector s (StorageType YCbCrSubsampling)
outVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` Int
writeIdx) Pixel8
y
                    (STVector s (StorageType YCbCrSubsampling)
outVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
1)) Pixel8
cb
                    (STVector s (StorageType YCbCrSubsampling)
outVec forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
2)) Pixel8
cr
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
readIndex forall a. Num a => a -> a -> a
+ Int
1

              forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ Int -> Int -> ST s Int
writer Int
readIdx [Int]
pixelIndices

              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
readIdx forall a. Num a => a -> a -> a
+ Int
blockSize

gatherStrips :: ( Unpackable comp
                , Pixel pixel
                , StorageType comp ~ PixelBaseComponent pixel
                )
             => comp -> B.ByteString -> TiffInfo -> Image pixel
gatherStrips :: forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips comp
comp ByteString
str TiffInfo
nfo = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
  let width :: Int
width = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TiffInfo -> Pixel32
tiffWidth TiffInfo
nfo
      height :: Int
height = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TiffInfo -> Pixel32
tiffHeight TiffInfo
nfo
      sampleCount :: Int
sampleCount = if TiffInfo -> Pixel32
tiffSampleCount TiffInfo
nfo forall a. Eq a => a -> a -> Bool
/= Pixel32
0
        then forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TiffInfo -> Pixel32
tiffSampleCount TiffInfo
nfo
        else forall a. Vector a -> Int
V.length forall a b. (a -> b) -> a -> b
$ TiffInfo -> Vector Pixel32
tiffBitsPerSample TiffInfo
nfo

      rowPerStrip :: Int
rowPerStrip = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TiffInfo -> Pixel32
tiffRowPerStrip TiffInfo
nfo
      endianness :: Endianness
endianness = TiffHeader -> Endianness
hdrEndianness forall a b. (a -> b) -> a -> b
$ TiffInfo -> TiffHeader
tiffHeader TiffInfo
nfo

      stripCount :: Int
stripCount = forall a. Vector a -> Int
V.length forall a b. (a -> b) -> a -> b
$ TiffInfo -> Vector Pixel32
tiffOffsets TiffInfo
nfo
      compression :: TiffCompression
compression = TiffInfo -> TiffCompression
tiffCompression TiffInfo
nfo

  MVector s (PixelBaseComponent pixel)
outVec <- forall a s.
Unpackable a =>
a -> Int -> ST s (STVector s (StorageType a))
outAlloc comp
comp forall a b. (a -> b) -> a -> b
$ Int
width forall a. Num a => a -> a -> a
* Int
height forall a. Num a => a -> a -> a
* Int
sampleCount
  STVector s Pixel8
tempVec <- forall a s.
Unpackable a =>
a -> STVector s (StorageType a) -> Int -> ST s (STVector s Pixel8)
allocTempBuffer comp
comp MVector s (PixelBaseComponent pixel)
outVec
                        (Int
rowPerStrip forall a. Num a => a -> a -> a
* Int
width forall a. Num a => a -> a -> a
* Int
sampleCount)

  let mutableImage :: MutableImage s pixel
mutableImage = MutableImage
                   { mutableImageWidth :: Int
mutableImageWidth = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width
                   , mutableImageHeight :: Int
mutableImageHeight = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height
                   , mutableImageData :: MVector s (PixelBaseComponent pixel)
mutableImageData = MVector s (PixelBaseComponent pixel)
outVec
                   }

  case TiffInfo -> TiffPlanarConfiguration
tiffPlaneConfiguration TiffInfo
nfo of
    TiffPlanarConfiguration
PlanarConfigContig -> forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ (Int, Int, Pixel32, Pixel32) -> ST s ()
unpacker Vector (Int, Int, Pixel32, Pixel32)
sizes
        where unpacker :: (Int, Int, Pixel32, Pixel32) -> ST s ()
unpacker (Int
idx, Int
stripSampleCount, Pixel32
offset, Pixel32
packedSize) = do
                  let (Int
writeIdx, Int
tempStride)  = forall a. Unpackable a => a -> Int -> Int -> (Int, Int)
offsetStride comp
comp Int
idx Int
1
                  Int
_ <- forall s.
TiffCompression
-> ByteString
-> STVector s Pixel8
-> Int
-> Int
-> (Pixel32, Pixel32)
-> ST s Int
uncompressAt TiffCompression
compression ByteString
str STVector s Pixel8
tempVec Int
tempStride
                                    Int
writeIdx (Pixel32
offset, Pixel32
packedSize)
                  let typ :: M.MVector s a -> a
                      typ :: forall s a. MVector s a -> a
typ = forall a b. a -> b -> a
const forall a. HasCallStack => a
undefined
                      sampleSize :: Int
sampleSize = forall a. Storable a => a -> Int
sizeOf (forall s a. MVector s a -> a
typ MVector s (PixelBaseComponent pixel)
outVec)
                  forall a s.
Unpackable a =>
a
-> Endianness
-> STVector s Pixel8
-> Int
-> Int
-> Pixel32
-> Int
-> STVector s (StorageType a)
-> ST s ()
mergeBackTempBuffer comp
comp Endianness
endianness STVector s Pixel8
tempVec (Int
width forall a. Num a => a -> a -> a
* Int
sampleCount)
                                      Int
idx (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
stripSampleCount forall a. Num a => a -> a -> a
* Int
sampleSize) Int
1 MVector s (PixelBaseComponent pixel)
outVec


              fullStripSampleCount :: Int
fullStripSampleCount = Int
rowPerStrip forall a. Num a => a -> a -> a
* Int
width forall a. Num a => a -> a -> a
* Int
sampleCount
              startWriteOffset :: Vector Int
startWriteOffset = forall a. Int -> (Int -> a) -> Vector a
V.generate Int
stripCount (Int
fullStripSampleCount forall a. Num a => a -> a -> a
*)
              stripSampleCounts :: Vector Int
stripSampleCounts = forall a b. (a -> b) -> Vector a -> Vector b
V.map Int -> Int
strip Vector Int
startWriteOffset
                  where
                      strip :: Int -> Int
strip Int
start = forall a. Ord a => a -> a -> a
min Int
fullStripSampleCount (Int
width forall a. Num a => a -> a -> a
* Int
height forall a. Num a => a -> a -> a
* Int
sampleCount forall a. Num a => a -> a -> a
- Int
start)

              sizes :: Vector (Int, Int, Pixel32, Pixel32)
sizes = forall a b c d.
Vector a -> Vector b -> Vector c -> Vector d -> Vector (a, b, c, d)
V.zip4 Vector Int
startWriteOffset Vector Int
stripSampleCounts
                             (TiffInfo -> Vector Pixel32
tiffOffsets TiffInfo
nfo) (TiffInfo -> Vector Pixel32
tiffStripSize TiffInfo
nfo)

    TiffPlanarConfiguration
PlanarConfigSeparate -> forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ (Int, Pixel32, Pixel32) -> ST s ()
unpacker Vector (Int, Pixel32, Pixel32)
sizes
        where unpacker :: (Int, Pixel32, Pixel32) -> ST s ()
unpacker (Int
idx, Pixel32
offset, Pixel32
size) = do
                  let (Int
writeIdx, Int
tempStride) = forall a. Unpackable a => a -> Int -> Int -> (Int, Int)
offsetStride comp
comp Int
idx Int
stride
                  Int
_ <- forall s.
TiffCompression
-> ByteString
-> STVector s Pixel8
-> Int
-> Int
-> (Pixel32, Pixel32)
-> ST s Int
uncompressAt TiffCompression
compression ByteString
str STVector s Pixel8
tempVec Int
tempStride
                                    Int
writeIdx (Pixel32
offset, Pixel32
size)
                  forall a s.
Unpackable a =>
a
-> Endianness
-> STVector s Pixel8
-> Int
-> Int
-> Pixel32
-> Int
-> STVector s (StorageType a)
-> ST s ()
mergeBackTempBuffer comp
comp Endianness
endianness STVector s Pixel8
tempVec (Int
width forall a. Num a => a -> a -> a
* Int
sampleCount)
                                      Int
idx Pixel32
size Int
stride MVector s (PixelBaseComponent pixel)
outVec

              stride :: Int
stride = forall a. Vector a -> Int
V.length forall a b. (a -> b) -> a -> b
$ TiffInfo -> Vector Pixel32
tiffOffsets TiffInfo
nfo
              idxVector :: Vector Int
idxVector = forall a. Num a => a -> Int -> Vector a
V.enumFromN Int
0 Int
stride
              sizes :: Vector (Int, Pixel32, Pixel32)
sizes = forall a b c. Vector a -> Vector b -> Vector c -> Vector (a, b, c)
V.zip3 Vector Int
idxVector (TiffInfo -> Vector Pixel32
tiffOffsets TiffInfo
nfo) (TiffInfo -> Vector Pixel32
tiffStripSize TiffInfo
nfo)

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TiffInfo -> Predictor
tiffPredictor TiffInfo
nfo forall a. Eq a => a -> a -> Bool
== Predictor
PredictorHorizontalDifferencing) forall a b. (a -> b) -> a -> b
$ do
    let f :: p -> a -> a -> a
f p
_ a
c1 a
c2 = a
c1 forall a. Num a => a -> a -> a
+ a
c2
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
height forall a. Num a => a -> a -> a
- Int
1] forall a b. (a -> b) -> a -> b
$ \Int
y ->
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
width forall a. Num a => a -> a -> a
- Int
1] forall a b. (a -> b) -> a -> b
$ \Int
x -> do
        pixel
p <- forall a (m :: * -> *).
(Pixel a, PrimMonad m) =>
MutableImage (PrimState m) a -> Int -> Int -> m a
readPixel MutableImage s pixel
mutableImage (Int
x forall a. Num a => a -> a -> a
- Int
1) Int
y
        pixel
q <- forall a (m :: * -> *).
(Pixel a, PrimMonad m) =>
MutableImage (PrimState m) a -> Int -> Int -> m a
readPixel MutableImage s pixel
mutableImage Int
x Int
y
        forall a (m :: * -> *).
(Pixel a, PrimMonad m) =>
MutableImage (PrimState m) a -> Int -> Int -> a -> m ()
writePixel MutableImage s pixel
mutableImage Int
x Int
y forall a b. (a -> b) -> a -> b
$ forall a.
Pixel a =>
(Int
 -> PixelBaseComponent a
 -> PixelBaseComponent a
 -> PixelBaseComponent a)
-> a -> a -> a
mixWith forall {a} {p}. Num a => p -> a -> a -> a
f pixel
p pixel
q

  forall a (m :: * -> *).
(Storable (PixelBaseComponent a), PrimMonad m) =>
MutableImage (PrimState m) a -> m (Image a)
unsafeFreezeImage MutableImage s pixel
mutableImage

ifdSingleLong :: ExifTag -> Word32 -> Writer [ImageFileDirectory] ()
ifdSingleLong :: ExifTag -> Pixel32 -> Writer [ImageFileDirectory] ()
ifdSingleLong ExifTag
tag = ExifTag -> Vector Pixel32 -> Writer [ImageFileDirectory] ()
ifdMultiLong ExifTag
tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Vector a
V.singleton

ifdSingleShort :: Endianness -> ExifTag -> Word16
               -> Writer [ImageFileDirectory] ()
ifdSingleShort :: Endianness -> ExifTag -> Pixel16 -> Writer [ImageFileDirectory] ()
ifdSingleShort Endianness
endian ExifTag
tag = Endianness
-> ExifTag -> Vector Pixel32 -> Writer [ImageFileDirectory] ()
ifdMultiShort Endianness
endian ExifTag
tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Vector a
V.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

ifdMultiLong :: ExifTag -> V.Vector Word32 -> Writer [ImageFileDirectory] ()
ifdMultiLong :: ExifTag -> Vector Pixel32 -> Writer [ImageFileDirectory] ()
ifdMultiLong ExifTag
tag Vector Pixel32
v = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ImageFileDirectory
        { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
tag
        , ifdType :: IfdType
ifdType       = IfdType
TypeLong
        , ifdCount :: Pixel32
ifdCount      = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Int
V.length Vector Pixel32
v
        , ifdOffset :: Pixel32
ifdOffset     = Pixel32
offset
        , ifdExtended :: ExifData
ifdExtended   = ExifData
extended
        }
  where (Pixel32
offset, ExifData
extended)
                | forall a. Vector a -> Int
V.length Vector Pixel32
v forall a. Ord a => a -> a -> Bool
> Int
1 = (Pixel32
0, Vector Pixel32 -> ExifData
ExifLongs Vector Pixel32
v)
                | Bool
otherwise = (forall a. Vector a -> a
V.head Vector Pixel32
v, ExifData
ExifNone)

ifdMultiShort :: Endianness -> ExifTag -> V.Vector Word32
              -> Writer [ImageFileDirectory] ()
ifdMultiShort :: Endianness
-> ExifTag -> Vector Pixel32 -> Writer [ImageFileDirectory] ()
ifdMultiShort Endianness
endian ExifTag
tag Vector Pixel32
v = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ImageFileDirectory
        { ifdIdentifier :: ExifTag
ifdIdentifier = ExifTag
tag
        , ifdType :: IfdType
ifdType       = IfdType
TypeShort
        , ifdCount :: Pixel32
ifdCount      = Pixel32
size
        , ifdOffset :: Pixel32
ifdOffset     = Pixel32
offset
        , ifdExtended :: ExifData
ifdExtended   = ExifData
extended
        }
    where size :: Pixel32
size = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Int
V.length Vector Pixel32
v
          (Pixel32
offset, ExifData
extended)
                | Pixel32
size forall a. Ord a => a -> a -> Bool
> Pixel32
2 = (Pixel32
0, Vector Pixel16 -> ExifData
ExifShorts forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> Vector a -> Vector b
V.map forall a b. (Integral a, Num b) => a -> b
fromIntegral Vector Pixel32
v)
                | Pixel32
size forall a. Eq a => a -> a -> Bool
== Pixel32
2 =
                    let v1 :: Pixel32
v1 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> a
V.head Vector Pixel32
v
                        v2 :: Pixel32
v2 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Vector Pixel32
v forall a. Vector a -> Int -> a
`V.unsafeIndex` Int
1
                    in
                    case Endianness
endian of
                      Endianness
EndianLittle -> (Pixel32
v2 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
16 forall a. Bits a => a -> a -> a
.|. Pixel32
v1, ExifData
ExifNone)
                      Endianness
EndianBig -> (Pixel32
v1 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
16 forall a. Bits a => a -> a -> a
.|. Pixel32
v2, ExifData
ExifNone)

                | Bool
otherwise = case Endianness
endian of
                    Endianness
EndianLittle -> (forall a. Vector a -> a
V.head Vector Pixel32
v, ExifData
ExifNone)
                    Endianness
EndianBig -> (forall a. Vector a -> a
V.head Vector Pixel32
v forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
16, ExifData
ExifNone)

instance BinaryParam B.ByteString TiffInfo where
  putP :: ByteString -> TiffInfo -> Put
putP ByteString
rawData TiffInfo
nfo = forall a b. BinaryParam a b => a -> b -> Put
putP ByteString
rawData (TiffInfo -> TiffHeader
tiffHeader TiffInfo
nfo, [[ImageFileDirectory]
list]) where
    endianness :: Endianness
endianness = TiffHeader -> Endianness
hdrEndianness forall a b. (a -> b) -> a -> b
$ TiffInfo -> TiffHeader
tiffHeader TiffInfo
nfo

    ifdShort :: ExifTag -> Pixel16 -> Writer [ImageFileDirectory] ()
ifdShort = Endianness -> ExifTag -> Pixel16 -> Writer [ImageFileDirectory] ()
ifdSingleShort Endianness
endianness
    ifdShorts :: ExifTag -> Vector Pixel32 -> Writer [ImageFileDirectory] ()
ifdShorts = Endianness
-> ExifTag -> Vector Pixel32 -> Writer [ImageFileDirectory] ()
ifdMultiShort Endianness
endianness

    list :: [ImageFileDirectory]
list = forall w a. Writer w a -> w
execWriter forall a b. (a -> b) -> a -> b
$ do
      ExifTag -> Pixel32 -> Writer [ImageFileDirectory] ()
ifdSingleLong ExifTag
TagImageWidth forall a b. (a -> b) -> a -> b
$ TiffInfo -> Pixel32
tiffWidth TiffInfo
nfo
      ExifTag -> Pixel32 -> Writer [ImageFileDirectory] ()
ifdSingleLong ExifTag
TagImageLength forall a b. (a -> b) -> a -> b
$ TiffInfo -> Pixel32
tiffHeight TiffInfo
nfo
      ExifTag -> Vector Pixel32 -> Writer [ImageFileDirectory] ()
ifdShorts ExifTag
TagBitsPerSample forall a b. (a -> b) -> a -> b
$ TiffInfo -> Vector Pixel32
tiffBitsPerSample TiffInfo
nfo
      ExifTag -> Pixel32 -> Writer [ImageFileDirectory] ()
ifdSingleLong ExifTag
TagSamplesPerPixel forall a b. (a -> b) -> a -> b
$ TiffInfo -> Pixel32
tiffSampleCount TiffInfo
nfo
      ExifTag -> Pixel32 -> Writer [ImageFileDirectory] ()
ifdSingleLong ExifTag
TagRowPerStrip forall a b. (a -> b) -> a -> b
$ TiffInfo -> Pixel32
tiffRowPerStrip TiffInfo
nfo
      ExifTag -> Pixel16 -> Writer [ImageFileDirectory] ()
ifdShort ExifTag
TagPhotometricInterpretation
                                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. TiffColorspace -> Pixel16
packPhotometricInterpretation
                                  forall a b. (a -> b) -> a -> b
$ TiffInfo -> TiffColorspace
tiffColorspace TiffInfo
nfo
      ExifTag -> Pixel16 -> Writer [ImageFileDirectory] ()
ifdShort ExifTag
TagPlanarConfiguration
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. TiffPlanarConfiguration -> Pixel16
constantToPlaneConfiguration forall a b. (a -> b) -> a -> b
$ TiffInfo -> TiffPlanarConfiguration
tiffPlaneConfiguration TiffInfo
nfo
      ExifTag -> Vector Pixel32 -> Writer [ImageFileDirectory] ()
ifdMultiLong ExifTag
TagSampleFormat
                                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
V.fromList
                                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map TiffSampleFormat -> Pixel32
packSampleFormat
                                  forall a b. (a -> b) -> a -> b
$ TiffInfo -> [TiffSampleFormat]
tiffSampleFormat TiffInfo
nfo
      ExifTag -> Pixel16 -> Writer [ImageFileDirectory] ()
ifdShort ExifTag
TagCompression forall b c a. (b -> c) -> (a -> b) -> a -> c
. TiffCompression -> Pixel16
packCompression
                                    forall a b. (a -> b) -> a -> b
$ TiffInfo -> TiffCompression
tiffCompression TiffInfo
nfo
      ExifTag -> Vector Pixel32 -> Writer [ImageFileDirectory] ()
ifdMultiLong ExifTag
TagStripOffsets forall a b. (a -> b) -> a -> b
$ TiffInfo -> Vector Pixel32
tiffOffsets TiffInfo
nfo

      ExifTag -> Vector Pixel32 -> Writer [ImageFileDirectory] ()
ifdMultiLong ExifTag
TagStripByteCounts forall a b. (a -> b) -> a -> b
$ TiffInfo -> Vector Pixel32
tiffStripSize TiffInfo
nfo

      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ())
            (ExifTag -> Pixel16 -> Writer [ImageFileDirectory] ()
ifdShort ExifTag
TagExtraSample forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtraSample -> Pixel16
codeOfExtraSample)
          forall a b. (a -> b) -> a -> b
$ TiffInfo -> Maybe ExtraSample
tiffExtraSample TiffInfo
nfo

      let subSampling :: Vector Pixel32
subSampling = TiffInfo -> Vector Pixel32
tiffYCbCrSubsampling TiffInfo
nfo
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Vector a -> Bool
V.null Vector Pixel32
subSampling) forall a b. (a -> b) -> a -> b
$
           ExifTag -> Vector Pixel32 -> Writer [ImageFileDirectory] ()
ifdShorts ExifTag
TagYCbCrSubsampling Vector Pixel32
subSampling

  getP :: ByteString -> Get TiffInfo
getP ByteString
rawData = do
    (TiffHeader
hdr, [[ImageFileDirectory]]
cleanedFull :: [[ImageFileDirectory]]) <- forall a b. BinaryParam a b => a -> Get b
getP ByteString
rawData

    let cleaned :: [ImageFileDirectory]
cleaned = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ImageFileDirectory]]
cleanedFull
        dataFind :: String -> ExifTag -> Get Pixel32
dataFind String
str ExifTag
tag = String -> ExifTag -> [ImageFileDirectory] -> Get Pixel32
findIFDData String
str ExifTag
tag [ImageFileDirectory]
cleaned
        dataDefault :: Pixel32 -> ExifTag -> Get Pixel32
dataDefault Pixel32
def ExifTag
tag = Pixel32 -> ExifTag -> [ImageFileDirectory] -> Get Pixel32
findIFDDefaultData Pixel32
def ExifTag
tag [ImageFileDirectory]
cleaned
        extFind :: String -> ExifTag -> Get ExifData
extFind String
str ExifTag
tag = String -> ExifTag -> [ImageFileDirectory] -> Get ExifData
findIFDExt String
str ExifTag
tag [ImageFileDirectory]
cleaned
        extDefault :: [Pixel32] -> ExifTag -> Get [Pixel32]
extDefault [Pixel32]
def ExifTag
tag = [Pixel32] -> ExifTag -> [ImageFileDirectory] -> Get [Pixel32]
findIFDExtDefaultData [Pixel32]
def ExifTag
tag [ImageFileDirectory]
cleaned

    TiffHeader
-> Pixel32
-> Pixel32
-> TiffColorspace
-> Pixel32
-> Pixel32
-> TiffPlanarConfiguration
-> [TiffSampleFormat]
-> Vector Pixel32
-> TiffCompression
-> Vector Pixel32
-> Vector Pixel32
-> Maybe (Image PixelRGB16)
-> Vector Pixel32
-> Maybe ExtraSample
-> Predictor
-> Metadatas
-> TiffInfo
TiffInfo TiffHeader
hdr
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ExifTag -> Get Pixel32
dataFind String
"Can't find width" ExifTag
TagImageWidth
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> ExifTag -> Get Pixel32
dataFind String
"Can't find height" ExifTag
TagImageLength
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> ExifTag -> Get Pixel32
dataFind String
"Can't find color space" ExifTag
TagPhotometricInterpretation
                     forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pixel32 -> Get TiffColorspace
unpackPhotometricInterpretation)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> ExifTag -> Get Pixel32
dataFind String
"Can't find sample per pixel" ExifTag
TagSamplesPerPixel
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> ExifTag -> Get Pixel32
dataFind String
"Can't find row per strip" ExifTag
TagRowPerStrip
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pixel32 -> ExifTag -> Get Pixel32
dataDefault Pixel32
1 ExifTag
TagPlanarConfiguration
                     forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pixel32 -> Get TiffPlanarConfiguration
planarConfgOfConstant)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Pixel32] -> ExifTag -> Get [Pixel32]
extDefault [Pixel32
1] ExifTag
TagSampleFormat
                     forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pixel32 -> Get TiffSampleFormat
unpackSampleFormat)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> ExifTag -> Get ExifData
extFind String
"Can't find bit per sample" ExifTag
TagBitsPerSample
                     forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ExifData -> Get (Vector Pixel32)
unLong String
"Can't find bit depth")
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> ExifTag -> Get Pixel32
dataFind String
"Can't find Compression" ExifTag
TagCompression
                     forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pixel32 -> Get TiffCompression
unPackCompression)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> ExifTag -> Get ExifData
extFind String
"Can't find byte counts" ExifTag
TagStripByteCounts
                     forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ExifData -> Get (Vector Pixel32)
unLong String
"Can't find bit per sample")
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> ExifTag -> Get ExifData
extFind String
"Strip offsets missing" ExifTag
TagStripOffsets
                     forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ExifData -> Get (Vector Pixel32)
unLong String
"Can't find strip offsets")
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [ImageFileDirectory] -> Get (Maybe (Image PixelRGB16))
findPalette [ImageFileDirectory]
cleaned
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. [a] -> Vector a
V.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pixel32] -> ExifTag -> Get [Pixel32]
extDefault [Pixel32
2, Pixel32
2] ExifTag
TagYCbCrSubsampling)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pixel32 -> ExifTag -> Get Pixel32
dataDefault Pixel32
1 ExifTag
TagPredictor
                     forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pixel32 -> Get Predictor
predictorOfConstant)
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ImageFileDirectory] -> Metadatas
extractTiffMetadata [ImageFileDirectory]
cleaned)

palette16Of :: Image PixelRGB16 -> Palette' PixelRGB16
palette16Of :: Image PixelRGB16 -> Palette' PixelRGB16
palette16Of Image PixelRGB16
p = Palette'
    { _paletteSize :: Int
_paletteSize = forall a. Image a -> Int
imageWidth Image PixelRGB16
p
    , _paletteData :: Vector (PixelBaseComponent PixelRGB16)
_paletteData = forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image PixelRGB16
p
    }

unpack :: B.ByteString -> TiffInfo -> Either String PalettedImage
-- | while mandatory some images don't put correct

-- rowperstrip. So replacing 0 with actual image height.

unpack :: ByteString -> TiffInfo -> Either String PalettedImage
unpack ByteString
file nfo :: TiffInfo
nfo@TiffInfo { tiffRowPerStrip :: TiffInfo -> Pixel32
tiffRowPerStrip = Pixel32
0 } =
    ByteString -> TiffInfo -> Either String PalettedImage
unpack ByteString
file forall a b. (a -> b) -> a -> b
$ TiffInfo
nfo { tiffRowPerStrip :: Pixel32
tiffRowPerStrip = TiffInfo -> Pixel32
tiffHeight TiffInfo
nfo }
unpack ByteString
file nfo :: TiffInfo
nfo@TiffInfo { tiffColorspace :: TiffInfo -> TiffColorspace
tiffColorspace = TiffColorspace
TiffPaleted
                         , tiffBitsPerSample :: TiffInfo -> Vector Pixel32
tiffBitsPerSample = Vector Pixel32
lst
                         , tiffSampleFormat :: TiffInfo -> [TiffSampleFormat]
tiffSampleFormat = [TiffSampleFormat]
format
                         , tiffPalette :: TiffInfo -> Maybe (Image PixelRGB16)
tiffPalette = Just Image PixelRGB16
p
                         }
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. a -> Vector a
V.singleton Pixel32
8 Bool -> Bool -> Bool
&& [TiffSampleFormat]
format forall a. Eq a => a -> a -> Bool
== [TiffSampleFormat
TiffSampleUint] =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Pixel8 -> Palette' PixelRGB16 -> PalettedImage
PalettedRGB16 (forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips (Pixel8
0 :: Word8) ByteString
file TiffInfo
nfo) forall a b. (a -> b) -> a -> b
$ Image PixelRGB16 -> Palette' PixelRGB16
palette16Of Image PixelRGB16
p
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. a -> Vector a
V.singleton Pixel32
4 Bool -> Bool -> Bool
&& [TiffSampleFormat]
format forall a. Eq a => a -> a -> Bool
== [TiffSampleFormat
TiffSampleUint] =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Pixel8 -> Palette' PixelRGB16 -> PalettedImage
PalettedRGB16 (forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips Pack4
Pack4 ByteString
file TiffInfo
nfo) forall a b. (a -> b) -> a -> b
$ Image PixelRGB16 -> Palette' PixelRGB16
palette16Of Image PixelRGB16
p
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. a -> Vector a
V.singleton Pixel32
2 Bool -> Bool -> Bool
&& [TiffSampleFormat]
format forall a. Eq a => a -> a -> Bool
== [TiffSampleFormat
TiffSampleUint] =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Pixel8 -> Palette' PixelRGB16 -> PalettedImage
PalettedRGB16 (forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips Pack2
Pack2 ByteString
file TiffInfo
nfo) forall a b. (a -> b) -> a -> b
$ Image PixelRGB16 -> Palette' PixelRGB16
palette16Of Image PixelRGB16
p

unpack ByteString
file nfo :: TiffInfo
nfo@TiffInfo { tiffColorspace :: TiffInfo -> TiffColorspace
tiffColorspace = TiffColorspace
TiffCMYK
                         , tiffBitsPerSample :: TiffInfo -> Vector Pixel32
tiffBitsPerSample = Vector Pixel32
lst
                         , tiffSampleFormat :: TiffInfo -> [TiffSampleFormat]
tiffSampleFormat = [TiffSampleFormat]
format }
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. [a] -> Vector a
V.fromList [Pixel32
8, Pixel32
8, Pixel32
8, Pixel32
8] Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelCMYK8 -> DynamicImage
ImageCMYK8 forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips (Pixel8
0 :: Word8) ByteString
file TiffInfo
nfo

  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. [a] -> Vector a
V.fromList [Pixel32
16, Pixel32
16, Pixel32
16, Pixel32
16] Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelCMYK16 -> DynamicImage
ImageCMYK16 forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips (Pixel16
0 :: Word16) ByteString
file TiffInfo
nfo

unpack ByteString
file nfo :: TiffInfo
nfo@TiffInfo { tiffColorspace :: TiffInfo -> TiffColorspace
tiffColorspace = TiffColorspace
TiffMonochromeWhite0 } = do
    PalettedImage
img <- ByteString -> TiffInfo -> Either String PalettedImage
unpack ByteString
file (TiffInfo
nfo { tiffColorspace :: TiffColorspace
tiffColorspace = TiffColorspace
TiffMonochrome })
    case PalettedImage
img of
      TrueColorImage (ImageY8 Image Pixel8
i) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Pixel8 -> DynamicImage
ImageY8 forall a b. (a -> b) -> a -> b
$ forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap (forall a. Bounded a => a
maxBound forall a. Num a => a -> a -> a
-) Image Pixel8
i
      TrueColorImage (ImageY16 Image Pixel16
i) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Pixel16 -> DynamicImage
ImageY16 forall a b. (a -> b) -> a -> b
$ forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap (forall a. Bounded a => a
maxBound forall a. Num a => a -> a -> a
-) Image Pixel16
i
      TrueColorImage (ImageYA8 Image PixelYA8
i) -> let negative :: PixelYA8 -> PixelYA8
negative (PixelYA8 Pixel8
y Pixel8
a) = Pixel8 -> Pixel8 -> PixelYA8
PixelYA8 (forall a. Bounded a => a
maxBound forall a. Num a => a -> a -> a
- Pixel8
y) Pixel8
a
                    in forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelYA8 -> DynamicImage
ImageYA8 forall a b. (a -> b) -> a -> b
$ forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap PixelYA8 -> PixelYA8
negative Image PixelYA8
i
      TrueColorImage (ImageYA16 Image PixelYA16
i) -> let negative :: PixelYA16 -> PixelYA16
negative (PixelYA16 Pixel16
y Pixel16
a) = Pixel16 -> Pixel16 -> PixelYA16
PixelYA16 (forall a. Bounded a => a
maxBound forall a. Num a => a -> a -> a
- Pixel16
y) Pixel16
a
                     in forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelYA16 -> DynamicImage
ImageYA16 forall a b. (a -> b) -> a -> b
$ forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap PixelYA16 -> PixelYA16
negative Image PixelYA16
i
      PalettedImage
_ -> forall a b. a -> Either a b
Left String
"Unsupported color type used with colorspace MonochromeWhite0"

unpack ByteString
file nfo :: TiffInfo
nfo@TiffInfo { tiffColorspace :: TiffInfo -> TiffColorspace
tiffColorspace = TiffColorspace
TiffMonochrome
                         , tiffBitsPerSample :: TiffInfo -> Vector Pixel32
tiffBitsPerSample = Vector Pixel32
lst
                         , tiffSampleFormat :: TiffInfo -> [TiffSampleFormat]
tiffSampleFormat = [TiffSampleFormat]
format }
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. a -> Vector a
V.singleton Pixel32
2 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Pixel8 -> DynamicImage
ImageY8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap (forall a.
Pixel a =>
(PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
colorMap (Pixel8
0x55 forall a. Num a => a -> a -> a
*)) forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips Pack2
Pack2 ByteString
file TiffInfo
nfo
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. a -> Vector a
V.singleton Pixel32
4 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Pixel8 -> DynamicImage
ImageY8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap (forall a.
Pixel a =>
(PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
colorMap (Pixel8
0x11 forall a. Num a => a -> a -> a
*)) forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips Pack4
Pack4 ByteString
file TiffInfo
nfo
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. a -> Vector a
V.singleton Pixel32
8 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Pixel8 -> DynamicImage
ImageY8 forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips (Pixel8
0 :: Word8) ByteString
file TiffInfo
nfo
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. a -> Vector a
V.singleton Pixel32
12 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Pixel16 -> DynamicImage
ImageY16 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap (forall a.
Pixel a =>
(PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
colorMap forall {a}. (Num a, Bits a) => a -> a
expand12to16) forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips Pack12
Pack12 ByteString
file TiffInfo
nfo
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. a -> Vector a
V.singleton Pixel32
16 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Pixel16 -> DynamicImage
ImageY16 forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips (Pixel16
0 :: Word16) ByteString
file TiffInfo
nfo
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. a -> Vector a
V.singleton Pixel32
32 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        let img :: Image Pixel32
img = forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips (Pixel32
0 :: Word32) ByteString
file TiffInfo
nfo :: Image Pixel32
        in forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ DynamicImage -> PalettedImage
TrueColorImage forall a b. (a -> b) -> a -> b
$ Image Pixel32 -> DynamicImage
ImageY32 forall a b. (a -> b) -> a -> b
$ Image Pixel32
img
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. a -> Vector a
V.singleton Pixel32
32 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleFloat forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        let img :: Image PixelF
img = forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips (PixelF
0 :: Float) ByteString
file TiffInfo
nfo :: Image PixelF
        in forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ DynamicImage -> PalettedImage
TrueColorImage forall a b. (a -> b) -> a -> b
$ Image PixelF -> DynamicImage
ImageYF forall a b. (a -> b) -> a -> b
$ Image PixelF
img
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. a -> Vector a
V.singleton Pixel32
64 = forall a b. a -> Either a b
Left String
"Failure to unpack TIFF file, 64-bit samples unsupported."
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. [a] -> Vector a
V.fromList [Pixel32
2, Pixel32
2] Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelYA8 -> DynamicImage
ImageYA8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap (forall a.
Pixel a =>
(PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
colorMap (Pixel8
0x55 forall a. Num a => a -> a -> a
*)) forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips Pack2
Pack2 ByteString
file TiffInfo
nfo
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. [a] -> Vector a
V.fromList [Pixel32
4, Pixel32
4] Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelYA8 -> DynamicImage
ImageYA8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap (forall a.
Pixel a =>
(PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
colorMap (Pixel8
0x11 forall a. Num a => a -> a -> a
*)) forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips Pack4
Pack4 ByteString
file TiffInfo
nfo
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. [a] -> Vector a
V.fromList [Pixel32
8, Pixel32
8] Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelYA8 -> DynamicImage
ImageYA8 forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips (Pixel8
0 :: Word8) ByteString
file TiffInfo
nfo
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. [a] -> Vector a
V.fromList [Pixel32
12, Pixel32
12] Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelYA16 -> DynamicImage
ImageYA16 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap (forall a.
Pixel a =>
(PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
colorMap forall {a}. (Num a, Bits a) => a -> a
expand12to16) forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips Pack12
Pack12 ByteString
file TiffInfo
nfo
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. [a] -> Vector a
V.fromList [Pixel32
16, Pixel32
16] Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelYA16 -> DynamicImage
ImageYA16 forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips (Pixel16
0 :: Word16) ByteString
file TiffInfo
nfo
    where
      expand12to16 :: a -> a
expand12to16 a
x = a
x forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
4 forall a. Num a => a -> a -> a
+ a
x forall a. Bits a => a -> Int -> a
`unsafeShiftR` (Int
12 forall a. Num a => a -> a -> a
- Int
4)

unpack ByteString
file nfo :: TiffInfo
nfo@TiffInfo { tiffColorspace :: TiffInfo -> TiffColorspace
tiffColorspace = TiffColorspace
TiffYCbCr
                         , tiffBitsPerSample :: TiffInfo -> Vector Pixel32
tiffBitsPerSample = Vector Pixel32
lst
                         , tiffPlaneConfiguration :: TiffInfo -> TiffPlanarConfiguration
tiffPlaneConfiguration = TiffPlanarConfiguration
PlanarConfigContig
                         , tiffSampleFormat :: TiffInfo -> [TiffSampleFormat]
tiffSampleFormat = [TiffSampleFormat]
format }
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. [a] -> Vector a
V.fromList [Pixel32
8, Pixel32
8, Pixel32
8] Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelYCbCr8 -> DynamicImage
ImageYCbCr8 forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips YCbCrSubsampling
cbcrConf  ByteString
file TiffInfo
nfo
      where defaulting :: a -> a
defaulting a
0 = a
2
            defaulting a
n = a
n

            w :: Pixel32
w = forall {a}. (Eq a, Num a) => a -> a
defaulting forall a b. (a -> b) -> a -> b
$ TiffInfo -> Vector Pixel32
tiffYCbCrSubsampling TiffInfo
nfo forall a. Vector a -> Int -> a
V.! Int
0
            h :: Pixel32
h = forall {a}. (Eq a, Num a) => a -> a
defaulting forall a b. (a -> b) -> a -> b
$ TiffInfo -> Vector Pixel32
tiffYCbCrSubsampling TiffInfo
nfo forall a. Vector a -> Int -> a
V.! Int
1
            cbcrConf :: YCbCrSubsampling
cbcrConf = YCbCrSubsampling
                { ycbcrWidth :: Int
ycbcrWidth        = forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
w
                , ycbcrHeight :: Int
ycbcrHeight       = forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
h
                , ycbcrImageWidth :: Int
ycbcrImageWidth   = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TiffInfo -> Pixel32
tiffWidth TiffInfo
nfo
                , ycbcrStripHeight :: Int
ycbcrStripHeight  = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TiffInfo -> Pixel32
tiffRowPerStrip TiffInfo
nfo
                }

unpack ByteString
file nfo :: TiffInfo
nfo@TiffInfo { tiffColorspace :: TiffInfo -> TiffColorspace
tiffColorspace = TiffColorspace
TiffRGB
                         , tiffBitsPerSample :: TiffInfo -> Vector Pixel32
tiffBitsPerSample = Vector Pixel32
lst
                         , tiffSampleFormat :: TiffInfo -> [TiffSampleFormat]
tiffSampleFormat = [TiffSampleFormat]
format }
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. [a] -> Vector a
V.fromList [Pixel32
2, Pixel32
2, Pixel32
2] Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap (forall a.
Pixel a =>
(PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
colorMap (Pixel8
0x55 forall a. Num a => a -> a -> a
*)) forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips Pack2
Pack2 ByteString
file TiffInfo
nfo
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. [a] -> Vector a
V.fromList [Pixel32
4, Pixel32
4, Pixel32
4] Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap (forall a.
Pixel a =>
(PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
colorMap (Pixel8
0x11 forall a. Num a => a -> a -> a
*)) forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips Pack4
Pack4 ByteString
file TiffInfo
nfo
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. [a] -> Vector a
V.fromList [Pixel32
8, Pixel32
8, Pixel32
8] Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips (Pixel8
0 :: Word8) ByteString
file TiffInfo
nfo
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. [a] -> Vector a
V.fromList [Pixel32
8, Pixel32
8, Pixel32
8, Pixel32
8] Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGBA8 -> DynamicImage
ImageRGBA8 forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips (Pixel8
0 :: Word8) ByteString
file TiffInfo
nfo
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. [a] -> Vector a
V.fromList [Pixel32
16, Pixel32
16, Pixel32
16] Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB16 -> DynamicImage
ImageRGB16 forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips (Pixel16
0 :: Word16) ByteString
file TiffInfo
nfo
  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. [a] -> Vector a
V.fromList [Pixel32
16, Pixel32
16, Pixel32
16, Pixel32
16] Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGBA16 -> DynamicImage
ImageRGBA16 forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips (Pixel16
0 :: Word16) ByteString
file TiffInfo
nfo
unpack ByteString
file nfo :: TiffInfo
nfo@TiffInfo { tiffColorspace :: TiffInfo -> TiffColorspace
tiffColorspace = TiffColorspace
TiffMonochrome
                         , tiffBitsPerSample :: TiffInfo -> Vector Pixel32
tiffBitsPerSample = Vector Pixel32
lst
                         , tiffSampleFormat :: TiffInfo -> [TiffSampleFormat]
tiffSampleFormat = [TiffSampleFormat]
format }
  -- some files are a little bit borked...

  | Vector Pixel32
lst forall a. Eq a => a -> a -> Bool
== forall a. [a] -> Vector a
V.fromList [Pixel32
8, Pixel32
8, Pixel32
8] Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TiffSampleFormat
TiffSampleUint forall a. Eq a => a -> a -> Bool
==) [TiffSampleFormat]
format =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 forall a b. (a -> b) -> a -> b
$ forall comp pixel.
(Unpackable comp, Pixel pixel,
 StorageType comp ~ PixelBaseComponent pixel) =>
comp -> ByteString -> TiffInfo -> Image pixel
gatherStrips (Pixel8
0 :: Word8) ByteString
file TiffInfo
nfo

unpack ByteString
_ TiffInfo
_ = forall a b. a -> Either a b
Left String
"Failure to unpack TIFF file"

-- | Decode a tiff encoded image while preserving the underlying

-- pixel type (except for Y32 which is truncated to 16 bits).

--

-- This function can output the following images:

--

--  * 'ImageY8'

--

--  * 'ImageY16'

--

--  * 'ImageY32'

--

--  * 'ImageYF'

--

--  * 'ImageYA8'

--

--  * 'ImageYA16'

--

--  * 'ImageRGB8'

--

--  * 'ImageRGB16'

--

--  * 'ImageRGBA8'

--

--  * 'ImageRGBA16'

--

--  * 'ImageCMYK8'

--

--  * 'ImageCMYK16'

--

decodeTiff :: B.ByteString -> Either String DynamicImage
decodeTiff :: ByteString -> Either String DynamicImage
decodeTiff = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String (DynamicImage, Metadatas)
decodeTiffWithMetadata 

-- | Like 'decodeTiff' but also provides some metdata present

-- in the Tiff file.

--

-- The metadata extracted are the 'Codec.Picture.Metadata.DpiX' &

-- 'Codec.Picture.Metadata.DpiY' information alongside the EXIF informations.

decodeTiffWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
decodeTiffWithMetadata :: ByteString -> Either String (DynamicImage, Metadatas)
decodeTiffWithMetadata ByteString
str = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first PalettedImage -> DynamicImage
palettedToTrueColor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String (PalettedImage, Metadatas)
decodeTiffWithPaletteAndMetadata ByteString
str

-- | Decode TIFF and provide separated palette and metadata

decodeTiffWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)
decodeTiffWithPaletteAndMetadata :: ByteString -> Either String (PalettedImage, Metadatas)
decodeTiffWithPaletteAndMetadata ByteString
file = forall a. Get a -> ByteString -> Either String a
runGetStrict (forall a b. BinaryParam a b => a -> Get b
getP ByteString
file) ByteString
file forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TiffInfo -> Either String (PalettedImage, Metadatas)
go
  where
    go :: TiffInfo -> Either String (PalettedImage, Metadatas)
go TiffInfo
tinfo = (, TiffInfo -> Metadatas
tiffMetadatas TiffInfo
tinfo) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> TiffInfo -> Either String PalettedImage
unpack ByteString
file TiffInfo
tinfo
    

-- | Class defining which pixel types can be serialized in a

-- Tiff file.

class (Pixel px) => TiffSaveable px where
  colorSpaceOfPixel :: px -> TiffColorspace

  extraSampleCodeOfPixel :: px -> Maybe ExtraSample
  extraSampleCodeOfPixel px
_ = forall a. Maybe a
Nothing

  subSamplingInfo   :: px -> V.Vector Word32
  subSamplingInfo px
_ = forall a. Vector a
V.empty

  sampleFormat :: px -> [TiffSampleFormat]
  sampleFormat px
_ = [TiffSampleFormat
TiffSampleUint]

instance TiffSaveable Pixel8 where
  colorSpaceOfPixel :: Pixel8 -> TiffColorspace
colorSpaceOfPixel Pixel8
_ = TiffColorspace
TiffMonochrome

instance TiffSaveable Pixel16 where
  colorSpaceOfPixel :: Pixel16 -> TiffColorspace
colorSpaceOfPixel Pixel16
_ = TiffColorspace
TiffMonochrome

instance TiffSaveable Pixel32 where
  colorSpaceOfPixel :: Pixel32 -> TiffColorspace
colorSpaceOfPixel Pixel32
_ = TiffColorspace
TiffMonochrome

instance TiffSaveable PixelF where
  colorSpaceOfPixel :: PixelF -> TiffColorspace
colorSpaceOfPixel PixelF
_ = TiffColorspace
TiffMonochrome
  sampleFormat :: PixelF -> [TiffSampleFormat]
sampleFormat PixelF
_      = [TiffSampleFormat
TiffSampleFloat]

instance TiffSaveable PixelYA8 where
  colorSpaceOfPixel :: PixelYA8 -> TiffColorspace
colorSpaceOfPixel PixelYA8
_ = TiffColorspace
TiffMonochrome
  extraSampleCodeOfPixel :: PixelYA8 -> Maybe ExtraSample
extraSampleCodeOfPixel PixelYA8
_ = forall a. a -> Maybe a
Just ExtraSample
ExtraSampleUnassociatedAlpha

instance TiffSaveable PixelYA16 where
  colorSpaceOfPixel :: PixelYA16 -> TiffColorspace
colorSpaceOfPixel PixelYA16
_ = TiffColorspace
TiffMonochrome
  extraSampleCodeOfPixel :: PixelYA16 -> Maybe ExtraSample
extraSampleCodeOfPixel PixelYA16
_ = forall a. a -> Maybe a
Just ExtraSample
ExtraSampleUnassociatedAlpha

instance TiffSaveable PixelCMYK8 where
  colorSpaceOfPixel :: PixelCMYK8 -> TiffColorspace
colorSpaceOfPixel PixelCMYK8
_ = TiffColorspace
TiffCMYK

instance TiffSaveable PixelCMYK16 where
  colorSpaceOfPixel :: PixelCMYK16 -> TiffColorspace
colorSpaceOfPixel PixelCMYK16
_ = TiffColorspace
TiffCMYK

instance TiffSaveable PixelRGB8 where
  colorSpaceOfPixel :: PixelRGB8 -> TiffColorspace
colorSpaceOfPixel  PixelRGB8
_ = TiffColorspace
TiffRGB

instance TiffSaveable PixelRGB16 where
  colorSpaceOfPixel :: PixelRGB16 -> TiffColorspace
colorSpaceOfPixel  PixelRGB16
_ = TiffColorspace
TiffRGB

instance TiffSaveable PixelRGBA8 where
  colorSpaceOfPixel :: PixelRGBA8 -> TiffColorspace
colorSpaceOfPixel PixelRGBA8
_ = TiffColorspace
TiffRGB
  extraSampleCodeOfPixel :: PixelRGBA8 -> Maybe ExtraSample
extraSampleCodeOfPixel PixelRGBA8
_ = forall a. a -> Maybe a
Just ExtraSample
ExtraSampleUnassociatedAlpha

instance TiffSaveable PixelRGBA16 where
  colorSpaceOfPixel :: PixelRGBA16 -> TiffColorspace
colorSpaceOfPixel PixelRGBA16
_ = TiffColorspace
TiffRGB
  extraSampleCodeOfPixel :: PixelRGBA16 -> Maybe ExtraSample
extraSampleCodeOfPixel PixelRGBA16
_ = forall a. a -> Maybe a
Just ExtraSample
ExtraSampleUnassociatedAlpha

instance TiffSaveable PixelYCbCr8 where
  colorSpaceOfPixel :: PixelYCbCr8 -> TiffColorspace
colorSpaceOfPixel PixelYCbCr8
_ = TiffColorspace
TiffYCbCr
  subSamplingInfo :: PixelYCbCr8 -> Vector Pixel32
subSamplingInfo PixelYCbCr8
_ = forall a. Int -> [a] -> Vector a
V.fromListN Int
2 [Pixel32
1, Pixel32
1]

-- | Transform an image into a Tiff encoded bytestring, ready to be

-- written as a file.

encodeTiff :: forall px. (TiffSaveable px) => Image px -> Lb.ByteString
encodeTiff :: forall px. TiffSaveable px => Image px -> ByteString
encodeTiff Image px
img = Put -> ByteString
runPut forall a b. (a -> b) -> a -> b
$ forall a b. BinaryParam a b => a -> b -> Put
putP ByteString
rawPixelData TiffInfo
hdr
  where intSampleCount :: Int
intSampleCount = forall a. Pixel a => a -> Int
componentCount (forall a. HasCallStack => a
undefined :: px)
        sampleCount :: Pixel32
sampleCount = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
intSampleCount

        sampleType :: PixelBaseComponent px
sampleType = forall a. HasCallStack => a
undefined :: PixelBaseComponent px
        pixelData :: Vector (PixelBaseComponent px)
pixelData = forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image px
img

        rawPixelData :: ByteString
rawPixelData = forall a. Storable a => Vector a -> ByteString
toByteString Vector (PixelBaseComponent px)
pixelData
        width :: Pixel32
width = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Image a -> Int
imageWidth Image px
img
        height :: Pixel32
height = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Image a -> Int
imageHeight Image px
img
        intSampleSize :: Int
intSampleSize = forall a. Storable a => a -> Int
sizeOf PixelBaseComponent px
sampleType
        sampleSize :: Pixel32
sampleSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
intSampleSize
        bitPerSample :: Pixel32
bitPerSample = Pixel32
sampleSize forall a. Num a => a -> a -> a
* Pixel32
8
        imageSize :: Pixel32
imageSize = Pixel32
width forall a. Num a => a -> a -> a
* Pixel32
height forall a. Num a => a -> a -> a
* Pixel32
sampleCount forall a. Num a => a -> a -> a
* Pixel32
sampleSize
        headerSize :: Pixel32
headerSize = Pixel32
8

        hdr :: TiffInfo
hdr = TiffInfo
            { tiffHeader :: TiffHeader
tiffHeader             = TiffHeader
                                            { hdrEndianness :: Endianness
hdrEndianness = Endianness
EndianLittle
                                            , hdrOffset :: Pixel32
hdrOffset = Pixel32
headerSize forall a. Num a => a -> a -> a
+ Pixel32
imageSize
                                            }
            , tiffWidth :: Pixel32
tiffWidth              = Pixel32
width
            , tiffHeight :: Pixel32
tiffHeight             = Pixel32
height
            , tiffColorspace :: TiffColorspace
tiffColorspace         = forall px. TiffSaveable px => px -> TiffColorspace
colorSpaceOfPixel (forall a. HasCallStack => a
undefined :: px)
            , tiffSampleCount :: Pixel32
tiffSampleCount        = forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel32
sampleCount
            , tiffRowPerStrip :: Pixel32
tiffRowPerStrip        = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Image a -> Int
imageHeight Image px
img
            , tiffPlaneConfiguration :: TiffPlanarConfiguration
tiffPlaneConfiguration = TiffPlanarConfiguration
PlanarConfigContig
            , tiffSampleFormat :: [TiffSampleFormat]
tiffSampleFormat       = forall px. TiffSaveable px => px -> [TiffSampleFormat]
sampleFormat (forall a. HasCallStack => a
undefined :: px)
            , tiffBitsPerSample :: Vector Pixel32
tiffBitsPerSample      = forall a. Int -> a -> Vector a
V.replicate Int
intSampleCount Pixel32
bitPerSample
            , tiffCompression :: TiffCompression
tiffCompression        = TiffCompression
CompressionNone
            , tiffStripSize :: Vector Pixel32
tiffStripSize          = forall a. a -> Vector a
V.singleton Pixel32
imageSize
            , tiffOffsets :: Vector Pixel32
tiffOffsets            = forall a. a -> Vector a
V.singleton Pixel32
headerSize
            , tiffPalette :: Maybe (Image PixelRGB16)
tiffPalette            = forall a. Maybe a
Nothing
            , tiffYCbCrSubsampling :: Vector Pixel32
tiffYCbCrSubsampling   = forall px. TiffSaveable px => px -> Vector Pixel32
subSamplingInfo (forall a. HasCallStack => a
undefined :: px)
            , tiffExtraSample :: Maybe ExtraSample
tiffExtraSample        = forall px. TiffSaveable px => px -> Maybe ExtraSample
extraSampleCodeOfPixel (forall a. HasCallStack => a
undefined :: px)
            , tiffPredictor :: Predictor
tiffPredictor          = Predictor
PredictorNone -- not used when writing

            , tiffMetadatas :: Metadatas
tiffMetadatas          = forall a. Monoid a => a
mempty
            }

-- | Helper function to directly write an image as a tiff on disk.

writeTiff :: (TiffSaveable pixel) => FilePath -> Image pixel -> IO ()
writeTiff :: forall pixel. TiffSaveable pixel => String -> Image pixel -> IO ()
writeTiff String
path Image pixel
img = String -> ByteString -> IO ()
Lb.writeFile String
path forall a b. (a -> b) -> a -> b
$ forall px. TiffSaveable px => Image px -> ByteString
encodeTiff Image pixel
img

{-# ANN module "HLint: ignore Reduce duplication" #-}