{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
-- | Module used for loading & writing \'Portable Network Graphics\' (PNG)

-- files.

--

-- A high level API is provided. It loads and saves images for you

-- while hiding all the details about PNG chunks.

--

-- Basic functions for PNG handling are 'decodePng', 'encodePng'

-- and 'encodePalettedPng'. Convenience functions are provided

-- for direct file handling and using 'DynamicImage's.

--

-- The loader has been validated against the pngsuite (http://www.libpng.org/pub/png/pngsuite.html)

module Codec.Picture.Png( -- * High level functions

                          PngSavable( .. ),
                          PngPaletteSaveable( .. )

                        , decodePng
                        , decodePngWithMetadata
                        , decodePngWithPaletteAndMetadata

                        , writePng
                        , encodeDynamicPng
                        , writeDynamicPng
                        ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( (<$>) )
#endif

import Control.Arrow( first )
import Control.Monad( forM_, foldM_, when, void )
import Control.Monad.ST( ST, runST )

#if !MIN_VERSION_base(4,11,0)
import Data.Monoid( (<>) )
#endif

import Data.Binary( Binary( get) )

import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Mutable as M
import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR )
import Data.List( find, zip4 )
import Data.Word( Word8, Word16, Word32 )
import qualified Codec.Compression.Zlib as Z
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as BU
import qualified Data.ByteString.Lazy as Lb
import Foreign.Storable ( Storable )

import Codec.Picture.Types
import Codec.Picture.Metadata
import Codec.Picture.Png.Internal.Type
import Codec.Picture.Png.Internal.Export
import Codec.Picture.Png.Internal.Metadata
import Codec.Picture.InternalHelper

-- | Simple structure used to hold information about Adam7 deinterlacing.

-- A structure is used to avoid pollution of the module namespace.

data Adam7MatrixInfo = Adam7MatrixInfo
    { Adam7MatrixInfo -> [Int]
adam7StartingRow  :: [Int]
    , Adam7MatrixInfo -> [Int]
adam7StartingCol  :: [Int]
    , Adam7MatrixInfo -> [Int]
adam7RowIncrement :: [Int]
    , Adam7MatrixInfo -> [Int]
adam7ColIncrement :: [Int]
    , Adam7MatrixInfo -> [Int]
adam7BlockHeight  :: [Int]
    , Adam7MatrixInfo -> [Int]
adam7BlockWidth   :: [Int]
    }

-- | The real info about the matrix.

adam7MatrixInfo :: Adam7MatrixInfo
adam7MatrixInfo :: Adam7MatrixInfo
adam7MatrixInfo = Adam7MatrixInfo :: [Int]
-> [Int] -> [Int] -> [Int] -> [Int] -> [Int] -> Adam7MatrixInfo
Adam7MatrixInfo
    { adam7StartingRow :: [Int]
adam7StartingRow  = [0, 0, 4, 0, 2, 0, 1]
    , adam7StartingCol :: [Int]
adam7StartingCol  = [0, 4, 0, 2, 0, 1, 0]
    , adam7RowIncrement :: [Int]
adam7RowIncrement = [8, 8, 8, 4, 4, 2, 2]
    , adam7ColIncrement :: [Int]
adam7ColIncrement = [8, 8, 4, 4, 2, 2, 1]
    , adam7BlockHeight :: [Int]
adam7BlockHeight  = [8, 8, 4, 4, 2, 2, 1]
    , adam7BlockWidth :: [Int]
adam7BlockWidth   = [8, 4, 4, 2, 2, 1, 1]
    }

unparsePngFilter :: Word8 -> Either String PngFilter
{-# INLINE unparsePngFilter #-}
unparsePngFilter :: Word8 -> Either String PngFilter
unparsePngFilter 0 = PngFilter -> Either String PngFilter
forall a b. b -> Either a b
Right PngFilter
FilterNone
unparsePngFilter 1 = PngFilter -> Either String PngFilter
forall a b. b -> Either a b
Right PngFilter
FilterSub
unparsePngFilter 2 = PngFilter -> Either String PngFilter
forall a b. b -> Either a b
Right PngFilter
FilterUp
unparsePngFilter 3 = PngFilter -> Either String PngFilter
forall a b. b -> Either a b
Right PngFilter
FilterAverage
unparsePngFilter 4 = PngFilter -> Either String PngFilter
forall a b. b -> Either a b
Right PngFilter
FilterPaeth
unparsePngFilter _ = String -> Either String PngFilter
forall a b. a -> Either a b
Left "Invalid scanline filter"

getBounds :: (Monad m, Storable a) => M.STVector s a -> m (Int, Int)
{-# INLINE getBounds #-}
getBounds :: STVector s a -> m (Int, Int)
getBounds v :: STVector s a
v = (Int, Int) -> m (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (0, STVector s a -> Int
forall a s. Storable a => MVector s a -> Int
M.length STVector s a
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)

-- | Apply a filtering method on a reduced image. Apply the filter

-- on each line, using the previous line (the one above it) to perform

-- some prediction on the value.

pngFiltering :: LineUnpacker s -> Int -> (Int, Int)    -- ^ Image size

             -> B.ByteString -> Int
             -> ST s Int
pngFiltering :: LineUnpacker s
-> Int -> (Int, Int) -> ByteString -> Int -> ST s Int
pngFiltering _ _ (imgWidth :: Int
imgWidth, imgHeight :: Int
imgHeight) _str :: ByteString
_str initialIdx :: Int
initialIdx
        | Int
imgWidth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 Bool -> Bool -> Bool
|| Int
imgHeight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
initialIdx
pngFiltering unpacker :: LineUnpacker s
unpacker beginZeroes :: Int
beginZeroes (imgWidth :: Int
imgWidth, imgHeight :: Int
imgHeight) str :: ByteString
str initialIdx :: Int
initialIdx = do
    PngLine s
thisLine <- 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
beginZeroes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
imgWidth) 0
    PngLine s
otherLine <- 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
beginZeroes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
imgWidth) 0
    let folder :: PngLine s -> PngLine s -> Int -> Int -> ST s Int
folder            _          _  lineIndex :: Int
lineIndex !Int
idx | Int
lineIndex Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
imgHeight = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
idx
        folder previousLine :: PngLine s
previousLine currentLine :: PngLine s
currentLine lineIndex :: Int
lineIndex !Int
idx = do
               let byte :: Word8
byte = ByteString
str ByteString -> Int -> Word8
`BU.unsafeIndex` Int
idx
               let lineFilter :: PngLine s -> PngLine s -> Int -> ST s Int
lineFilter = case Word8 -> Either String PngFilter
unparsePngFilter Word8
byte of
                       Right FilterNone    -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterNone
                       Right FilterSub     -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterSub
                       Right FilterAverage -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterAverage
                       Right FilterUp      -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterUp
                       Right FilterPaeth   -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterPaeth
                       _ -> PngLine s -> PngLine s -> Int -> ST s Int
forall s. PngLine s -> PngLine s -> Int -> ST s Int
filterNone
               Int
idx' <- PngLine s -> PngLine s -> Int -> ST s Int
lineFilter PngLine s
previousLine PngLine s
currentLine (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
               LineUnpacker s
unpacker Int
lineIndex (Int
stride, PngLine s
currentLine)
               PngLine s -> PngLine s -> Int -> Int -> ST s Int
folder PngLine s
currentLine PngLine s
previousLine (Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int
idx'

    PngLine s -> PngLine s -> Int -> Int -> ST s Int
folder PngLine s
thisLine PngLine s
otherLine (0 :: Int) Int
initialIdx

    where stride :: Int
stride = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
beginZeroes
          lastIdx :: Int
lastIdx = Int
beginZeroes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
imgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1

          -- The filter implementation are... well non-idiomatic

          -- to say the least, but my benchmarks proved me one thing,

          -- they are faster than mapM_, gained something like 5% with

          -- a rewrite from mapM_ to this direct version

          filterNone, filterSub, filterUp, filterPaeth,
                filterAverage :: PngLine s -> PngLine s -> Int -> ST s Int
          filterNone :: PngLine s -> PngLine s -> Int -> ST s Int
filterNone !PngLine s
_previousLine !PngLine s
thisLine = Int -> Int -> ST s Int
inner Int
beginZeroes
            where inner :: Int -> Int -> ST s Int
inner idx :: Int
idx !Int
readIdx
                            | Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lastIdx = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
readIdx
                            | Bool
otherwise = do let byte :: Word8
byte = ByteString
str ByteString -> Int -> Word8
`BU.unsafeIndex` Int
readIdx
                                             (PngLine s
MVector (PrimState (ST s)) Word8
thisLine 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
idx) Word8
byte
                                             Int -> Int -> ST s Int
inner (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

          filterSub :: PngLine s -> PngLine s -> Int -> ST s Int
filterSub !PngLine s
_previousLine !PngLine s
thisLine = Int -> Int -> ST s Int
inner Int
beginZeroes
            where inner :: Int -> Int -> ST s Int
inner idx :: Int
idx !Int
readIdx
                            | Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lastIdx = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
readIdx
                            | Bool
otherwise = do let byte :: Word8
byte = ByteString
str ByteString -> Int -> Word8
`BU.unsafeIndex` Int
readIdx
                                             Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
thisLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
stride)
                                             (PngLine s
MVector (PrimState (ST s)) Word8
thisLine 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
idx) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Word8
byte Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
val
                                             Int -> Int -> ST s Int
inner (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

          filterUp :: PngLine s -> PngLine s -> Int -> ST s Int
filterUp !PngLine s
previousLine !PngLine s
thisLine = Int -> Int -> ST s Int
inner Int
beginZeroes
            where inner :: Int -> Int -> ST s Int
inner idx :: Int
idx !Int
readIdx
                            | Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lastIdx = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
readIdx
                            | Bool
otherwise = do let byte :: Word8
byte = ByteString
str ByteString -> Int -> Word8
`BU.unsafeIndex` Int
readIdx
                                             Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
previousLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
                                             (PngLine s
MVector (PrimState (ST s)) Word8
thisLine 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
idx) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Word8
val Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
byte
                                             Int -> Int -> ST s Int
inner (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

          filterAverage :: PngLine s -> PngLine s -> Int -> ST s Int
filterAverage !PngLine s
previousLine !PngLine s
thisLine = Int -> Int -> ST s Int
inner Int
beginZeroes
            where inner :: Int -> Int -> ST s Int
inner idx :: Int
idx !Int
readIdx
                            | Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lastIdx = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
readIdx
                            | Bool
otherwise = do let byte :: Word8
byte = ByteString
str ByteString -> Int -> Word8
`BU.unsafeIndex` Int
readIdx
                                             Word8
valA <- PngLine s
MVector (PrimState (ST s)) Word8
thisLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
stride)
                                             Word8
valB <- PngLine s
MVector (PrimState (ST s)) Word8
previousLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
                                             let a' :: Word16
a' = Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
valA
                                                 b' :: Word16
b' = Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
valB
                                                 average :: Word8
average = Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word16
a' Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
b') Word16 -> Word16 -> Word16
forall a. Integral a => a -> a -> a
`div` (2 :: Word16)) 
                                                 writeVal :: Word8
writeVal = Word8
byte Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
average 
                                             (PngLine s
MVector (PrimState (ST s)) Word8
thisLine 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
idx) Word8
writeVal
                                             Int -> Int -> ST s Int
inner (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

          filterPaeth :: PngLine s -> PngLine s -> Int -> ST s Int
filterPaeth !PngLine s
previousLine !PngLine s
thisLine = Int -> Int -> ST s Int
inner Int
beginZeroes
            where inner :: Int -> Int -> ST s Int
inner idx :: Int
idx !Int
readIdx
                            | Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lastIdx = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
readIdx
                            | Bool
otherwise = do let byte :: Word8
byte = ByteString
str ByteString -> Int -> Word8
`BU.unsafeIndex` Int
readIdx
                                             Word8
valA <- PngLine s
MVector (PrimState (ST s)) Word8
thisLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
stride)
                                             Word8
valC <- PngLine s
MVector (PrimState (ST s)) Word8
previousLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
stride)
                                             Word8
valB <- PngLine s
MVector (PrimState (ST s)) Word8
previousLine MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
                                             (PngLine s
MVector (PrimState (ST s)) Word8
thisLine 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
idx) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Word8
byte Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8 -> Word8 -> Word8 -> Word8
forall p. Integral p => p -> p -> p -> p
paeth Word8
valA Word8
valB Word8
valC
                                             Int -> Int -> ST s Int
inner (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

                  paeth :: p -> p -> p -> p
paeth a :: p
a b :: p
b c :: p
c
                    | Int
pa Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
pb Bool -> Bool -> Bool
&& Int
pa Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
pc = p
a
                    | Int
pb Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
pc             = p
b
                    | Bool
otherwise            = p
c
                      where a' :: Int
a' = p -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
a :: Int
                            b' :: Int
b' = p -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
b
                            c' :: Int
c' = p -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
c
                            p :: Int
p = Int
a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
c'
                            pa :: Int
pa = Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a'
                            pb :: Int
pb = Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b'
                            pc :: Int
pc = Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
c'
                  
-- | Directly stolen from the definition in the standard (on W3C page),

-- pixel predictor.


type PngLine s = M.STVector s Word8
type LineUnpacker s = Int -> (Int, PngLine s) -> ST s ()

type StrideInfo  = (Int, Int)

type BeginOffset = (Int, Int)


-- | Unpack lines where bit depth is 8

byteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
byteUnpacker :: Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
byteUnpacker sampleCount :: Int
sampleCount (MutableImage{ mutableImageWidth :: forall s a. MutableImage s a -> Int
mutableImageWidth = Int
imgWidth, mutableImageData :: forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData = STVector s (PixelBaseComponent Word8)
arr })
             (strideWidth :: Int
strideWidth, strideHeight :: Int
strideHeight) (beginLeft :: Int
beginLeft, beginTop :: Int
beginTop) h :: Int
h (beginIdx :: Int
beginIdx, line :: PngLine s
line) = do
    (_, maxIdx :: Int
maxIdx) <- PngLine s -> ST s (Int, Int)
forall (m :: * -> *) a s.
(Monad m, Storable a) =>
STVector s a -> m (Int, Int)
getBounds PngLine s
line
    let realTop :: Int
realTop = Int
beginTop Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideHeight
        lineIndex :: Int
lineIndex = Int
realTop Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth
        pixelToRead :: Int
pixelToRead = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
imgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
maxIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
beginIdx) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
sampleCount
        inner :: Int -> ST s ()
inner pixelIndex :: Int
pixelIndex | Int
pixelIndex Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
pixelToRead = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                         | Bool
otherwise = do
            let destPixelIndex :: Int
destPixelIndex = Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginLeft 
                destSampleIndex :: Int
destSampleIndex = Int
destPixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampleCount
                srcPixelIndex :: Int
srcPixelIndex = Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginIdx
                perPixel :: Int -> ST s ()
perPixel sample :: Int
sample | Int
sample Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
sampleCount = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                | Bool
otherwise = do
                    Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
srcPixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sample)
                    let writeIdx :: Int
writeIdx = Int
destSampleIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sample
                    (STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr 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
val
                    Int -> ST s ()
perPixel (Int
sample Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
            Int -> ST s ()
perPixel 0
            Int -> ST s ()
inner (Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
    Int -> ST s ()
inner 0
             

-- | Unpack lines where bit depth is 1

bitUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
bitUnpacker :: Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
bitUnpacker _ (MutableImage{ mutableImageWidth :: forall s a. MutableImage s a -> Int
mutableImageWidth = Int
imgWidth, mutableImageData :: forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData = STVector s (PixelBaseComponent Word8)
arr })
              (strideWidth :: Int
strideWidth, strideHeight :: Int
strideHeight) (beginLeft :: Int
beginLeft, beginTop :: Int
beginTop) h :: Int
h (beginIdx :: Int
beginIdx, line :: PngLine s
line) = do
    (_, endLine :: Int
endLine) <- PngLine s -> ST s (Int, Int)
forall (m :: * -> *) a s.
(Monad m, Storable a) =>
STVector s a -> m (Int, Int)
getBounds PngLine s
line
    let realTop :: Int
realTop = Int
beginTop Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideHeight
        lineIndex :: Int
lineIndex = Int
realTop Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth
        (lineWidth :: Int
lineWidth, subImageRest :: Int
subImageRest) = (Int
imgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
beginLeft) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
strideWidth
        subPadd :: Int
subPadd | Int
subImageRest Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = 1
                | Bool
otherwise = 0
        (pixelToRead :: Int
pixelToRead, lineRest :: Int
lineRest) = (Int
lineWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
subPadd) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` 8
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. Int
pixelToRead Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \pixelIndex :: Int
pixelIndex -> do
        Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
pixelIndex  Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginIdx)
        let writeIdx :: Int -> Int
writeIdx n :: Int
n = Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* 8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginLeft 
        [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. 7] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \bit :: Int
bit -> (STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr 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 -> Int
writeIdx (7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bit)) ((Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
bit) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 1)

    Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
lineRest Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0)
         (do Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
endLine
             let writeIdx :: Int -> Int
writeIdx n :: Int
n = Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
pixelToRead Int -> Int -> Int
forall a. Num a => a -> a -> a
* 8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginLeft
             [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. Int
lineRest Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \bit :: Int
bit ->
                (STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr 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 -> Int
writeIdx Int
bit) ((Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` (7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bit)) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x1))


-- | Unpack lines when bit depth is 2

twoBitsUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
twoBitsUnpacker :: Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
twoBitsUnpacker _ (MutableImage{ mutableImageWidth :: forall s a. MutableImage s a -> Int
mutableImageWidth = Int
imgWidth, mutableImageData :: forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData = STVector s (PixelBaseComponent Word8)
arr })
                  (strideWidth :: Int
strideWidth, strideHeight :: Int
strideHeight) (beginLeft :: Int
beginLeft, beginTop :: Int
beginTop) h :: Int
h (beginIdx :: Int
beginIdx, line :: PngLine s
line) = do
    (_, endLine :: Int
endLine) <- PngLine s -> ST s (Int, Int)
forall (m :: * -> *) a s.
(Monad m, Storable a) =>
STVector s a -> m (Int, Int)
getBounds PngLine s
line
    let realTop :: Int
realTop = Int
beginTop Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideHeight
        lineIndex :: Int
lineIndex = Int
realTop Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth
        (lineWidth :: Int
lineWidth, subImageRest :: Int
subImageRest) = (Int
imgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
beginLeft) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
strideWidth
        subPadd :: Int
subPadd | Int
subImageRest Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = 1
                | Bool
otherwise = 0
        (pixelToRead :: Int
pixelToRead, lineRest :: Int
lineRest) = (Int
lineWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
subPadd) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` 4

    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. Int
pixelToRead Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \pixelIndex :: Int
pixelIndex -> do
        Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
pixelIndex  Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginIdx)
        let writeIdx :: Int -> Int
writeIdx n :: Int
n = Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginLeft 
        (STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr 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 -> Int
writeIdx 0) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 6) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x3
        (STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr 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 -> Int
writeIdx 1) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 4) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x3
        (STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr 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 -> Int
writeIdx 2) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 2) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x3
        (STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr 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 -> Int
writeIdx 3) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Word8
val Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x3

    Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
lineRest Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0)
         (do Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
endLine
             let writeIdx :: Int -> Int
writeIdx n :: Int
n = Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
pixelToRead Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginLeft
             [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. Int
lineRest Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \bit :: Int
bit ->
                (STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr 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 -> Int
writeIdx Int
bit) ((Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` (6 Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
bit)) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x3))

halfByteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
halfByteUnpacker :: Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
halfByteUnpacker _ (MutableImage{ mutableImageWidth :: forall s a. MutableImage s a -> Int
mutableImageWidth = Int
imgWidth, mutableImageData :: forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData = STVector s (PixelBaseComponent Word8)
arr })
                   (strideWidth :: Int
strideWidth, strideHeight :: Int
strideHeight) (beginLeft :: Int
beginLeft, beginTop :: Int
beginTop) h :: Int
h (beginIdx :: Int
beginIdx, line :: PngLine s
line) = do
    (_, endLine :: Int
endLine) <- PngLine s -> ST s (Int, Int)
forall (m :: * -> *) a s.
(Monad m, Storable a) =>
STVector s a -> m (Int, Int)
getBounds PngLine s
line
    let realTop :: Int
realTop = Int
beginTop Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideHeight
        lineIndex :: Int
lineIndex = Int
realTop Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth
        (lineWidth :: Int
lineWidth, subImageRest :: Int
subImageRest) = (Int
imgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
beginLeft) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
strideWidth
        subPadd :: Int
subPadd | Int
subImageRest Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = 1
                | Bool
otherwise = 0
        (pixelToRead :: Int
pixelToRead, lineRest :: Int
lineRest) = (Int
lineWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
subPadd) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` 2
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. Int
pixelToRead Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \pixelIndex :: Int
pixelIndex -> do
        Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
pixelIndex  Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginIdx)
        let writeIdx :: Int -> Int
writeIdx n :: Int
n = Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginLeft 
        (STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr 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 -> Int
writeIdx 0) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 4) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0xF
        (STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr 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 -> Int
writeIdx 1) (Word8 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Word8
val Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0xF
    
    Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
lineRest Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0)
         (do Word8
val <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
endLine
             let writeIdx :: Int
writeIdx = Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
pixelToRead Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginLeft 
             (STVector s (PixelBaseComponent Word8)
MVector (PrimState (ST s)) Word8
arr 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 -> ST s ()) -> Word8 -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 4) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0xF)

shortUnpacker :: Int -> MutableImage s Word16 -> StrideInfo -> BeginOffset -> LineUnpacker s
shortUnpacker :: Int
-> MutableImage s Word16
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
shortUnpacker sampleCount :: Int
sampleCount (MutableImage{ mutableImageWidth :: forall s a. MutableImage s a -> Int
mutableImageWidth = Int
imgWidth, mutableImageData :: forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData = STVector s (PixelBaseComponent Word16)
arr })
             (strideWidth :: Int
strideWidth, strideHeight :: Int
strideHeight) (beginLeft :: Int
beginLeft, beginTop :: Int
beginTop) h :: Int
h (beginIdx :: Int
beginIdx, line :: PngLine s
line) = do
    (_, maxIdx :: Int
maxIdx) <- PngLine s -> ST s (Int, Int)
forall (m :: * -> *) a s.
(Monad m, Storable a) =>
STVector s a -> m (Int, Int)
getBounds PngLine s
line
    let realTop :: Int
realTop = Int
beginTop Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideHeight
        lineIndex :: Int
lineIndex = Int
realTop Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth
        pixelToRead :: Int
pixelToRead = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
imgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
maxIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
beginIdx) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` (Int
sampleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2)
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. Int
pixelToRead] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \pixelIndex :: Int
pixelIndex -> do
        let destPixelIndex :: Int
destPixelIndex = Int
lineIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
strideWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginLeft 
            destSampleIndex :: Int
destSampleIndex = Int
destPixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampleCount
            srcPixelIndex :: Int
srcPixelIndex = Int
pixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
beginIdx
        [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. Int
sampleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \sample :: Int
sample -> do
            Word8
highBits <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
srcPixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sample Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 0)
            Word8
lowBits <- PngLine s
MVector (PrimState (ST s)) Word8
line MVector (PrimState (ST s)) Word8 -> Int -> ST s Word8
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
srcPixelIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sample Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
            let fullValue :: Word16
fullValue = Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
lowBits Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
highBits Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 8)
                writeIdx :: Int
writeIdx = Int
destSampleIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sample
            (STVector s (PixelBaseComponent Word16)
MVector (PrimState (ST s)) Word16
arr MVector (PrimState (ST s)) Word16 -> Int -> Word16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) Word16
fullValue

-- | Transform a scanline to a bunch of bytes. Bytes are then packed

-- into pixels at a further step.

scanlineUnpacker8 :: Int -> Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset
                 -> LineUnpacker s
scanlineUnpacker8 :: Int
-> Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
scanlineUnpacker8 1 = Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
bitUnpacker
scanlineUnpacker8 2 = Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
twoBitsUnpacker
scanlineUnpacker8 4 = Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
halfByteUnpacker
scanlineUnpacker8 8 = Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
byteUnpacker
scanlineUnpacker8 _ = String
-> Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall a. HasCallStack => String -> a
error "Impossible bit depth"

byteSizeOfBitLength :: Int -> Int -> Int -> Int
byteSizeOfBitLength :: Int -> Int -> Int -> Int
byteSizeOfBitLength pixelBitDepth :: Int
pixelBitDepth sampleCount :: Int
sampleCount dimension :: Int
dimension = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Int
rest Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 then 1 else 0)
   where (size :: Int
size, rest :: Int
rest) = (Int
pixelBitDepth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
dimension Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampleCount) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 8

scanLineInterleaving :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s)
                     -> B.ByteString
                     -> ST s ()
scanLineInterleaving :: Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
scanLineInterleaving depth :: Int
depth sampleCount :: Int
sampleCount (imgWidth :: Int
imgWidth, imgHeight :: Int
imgHeight) unpacker :: (Int, Int) -> (Int, Int) -> LineUnpacker s
unpacker str :: ByteString
str =
    ST s Int -> ST s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ST s Int -> ST s ()) -> ST s Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ LineUnpacker s
-> Int -> (Int, Int) -> ByteString -> Int -> ST s Int
forall s.
LineUnpacker s
-> Int -> (Int, Int) -> ByteString -> Int -> ST s Int
pngFiltering ((Int, Int) -> (Int, Int) -> LineUnpacker s
unpacker (1,1) (0, 0)) Int
strideInfo (Int
byteWidth, Int
imgHeight) ByteString
str 0
        where byteWidth :: Int
byteWidth = Int -> Int -> Int -> Int
byteSizeOfBitLength Int
depth Int
sampleCount Int
imgWidth
              strideInfo :: Int
strideInfo | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 8 = 1
                         | Bool
otherwise = Int
sampleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
depth Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 8)

-- | Given data and image size, recreate an image with deinterlaced

-- data for PNG's adam 7 method.

adam7Unpack :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s)
            -> B.ByteString -> ST s ()
adam7Unpack :: Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
adam7Unpack depth :: Int
depth sampleCount :: Int
sampleCount (imgWidth :: Int
imgWidth, imgHeight :: Int
imgHeight) unpacker :: (Int, Int) -> (Int, Int) -> LineUnpacker s
unpacker str :: ByteString
str =
  ST s () -> ST s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Int -> (Int -> ST s Int) -> ST s Int)
-> Int -> [Int -> ST s Int] -> ST s ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (\i :: Int
i f :: Int -> ST s Int
f -> Int -> ST s Int
f Int
i) 0 [Int -> ST s Int]
subImages
    where Adam7MatrixInfo { adam7StartingRow :: Adam7MatrixInfo -> [Int]
adam7StartingRow  = [Int]
startRows
                          , adam7RowIncrement :: Adam7MatrixInfo -> [Int]
adam7RowIncrement = [Int]
rowIncrement
                          , adam7StartingCol :: Adam7MatrixInfo -> [Int]
adam7StartingCol  = [Int]
startCols
                          , adam7ColIncrement :: Adam7MatrixInfo -> [Int]
adam7ColIncrement = [Int]
colIncrement } = Adam7MatrixInfo
adam7MatrixInfo

          subImages :: [Int -> ST s Int]
subImages = 
              [LineUnpacker s
-> Int -> (Int, Int) -> ByteString -> Int -> ST s Int
forall s.
LineUnpacker s
-> Int -> (Int, Int) -> ByteString -> Int -> ST s Int
pngFiltering ((Int, Int) -> (Int, Int) -> LineUnpacker s
unpacker (Int
incrW, Int
incrH) (Int
beginW, Int
beginH)) Int
strideInfo (Int
byteWidth, Int
passHeight) ByteString
str
                            | (beginW :: Int
beginW, incrW :: Int
incrW, beginH :: Int
beginH, incrH :: Int
incrH) <- [Int] -> [Int] -> [Int] -> [Int] -> [(Int, Int, Int, Int)]
forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [Int]
startCols [Int]
colIncrement [Int]
startRows [Int]
rowIncrement
                            , let passWidth :: Int
passWidth = Int -> Int -> Int -> Int
forall p. Integral p => p -> p -> p -> p
sizer Int
imgWidth Int
beginW Int
incrW
                                  passHeight :: Int
passHeight = Int -> Int -> Int -> Int
forall p. Integral p => p -> p -> p -> p
sizer Int
imgHeight Int
beginH Int
incrH
                                  byteWidth :: Int
byteWidth = Int -> Int -> Int -> Int
byteSizeOfBitLength Int
depth Int
sampleCount Int
passWidth
                            ]
          strideInfo :: Int
strideInfo | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 8 = 1
                     | Bool
otherwise = Int
sampleCount Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
depth Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 8)
          sizer :: p -> p -> p -> p
sizer dimension :: p
dimension begin :: p
begin increment :: p
increment
            | p
dimension p -> p -> Bool
forall a. Ord a => a -> a -> Bool
<= p
begin = 0
            | Bool
otherwise = p
outDim p -> p -> p
forall a. Num a => a -> a -> a
+ (if p
restDim p -> p -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 then 1 else 0)
                where (outDim :: p
outDim, restDim :: p
restDim) = (p
dimension p -> p -> p
forall a. Num a => a -> a -> a
- p
begin) p -> p -> (p, p)
forall a. Integral a => a -> a -> (a, a)
`quotRem` p
increment

-- | deinterlace picture in function of the method indicated

-- in the iHDR

deinterlacer :: PngIHdr -> B.ByteString -> ST s (Either (V.Vector Word8) (V.Vector Word16))
deinterlacer :: PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
deinterlacer (PngIHdr { width :: PngIHdr -> Word32
width = Word32
w, height :: PngIHdr -> Word32
height = Word32
h, colourType :: PngIHdr -> PngImageType
colourType  = PngImageType
imgKind
                      , interlaceMethod :: PngIHdr -> PngInterlaceMethod
interlaceMethod = PngInterlaceMethod
method, bitDepth :: PngIHdr -> Word8
bitDepth = Word8
depth  }) str :: ByteString
str = do
    let compCount :: Word32
compCount = PngImageType -> Word32
sampleCountOfImageType PngImageType
imgKind 
        arraySize :: Int
arraySize = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ Word32
w Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
h Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
compCount
        deinterlaceFunction :: Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
deinterlaceFunction = case PngInterlaceMethod
method of
            PngNoInterlace -> Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
forall s.
Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
scanLineInterleaving
            PngInterlaceAdam7 -> Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
forall s.
Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
adam7Unpack
        iBitDepth :: Int
iBitDepth = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
depth
    if Int
iBitDepth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 8
      then do
        MVector s Word8
imgArray <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
arraySize
        let mutableImage :: MutableImage s Word8
mutableImage = Int
-> Int
-> STVector s (PixelBaseComponent Word8)
-> MutableImage s Word8
forall s a.
Int -> Int -> STVector s (PixelBaseComponent a) -> MutableImage s a
MutableImage (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
h) MVector s Word8
STVector s (PixelBaseComponent Word8)
imgArray
        Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
deinterlaceFunction Int
iBitDepth 
                            (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
compCount)
                            (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w, Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
h)
                            (Int
-> Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> Int
-> MutableImage s Word8
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
scanlineUnpacker8 Int
iBitDepth (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
compCount)
                                                         MutableImage s Word8
mutableImage)
                            ByteString
str
        Vector Word8 -> Either (Vector Word8) (Vector Word16)
forall a b. a -> Either a b
Left (Vector Word8 -> Either (Vector Word8) (Vector Word16))
-> ST s (Vector Word8)
-> ST s (Either (Vector Word8) (Vector Word16))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState (ST s)) Word8 -> ST s (Vector Word8)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze MVector s Word8
MVector (PrimState (ST s)) Word8
imgArray

      else do
        MVector s Word16
imgArray <- Int -> ST s (MVector (PrimState (ST s)) Word16)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
arraySize
        let mutableImage :: MutableImage s Word16
mutableImage = Int
-> Int
-> STVector s (PixelBaseComponent Word16)
-> MutableImage s Word16
forall s a.
Int -> Int -> STVector s (PixelBaseComponent a) -> MutableImage s a
MutableImage (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
h) MVector s Word16
STVector s (PixelBaseComponent Word16)
imgArray
        Int
-> Int
-> (Int, Int)
-> ((Int, Int) -> (Int, Int) -> LineUnpacker s)
-> ByteString
-> ST s ()
deinterlaceFunction Int
iBitDepth 
                            (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
compCount)
                            (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w, Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
h)
                            (Int
-> MutableImage s Word16
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
forall s.
Int
-> MutableImage s Word16
-> (Int, Int)
-> (Int, Int)
-> LineUnpacker s
shortUnpacker (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
compCount) MutableImage s Word16
mutableImage)
                            ByteString
str
        Vector Word16 -> Either (Vector Word8) (Vector Word16)
forall a b. b -> Either a b
Right (Vector Word16 -> Either (Vector Word8) (Vector Word16))
-> ST s (Vector Word16)
-> ST s (Either (Vector Word8) (Vector Word16))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState (ST s)) Word16 -> ST s (Vector Word16)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze MVector s Word16
MVector (PrimState (ST s)) Word16
imgArray

generateGreyscalePalette :: Word8 -> PngPalette
generateGreyscalePalette :: Word8 -> PngPalette
generateGreyscalePalette bits :: Word8
bits = Int -> Vector (PixelBaseComponent PixelRGB8) -> PngPalette
forall px. Int -> Vector (PixelBaseComponent px) -> Palette' px
Palette' (Int
maxValueInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Vector Word8
Vector (PixelBaseComponent PixelRGB8)
vec
    where maxValue :: Int
maxValue = 2 Int -> Word8 -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Word8
bits Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
          vec :: Vector Word8
vec = Int -> [Word8] -> Vector Word8
forall a. Storable a => Int -> [a] -> Vector a
V.fromListN ((Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxValue Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* 3) ([Word8] -> Vector Word8) -> [Word8] -> Vector Word8
forall a b. (a -> b) -> a -> b
$ [[Word8]] -> [Word8]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Word8]]
pixels
          pixels :: [[Word8]]
pixels = [[Word8
i, Word8
i, Word8
i] | Int
n <- [0 .. Int
maxValue]
                              , let i :: Word8
i = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* (255 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
maxValue)]

sampleCountOfImageType :: PngImageType -> Word32
sampleCountOfImageType :: PngImageType -> Word32
sampleCountOfImageType PngGreyscale = 1
sampleCountOfImageType PngTrueColour = 3
sampleCountOfImageType PngIndexedColor = 1
sampleCountOfImageType PngGreyscaleWithAlpha = 2
sampleCountOfImageType PngTrueColourWithAlpha = 4

paletteRGB1, paletteRGB2, paletteRGB4 :: PngPalette
paletteRGB1 :: PngPalette
paletteRGB1 = Word8 -> PngPalette
generateGreyscalePalette 1
paletteRGB2 :: PngPalette
paletteRGB2 = Word8 -> PngPalette
generateGreyscalePalette 2
paletteRGB4 :: PngPalette
paletteRGB4 = Word8 -> PngPalette
generateGreyscalePalette 4

addTransparencyToPalette :: PngPalette -> Lb.ByteString -> Palette' PixelRGBA8
addTransparencyToPalette :: PngPalette -> ByteString -> Palette' PixelRGBA8
addTransparencyToPalette pal :: PngPalette
pal transpBuffer :: ByteString
transpBuffer = 
  Int
-> Vector (PixelBaseComponent PixelRGBA8) -> Palette' PixelRGBA8
forall px. Int -> Vector (PixelBaseComponent px) -> Palette' px
Palette' (PngPalette -> Int
forall px. Palette' px -> Int
_paletteSize PngPalette
pal) (Vector Word8 -> Palette' PixelRGBA8)
-> (Image PixelRGB8 -> Vector Word8)
-> Image PixelRGB8
-> Palette' PixelRGBA8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGBA8 -> Vector Word8
forall a. Image a -> Vector (PixelBaseComponent a)
imageData (Image PixelRGBA8 -> Vector Word8)
-> (Image PixelRGB8 -> Image PixelRGBA8)
-> Image PixelRGB8
-> Vector Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> PixelRGB8 -> PixelRGBA8)
-> Image PixelRGB8 -> Image PixelRGBA8
forall a b.
(Pixel a, Pixel b) =>
(Int -> Int -> a -> b) -> Image a -> Image b
pixelMapXY Int -> Int -> PixelRGB8 -> PixelRGBA8
addOpacity (Image PixelRGB8 -> Palette' PixelRGBA8)
-> Image PixelRGB8 -> Palette' PixelRGBA8
forall a b. (a -> b) -> a -> b
$ PngPalette -> Image PixelRGB8
forall px. Palette' px -> Image px
palettedAsImage PngPalette
pal
  where 
    maxi :: Int
maxi = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
Lb.length ByteString
transpBuffer
    addOpacity :: Int -> Int -> PixelRGB8 -> PixelRGBA8
addOpacity ix :: Int
ix _ (PixelRGB8 r :: Word8
r g :: Word8
g b :: Word8
b) | Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
maxi =
      Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
r Word8
g Word8
b (Word8 -> PixelRGBA8) -> Word8 -> PixelRGBA8
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64 -> Word8
Lb.index ByteString
transpBuffer (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ix)
    addOpacity _ _ (PixelRGB8 r :: Word8
r g :: Word8
g b :: Word8
b) = Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
r Word8
g Word8
b 255

unparse :: PngIHdr -> Maybe PngPalette -> [Lb.ByteString] -> PngImageType
        -> B.ByteString -> Either String PalettedImage
unparse :: PngIHdr
-> Maybe PngPalette
-> [ByteString]
-> PngImageType
-> ByteString
-> Either String PalettedImage
unparse ihdr :: PngIHdr
ihdr _ t :: [ByteString]
t PngGreyscale bytes :: ByteString
bytes
  | PngIHdr -> Word8
bitDepth PngIHdr
ihdr Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = PngIHdr
-> Maybe PngPalette
-> [ByteString]
-> PngImageType
-> ByteString
-> Either String PalettedImage
unparse PngIHdr
ihdr (PngPalette -> Maybe PngPalette
forall a. a -> Maybe a
Just PngPalette
paletteRGB1) [ByteString]
t PngImageType
PngIndexedColor ByteString
bytes
  | PngIHdr -> Word8
bitDepth PngIHdr
ihdr Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 2 = PngIHdr
-> Maybe PngPalette
-> [ByteString]
-> PngImageType
-> ByteString
-> Either String PalettedImage
unparse PngIHdr
ihdr (PngPalette -> Maybe PngPalette
forall a. a -> Maybe a
Just PngPalette
paletteRGB2) [ByteString]
t PngImageType
PngIndexedColor ByteString
bytes
  | PngIHdr -> Word8
bitDepth PngIHdr
ihdr Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 4 = PngIHdr
-> Maybe PngPalette
-> [ByteString]
-> PngImageType
-> ByteString
-> Either String PalettedImage
unparse PngIHdr
ihdr (PngPalette -> Maybe PngPalette
forall a. a -> Maybe a
Just PngPalette
paletteRGB4) [ByteString]
t PngImageType
PngIndexedColor ByteString
bytes
  | Bool
otherwise =
      (DynamicImage -> PalettedImage)
-> Either String DynamicImage -> Either String PalettedImage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DynamicImage -> PalettedImage
TrueColorImage (Either String DynamicImage -> Either String PalettedImage)
-> (Either (Vector Word8) (Vector Word16)
    -> Either String DynamicImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PngIHdr
-> (Image Word8 -> DynamicImage)
-> (Image Word16 -> DynamicImage)
-> Either
     (Vector (PixelBaseComponent Word8))
     (Vector (PixelBaseComponent Word16))
-> Either String DynamicImage
forall a pxWord8 pxWord16.
PngIHdr
-> (Image pxWord8 -> DynamicImage)
-> (Image pxWord16 -> DynamicImage)
-> Either
     (Vector (PixelBaseComponent pxWord8))
     (Vector (PixelBaseComponent pxWord16))
-> Either a DynamicImage
toImage PngIHdr
ihdr Image Word8 -> DynamicImage
ImageY8 Image Word16 -> DynamicImage
ImageY16 (Either (Vector Word8) (Vector Word16)
 -> Either String PalettedImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either (Vector Word8) (Vector Word16)))
 -> Either (Vector Word8) (Vector Word16))
-> (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a b. (a -> b) -> a -> b
$ PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
forall s.
PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
deinterlacer PngIHdr
ihdr ByteString
bytes

unparse _ Nothing _ PngIndexedColor  _ = String -> Either String PalettedImage
forall a b. a -> Either a b
Left "no valid palette found"
unparse ihdr :: PngIHdr
ihdr _ _ PngTrueColour          bytes :: ByteString
bytes =
  (DynamicImage -> PalettedImage)
-> Either String DynamicImage -> Either String PalettedImage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DynamicImage -> PalettedImage
TrueColorImage (Either String DynamicImage -> Either String PalettedImage)
-> (Either (Vector Word8) (Vector Word16)
    -> Either String DynamicImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PngIHdr
-> (Image PixelRGB8 -> DynamicImage)
-> (Image PixelRGB16 -> DynamicImage)
-> Either
     (Vector (PixelBaseComponent PixelRGB8))
     (Vector (PixelBaseComponent PixelRGB16))
-> Either String DynamicImage
forall a pxWord8 pxWord16.
PngIHdr
-> (Image pxWord8 -> DynamicImage)
-> (Image pxWord16 -> DynamicImage)
-> Either
     (Vector (PixelBaseComponent pxWord8))
     (Vector (PixelBaseComponent pxWord16))
-> Either a DynamicImage
toImage PngIHdr
ihdr Image PixelRGB8 -> DynamicImage
ImageRGB8 Image PixelRGB16 -> DynamicImage
ImageRGB16 (Either (Vector Word8) (Vector Word16)
 -> Either String PalettedImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either (Vector Word8) (Vector Word16)))
 -> Either (Vector Word8) (Vector Word16))
-> (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a b. (a -> b) -> a -> b
$ PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
forall s.
PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
deinterlacer PngIHdr
ihdr ByteString
bytes
unparse ihdr :: PngIHdr
ihdr _ _ PngGreyscaleWithAlpha  bytes :: ByteString
bytes =
  (DynamicImage -> PalettedImage)
-> Either String DynamicImage -> Either String PalettedImage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DynamicImage -> PalettedImage
TrueColorImage (Either String DynamicImage -> Either String PalettedImage)
-> (Either (Vector Word8) (Vector Word16)
    -> Either String DynamicImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PngIHdr
-> (Image PixelYA8 -> DynamicImage)
-> (Image PixelYA16 -> DynamicImage)
-> Either
     (Vector (PixelBaseComponent PixelYA8))
     (Vector (PixelBaseComponent PixelYA16))
-> Either String DynamicImage
forall a pxWord8 pxWord16.
PngIHdr
-> (Image pxWord8 -> DynamicImage)
-> (Image pxWord16 -> DynamicImage)
-> Either
     (Vector (PixelBaseComponent pxWord8))
     (Vector (PixelBaseComponent pxWord16))
-> Either a DynamicImage
toImage PngIHdr
ihdr Image PixelYA8 -> DynamicImage
ImageYA8 Image PixelYA16 -> DynamicImage
ImageYA16 (Either (Vector Word8) (Vector Word16)
 -> Either String PalettedImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either (Vector Word8) (Vector Word16)))
 -> Either (Vector Word8) (Vector Word16))
-> (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a b. (a -> b) -> a -> b
$ PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
forall s.
PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
deinterlacer PngIHdr
ihdr ByteString
bytes
unparse ihdr :: PngIHdr
ihdr _ _ PngTrueColourWithAlpha bytes :: ByteString
bytes =
  (DynamicImage -> PalettedImage)
-> Either String DynamicImage -> Either String PalettedImage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DynamicImage -> PalettedImage
TrueColorImage (Either String DynamicImage -> Either String PalettedImage)
-> (Either (Vector Word8) (Vector Word16)
    -> Either String DynamicImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PngIHdr
-> (Image PixelRGBA8 -> DynamicImage)
-> (Image PixelRGBA16 -> DynamicImage)
-> Either
     (Vector (PixelBaseComponent PixelRGBA8))
     (Vector (PixelBaseComponent PixelRGBA16))
-> Either String DynamicImage
forall a pxWord8 pxWord16.
PngIHdr
-> (Image pxWord8 -> DynamicImage)
-> (Image pxWord16 -> DynamicImage)
-> Either
     (Vector (PixelBaseComponent pxWord8))
     (Vector (PixelBaseComponent pxWord16))
-> Either a DynamicImage
toImage PngIHdr
ihdr Image PixelRGBA8 -> DynamicImage
ImageRGBA8 Image PixelRGBA16 -> DynamicImage
ImageRGBA16 (Either (Vector Word8) (Vector Word16)
 -> Either String PalettedImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either (Vector Word8) (Vector Word16)))
 -> Either (Vector Word8) (Vector Word16))
-> (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a b. (a -> b) -> a -> b
$ PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
forall s.
PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
deinterlacer PngIHdr
ihdr ByteString
bytes
unparse ihdr :: PngIHdr
ihdr (Just plte :: PngPalette
plte) transparency :: [ByteString]
transparency PngIndexedColor bytes :: ByteString
bytes =
  PngIHdr
-> PngPalette
-> [ByteString]
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall t.
PngIHdr
-> PngPalette
-> [ByteString]
-> Either (Vector Word8) t
-> Either String PalettedImage
palette8 PngIHdr
ihdr PngPalette
plte [ByteString]
transparency (Either (Vector Word8) (Vector Word16)
 -> Either String PalettedImage)
-> Either (Vector Word8) (Vector Word16)
-> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either (Vector Word8) (Vector Word16)))
 -> Either (Vector Word8) (Vector Word16))
-> (forall s. ST s (Either (Vector Word8) (Vector Word16)))
-> Either (Vector Word8) (Vector Word16)
forall a b. (a -> b) -> a -> b
$ PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
forall s.
PngIHdr
-> ByteString -> ST s (Either (Vector Word8) (Vector Word16))
deinterlacer PngIHdr
ihdr ByteString
bytes

toImage :: forall a pxWord8 pxWord16
         . PngIHdr
        -> (Image pxWord8 -> DynamicImage) -> (Image pxWord16 -> DynamicImage)
        -> Either (V.Vector (PixelBaseComponent pxWord8))
                  (V.Vector (PixelBaseComponent pxWord16))
        -> Either a DynamicImage
toImage :: PngIHdr
-> (Image pxWord8 -> DynamicImage)
-> (Image pxWord16 -> DynamicImage)
-> Either
     (Vector (PixelBaseComponent pxWord8))
     (Vector (PixelBaseComponent pxWord16))
-> Either a DynamicImage
toImage hdr :: PngIHdr
hdr const1 :: Image pxWord8 -> DynamicImage
const1 const2 :: Image pxWord16 -> DynamicImage
const2 lr :: Either
  (Vector (PixelBaseComponent pxWord8))
  (Vector (PixelBaseComponent pxWord16))
lr = DynamicImage -> Either a DynamicImage
forall a b. b -> Either a b
Right (DynamicImage -> Either a DynamicImage)
-> DynamicImage -> Either a DynamicImage
forall a b. (a -> b) -> a -> b
$ case Either
  (Vector (PixelBaseComponent pxWord8))
  (Vector (PixelBaseComponent pxWord16))
lr of
    Left a :: Vector (PixelBaseComponent pxWord8)
a -> Image pxWord8 -> DynamicImage
const1 (Image pxWord8 -> DynamicImage) -> Image pxWord8 -> DynamicImage
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector (PixelBaseComponent pxWord8) -> Image pxWord8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector (PixelBaseComponent pxWord8)
a
    Right a :: Vector (PixelBaseComponent pxWord16)
a -> Image pxWord16 -> DynamicImage
const2 (Image pxWord16 -> DynamicImage) -> Image pxWord16 -> DynamicImage
forall a b. (a -> b) -> a -> b
$ Int
-> Int -> Vector (PixelBaseComponent pxWord16) -> Image pxWord16
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector (PixelBaseComponent pxWord16)
a
  where
    w :: Int
w = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word32
width PngIHdr
hdr
    h :: Int
h = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word32
height PngIHdr
hdr

palette8 :: PngIHdr -> PngPalette -> [Lb.ByteString] -> Either (V.Vector Word8) t
         -> Either String PalettedImage
palette8 :: PngIHdr
-> PngPalette
-> [ByteString]
-> Either (Vector Word8) t
-> Either String PalettedImage
palette8 hdr :: PngIHdr
hdr palette :: PngPalette
palette transparency :: [ByteString]
transparency eimg :: Either (Vector Word8) t
eimg = case ([ByteString]
transparency, Either (Vector Word8) t
eimg) of
  ([c :: ByteString
c], Left img :: Vector Word8
img) ->
    PalettedImage -> Either String PalettedImage
forall a b. b -> Either a b
Right (PalettedImage -> Either String PalettedImage)
-> (Palette' PixelRGBA8 -> PalettedImage)
-> Palette' PixelRGBA8
-> Either String PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Word8 -> Palette' PixelRGBA8 -> PalettedImage
PalettedRGBA8 (Int -> Int -> Vector (PixelBaseComponent Word8) -> Image Word8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Word8
Vector (PixelBaseComponent Word8)
img) (Palette' PixelRGBA8 -> Either String PalettedImage)
-> Palette' PixelRGBA8 -> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ PngPalette -> ByteString -> Palette' PixelRGBA8
addTransparencyToPalette PngPalette
palette ByteString
c
  (_, Left img :: Vector Word8
img) ->
    PalettedImage -> Either String PalettedImage
forall (m :: * -> *) a. Monad m => a -> m a
return (PalettedImage -> Either String PalettedImage)
-> PalettedImage -> Either String PalettedImage
forall a b. (a -> b) -> a -> b
$ Image Word8 -> PngPalette -> PalettedImage
PalettedRGB8 (Int -> Int -> Vector (PixelBaseComponent Word8) -> Image Word8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Word8
Vector (PixelBaseComponent Word8)
img) PngPalette
palette
  (_, Right _) ->
    String -> Either String PalettedImage
forall a b. a -> Either a b
Left "Invalid bit depth for paleted image"
  where
    w :: Int
w = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word32
width PngIHdr
hdr
    h :: Int
h = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ PngIHdr -> Word32
height PngIHdr
hdr


-- | Transform a raw png image to an image, without modifying the

-- underlying pixel type. If the image is greyscale and < 8 bits,

-- a transformation to RGBA8 is performed. This should change

-- in the future.

-- The resulting image let you manage the pixel types.

--

-- This function can output the following images:

--

--  * 'ImageY8'

--

--  * 'ImageY16'

--

--  * 'ImageYA8'

--

--  * 'ImageYA16'

--

--  * 'ImageRGB8'

--

--  * 'ImageRGB16'

--

--  * 'ImageRGBA8'

--

--  * 'ImageRGBA16'

--

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

-- | Decode a PNG file with, possibly, separated palette.

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

-- | Same as 'decodePng' but also extract meta datas present

-- in the files.

decodePngWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)
decodePngWithPaletteAndMetadata :: ByteString -> Either String (PalettedImage, Metadatas)
decodePngWithPaletteAndMetadata byte :: ByteString
byte =  do
  PngRawImage
rawImg <- Get PngRawImage -> ByteString -> Either String PngRawImage
forall a. Get a -> ByteString -> Either String a
runGetStrict Get PngRawImage
forall t. Binary t => Get t
get ByteString
byte
  let ihdr :: PngIHdr
ihdr = PngRawImage -> PngIHdr
header PngRawImage
rawImg
      metadatas :: Metadatas
metadatas =
         SourceFormat -> Word32 -> Word32 -> Metadatas
forall nSize.
Integral nSize =>
SourceFormat -> nSize -> nSize -> Metadatas
basicMetadata SourceFormat
SourcePng (PngIHdr -> Word32
width PngIHdr
ihdr) (PngIHdr -> Word32
height PngIHdr
ihdr) Metadatas -> Metadatas -> Metadatas
forall a. Semigroup a => a -> a -> a
<> PngRawImage -> Metadatas
extractMetadatas PngRawImage
rawImg
      compressedImageData :: ByteString
compressedImageData =
            [ByteString] -> ByteString
Lb.concat [PngRawChunk -> ByteString
chunkData PngRawChunk
chunk | PngRawChunk
chunk <- PngRawImage -> [PngRawChunk]
chunks PngRawImage
rawImg
                                       , PngRawChunk -> ByteString
chunkType PngRawChunk
chunk ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
iDATSignature]
      zlibHeaderSize :: Int64
zlibHeaderSize = 1 {- compression method/flags code -}
                     Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ 1 {- Additional flags/check bits -}
                     Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ 4 {-CRC-}

      transparencyColor :: [ByteString]
transparencyColor =
          [ PngRawChunk -> ByteString
chunkData PngRawChunk
chunk | PngRawChunk
chunk <- PngRawImage -> [PngRawChunk]
chunks PngRawImage
rawImg
                            , PngRawChunk -> ByteString
chunkType PngRawChunk
chunk ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
tRNSSignature ]


  if ByteString -> Int64
Lb.length ByteString
compressedImageData Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
zlibHeaderSize then
    String -> Either String (PalettedImage, Metadatas)
forall a b. a -> Either a b
Left "Invalid data size"
  else
    let imgData :: ByteString
imgData = ByteString -> ByteString
Z.decompress ByteString
compressedImageData
        parseableData :: ByteString
parseableData = [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
Lb.toChunks ByteString
imgData
        palette :: Maybe PngPalette
palette = do 
          PngRawChunk
p <- (PngRawChunk -> Bool) -> [PngRawChunk] -> Maybe PngRawChunk
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\c :: PngRawChunk
c -> ByteString
pLTESignature ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== PngRawChunk -> ByteString
chunkType PngRawChunk
c) ([PngRawChunk] -> Maybe PngRawChunk)
-> [PngRawChunk] -> Maybe PngRawChunk
forall a b. (a -> b) -> a -> b
$ PngRawImage -> [PngRawChunk]
chunks PngRawImage
rawImg
          case PngRawChunk -> Either String PngPalette
parsePalette PngRawChunk
p of
            Left _ -> Maybe PngPalette
forall a. Maybe a
Nothing
            Right plte :: PngPalette
plte -> PngPalette -> Maybe PngPalette
forall (m :: * -> *) a. Monad m => a -> m a
return PngPalette
plte
    in
    (, Metadatas
metadatas) (PalettedImage -> (PalettedImage, Metadatas))
-> Either String PalettedImage
-> Either String (PalettedImage, Metadatas)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        PngIHdr
-> Maybe PngPalette
-> [ByteString]
-> PngImageType
-> ByteString
-> Either String PalettedImage
unparse PngIHdr
ihdr Maybe PngPalette
palette [ByteString]
transparencyColor (PngIHdr -> PngImageType
colourType PngIHdr
ihdr) ByteString
parseableData

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