content: {-# 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
      { adam7StartingRow  :: [Int]
      , adam7StartingCol  :: [Int]
      , adam7RowIncrement :: [Int]
      , adam7ColIncrement :: [Int]
      , adam7BlockHeight  :: [Int]
      , adam7BlockWidth   :: [Int]
      }
  
  -- | The real info about the matrix.
  adam7MatrixInfo :: Adam7MatrixInfo
  adam7MatrixInfo = Adam7MatrixInfo
      { adam7StartingRow  = [0, 0, 4, 0, 2, 0, 1]
      , adam7StartingCol  = [0, 4, 0, 2, 0, 1, 0]
      , adam7RowIncrement = [8, 8, 8, 4, 4, 2, 2]
      , adam7ColIncrement = [8, 8, 4, 4, 2, 2, 1]
      , adam7BlockHeight  = [8, 8, 4, 4, 2, 2, 1]
      , adam7BlockWidth   = [8, 4, 4, 2, 2, 1, 1]
      }
  
  unparsePngFilter :: Word8 -> Either String PngFilter
  {-# INLINE unparsePngFilter #-}
  unparsePngFilter 0 = Right FilterNone
  unparsePngFilter 1 = Right FilterSub
  unparsePngFilter 2 = Right FilterUp
  unparsePngFilter 3 = Right FilterAverage
  unparsePngFilter 4 = Right FilterPaeth
  unparsePngFilter _ = Left "Invalid scanline filter"
  
  getBounds :: (Monad m, Storable a) => M.STVector s a -> m (Int, Int)
  {-# INLINE getBounds #-}
  getBounds v = return (0, M.length v - 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 _ _ (imgWidth, imgHeight) _str initialIdx
          | imgWidth <= 0 || imgHeight <= 0 = return initialIdx
  pngFiltering unpacker beginZeroes (imgWidth, imgHeight) str initialIdx = do
      thisLine <- M.replicate (beginZeroes + imgWidth) 0
      otherLine <- M.replicate (beginZeroes + imgWidth) 0
      let folder            _          _  lineIndex !idx | lineIndex >= imgHeight = return idx
          folder previousLine currentLine lineIndex !idx = do
                 let byte = str `BU.unsafeIndex` idx
                 let lineFilter = case unparsePngFilter byte of
                         Right FilterNone    -> filterNone
                         Right FilterSub     -> filterSub
                         Right FilterAverage -> filterAverage
                         Right FilterUp      -> filterUp
                         Right FilterPaeth   -> filterPaeth
                         _ -> filterNone
                 idx' <- lineFilter previousLine currentLine $ idx + 1
                 unpacker lineIndex (stride, currentLine)
                 folder currentLine previousLine (lineIndex + 1) idx'
  
      folder thisLine otherLine (0 :: Int) initialIdx
  
      where stride = fromIntegral beginZeroes
            lastIdx = beginZeroes + imgWidth - 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 !_previousLine !thisLine = inner beginZeroes
              where inner idx !readIdx
                              | idx > lastIdx = return readIdx
                              | otherwise = do let byte = str `BU.unsafeIndex` readIdx
                                               (thisLine `M.unsafeWrite` idx) byte
                                               inner (idx + 1) $ readIdx + 1
  
            filterSub !_previousLine !thisLine = inner beginZeroes
              where inner idx !readIdx
                              | idx > lastIdx = return readIdx
                              | otherwise = do let byte = str `BU.unsafeIndex` readIdx
                                               val <- thisLine `M.unsafeRead` (idx - stride)
                                               (thisLine `M.unsafeWrite` idx) $ byte + val
                                               inner (idx + 1) $ readIdx + 1
  
            filterUp !previousLine !thisLine = inner beginZeroes
              where inner idx !readIdx
                              | idx > lastIdx = return readIdx
                              | otherwise = do let byte = str `BU.unsafeIndex` readIdx
                                               val <- previousLine `M.unsafeRead` idx
                                               (thisLine `M.unsafeWrite` idx) $ val + byte
                                               inner (idx + 1) $ readIdx + 1
  
            filterAverage !previousLine !thisLine = inner beginZeroes
              where inner idx !readIdx
                              | idx > lastIdx = return readIdx
                              | otherwise = do let byte = str `BU.unsafeIndex` readIdx
                                               valA <- thisLine `M.unsafeRead` (idx - stride)
                                               valB <- previousLine `M.unsafeRead` idx
                                               let a' = fromIntegral valA
                                                   b' = fromIntegral valB
                                                   average = fromIntegral ((a' + b') `div` (2 :: Word16)) 
                                                   writeVal = byte + average 
                                               (thisLine `M.unsafeWrite` idx) writeVal
                                               inner (idx + 1) $ readIdx + 1
  
            filterPaeth !previousLine !thisLine = inner beginZeroes
              where inner idx !readIdx
                              | idx > lastIdx = return readIdx
                              | otherwise = do let byte = str `BU.unsafeIndex` readIdx
                                               valA <- thisLine `M.unsafeRead` (idx - stride)
                                               valC <- previousLine `M.unsafeRead` (idx - stride)
                                               valB <- previousLine `M.unsafeRead` idx
                                               (thisLine `M.unsafeWrite` idx) $ byte + paeth valA valB valC
                                               inner (idx + 1) $ readIdx + 1
  
                    paeth a b c
                      | pa <= pb && pa <= pc = a
                      | pb <= pc             = b
                      | otherwise            = c
                        where a' = fromIntegral a :: Int
                              b' = fromIntegral b
                              c' = fromIntegral c
                              p = a' + b' - c'
                              pa = abs $ p - a'
                              pb = abs $ p - b'
                              pc = abs $ p - 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 sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
               (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do
      (_, maxIdx) <- getBounds line
      let realTop = beginTop + h * strideHeight
          lineIndex = realTop * imgWidth
          pixelToRead = min (imgWidth - 1) $ (maxIdx - beginIdx) `div` sampleCount
          inner pixelIndex | pixelIndex > pixelToRead = return ()
                           | otherwise = do
              let destPixelIndex = lineIndex + pixelIndex * strideWidth + beginLeft 
                  destSampleIndex = destPixelIndex * sampleCount
                  srcPixelIndex = pixelIndex * sampleCount + beginIdx
                  perPixel sample | sample >= sampleCount = return ()
                                  | otherwise = do
                      val <- line `M.unsafeRead` (srcPixelIndex + sample)
                      let writeIdx = destSampleIndex + sample
                      (arr `M.unsafeWrite` writeIdx) val
                      perPixel (sample + 1)
              perPixel 0
              inner (pixelIndex + 1)
      inner 0
               
  
  -- | Unpack lines where bit depth is 1
  bitUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
  bitUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
                (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do
      (_, endLine) <- getBounds line
      let realTop = beginTop + h * strideHeight
          lineIndex = realTop * imgWidth
          (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth
          subPadd | subImageRest > 0 = 1
                  | otherwise = 0
          (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 8
      forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do
          val <- line `M.unsafeRead` (pixelIndex  + beginIdx)
          let writeIdx n = lineIndex + (pixelIndex * 8 + n) * strideWidth + beginLeft 
          forM_ [0 .. 7] $ \bit -> (arr `M.unsafeWrite` writeIdx (7 - bit)) ((val `unsafeShiftR` bit) .&. 1)
  
      when (lineRest /= 0)
           (do val <- line `M.unsafeRead` endLine
               let writeIdx n = lineIndex + (pixelToRead * 8 + n) * strideWidth + beginLeft
               forM_ [0 .. lineRest - 1] $ \bit ->
                  (arr `M.unsafeWrite` writeIdx bit) ((val `unsafeShiftR` (7 - bit)) .&. 0x1))
  
  
  -- | Unpack lines when bit depth is 2
  twoBitsUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
  twoBitsUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
                    (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do
      (_, endLine) <- getBounds line
      let realTop = beginTop + h * strideHeight
          lineIndex = realTop * imgWidth
          (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth
          subPadd | subImageRest > 0 = 1
                  | otherwise = 0
          (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 4
  
      forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do
          val <- line `M.unsafeRead` (pixelIndex  + beginIdx)
          let writeIdx n = lineIndex + (pixelIndex * 4 + n) * strideWidth + beginLeft 
          (arr `M.unsafeWrite` writeIdx 0) $ (val `unsafeShiftR` 6) .&. 0x3
          (arr `M.unsafeWrite` writeIdx 1) $ (val `unsafeShiftR` 4) .&. 0x3
          (arr `M.unsafeWrite` writeIdx 2) $ (val `unsafeShiftR` 2) .&. 0x3
          (arr `M.unsafeWrite` writeIdx 3) $ val .&. 0x3
  
      when (lineRest /= 0)
           (do val <- line `M.unsafeRead` endLine
               let writeIdx n = lineIndex + (pixelToRead * 4 + n) * strideWidth + beginLeft
               forM_ [0 .. lineRest - 1] $ \bit ->
                  (arr `M.unsafeWrite` writeIdx bit) ((val `unsafeShiftR` (6 - 2 * bit)) .&. 0x3))
  
  halfByteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
  halfByteUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
                     (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do
      (_, endLine) <- getBounds line
      let realTop = beginTop + h * strideHeight
          lineIndex = realTop * imgWidth
          (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth
          subPadd | subImageRest > 0 = 1
                  | otherwise = 0
          (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 2
      forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do
          val <- line `M.unsafeRead` (pixelIndex  + beginIdx)
          let writeIdx n = lineIndex + (pixelIndex * 2 + n) * strideWidth + beginLeft 
          (arr `M.unsafeWrite` writeIdx 0) $ (val `unsafeShiftR` 4) .&. 0xF
          (arr `M.unsafeWrite` writeIdx 1) $ val .&. 0xF
      
      when (lineRest /= 0)
           (do val <- line `M.unsafeRead` endLine
               let writeIdx = lineIndex + (pixelToRead * 2) * strideWidth + beginLeft 
               (arr `M.unsafeWrite` writeIdx) $ (val `unsafeShiftR` 4) .&. 0xF)
  
  shortUnpacker :: Int -> MutableImage s Word16 -> StrideInfo -> BeginOffset -> LineUnpacker s
  shortUnpacker sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
               (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do
      (_, maxIdx) <- getBounds line
      let realTop = beginTop + h * strideHeight
          lineIndex = realTop * imgWidth
          pixelToRead = min (imgWidth - 1) $ (maxIdx - beginIdx) `div` (sampleCount * 2)
      forM_ [0 .. pixelToRead] $ \pixelIndex -> do
          let destPixelIndex = lineIndex + pixelIndex * strideWidth + beginLeft 
              destSampleIndex = destPixelIndex * sampleCount
              srcPixelIndex = pixelIndex * sampleCount * 2 + beginIdx
          forM_ [0 .. sampleCount - 1] $ \sample -> do
              highBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 0)
              lowBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 1)
              let fullValue = fromIntegral lowBits .|. (fromIntegral highBits `unsafeShiftL` 8)
                  writeIdx = destSampleIndex + sample
              (arr `M.unsafeWrite` writeIdx) 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 1 = bitUnpacker
  scanlineUnpacker8 2 = twoBitsUnpacker
  scanlineUnpacker8 4 = halfByteUnpacker
  scanlineUnpacker8 8 = byteUnpacker
  scanlineUnpacker8 _ = error "Impossible bit depth"
  
  byteSizeOfBitLength :: Int -> Int -> Int -> Int
  byteSizeOfBitLength pixelBitDepth sampleCount dimension = size + (if rest /= 0 then 1 else 0)
     where (size, rest) = (pixelBitDepth * dimension * sampleCount) `quotRem` 8
  
  scanLineInterleaving :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s)
                       -> B.ByteString
                       -> ST s ()
  scanLineInterleaving depth sampleCount (imgWidth, imgHeight) unpacker str =
      void $ pngFiltering (unpacker (1,1) (0, 0)) strideInfo (byteWidth, imgHeight) str 0
          where byteWidth = byteSizeOfBitLength depth sampleCount imgWidth
                strideInfo | depth < 8 = 1
                           | otherwise = sampleCount * (depth `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 depth sampleCount (imgWidth, imgHeight) unpacker str =
    void $ foldM_ (\i f -> f i) 0 subImages
      where Adam7MatrixInfo { adam7StartingRow  = startRows
                            , adam7RowIncrement = rowIncrement
                            , adam7StartingCol  = startCols
                            , adam7ColIncrement = colIncrement } = adam7MatrixInfo
  
            subImages = 
                [pngFiltering (unpacker (incrW, incrH) (beginW, beginH)) strideInfo (byteWidth, passHeight) str
                              | (beginW, incrW, beginH, incrH) <- zip4 startCols colIncrement startRows rowIncrement
                              , let passWidth = sizer imgWidth beginW incrW
                                    passHeight = sizer imgHeight beginH incrH
                                    byteWidth = byteSizeOfBitLength depth sampleCount passWidth
                              ]
            strideInfo | depth < 8 = 1
                       | otherwise = sampleCount * (depth `div` 8)
            sizer dimension begin increment
              | dimension <= begin = 0
              | otherwise = outDim + (if restDim /= 0 then 1 else 0)
                  where (outDim, restDim) = (dimension - begin) `quotRem` 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 { width = w, height = h, colourType  = imgKind
                        , interlaceMethod = method, bitDepth = depth  }) str = do
      let compCount = fromIntegral $ sampleCountOfImageType imgKind 
          arraySize = (fromIntegral w) * (fromIntegral h) * compCount
          deinterlaceFunction = case method of
              PngNoInterlace -> scanLineInterleaving
              PngInterlaceAdam7 -> adam7Unpack
          iBitDepth = fromIntegral depth
      if iBitDepth <= 8
        then do
          imgArray <- M.new arraySize
          let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray
          deinterlaceFunction iBitDepth 
                              compCount
                              (fromIntegral w, fromIntegral h)
                              (scanlineUnpacker8 iBitDepth compCount mutableImage)
                              str
          Left <$> V.unsafeFreeze imgArray
  
        else do
          imgArray <- M.new arraySize
          let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray
          deinterlaceFunction iBitDepth 
                              compCount
                              (fromIntegral w, fromIntegral h)
                              (shortUnpacker compCount mutableImage)
                              str
          Right <$> V.unsafeFreeze imgArray
  
  generateGreyscalePalette :: Word8 -> PngPalette
  generateGreyscalePalette bits = Palette' (maxValue+1) vec
      where maxValue = 2 ^ bits - 1
            vec = V.fromListN ((fromIntegral maxValue + 1) * 3) $ concat pixels
            pixels = [[i, i, i] | n <- [0 .. maxValue]
                                , let i = fromIntegral $ n * (255 `div` maxValue)]
  
  sampleCountOfImageType :: PngImageType -> Word32
  sampleCountOfImageType PngGreyscale = 1
  sampleCountOfImageType PngTrueColour = 3
  sampleCountOfImageType PngIndexedColor = 1
  sampleCountOfImageType PngGreyscaleWithAlpha = 2
  sampleCountOfImageType PngTrueColourWithAlpha = 4
  
  paletteRGB1, paletteRGB2, paletteRGB4 :: PngPalette
  paletteRGB1 = generateGreyscalePalette 1
  paletteRGB2 = generateGreyscalePalette 2
  paletteRGB4 = generateGreyscalePalette 4
  
  addTransparencyToPalette :: PngPalette -> Lb.ByteString -> Palette' PixelRGBA8
  addTransparencyToPalette pal transpBuffer = 
    Palette' (_paletteSize pal) . imageData . pixelMapXY addOpacity $ palettedAsImage pal
    where 
      maxi = fromIntegral $ Lb.length transpBuffer
      addOpacity ix _ (PixelRGB8 r g b) | ix < maxi =
        PixelRGBA8 r g b $ Lb.index transpBuffer (fromIntegral ix)
      addOpacity _ _ (PixelRGB8 r g b) = PixelRGBA8 r g b 255
  
  unparse :: PngIHdr -> Maybe PngPalette -> [Lb.ByteString] -> PngImageType
          -> B.ByteString -> Either String PalettedImage
  unparse ihdr _ t PngGreyscale bytes
    | bitDepth ihdr == 1 = unparse ihdr (Just paletteRGB1) t PngIndexedColor bytes
    | bitDepth ihdr == 2 = unparse ihdr (Just paletteRGB2) t PngIndexedColor bytes
    | bitDepth ihdr == 4 = unparse ihdr (Just paletteRGB4) t PngIndexedColor bytes
    | otherwise =
        fmap TrueColorImage . toImage ihdr ImageY8 ImageY16 $ runST $ deinterlacer ihdr bytes
  
  unparse _ Nothing _ PngIndexedColor  _ = Left "no valid palette found"
  unparse ihdr _ _ PngTrueColour          bytes =
    fmap TrueColorImage . toImage ihdr ImageRGB8 ImageRGB16 $ runST $ deinterlacer ihdr bytes
  unparse ihdr _ _ PngGreyscaleWithAlpha  bytes =
    fmap TrueColorImage . toImage ihdr ImageYA8 ImageYA16 $ runST $ deinterlacer ihdr bytes
  unparse ihdr _ _ PngTrueColourWithAlpha bytes =
    fmap TrueColorImage . toImage ihdr ImageRGBA8 ImageRGBA16 $ runST $ deinterlacer ihdr bytes
  unparse ihdr (Just plte) transparency PngIndexedColor bytes =
    palette8 ihdr plte transparency $ runST $ deinterlacer ihdr 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 hdr const1 const2 lr = Right $ case lr of
      Left a -> const1 $ Image w h a
      Right a -> const2 $ Image w h a
    where
      w = fromIntegral $ width hdr
      h = fromIntegral $ height hdr
  
  palette8 :: PngIHdr -> PngPalette -> [Lb.ByteString] -> Either (V.Vector Word8) t
           -> Either String PalettedImage
  palette8 hdr palette transparency eimg = case (transparency, eimg) of
    ([c], Left img) ->
      Right . PalettedRGBA8 (Image w h img) $ addTransparencyToPalette palette c
    (_, Left img) ->
      return $ PalettedRGB8 (Image w h img) palette
    (_, Right _) ->
      Left "Invalid bit depth for paleted image"
    where
      w = fromIntegral $ width hdr
      h = fromIntegral $ height 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 = fmap fst . decodePngWithMetadata
  
  -- | Decode a PNG file with, possibly, separated palette.
  decodePngWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
  decodePngWithMetadata b = first palettedToTrueColor <$> decodePngWithPaletteAndMetadata b
  
  -- | Same as 'decodePng' but also extract meta datas present
  -- in the files.
  decodePngWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)
  decodePngWithPaletteAndMetadata byte =  do
    rawImg <- runGetStrict get byte
    let ihdr = header rawImg
        metadatas =
           basicMetadata SourcePng (width ihdr) (height ihdr) <> extractMetadatas rawImg
        compressedImageData =
              Lb.concat [chunkData chunk | chunk <- chunks rawImg
                                         , chunkType chunk == iDATSignature]
        zlibHeaderSize = 1 {- compression method/flags code -}
                       + 1 {- Additional flags/check bits -}
                       + 4 {-CRC-}
  
        transparencyColor =
            [ chunkData chunk | chunk <- chunks rawImg
                              , chunkType chunk == tRNSSignature ]
  
  
    if Lb.length compressedImageData <= zlibHeaderSize then
      Left "Invalid data size"
    else
      let imgData = Z.decompress compressedImageData
          parseableData = B.concat $ Lb.toChunks imgData
          palette = do 
            p <- find (\c -> pLTESignature == chunkType c) $ chunks rawImg
            case parsePalette p of
              Left _ -> Nothing
              Right plte -> return plte
      in
      (, metadatas) <$>
          unparse ihdr palette transparencyColor (colourType ihdr) parseableData
  
  {-# ANN module "HLint: ignore Reduce duplication" #-}
  
  