Png.hs

{-# 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 = sampleCountOfImageType imgKind 
        arraySize = fromIntegral $ w * 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 
                            (fromIntegral compCount)
                            (fromIntegral w, fromIntegral h)
                            (scanlineUnpacker8 iBitDepth (fromIntegral compCount)
                                                         mutableImage)
                            str
        Left <$> V.unsafeFreeze imgArray

      else do
        imgArray <- M.new arraySize
        let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray
        deinterlaceFunction iBitDepth 
                            (fromIntegral compCount)
                            (fromIntegral w, fromIntegral h)
                            (shortUnpacker (fromIntegral compCount) mutableImage)
                            str
        Right <$> V.unsafeFreeze imgArray

generateGreyscalePalette :: Word8 -> PngPalette
generateGreyscalePalette bits = Palette' vec
    where maxValue = (2 :: Int) ^ 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' . 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" #-}