1{-# LANGUAGE FlexibleContexts #-} 2{-# LANGUAGE TypeSynonymInstances #-} 3{-# LANGUAGE BangPatterns #-} 4{-# LANGUAGE ScopedTypeVariables #-} 5{-# LANGUAGE TypeFamilies #-} 6{-# LANGUAGE TupleSections #-} 7{-# LANGUAGE CPP #-} 8-- | Module used for loading & writing \'Portable Network Graphics\' (PNG) 9-- files. 10-- 11-- A high level API is provided. It loads and saves images for you 12-- while hiding all the details about PNG chunks. 13-- 14-- Basic functions for PNG handling are 'decodePng', 'encodePng' 15-- and 'encodePalettedPng'. Convenience functions are provided 16-- for direct file handling and using 'DynamicImage's. 17-- 18-- The loader has been validated against the pngsuite (http://www.libpng.org/pub/png/pngsuite.html) 19module Codec.Picture.Png( -- * High level functions 20 PngSavable( .. ), 21 PngPaletteSaveable( .. ) 22 23 , decodePng 24 , decodePngWithMetadata 25 , decodePngWithPaletteAndMetadata 26 27 , writePng 28 , encodeDynamicPng 29 , writeDynamicPng 30 ) where 31 32#if !MIN_VERSION_base(4,8,0) 33import Control.Applicative( (<$>) ) 34#endif 35 36import Control.Arrow( first ) 37import Control.Monad( forM_, foldM_, when, void ) 38import Control.Monad.ST( ST, runST ) 39 40#if !MIN_VERSION_base(4,11,0) 41import Data.Monoid( (<>) ) 42#endif 43 44import Data.Binary( Binary( get) ) 45 46import qualified Data.Vector.Storable as V 47import qualified Data.Vector.Storable.Mutable as M 48import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR ) 49import Data.List( find, zip4 ) 50import Data.Word( Word8, Word16, Word32 ) 51import qualified Codec.Compression.Zlib as Z 52import qualified Data.ByteString as B 53import qualified Data.ByteString.Unsafe as BU 54import qualified Data.ByteString.Lazy as Lb 55import Foreign.Storable ( Storable ) 56 57import Codec.Picture.Types 58import Codec.Picture.Metadata 59import Codec.Picture.Png.Internal.Type 60import Codec.Picture.Png.Internal.Export 61import Codec.Picture.Png.Internal.Metadata 62import Codec.Picture.InternalHelper 63 64-- | Simple structure used to hold information about Adam7 deinterlacing. 65-- A structure is used to avoid pollution of the module namespace. 66data Adam7MatrixInfo = Adam7MatrixInfo 67 { adam7StartingRow :: [Int] 68 , adam7StartingCol :: [Int] 69 , adam7RowIncrement :: [Int] 70 , adam7ColIncrement :: [Int] 71 , adam7BlockHeight :: [Int] 72 , adam7BlockWidth :: [Int] 73 } 74 75-- | The real info about the matrix. 76adam7MatrixInfo :: Adam7MatrixInfo 77adam7MatrixInfo = Adam7MatrixInfo 78 { adam7StartingRow = [0, 0, 4, 0, 2, 0, 1] 79 , adam7StartingCol = [0, 4, 0, 2, 0, 1, 0] 80 , adam7RowIncrement = [8, 8, 8, 4, 4, 2, 2] 81 , adam7ColIncrement = [8, 8, 4, 4, 2, 2, 1] 82 , adam7BlockHeight = [8, 8, 4, 4, 2, 2, 1] 83 , adam7BlockWidth = [8, 4, 4, 2, 2, 1, 1] 84 } 85 86unparsePngFilter :: Word8 -> Either String PngFilter 87{-# INLINE unparsePngFilter #-} 88unparsePngFilter 0 = Right FilterNone 89unparsePngFilter 1 = Right FilterSub 90unparsePngFilter 2 = Right FilterUp 91unparsePngFilter 3 = Right FilterAverage 92unparsePngFilter 4 = Right FilterPaeth 93unparsePngFilter _ = Left "Invalid scanline filter" 94 95getBounds :: (Monad m, Storable a) => M.STVector s a -> m (Int, Int) 96{-# INLINE getBounds #-} 97getBounds v = return (0, M.length v - 1) 98 99-- | Apply a filtering method on a reduced image. Apply the filter 100-- on each line, using the previous line (the one above it) to perform 101-- some prediction on the value. 102pngFiltering :: LineUnpacker s -> Int -> (Int, Int) -- ^ Image size 103 -> B.ByteString -> Int 104 -> ST s Int 105pngFiltering _ _ (imgWidth, imgHeight) _str initialIdx 106 | imgWidth <= 0 || imgHeight <= 0 = return initialIdx 107pngFiltering unpacker beginZeroes (imgWidth, imgHeight) str initialIdx = do 108 thisLine <- M.replicate (beginZeroes + imgWidth) 0 109 otherLine <- M.replicate (beginZeroes + imgWidth) 0 110 let folder _ _ lineIndex !idx | lineIndex >= imgHeight = return idx 111 folder previousLine currentLine lineIndex !idx = do 112 let byte = str `BU.unsafeIndex` idx 113 let lineFilter = case unparsePngFilter byte of 114 Right FilterNone -> filterNone 115 Right FilterSub -> filterSub 116 Right FilterAverage -> filterAverage 117 Right FilterUp -> filterUp 118 Right FilterPaeth -> filterPaeth 119 _ -> filterNone 120 idx' <- lineFilter previousLine currentLine $ idx + 1 121 unpacker lineIndex (stride, currentLine) 122 folder currentLine previousLine (lineIndex + 1) idx' 123 124 folder thisLine otherLine (0 :: Int) initialIdx 125 126 where stride = fromIntegral beginZeroes 127 lastIdx = beginZeroes + imgWidth - 1 128 129 -- The filter implementation are... well non-idiomatic 130 -- to say the least, but my benchmarks proved me one thing, 131 -- they are faster than mapM_, gained something like 5% with 132 -- a rewrite from mapM_ to this direct version 133 filterNone, filterSub, filterUp, filterPaeth, 134 filterAverage :: PngLine s -> PngLine s -> Int -> ST s Int 135 filterNone !_previousLine !thisLine = inner beginZeroes 136 where inner idx !readIdx 137 | idx > lastIdx = return readIdx 138 | otherwise = do let byte = str `BU.unsafeIndex` readIdx 139 (thisLine `M.unsafeWrite` idx) byte 140 inner (idx + 1) $ readIdx + 1 141 142 filterSub !_previousLine !thisLine = inner beginZeroes 143 where inner idx !readIdx 144 | idx > lastIdx = return readIdx 145 | otherwise = do let byte = str `BU.unsafeIndex` readIdx 146 val <- thisLine `M.unsafeRead` (idx - stride) 147 (thisLine `M.unsafeWrite` idx) $ byte + val 148 inner (idx + 1) $ readIdx + 1 149 150 filterUp !previousLine !thisLine = inner beginZeroes 151 where inner idx !readIdx 152 | idx > lastIdx = return readIdx 153 | otherwise = do let byte = str `BU.unsafeIndex` readIdx 154 val <- previousLine `M.unsafeRead` idx 155 (thisLine `M.unsafeWrite` idx) $ val + byte 156 inner (idx + 1) $ readIdx + 1 157 158 filterAverage !previousLine !thisLine = inner beginZeroes 159 where inner idx !readIdx 160 | idx > lastIdx = return readIdx 161 | otherwise = do let byte = str `BU.unsafeIndex` readIdx 162 valA <- thisLine `M.unsafeRead` (idx - stride) 163 valB <- previousLine `M.unsafeRead` idx 164 let a' = fromIntegral valA 165 b' = fromIntegral valB 166 average = fromIntegral ((a' + b') `div` (2 :: Word16)) 167 writeVal = byte + average 168 (thisLine `M.unsafeWrite` idx) writeVal 169 inner (idx + 1) $ readIdx + 1 170 171 filterPaeth !previousLine !thisLine = inner beginZeroes 172 where inner idx !readIdx 173 | idx > lastIdx = return readIdx 174 | otherwise = do let byte = str `BU.unsafeIndex` readIdx 175 valA <- thisLine `M.unsafeRead` (idx - stride) 176 valC <- previousLine `M.unsafeRead` (idx - stride) 177 valB <- previousLine `M.unsafeRead` idx 178 (thisLine `M.unsafeWrite` idx) $ byte + paeth valA valB valC 179 inner (idx + 1) $ readIdx + 1 180 181 paeth a b c 182 | pa <= pb && pa <= pc = a 183 | pb <= pc = b 184 | otherwise = c 185 where a' = fromIntegral a :: Int 186 b' = fromIntegral b 187 c' = fromIntegral c 188 p = a' + b' - c' 189 pa = abs $ p - a' 190 pb = abs $ p - b' 191 pc = abs $ p - c' 192 193-- | Directly stolen from the definition in the standard (on W3C page), 194-- pixel predictor. 195 196type PngLine s = M.STVector s Word8 197type LineUnpacker s = Int -> (Int, PngLine s) -> ST s () 198 199type StrideInfo = (Int, Int) 200 201type BeginOffset = (Int, Int) 202 203 204-- | Unpack lines where bit depth is 8 205byteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s 206byteUnpacker sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) 207 (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do 208 (_, maxIdx) <- getBounds line 209 let realTop = beginTop + h * strideHeight 210 lineIndex = realTop * imgWidth 211 pixelToRead = min (imgWidth - 1) $ (maxIdx - beginIdx) `div` sampleCount 212 inner pixelIndex | pixelIndex > pixelToRead = return () 213 | otherwise = do 214 let destPixelIndex = lineIndex + pixelIndex * strideWidth + beginLeft 215 destSampleIndex = destPixelIndex * sampleCount 216 srcPixelIndex = pixelIndex * sampleCount + beginIdx 217 perPixel sample | sample >= sampleCount = return () 218 | otherwise = do 219 val <- line `M.unsafeRead` (srcPixelIndex + sample) 220 let writeIdx = destSampleIndex + sample 221 (arr `M.unsafeWrite` writeIdx) val 222 perPixel (sample + 1) 223 perPixel 0 224 inner (pixelIndex + 1) 225 inner 0 226 227 228-- | Unpack lines where bit depth is 1 229bitUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s 230bitUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) 231 (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do 232 (_, endLine) <- getBounds line 233 let realTop = beginTop + h * strideHeight 234 lineIndex = realTop * imgWidth 235 (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth 236 subPadd | subImageRest > 0 = 1 237 | otherwise = 0 238 (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 8 239 forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do 240 val <- line `M.unsafeRead` (pixelIndex + beginIdx) 241 let writeIdx n = lineIndex + (pixelIndex * 8 + n) * strideWidth + beginLeft 242 forM_ [0 .. 7] $ \bit -> (arr `M.unsafeWrite` writeIdx (7 - bit)) ((val `unsafeShiftR` bit) .&. 1) 243 244 when (lineRest /= 0) 245 (do val <- line `M.unsafeRead` endLine 246 let writeIdx n = lineIndex + (pixelToRead * 8 + n) * strideWidth + beginLeft 247 forM_ [0 .. lineRest - 1] $ \bit -> 248 (arr `M.unsafeWrite` writeIdx bit) ((val `unsafeShiftR` (7 - bit)) .&. 0x1)) 249 250 251-- | Unpack lines when bit depth is 2 252twoBitsUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s 253twoBitsUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) 254 (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do 255 (_, endLine) <- getBounds line 256 let realTop = beginTop + h * strideHeight 257 lineIndex = realTop * imgWidth 258 (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth 259 subPadd | subImageRest > 0 = 1 260 | otherwise = 0 261 (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 4 262 263 forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do 264 val <- line `M.unsafeRead` (pixelIndex + beginIdx) 265 let writeIdx n = lineIndex + (pixelIndex * 4 + n) * strideWidth + beginLeft 266 (arr `M.unsafeWrite` writeIdx 0) $ (val `unsafeShiftR` 6) .&. 0x3 267 (arr `M.unsafeWrite` writeIdx 1) $ (val `unsafeShiftR` 4) .&. 0x3 268 (arr `M.unsafeWrite` writeIdx 2) $ (val `unsafeShiftR` 2) .&. 0x3 269 (arr `M.unsafeWrite` writeIdx 3) $ val .&. 0x3 270 271 when (lineRest /= 0) 272 (do val <- line `M.unsafeRead` endLine 273 let writeIdx n = lineIndex + (pixelToRead * 4 + n) * strideWidth + beginLeft 274 forM_ [0 .. lineRest - 1] $ \bit -> 275 (arr `M.unsafeWrite` writeIdx bit) ((val `unsafeShiftR` (6 - 2 * bit)) .&. 0x3)) 276 277halfByteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s 278halfByteUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) 279 (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do 280 (_, endLine) <- getBounds line 281 let realTop = beginTop + h * strideHeight 282 lineIndex = realTop * imgWidth 283 (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth 284 subPadd | subImageRest > 0 = 1 285 | otherwise = 0 286 (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 2 287 forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do 288 val <- line `M.unsafeRead` (pixelIndex + beginIdx) 289 let writeIdx n = lineIndex + (pixelIndex * 2 + n) * strideWidth + beginLeft 290 (arr `M.unsafeWrite` writeIdx 0) $ (val `unsafeShiftR` 4) .&. 0xF 291 (arr `M.unsafeWrite` writeIdx 1) $ val .&. 0xF 292 293 when (lineRest /= 0) 294 (do val <- line `M.unsafeRead` endLine 295 let writeIdx = lineIndex + (pixelToRead * 2) * strideWidth + beginLeft 296 (arr `M.unsafeWrite` writeIdx) $ (val `unsafeShiftR` 4) .&. 0xF) 297 298shortUnpacker :: Int -> MutableImage s Word16 -> StrideInfo -> BeginOffset -> LineUnpacker s 299shortUnpacker sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) 300 (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do 301 (_, maxIdx) <- getBounds line 302 let realTop = beginTop + h * strideHeight 303 lineIndex = realTop * imgWidth 304 pixelToRead = min (imgWidth - 1) $ (maxIdx - beginIdx) `div` (sampleCount * 2) 305 forM_ [0 .. pixelToRead] $ \pixelIndex -> do 306 let destPixelIndex = lineIndex + pixelIndex * strideWidth + beginLeft 307 destSampleIndex = destPixelIndex * sampleCount 308 srcPixelIndex = pixelIndex * sampleCount * 2 + beginIdx 309 forM_ [0 .. sampleCount - 1] $ \sample -> do 310 highBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 0) 311 lowBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 1) 312 let fullValue = fromIntegral lowBits .|. (fromIntegral highBits `unsafeShiftL` 8) 313 writeIdx = destSampleIndex + sample 314 (arr `M.unsafeWrite` writeIdx) fullValue 315 316-- | Transform a scanline to a bunch of bytes. Bytes are then packed 317-- into pixels at a further step. 318scanlineUnpacker8 :: Int -> Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset 319 -> LineUnpacker s 320scanlineUnpacker8 1 = bitUnpacker 321scanlineUnpacker8 2 = twoBitsUnpacker 322scanlineUnpacker8 4 = halfByteUnpacker 323scanlineUnpacker8 8 = byteUnpacker 324scanlineUnpacker8 _ = error "Impossible bit depth" 325 326byteSizeOfBitLength :: Int -> Int -> Int -> Int 327byteSizeOfBitLength pixelBitDepth sampleCount dimension = size + (if rest /= 0 then 1 else 0) 328 where (size, rest) = (pixelBitDepth * dimension * sampleCount) `quotRem` 8 329 330scanLineInterleaving :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s) 331 -> B.ByteString 332 -> ST s () 333scanLineInterleaving depth sampleCount (imgWidth, imgHeight) unpacker str = 334 void $ pngFiltering (unpacker (1,1) (0, 0)) strideInfo (byteWidth, imgHeight) str 0 335 where byteWidth = byteSizeOfBitLength depth sampleCount imgWidth 336 strideInfo | depth < 8 = 1 337 | otherwise = sampleCount * (depth `div` 8) 338 339-- | Given data and image size, recreate an image with deinterlaced 340-- data for PNG's adam 7 method. 341adam7Unpack :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s) 342 -> B.ByteString -> ST s () 343adam7Unpack depth sampleCount (imgWidth, imgHeight) unpacker str = 344 void $ foldM_ (\i f -> f i) 0 subImages 345 where Adam7MatrixInfo { adam7StartingRow = startRows 346 , adam7RowIncrement = rowIncrement 347 , adam7StartingCol = startCols 348 , adam7ColIncrement = colIncrement } = adam7MatrixInfo 349 350 subImages = 351 [pngFiltering (unpacker (incrW, incrH) (beginW, beginH)) strideInfo (byteWidth, passHeight) str 352 | (beginW, incrW, beginH, incrH) <- zip4 startCols colIncrement startRows rowIncrement 353 , let passWidth = sizer imgWidth beginW incrW 354 passHeight = sizer imgHeight beginH incrH 355 byteWidth = byteSizeOfBitLength depth sampleCount passWidth 356 ] 357 strideInfo | depth < 8 = 1 358 | otherwise = sampleCount * (depth `div` 8) 359 sizer dimension begin increment 360 | dimension <= begin = 0 361 | otherwise = outDim + (if restDim /= 0 then 1 else 0) 362 where (outDim, restDim) = (dimension - begin) `quotRem` increment 363 364-- | deinterlace picture in function of the method indicated 365-- in the iHDR 366deinterlacer :: PngIHdr -> B.ByteString -> ST s (Either (V.Vector Word8) (V.Vector Word16)) 367deinterlacer (PngIHdr { width = w, height = h, colourType = imgKind 368 , interlaceMethod = method, bitDepth = depth }) str = do 369 let compCount = sampleCountOfImageType imgKind 370 arraySize = fromIntegral $ w * h * compCount 371 deinterlaceFunction = case method of 372 PngNoInterlace -> scanLineInterleaving 373 PngInterlaceAdam7 -> adam7Unpack 374 iBitDepth = fromIntegral depth 375 if iBitDepth <= 8 376 then do 377 imgArray <- M.new arraySize 378 let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray 379 deinterlaceFunction iBitDepth 380 (fromIntegral compCount) 381 (fromIntegral w, fromIntegral h) 382 (scanlineUnpacker8 iBitDepth (fromIntegral compCount) 383 mutableImage) 384 str 385 Left <$> V.unsafeFreeze imgArray 386 387 else do 388 imgArray <- M.new arraySize 389 let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray 390 deinterlaceFunction iBitDepth 391 (fromIntegral compCount) 392 (fromIntegral w, fromIntegral h) 393 (shortUnpacker (fromIntegral compCount) mutableImage) 394 str 395 Right <$> V.unsafeFreeze imgArray 396 397generateGreyscalePalette :: Word8 -> PngPalette 398generateGreyscalePalette bits = Palette' (maxValue+1) vec 399 where maxValue = 2 ^ bits - 1 400 vec = V.fromListN ((fromIntegral maxValue + 1) * 3) $ concat pixels 401 pixels = [[i, i, i] | n <- [0 .. maxValue] 402 , let i = fromIntegral $ n * (255 `div` maxValue)] 403 404sampleCountOfImageType :: PngImageType -> Word32 405sampleCountOfImageType PngGreyscale = 1 406sampleCountOfImageType PngTrueColour = 3 407sampleCountOfImageType PngIndexedColor = 1 408sampleCountOfImageType PngGreyscaleWithAlpha = 2 409sampleCountOfImageType PngTrueColourWithAlpha = 4 410 411paletteRGB1, paletteRGB2, paletteRGB4 :: PngPalette 412paletteRGB1 = generateGreyscalePalette 1 413paletteRGB2 = generateGreyscalePalette 2 414paletteRGB4 = generateGreyscalePalette 4 415 416addTransparencyToPalette :: PngPalette -> Lb.ByteString -> Palette' PixelRGBA8 417addTransparencyToPalette pal transpBuffer = 418 Palette' (_paletteSize pal) . imageData . pixelMapXY addOpacity $ palettedAsImage pal 419 where 420 maxi = fromIntegral $ Lb.length transpBuffer 421 addOpacity ix _ (PixelRGB8 r g b) | ix < maxi = 422 PixelRGBA8 r g b $ Lb.index transpBuffer (fromIntegral ix) 423 addOpacity _ _ (PixelRGB8 r g b) = PixelRGBA8 r g b 255 424 425unparse :: PngIHdr -> Maybe PngPalette -> [Lb.ByteString] -> PngImageType 426 -> B.ByteString -> Either String PalettedImage 427unparse ihdr _ t PngGreyscale bytes 428 | bitDepth ihdr == 1 = unparse ihdr (Just paletteRGB1) t PngIndexedColor bytes 429 | bitDepth ihdr == 2 = unparse ihdr (Just paletteRGB2) t PngIndexedColor bytes 430 | bitDepth ihdr == 4 = unparse ihdr (Just paletteRGB4) t PngIndexedColor bytes 431 | otherwise = 432 fmap TrueColorImage . toImage ihdr ImageY8 ImageY16 $ runST $ deinterlacer ihdr bytes 433 434unparse _ Nothing _ PngIndexedColor _ = Left "no valid palette found" 435unparse ihdr _ _ PngTrueColour bytes = 436 fmap TrueColorImage . toImage ihdr ImageRGB8 ImageRGB16 $ runST $ deinterlacer ihdr bytes 437unparse ihdr _ _ PngGreyscaleWithAlpha bytes = 438 fmap TrueColorImage . toImage ihdr ImageYA8 ImageYA16 $ runST $ deinterlacer ihdr bytes 439unparse ihdr _ _ PngTrueColourWithAlpha bytes = 440 fmap TrueColorImage . toImage ihdr ImageRGBA8 ImageRGBA16 $ runST $ deinterlacer ihdr bytes 441unparse ihdr (Just plte) transparency PngIndexedColor bytes = 442 palette8 ihdr plte transparency $ runST $ deinterlacer ihdr bytes 443 444toImage :: forall a pxWord8 pxWord16 445 . PngIHdr 446 -> (Image pxWord8 -> DynamicImage) -> (Image pxWord16 -> DynamicImage) 447 -> Either (V.Vector (PixelBaseComponent pxWord8)) 448 (V.Vector (PixelBaseComponent pxWord16)) 449 -> Either a DynamicImage 450toImage hdr const1 const2 lr = Right $ case lr of 451 Left a -> const1 $ Image w h a 452 Right a -> const2 $ Image w h a 453 where 454 w = fromIntegral $ width hdr 455 h = fromIntegral $ height hdr 456 457palette8 :: PngIHdr -> PngPalette -> [Lb.ByteString] -> Either (V.Vector Word8) t 458 -> Either String PalettedImage 459palette8 hdr palette transparency eimg = case (transparency, eimg) of 460 ([c], Left img) -> 461 Right . PalettedRGBA8 (Image w h img) $ addTransparencyToPalette palette c 462 (_, Left img) -> 463 return $ PalettedRGB8 (Image w h img) palette 464 (_, Right _) -> 465 Left "Invalid bit depth for paleted image" 466 where 467 w = fromIntegral $ width hdr 468 h = fromIntegral $ height hdr 469 470 471-- | Transform a raw png image to an image, without modifying the 472-- underlying pixel type. If the image is greyscale and < 8 bits, 473-- a transformation to RGBA8 is performed. This should change 474-- in the future. 475-- The resulting image let you manage the pixel types. 476-- 477-- This function can output the following images: 478-- 479-- * 'ImageY8' 480-- 481-- * 'ImageY16' 482-- 483-- * 'ImageYA8' 484-- 485-- * 'ImageYA16' 486-- 487-- * 'ImageRGB8' 488-- 489-- * 'ImageRGB16' 490-- 491-- * 'ImageRGBA8' 492-- 493-- * 'ImageRGBA16' 494-- 495decodePng :: B.ByteString -> Either String DynamicImage 496decodePng = fmap fst . decodePngWithMetadata 497 498-- | Decode a PNG file with, possibly, separated palette. 499decodePngWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) 500decodePngWithMetadata b = first palettedToTrueColor <$> decodePngWithPaletteAndMetadata b 501 502-- | Same as 'decodePng' but also extract meta datas present 503-- in the files. 504decodePngWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) 505decodePngWithPaletteAndMetadata byte = do 506 rawImg <- runGetStrict get byte 507 let ihdr = header rawImg 508 metadatas = 509 basicMetadata SourcePng (width ihdr) (height ihdr) <> extractMetadatas rawImg 510 compressedImageData = 511 Lb.concat [chunkData chunk | chunk <- chunks rawImg 512 , chunkType chunk == iDATSignature] 513 zlibHeaderSize = 1 {- compression method/flags code -} 514 + 1 {- Additional flags/check bits -} 515 + 4 {-CRC-} 516 517 transparencyColor = 518 [ chunkData chunk | chunk <- chunks rawImg 519 , chunkType chunk == tRNSSignature ] 520 521 522 if Lb.length compressedImageData <= zlibHeaderSize then 523 Left "Invalid data size" 524 else 525 let imgData = Z.decompress compressedImageData 526 parseableData = B.concat $ Lb.toChunks imgData 527 palette = do 528 p <- find (\c -> pLTESignature == chunkType c) $ chunks rawImg 529 case parsePalette p of 530 Left _ -> Nothing 531 Right plte -> return plte 532 in 533 (, metadatas) <$> 534 unparse ihdr palette transparencyColor (colourType ihdr) parseableData 535 536{-# ANN module "HLint: ignore Reduce duplication" #-} 537 538