{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Module implementing a basic png export, no filtering is applyed, but

-- export at least valid images.

module Codec.Picture.Png.Internal.Export( PngSavable( .. )
                               , PngPaletteSaveable( .. )
                               , writePng
                               , encodeDynamicPng
                               , writeDynamicPng
                               ) where
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid( mempty )
#endif

import Control.Monad( forM_ )
import Control.Monad.ST( ST, runST )
import Data.Bits( unsafeShiftR, (.&.) )
import Data.Binary( encode )
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid( (<>) )
#endif
import Data.Word(Word8, Word16)
import qualified Codec.Compression.Zlib as Z
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as Lb

import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Storable.Mutable as M

import Codec.Picture.Types
import Codec.Picture.Png.Internal.Type
import Codec.Picture.Png.Internal.Metadata
import Codec.Picture.Metadata( Metadatas )
import Codec.Picture.VectorByteConversion( blitVector, toByteString )

-- | Encode a paletted image into a png if possible.

class PngPaletteSaveable a where
  -- | Encode a paletted image as a color indexed 8-bit PNG.

  -- the palette must have between 1 and 256 values in it.

  -- Accepts `PixelRGB8` and `PixelRGBA8` as palette pixel type

  encodePalettedPng :: Image a -> Image Pixel8 -> Either String Lb.ByteString
  encodePalettedPng = Metadatas -> Image a -> Image Pixel8 -> Either String ByteString
forall a.
PngPaletteSaveable a =>
Metadatas -> Image a -> Image Pixel8 -> Either String ByteString
encodePalettedPngWithMetadata Metadatas
forall a. Monoid a => a
mempty

  -- | Equivalent to 'encodePalettedPng' but allow writing of metadatas.

  -- See `encodePngWithMetadata` for the details of encoded metadatas

  -- Accepts `PixelRGB8` and `PixelRGBA8` as palette pixel type

  encodePalettedPngWithMetadata :: Metadatas -> Image a -> Image Pixel8 -> Either String Lb.ByteString

instance PngPaletteSaveable PixelRGB8 where
  encodePalettedPngWithMetadata :: Metadatas
-> Image PixelRGB8 -> Image Pixel8 -> Either String ByteString
encodePalettedPngWithMetadata Metadatas
metas Image PixelRGB8
pal Image Pixel8
img
      | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
256 Bool -> Bool -> Bool
|| Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1 = String -> Either String ByteString
forall a b. a -> Either a b
Left String
"Invalid palette"
      | (Pixel8 -> Bool) -> Vector Pixel8 -> Bool
forall a. Storable a => (a -> Bool) -> Vector a -> Bool
VS.any Pixel8 -> Bool
isTooBig (Vector Pixel8 -> Bool) -> Vector Pixel8 -> Bool
forall a b. (a -> b) -> a -> b
$ Image Pixel8 -> Vector (PixelBaseComponent Pixel8)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image Pixel8
img =
          String -> Either String ByteString
forall a b. a -> Either a b
Left String
"Image contains indexes absent from the palette"
      | Bool
otherwise = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Maybe (Image PixelRGB8)
-> Maybe (Vector Pixel8)
-> PngImageType
-> Metadatas
-> Image Pixel8
-> ByteString
forall px.
(Pixel px, PixelBaseComponent px ~ Pixel8) =>
Maybe (Image PixelRGB8)
-> Maybe (Vector Pixel8)
-> PngImageType
-> Metadatas
-> Image px
-> ByteString
genericEncodePng (Image PixelRGB8 -> Maybe (Image PixelRGB8)
forall a. a -> Maybe a
Just Image PixelRGB8
pal) Maybe (Vector Pixel8)
forall a. Maybe a
Nothing PngImageType
PngIndexedColor Metadatas
metas Image Pixel8
img
        where w :: Int
w = Image PixelRGB8 -> Int
forall a. Image a -> Int
imageWidth Image PixelRGB8
pal
              h :: Int
h = Image PixelRGB8 -> Int
forall a. Image a -> Int
imageHeight Image PixelRGB8
pal
              isTooBig :: Pixel8 -> Bool
isTooBig Pixel8
v = Pixel8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
w

instance PngPaletteSaveable PixelRGBA8 where
  encodePalettedPngWithMetadata :: Metadatas
-> Image PixelRGBA8 -> Image Pixel8 -> Either String ByteString
encodePalettedPngWithMetadata Metadatas
metas Image PixelRGBA8
pal Image Pixel8
img
      | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
256 Bool -> Bool -> Bool
|| Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1 = String -> Either String ByteString
forall a b. a -> Either a b
Left String
"Invalid palette"
      | (Pixel8 -> Bool) -> Vector Pixel8 -> Bool
forall a. Storable a => (a -> Bool) -> Vector a -> Bool
VS.any Pixel8 -> Bool
isTooBig (Vector Pixel8 -> Bool) -> Vector Pixel8 -> Bool
forall a b. (a -> b) -> a -> b
$ Image Pixel8 -> Vector (PixelBaseComponent Pixel8)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image Pixel8
img =
          String -> Either String ByteString
forall a b. a -> Either a b
Left String
"Image contains indexes absent from the palette"
      | Bool
otherwise = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Maybe (Image PixelRGB8)
-> Maybe (Vector Pixel8)
-> PngImageType
-> Metadatas
-> Image Pixel8
-> ByteString
forall px.
(Pixel px, PixelBaseComponent px ~ Pixel8) =>
Maybe (Image PixelRGB8)
-> Maybe (Vector Pixel8)
-> PngImageType
-> Metadatas
-> Image px
-> ByteString
genericEncodePng (Image PixelRGB8 -> Maybe (Image PixelRGB8)
forall a. a -> Maybe a
Just Image PixelRGB8
opaquePalette) (Vector Pixel8 -> Maybe (Vector Pixel8)
forall a. a -> Maybe a
Just Vector Pixel8
Vector (PixelBaseComponent Pixel8)
alphaPal) PngImageType
PngIndexedColor Metadatas
metas Image Pixel8
img
    where
      w :: Int
w = Image PixelRGBA8 -> Int
forall a. Image a -> Int
imageWidth Image PixelRGBA8
pal
      h :: Int
h = Image PixelRGBA8 -> Int
forall a. Image a -> Int
imageHeight Image PixelRGBA8
pal
      opaquePalette :: Image PixelRGB8
opaquePalette = Image PixelRGBA8 -> Image PixelRGB8
forall a b. TransparentPixel a b => Image a -> Image b
dropAlphaLayer Image PixelRGBA8
pal
      alphaPal :: Vector (PixelBaseComponent Pixel8)
alphaPal = Image Pixel8 -> Vector (PixelBaseComponent Pixel8)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData (Image Pixel8 -> Vector (PixelBaseComponent Pixel8))
-> Image Pixel8 -> Vector (PixelBaseComponent Pixel8)
forall a b. (a -> b) -> a -> b
$ PlaneAlpha
-> Image PixelRGBA8 -> Image (PixelBaseComponent PixelRGBA8)
forall px plane.
(Pixel px, Pixel (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px) ~ PixelBaseComponent px,
 ColorPlane px plane) =>
plane -> Image px -> Image (PixelBaseComponent px)
extractComponent PlaneAlpha
PlaneAlpha Image PixelRGBA8
pal
      isTooBig :: Pixel8 -> Bool
isTooBig Pixel8
v = Pixel8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
w

-- | Encode an image into a png if possible.

class PngSavable a where
    -- | Transform an image into a png encoded bytestring, ready

    -- to be written as a file.

    encodePng :: Image a -> Lb.ByteString
    encodePng = Metadatas -> Image a -> ByteString
forall a. PngSavable a => Metadatas -> Image a -> ByteString
encodePngWithMetadata Metadatas
forall a. Monoid a => a
mempty

    -- | Encode a png using some metadatas. The following metadata keys will

    -- be stored in a `tEXt` field :

    --

    --  * 'Codec.Picture.Metadata.Title'

    --  * 'Codec.Picture.Metadata.Description'

    --  * 'Codec.Picture.Metadata.Author'

    --  * 'Codec.Picture.Metadata.Copyright'

    --  * 'Codec.Picture.Metadata.Software'

    --  * 'Codec.Picture.Metadata.Comment'

    --  * 'Codec.Picture.Metadata.Disclaimer'

    --  * 'Codec.Picture.Metadata.Source'

    --  * 'Codec.Picture.Metadata.Warning'

    --  * 'Codec.Picture.Metadata.Unknown' using the key present in the constructor.

    -- 

    -- the followings metadata will bes tored in the `gAMA` chunk.

    --

    --  * 'Codec.Picture.Metadata.Gamma'

    --

    -- The followings metadata will be stored in a `pHYs` chunk

    --

    --  * 'Codec.Picture.Metadata.DpiX'

    --  * 'Codec.Picture.Metadata.DpiY' 

    encodePngWithMetadata :: Metadatas -> Image a -> Lb.ByteString

preparePngHeader :: Image a -> PngImageType -> Word8 -> PngIHdr
preparePngHeader :: Image a -> PngImageType -> Pixel8 -> PngIHdr
preparePngHeader (Image { imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h }) PngImageType
imgType Pixel8
depth = PngIHdr :: Word32
-> Word32
-> Pixel8
-> PngImageType
-> Pixel8
-> Pixel8
-> PngInterlaceMethod
-> PngIHdr
PngIHdr
  { width :: Word32
width             = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w
  , height :: Word32
height            = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h
  , bitDepth :: Pixel8
bitDepth          = Pixel8
depth
  , colourType :: PngImageType
colourType        = PngImageType
imgType
  , compressionMethod :: Pixel8
compressionMethod = Pixel8
0
  , filterMethod :: Pixel8
filterMethod      = Pixel8
0
  , interlaceMethod :: PngInterlaceMethod
interlaceMethod   = PngInterlaceMethod
PngNoInterlace
  }

-- | Helper function to directly write an image as a png on disk.

writePng :: (PngSavable pixel) => FilePath -> Image pixel -> IO ()
writePng :: String -> Image pixel -> IO ()
writePng String
path Image pixel
img = String -> ByteString -> IO ()
Lb.writeFile String
path (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Image pixel -> ByteString
forall a. PngSavable a => Image a -> ByteString
encodePng Image pixel
img

endChunk :: PngRawChunk
endChunk :: PngRawChunk
endChunk = ByteString -> ByteString -> PngRawChunk
mkRawChunk ByteString
iENDSignature ByteString
forall a. Monoid a => a
mempty

prepareIDatChunk :: Lb.ByteString -> PngRawChunk
prepareIDatChunk :: ByteString -> PngRawChunk
prepareIDatChunk = ByteString -> ByteString -> PngRawChunk
mkRawChunk ByteString
iDATSignature

genericEncode16BitsPng :: forall px. (Pixel px, PixelBaseComponent px ~ Word16)
                       => PngImageType -> Metadatas -> Image px -> Lb.ByteString
genericEncode16BitsPng :: PngImageType -> Metadatas -> Image px -> ByteString
genericEncode16BitsPng PngImageType
imgKind Metadatas
metas
                 image :: Image px
image@(Image { imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h, imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
imageData = Vector (PixelBaseComponent px)
arr }) =
  PngRawImage -> ByteString
forall a. Binary a => a -> ByteString
encode PngRawImage :: PngIHdr -> [PngRawChunk] -> PngRawImage
PngRawImage { header :: PngIHdr
header = PngIHdr
hdr
                     , chunks :: [PngRawChunk]
chunks = Metadatas -> [PngRawChunk]
encodeMetadatas Metadatas
metas 
                              [PngRawChunk] -> [PngRawChunk] -> [PngRawChunk]
forall a. Semigroup a => a -> a -> a
<> [ ByteString -> PngRawChunk
prepareIDatChunk ByteString
imgEncodedData
                                 , PngRawChunk
endChunk
                                 ]
                     }
    where hdr :: PngIHdr
hdr = Image px -> PngImageType -> Pixel8 -> PngIHdr
forall a. Image a -> PngImageType -> Pixel8 -> PngIHdr
preparePngHeader Image px
image PngImageType
imgKind Pixel8
16
          zero :: ByteString
zero = Pixel8 -> ByteString
B.singleton Pixel8
0
          compCount :: Int
compCount = px -> Int
forall a. Pixel a => a -> Int
componentCount (px
forall a. HasCallStack => a
undefined :: px)

          lineSize :: Int
lineSize = Int
compCount Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
w
          blitToByteString :: Vector Pixel8 -> ByteString
blitToByteString Vector Pixel8
vec = Vector Pixel8 -> Int -> Int -> ByteString
blitVector Vector Pixel8
vec Int
0 (Int
lineSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)
          encodeLine :: Int -> ByteString
encodeLine Int
line = Vector Pixel8 -> ByteString
blitToByteString (Vector Pixel8 -> ByteString) -> Vector Pixel8 -> ByteString
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Vector Pixel8)) -> Vector Pixel8
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Vector Pixel8)) -> Vector Pixel8)
-> (forall s. ST s (Vector Pixel8)) -> Vector Pixel8
forall a b. (a -> b) -> a -> b
$ do
              STVector s Pixel8
finalVec <- Int -> ST s (MVector (PrimState (ST s)) Pixel8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new (Int -> ST s (MVector (PrimState (ST s)) Pixel8))
-> Int -> ST s (MVector (PrimState (ST s)) Pixel8)
forall a b. (a -> b) -> a -> b
$ Int
lineSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 :: ST s (M.STVector s Word8)
              let baseIndex :: Int
baseIndex = Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
lineSize
              [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 ..  Int
lineSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
ix -> do
                  let v :: Word16
v = Vector Word16
Vector (PixelBaseComponent px)
arr Vector Word16 -> Int -> Word16
forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` (Int
baseIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ix)
                      high :: Pixel8
high = Word16 -> Pixel8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Pixel8) -> Word16 -> Pixel8
forall a b. (a -> b) -> a -> b
$ (Word16
v Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
8) Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0xFF
                      low :: Pixel8
low = Word16 -> Pixel8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Pixel8) -> Word16 -> Pixel8
forall a b. (a -> b) -> a -> b
$ Word16
v Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0xFF

                  (STVector s Pixel8
MVector (PrimState (ST s)) Pixel8
finalVec MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0)) Pixel8
high
                  (STVector s Pixel8
MVector (PrimState (ST s)) Pixel8
finalVec MVector (PrimState (ST s)) Pixel8 -> Int -> Pixel8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Pixel8
low

              MVector (PrimState (ST s)) Pixel8 -> ST s (Vector Pixel8)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze STVector s Pixel8
MVector (PrimState (ST s)) Pixel8
finalVec

          imgEncodedData :: ByteString
imgEncodedData = ByteString -> ByteString
Z.compress (ByteString -> ByteString)
-> ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
Lb.fromChunks
                        ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ByteString
zero, Int -> ByteString
encodeLine Int
line] | Int
line <- [Int
0 .. Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]

preparePalette :: Palette -> PngRawChunk
preparePalette :: Image PixelRGB8 -> PngRawChunk
preparePalette Image PixelRGB8
pal = PngRawChunk :: Word32 -> ByteString -> Word32 -> ByteString -> PngRawChunk
PngRawChunk
  { chunkLength :: Word32
chunkLength = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Image PixelRGB8 -> Int
forall a. Image a -> Int
imageWidth Image PixelRGB8
pal Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3
  , chunkType :: ByteString
chunkType   = ByteString
pLTESignature
  , chunkCRC :: Word32
chunkCRC    = [ByteString] -> Word32
pngComputeCrc [ByteString
pLTESignature, ByteString
binaryData]
  , chunkData :: ByteString
chunkData   = ByteString
binaryData
  }
  where binaryData :: ByteString
binaryData = [ByteString] -> ByteString
Lb.fromChunks [Vector Pixel8 -> ByteString
forall a. Storable a => Vector a -> ByteString
toByteString (Vector Pixel8 -> ByteString) -> Vector Pixel8 -> ByteString
forall a b. (a -> b) -> a -> b
$ Image PixelRGB8 -> Vector (PixelBaseComponent PixelRGB8)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image PixelRGB8
pal]

preparePaletteAlpha :: VS.Vector Pixel8 -> PngRawChunk
preparePaletteAlpha :: Vector Pixel8 -> PngRawChunk
preparePaletteAlpha Vector Pixel8
alphaPal = PngRawChunk :: Word32 -> ByteString -> Word32 -> ByteString -> PngRawChunk
PngRawChunk
  { chunkLength :: Word32
chunkLength = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Vector Pixel8 -> Int
forall a. Storable a => Vector a -> Int
VS.length Vector Pixel8
alphaPal
  , chunkType :: ByteString
chunkType   = ByteString
tRNSSignature
  , chunkCRC :: Word32
chunkCRC    = [ByteString] -> Word32
pngComputeCrc [ByteString
tRNSSignature, ByteString
binaryData]
  , chunkData :: ByteString
chunkData   = ByteString
binaryData
  }
  where binaryData :: ByteString
binaryData = [ByteString] -> ByteString
Lb.fromChunks [Vector Pixel8 -> ByteString
forall a. Storable a => Vector a -> ByteString
toByteString Vector Pixel8
alphaPal]

type PaletteAlpha = VS.Vector Pixel8

genericEncodePng :: forall px. (Pixel px, PixelBaseComponent px ~ Word8)
                 => Maybe Palette
                 -> Maybe PaletteAlpha
                 -> PngImageType -> Metadatas -> Image px
                 -> Lb.ByteString
genericEncodePng :: Maybe (Image PixelRGB8)
-> Maybe (Vector Pixel8)
-> PngImageType
-> Metadatas
-> Image px
-> ByteString
genericEncodePng Maybe (Image PixelRGB8)
palette Maybe (Vector Pixel8)
palAlpha PngImageType
imgKind Metadatas
metas
                 image :: Image px
image@(Image { imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h, imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
imageData = Vector (PixelBaseComponent px)
arr }) =
  PngRawImage -> ByteString
forall a. Binary a => a -> ByteString
encode PngRawImage :: PngIHdr -> [PngRawChunk] -> PngRawImage
PngRawImage { header :: PngIHdr
header = PngIHdr
hdr
                     , chunks :: [PngRawChunk]
chunks = Metadatas -> [PngRawChunk]
encodeMetadatas Metadatas
metas
                              [PngRawChunk] -> [PngRawChunk] -> [PngRawChunk]
forall a. Semigroup a => a -> a -> a
<> [PngRawChunk]
paletteChunk
                              [PngRawChunk] -> [PngRawChunk] -> [PngRawChunk]
forall a. Semigroup a => a -> a -> a
<> [PngRawChunk]
transpChunk
                              [PngRawChunk] -> [PngRawChunk] -> [PngRawChunk]
forall a. Semigroup a => a -> a -> a
<> [ ByteString -> PngRawChunk
prepareIDatChunk ByteString
imgEncodedData
                                 , PngRawChunk
endChunk
                                 ]}
  where
    hdr :: PngIHdr
hdr = Image px -> PngImageType -> Pixel8 -> PngIHdr
forall a. Image a -> PngImageType -> Pixel8 -> PngIHdr
preparePngHeader Image px
image PngImageType
imgKind Pixel8
8
    zero :: ByteString
zero = Pixel8 -> ByteString
B.singleton Pixel8
0
    compCount :: Int
compCount = px -> Int
forall a. Pixel a => a -> Int
componentCount (px
forall a. HasCallStack => a
undefined :: px)

    paletteChunk :: [PngRawChunk]
paletteChunk = case Maybe (Image PixelRGB8)
palette of
      Maybe (Image PixelRGB8)
Nothing -> []
      Just Image PixelRGB8
p -> [Image PixelRGB8 -> PngRawChunk
preparePalette Image PixelRGB8
p]

    transpChunk :: [PngRawChunk]
transpChunk = case Maybe (Vector Pixel8)
palAlpha of
      Maybe (Vector Pixel8)
Nothing -> []
      Just Vector Pixel8
p -> [Vector Pixel8 -> PngRawChunk
preparePaletteAlpha Vector Pixel8
p]

    lineSize :: Int
lineSize = Int
compCount Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
w
    encodeLine :: Int -> ByteString
encodeLine Int
line = Vector Pixel8 -> Int -> Int -> ByteString
blitVector Vector Pixel8
Vector (PixelBaseComponent px)
arr (Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
lineSize) Int
lineSize
    imgEncodedData :: ByteString
imgEncodedData = ByteString -> ByteString
Z.compress
        (ByteString -> ByteString)
-> ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
Lb.fromChunks
        ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ByteString
zero, Int -> ByteString
encodeLine Int
line] | Int
line <- [Int
0 .. Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]

instance PngSavable PixelRGBA8 where
  encodePngWithMetadata :: Metadatas -> Image PixelRGBA8 -> ByteString
encodePngWithMetadata = Maybe (Image PixelRGB8)
-> Maybe (Vector Pixel8)
-> PngImageType
-> Metadatas
-> Image PixelRGBA8
-> ByteString
forall px.
(Pixel px, PixelBaseComponent px ~ Pixel8) =>
Maybe (Image PixelRGB8)
-> Maybe (Vector Pixel8)
-> PngImageType
-> Metadatas
-> Image px
-> ByteString
genericEncodePng Maybe (Image PixelRGB8)
forall a. Maybe a
Nothing Maybe (Vector Pixel8)
forall a. Maybe a
Nothing PngImageType
PngTrueColourWithAlpha

instance PngSavable PixelRGB8 where
  encodePngWithMetadata :: Metadatas -> Image PixelRGB8 -> ByteString
encodePngWithMetadata = Maybe (Image PixelRGB8)
-> Maybe (Vector Pixel8)
-> PngImageType
-> Metadatas
-> Image PixelRGB8
-> ByteString
forall px.
(Pixel px, PixelBaseComponent px ~ Pixel8) =>
Maybe (Image PixelRGB8)
-> Maybe (Vector Pixel8)
-> PngImageType
-> Metadatas
-> Image px
-> ByteString
genericEncodePng Maybe (Image PixelRGB8)
forall a. Maybe a
Nothing Maybe (Vector Pixel8)
forall a. Maybe a
Nothing PngImageType
PngTrueColour

instance PngSavable Pixel8 where
  encodePngWithMetadata :: Metadatas -> Image Pixel8 -> ByteString
encodePngWithMetadata = Maybe (Image PixelRGB8)
-> Maybe (Vector Pixel8)
-> PngImageType
-> Metadatas
-> Image Pixel8
-> ByteString
forall px.
(Pixel px, PixelBaseComponent px ~ Pixel8) =>
Maybe (Image PixelRGB8)
-> Maybe (Vector Pixel8)
-> PngImageType
-> Metadatas
-> Image px
-> ByteString
genericEncodePng Maybe (Image PixelRGB8)
forall a. Maybe a
Nothing Maybe (Vector Pixel8)
forall a. Maybe a
Nothing PngImageType
PngGreyscale

instance PngSavable PixelYA8 where
  encodePngWithMetadata :: Metadatas -> Image PixelYA8 -> ByteString
encodePngWithMetadata = Maybe (Image PixelRGB8)
-> Maybe (Vector Pixel8)
-> PngImageType
-> Metadatas
-> Image PixelYA8
-> ByteString
forall px.
(Pixel px, PixelBaseComponent px ~ Pixel8) =>
Maybe (Image PixelRGB8)
-> Maybe (Vector Pixel8)
-> PngImageType
-> Metadatas
-> Image px
-> ByteString
genericEncodePng Maybe (Image PixelRGB8)
forall a. Maybe a
Nothing Maybe (Vector Pixel8)
forall a. Maybe a
Nothing PngImageType
PngGreyscaleWithAlpha

instance PngSavable PixelYA16 where
  encodePngWithMetadata :: Metadatas -> Image PixelYA16 -> ByteString
encodePngWithMetadata = PngImageType -> Metadatas -> Image PixelYA16 -> ByteString
forall px.
(Pixel px, PixelBaseComponent px ~ Word16) =>
PngImageType -> Metadatas -> Image px -> ByteString
genericEncode16BitsPng PngImageType
PngGreyscaleWithAlpha

instance PngSavable Pixel16 where
  encodePngWithMetadata :: Metadatas -> Image Word16 -> ByteString
encodePngWithMetadata = PngImageType -> Metadatas -> Image Word16 -> ByteString
forall px.
(Pixel px, PixelBaseComponent px ~ Word16) =>
PngImageType -> Metadatas -> Image px -> ByteString
genericEncode16BitsPng PngImageType
PngGreyscale

instance PngSavable PixelRGB16 where
  encodePngWithMetadata :: Metadatas -> Image PixelRGB16 -> ByteString
encodePngWithMetadata = PngImageType -> Metadatas -> Image PixelRGB16 -> ByteString
forall px.
(Pixel px, PixelBaseComponent px ~ Word16) =>
PngImageType -> Metadatas -> Image px -> ByteString
genericEncode16BitsPng PngImageType
PngTrueColour

instance PngSavable PixelRGBA16 where
  encodePngWithMetadata :: Metadatas -> Image PixelRGBA16 -> ByteString
encodePngWithMetadata = PngImageType -> Metadatas -> Image PixelRGBA16 -> ByteString
forall px.
(Pixel px, PixelBaseComponent px ~ Word16) =>
PngImageType -> Metadatas -> Image px -> ByteString
genericEncode16BitsPng PngImageType
PngTrueColourWithAlpha

-- | Write a dynamic image in a .png image file if possible.

-- The same restriction as encodeDynamicPng apply.

writeDynamicPng :: FilePath -> DynamicImage -> IO (Either String Bool)
writeDynamicPng :: String -> DynamicImage -> IO (Either String Bool)
writeDynamicPng String
path DynamicImage
img = case DynamicImage -> Either String ByteString
encodeDynamicPng DynamicImage
img of
        Left String
err -> Either String Bool -> IO (Either String Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Bool -> IO (Either String Bool))
-> Either String Bool -> IO (Either String Bool)
forall a b. (a -> b) -> a -> b
$ String -> Either String Bool
forall a b. a -> Either a b
Left String
err
        Right ByteString
b  -> String -> ByteString -> IO ()
Lb.writeFile String
path ByteString
b IO () -> IO (Either String Bool) -> IO (Either String Bool)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either String Bool -> IO (Either String Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
True)

-- | Encode a dynamic image in PNG if possible, supported images are:

--

--   * 'ImageY8'

--

--   * 'ImageY16'

--

--   * 'ImageYA8'

--

--   * 'ImageYA16'

--

--   * 'ImageRGB8'

--

--   * 'ImageRGB16'

--

--   * 'ImageRGBA8'

--

--   * 'ImageRGBA16'

--

encodeDynamicPng :: DynamicImage -> Either String Lb.ByteString
encodeDynamicPng :: DynamicImage -> Either String ByteString
encodeDynamicPng (ImageRGB8 Image PixelRGB8
img) = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Image PixelRGB8 -> ByteString
forall a. PngSavable a => Image a -> ByteString
encodePng Image PixelRGB8
img
encodeDynamicPng (ImageRGBA8 Image PixelRGBA8
img) = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Image PixelRGBA8 -> ByteString
forall a. PngSavable a => Image a -> ByteString
encodePng Image PixelRGBA8
img
encodeDynamicPng (ImageY8 Image Pixel8
img) = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Image Pixel8 -> ByteString
forall a. PngSavable a => Image a -> ByteString
encodePng Image Pixel8
img
encodeDynamicPng (ImageY16 Image Word16
img) = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Image Word16 -> ByteString
forall a. PngSavable a => Image a -> ByteString
encodePng Image Word16
img
encodeDynamicPng (ImageYA8 Image PixelYA8
img) = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Image PixelYA8 -> ByteString
forall a. PngSavable a => Image a -> ByteString
encodePng Image PixelYA8
img
encodeDynamicPng (ImageYA16 Image PixelYA16
img) = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Image PixelYA16 -> ByteString
forall a. PngSavable a => Image a -> ByteString
encodePng Image PixelYA16
img
encodeDynamicPng (ImageRGB16 Image PixelRGB16
img) = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Image PixelRGB16 -> ByteString
forall a. PngSavable a => Image a -> ByteString
encodePng Image PixelRGB16
img
encodeDynamicPng (ImageRGBA16 Image PixelRGBA16
img) = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Image PixelRGBA16 -> ByteString
forall a. PngSavable a => Image a -> ByteString
encodePng Image PixelRGBA16
img
encodeDynamicPng DynamicImage
_ = String -> Either String ByteString
forall a b. a -> Either a b
Left String
"Unsupported image format for PNG export"