{-# 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 -> Word32
tiffWidth              :: Word32
  , TiffInfo -> Word32
tiffHeight             :: Word32
  , TiffInfo -> TiffColorspace
tiffColorspace         :: TiffColorspace
  , TiffInfo -> Word32
tiffSampleCount        :: Word32
  , TiffInfo -> Word32
tiffRowPerStrip        :: Word32
  , TiffInfo -> TiffPlanarConfiguration
tiffPlaneConfiguration :: TiffPlanarConfiguration
  , TiffInfo -> [TiffSampleFormat]
tiffSampleFormat       :: [TiffSampleFormat]
  , TiffInfo -> Vector Word32
tiffBitsPerSample      :: V.Vector Word32
  , TiffInfo -> TiffCompression
tiffCompression        :: TiffCompression
  , TiffInfo -> Vector Word32
tiffStripSize          :: V.Vector Word32
  , TiffInfo -> Vector Word32
tiffOffsets            :: V.Vector Word32
  , TiffInfo -> Maybe (Image PixelRGB16)
tiffPalette            :: Maybe (Image PixelRGB16)
  , TiffInfo -> Vector Word32
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 Word32)
unLong String
_ (ExifLong Word32
v)   = Vector Word32 -> Get (Vector Word32)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector Word32 -> Get (Vector Word32))
-> Vector Word32 -> Get (Vector Word32)
forall a b. (a -> b) -> a -> b
$ Word32 -> Vector Word32
forall a. a -> Vector a
V.singleton Word32
v
unLong String
_ (ExifShort Word16
v)  = Vector Word32 -> Get (Vector Word32)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector Word32 -> Get (Vector Word32))
-> Vector Word32 -> Get (Vector Word32)
forall a b. (a -> b) -> a -> b
$ Word32 -> Vector Word32
forall a. a -> Vector a
V.singleton (Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
v)
unLong String
_ (ExifShorts Vector Word16
v) = Vector Word32 -> Get (Vector Word32)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector Word32 -> Get (Vector Word32))
-> Vector Word32 -> Get (Vector Word32)
forall a b. (a -> b) -> a -> b
$ (Word16 -> Word32) -> Vector Word16 -> Vector Word32
forall a b. (a -> b) -> Vector a -> Vector b
V.map Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Vector Word16
v
unLong String
_ (ExifLongs Vector Word32
v) = Vector Word32 -> Get (Vector Word32)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Vector Word32
v
unLong String
errMessage ExifData
_ = String -> Get (Vector Word32)
forall a. String -> Get a
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 ExifTag -> ExifTag -> Bool
forall a. Eq a => a -> a -> Bool
== ExifTag
tag] of
    [] -> String -> Get ImageFileDirectory
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
errorMessage
    (ImageFileDirectory
x:[ImageFileDirectory]
_) -> ImageFileDirectory -> Get ImageFileDirectory
forall a. a -> Get a
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 ExifTag -> ExifTag -> Bool
forall a. Eq a => a -> a -> Bool
== ExifTag
TagColorMap] of
        (ImageFileDirectory { ifdExtended :: ImageFileDirectory -> ExifData
ifdExtended = ExifShorts Vector Word16
vec }:[ImageFileDirectory]
_) ->
            Maybe (Image PixelRGB16) -> Get (Maybe (Image PixelRGB16))
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Image PixelRGB16) -> Get (Maybe (Image PixelRGB16)))
-> (Vector Word16 -> Maybe (Image PixelRGB16))
-> Vector Word16
-> Get (Maybe (Image PixelRGB16))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB16 -> Maybe (Image PixelRGB16)
forall a. a -> Maybe a
Just (Image PixelRGB16 -> Maybe (Image PixelRGB16))
-> (Vector Word16 -> Image PixelRGB16)
-> Vector Word16
-> Maybe (Image PixelRGB16)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Int
-> Vector (PixelBaseComponent PixelRGB16)
-> Image PixelRGB16
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
pixelCount Int
1 (Vector Word16 -> Get (Maybe (Image PixelRGB16)))
-> Vector Word16 -> Get (Maybe (Image PixelRGB16))
forall a b. (a -> b) -> a -> b
$ Int -> (Int -> Word16) -> Vector Word16
forall a. Storable a => Int -> (Int -> a) -> Vector a
VS.generate (Vector Word16 -> Int
forall a. Vector a -> Int
V.length Vector Word16
vec) Int -> Word16
axx
                where pixelCount :: Int
pixelCount = Vector Word16 -> Int
forall a. Vector a -> Int
V.length Vector Word16
vec Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3
                      axx :: Int -> Word16
axx Int
v = Vector Word16
vec Vector Word16 -> Int -> Word16
forall a. Vector a -> Int -> a
`V.unsafeIndex` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
color Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
pixelCount)
                          where (Int
idx, Int
color) = Int
v Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
3

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

findIFDData :: String -> ExifTag -> [ImageFileDirectory] -> Get Word32
findIFDData :: String -> ExifTag -> [ImageFileDirectory] -> Get Word32
findIFDData String
msg ExifTag
tag [ImageFileDirectory]
lst = ImageFileDirectory -> Word32
ifdOffset (ImageFileDirectory -> Word32)
-> Get ImageFileDirectory -> Get Word32
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 :: Word32 -> ExifTag -> [ImageFileDirectory] -> Get Word32
findIFDDefaultData Word32
d ExifTag
tag [ImageFileDirectory]
lst =
    case [ImageFileDirectory
v | ImageFileDirectory
v <- [ImageFileDirectory]
lst, ImageFileDirectory -> ExifTag
ifdIdentifier ImageFileDirectory
v ExifTag -> ExifTag -> Bool
forall a. Eq a => a -> a -> Bool
== ExifTag
tag] of
        [] -> Word32 -> Get Word32
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
d
        (ImageFileDirectory
x:[ImageFileDirectory]
_) -> Word32 -> Get Word32
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> Get Word32) -> Word32 -> Get Word32
forall a b. (a -> b) -> a -> b
$ ImageFileDirectory -> Word32
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 -> Word32
ifdCount = Word32
1, ifdOffset :: ImageFileDirectory -> Word32
ifdOffset = Word32
ofs, ifdType :: ImageFileDirectory -> IfdType
ifdType = IfdType
TypeShort } ->
               ExifData -> Get ExifData
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExifData -> Get ExifData)
-> (Word16 -> ExifData) -> Word16 -> Get ExifData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word16 -> ExifData
ExifShorts (Vector Word16 -> ExifData)
-> (Word16 -> Vector Word16) -> Word16 -> ExifData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Vector Word16
forall a. a -> Vector a
V.singleton (Word16 -> Get ExifData) -> Word16 -> Get ExifData
forall a b. (a -> b) -> a -> b
$ Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ofs
      ImageFileDirectory
        { ifdCount :: ImageFileDirectory -> Word32
ifdCount = Word32
1, ifdOffset :: ImageFileDirectory -> Word32
ifdOffset = Word32
ofs, ifdType :: ImageFileDirectory -> IfdType
ifdType = IfdType
TypeLong } ->
               ExifData -> Get ExifData
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExifData -> Get ExifData)
-> (Word32 -> ExifData) -> Word32 -> Get ExifData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word32 -> ExifData
ExifLongs  (Vector Word32 -> ExifData)
-> (Word32 -> Vector Word32) -> Word32 -> ExifData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Vector Word32
forall a. a -> Vector a
V.singleton (Word32 -> Get ExifData) -> Word32 -> Get ExifData
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ofs
      ImageFileDirectory { ifdExtended :: ImageFileDirectory -> ExifData
ifdExtended = ExifData
v } -> ExifData -> Get ExifData
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExifData
v


findIFDExtDefaultData :: [Word32] -> ExifTag -> [ImageFileDirectory]
                      -> Get [Word32]
findIFDExtDefaultData :: [Word32] -> ExifTag -> [ImageFileDirectory] -> Get [Word32]
findIFDExtDefaultData [Word32]
d ExifTag
tag [ImageFileDirectory]
lst =
    case [ImageFileDirectory
v | ImageFileDirectory
v <- [ImageFileDirectory]
lst, ImageFileDirectory -> ExifTag
ifdIdentifier ImageFileDirectory
v ExifTag -> ExifTag -> Bool
forall a. Eq a => a -> a -> Bool
== ExifTag
tag] of
        [] -> [Word32] -> Get [Word32]
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Word32]
d
        (ImageFileDirectory { ifdExtended :: ImageFileDirectory -> ExifData
ifdExtended = ExifData
ExifNone }:[ImageFileDirectory]
_) -> [Word32] -> Get [Word32]
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return [Word32]
d
        (ImageFileDirectory
x:[ImageFileDirectory]
_) -> Vector Word32 -> [Word32]
forall a. Vector a -> [a]
V.toList (Vector Word32 -> [Word32]) -> Get (Vector Word32) -> Get [Word32]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ExifData -> Get (Vector Word32)
unLong String
errorMessage (ImageFileDirectory -> ExifData
ifdExtended ImageFileDirectory
x)
            where errorMessage :: String
errorMessage =
                    String
"Can't parse tag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExifTag -> String
forall a. Show a => a -> String
show ExifTag
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExifData -> String
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 Word8 -> Int -> Int -> (Word32, Word32) -> ST s Int
copyByteString ByteString
str STVector s Word8
vec Int
stride Int
startWrite (Word32
from, Word32
count) = Int -> Int -> ST s Int
inner Int
startWrite Int
fromi
  where fromi :: Int
fromi = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
from
        maxi :: Int
maxi = Int
fromi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
count

        inner :: Int -> Int -> ST s Int
inner Int
writeIdx Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxi = Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
writeIdx
        inner Int
writeIdx Int
i = do
            let v :: Word8
v = ByteString
str ByteString -> Int -> Word8
`BU.unsafeIndex` Int
i
            (STVector s Word8
MVector (PrimState (ST s)) Word8
vec MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) Word8
v
            Int -> Int -> ST s Int
inner (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
stride) (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
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 Word8 -> Int -> Int -> (Word32, Word32) -> ST s Int
unpackPackBit ByteString
str STVector s Word8
outVec Int
stride Int
writeIndex (Word32
offset, Word32
size) = Int -> Int -> ST s Int
loop Int
fromi Int
writeIndex
  where fromi :: Int
fromi = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
offset
        maxi :: Int
maxi = Int
fromi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size

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

        loop :: Int -> Int -> ST s Int
loop Int
i Int
writeIdx | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxi = Int -> ST s Int
forall a. a -> ST s a
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 = Word8 -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString
str HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
`B.index` Int
i) :: Int8

                choice :: ST s Int
choice
                    -- data

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

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

                    -- noop

                    | Bool
otherwise = Int -> Int -> ST s Int
loop Int
writeIdx (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
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 Word8
-> Int
-> Int
-> (Word32, Word32)
-> ST s Int
uncompressAt TiffCompression
CompressionNone = ByteString
-> STVector s Word8 -> Int -> Int -> (Word32, Word32) -> ST s Int
forall s.
ByteString
-> STVector s Word8 -> Int -> Int -> (Word32, Word32) -> ST s Int
copyByteString
uncompressAt TiffCompression
CompressionPackBit = ByteString
-> STVector s Word8 -> Int -> Int -> (Word32, Word32) -> ST s Int
forall s.
ByteString
-> STVector s Word8 -> Int -> Int -> (Word32, Word32) -> ST s Int
unpackPackBit
uncompressAt TiffCompression
CompressionLZW =  \ByteString
str STVector s Word8
outVec Int
_stride Int
writeIndex (Word32
offset, Word32
size) -> do
    let toDecode :: ByteString
toDecode = Int -> ByteString -> ByteString
B.take (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
offset) ByteString
str
    BoolReader s () -> ST s ()
forall s a. BoolReader s a -> ST s a
runBoolReader (BoolReader s () -> ST s ()) -> BoolReader s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ ByteString -> STVector s Word8 -> Int -> BoolReader s ()
forall s. ByteString -> STVector s Word8 -> Int -> BoolReader s ()
decodeLzwTiff ByteString
toDecode STVector s Word8
outVec Int
writeIndex
    Int -> ST s Int
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
uncompressAt TiffCompression
_ = String
-> ByteString
-> STVector s Word8
-> Int
-> Int
-> (Word32, Word32)
-> ST s Int
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 :: Word8 -> Int -> Int -> (Int, Int)
offsetStride Word8
_ Int
i Int
stride = (Int
i, Int
stride)
  allocTempBuffer :: forall s.
Word8
-> STVector s (StorageType Word8) -> Int -> ST s (STVector s Word8)
allocTempBuffer Word8
_ STVector s (StorageType Word8)
buff Int
_ = STVector s Word8 -> ST s (STVector s Word8)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure STVector s Word8
STVector s (StorageType Word8)
buff
  mergeBackTempBuffer :: forall s.
Word8
-> Endianness
-> STVector s Word8
-> Int
-> Int
-> Word32
-> Int
-> STVector s (StorageType Word8)
-> ST s ()
mergeBackTempBuffer Word8
_ Endianness
_ STVector s Word8
_ Int
_ Int
_ Word32
_ Int
_ STVector s (StorageType Word8)
_ = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  outAlloc :: forall s. Word8 -> Int -> ST s (STVector s (StorageType Word8))
outAlloc Word8
_ Int
count = Int -> Word8 -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
M.replicate Int
count Word8
0 -- M.new


instance Unpackable Word16 where
  type StorageType Word16 = Word16

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

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

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

instance Unpackable Word32 where
  type StorageType Word32 = Word32

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

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

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

instance Unpackable Float where
  type StorageType Float = Float

  offsetStride :: Float -> Int -> Int -> (Int, Int)
offsetStride Float
_ Int
_ Int
_ = (Int
0, Int
1)
  outAlloc :: forall s. Float -> Int -> ST s (STVector s (StorageType Float))
outAlloc Float
_ = Int -> ST s (MVector s (StorageType Float))
Int -> ST s (MVector (PrimState (ST s)) Float)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new
  allocTempBuffer :: forall s.
Float
-> STVector s (StorageType Float) -> Int -> ST s (STVector s Word8)
allocTempBuffer Float
_ STVector s (StorageType Float)
_ Int
s = Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new (Int -> ST s (MVector (PrimState (ST s)) Word8))
-> Int -> ST s (MVector (PrimState (ST s)) Word8)
forall a b. (a -> b) -> a -> b
$ Int
s Int -> Int -> Int
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.
Float
-> Endianness
-> STVector s Word8
-> Int
-> Int
-> Word32
-> Int
-> STVector s (StorageType Float)
-> ST s ()
mergeBackTempBuffer Float
_ Endianness
endianness STVector s Word8
tempVec Int
lineSize Int
index Word32
size Int
stride STVector s (StorageType Float)
outVec =
        let outVecWord32 :: M.STVector s Word32
            outVecWord32 :: STVector s Word32
outVecWord32 = MVector s Float -> STVector s Word32
forall a b s.
(Storable a, Storable b) =>
MVector s a -> MVector s b
M.unsafeCast MVector s Float
STVector s (StorageType Float)
outVec
        in Word32
-> Endianness
-> STVector s Word8
-> Int
-> Int
-> Word32
-> Int
-> STVector s (StorageType Word32)
-> ST s ()
forall s.
Word32
-> Endianness
-> STVector s Word8
-> Int
-> Int
-> Word32
-> Int
-> STVector s (StorageType Word32)
-> ST s ()
forall a s.
Unpackable a =>
a
-> Endianness
-> STVector s Word8
-> Int
-> Int
-> Word32
-> Int
-> STVector s (StorageType a)
-> ST s ()
mergeBackTempBuffer (Word32
0 :: Word32)
                               Endianness
endianness
                               STVector s Word8
tempVec
                               Int
lineSize
                               Int
index
                               Word32
size
                               Int
stride
                               STVector s Word32
STVector s (StorageType Word32)
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 Word8)
allocTempBuffer Pack4
_ STVector s (StorageType Pack4)
_ = Int -> ST s (MVector s Word8)
Int -> ST s (MVector (PrimState (ST s)) Word8)
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
_ = Int -> ST s (MVector s (StorageType Pack4))
Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new
  mergeBackTempBuffer :: forall s.
Pack4
-> Endianness
-> STVector s Word8
-> Int
-> Int
-> Word32
-> Int
-> STVector s (StorageType Pack4)
-> ST s ()
mergeBackTempBuffer Pack4
_ Endianness
_ STVector s Word8
tempVec Int
lineSize Int
index Word32
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 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
stride

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

            Int -> Int -> Int -> ST s ()
inner (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
stride) (Int
line Int -> Int -> Int
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 Word8)
allocTempBuffer Pack2
_ STVector s (StorageType Pack2)
_ = Int -> ST s (MVector s Word8)
Int -> ST s (MVector (PrimState (ST s)) Word8)
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
_ = Int -> ST s (MVector s (StorageType Pack2))
Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new
  mergeBackTempBuffer :: forall s.
Pack2
-> Endianness
-> STVector s Word8
-> Int
-> Int
-> Word32
-> Int
-> STVector s (StorageType Pack2)
-> ST s ()
mergeBackTempBuffer Pack2
_ Endianness
_ STVector s Word8
tempVec Int
lineSize Int
index Word32
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 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
stride

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

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

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

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

            Int -> Int -> Int -> ST s ()
inner (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
stride) (Int
line Int -> Int -> Int
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 Word8)
allocTempBuffer Pack12
_ STVector s (StorageType Pack12)
_ = Int -> ST s (MVector s Word8)
Int -> ST s (MVector (PrimState (ST s)) Word8)
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
_ = Int -> ST s (MVector s (StorageType Pack12))
Int -> ST s (MVector (PrimState (ST s)) Word16)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new
  mergeBackTempBuffer :: forall s.
Pack12
-> Endianness
-> STVector s Word8
-> Int
-> Int
-> Word32
-> Int
-> STVector s (StorageType Pack12)
-> ST s ()
mergeBackTempBuffer Pack12
_ Endianness
_ STVector s Word8
tempVec Int
lineSize Int
index Word32
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 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
stride

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

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

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

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

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

            Int -> Int -> Int -> ST s ()
inner (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
stride) (Int
line Int -> Int -> Int
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
_ = Int -> ST s (MVector s (StorageType YCbCrSubsampling))
Int -> ST s (MVector (PrimState (ST s)) Word8)
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 Word8)
allocTempBuffer YCbCrSubsampling
_ STVector s (StorageType YCbCrSubsampling)
_ = Int -> ST s (MVector s Word8)
Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new
  mergeBackTempBuffer :: forall s.
YCbCrSubsampling
-> Endianness
-> STVector s Word8
-> Int
-> Int
-> Word32
-> Int
-> STVector s (StorageType YCbCrSubsampling)
-> ST s ()
mergeBackTempBuffer YCbCrSubsampling
subSampling Endianness
_ STVector s Word8
tempVec Int
_ Int
index Word32
size Int
_ STVector s (StorageType YCbCrSubsampling)
outVec =
      (Int -> (Int, Int) -> ST s Int) -> Int -> [(Int, Int)] -> ST s ()
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
                                  , Int
bx <- [Int
0, Int
w .. Int
imgWidth Int -> Int -> Int
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