1{-# LANGUAGE CPP #-} 2{-# LANGUAGE FlexibleContexts #-} 3{-# LANGUAGE TypeSynonymInstances #-} 4{-# LANGUAGE TypeFamilies #-} 5{-# LANGUAGE ScopedTypeVariables #-} 6-- | Module implementing a basic png export, no filtering is applyed, but 7-- export at least valid images. 8module Codec.Picture.Png.Internal.Export( PngSavable( .. ) 9 , PngPaletteSaveable( .. ) 10 , writePng 11 , encodeDynamicPng 12 , writeDynamicPng 13 ) where 14#if !MIN_VERSION_base(4,8,0) 15import Data.Monoid( mempty ) 16#endif 17 18import Control.Monad( forM_ ) 19import Control.Monad.ST( ST, runST ) 20import Data.Bits( unsafeShiftR, (.&.) ) 21import Data.Binary( encode ) 22#if !MIN_VERSION_base(4,11,0) 23import Data.Monoid( (<>) ) 24#endif 25import Data.Word(Word8, Word16) 26import qualified Codec.Compression.Zlib as Z 27import qualified Data.ByteString as B 28import qualified Data.ByteString.Lazy as Lb 29 30import qualified Data.Vector.Storable as VS 31import qualified Data.Vector.Storable.Mutable as M 32 33import Codec.Picture.Types 34import Codec.Picture.Png.Internal.Type 35import Codec.Picture.Png.Internal.Metadata 36import Codec.Picture.Metadata( Metadatas ) 37import Codec.Picture.VectorByteConversion( blitVector, toByteString ) 38 39-- | Encode a paletted image into a png if possible. 40class PngPaletteSaveable a where 41 -- | Encode a paletted image as a color indexed 8-bit PNG. 42 -- the palette must have between 1 and 256 values in it. 43 -- Accepts `PixelRGB8` and `PixelRGBA8` as palette pixel type 44 encodePalettedPng :: Image a -> Image Pixel8 -> Either String Lb.ByteString 45 encodePalettedPng = encodePalettedPngWithMetadata mempty 46 47 -- | Equivalent to 'encodePalettedPng' but allow writing of metadatas. 48 -- See `encodePngWithMetadata` for the details of encoded metadatas 49 -- Accepts `PixelRGB8` and `PixelRGBA8` as palette pixel type 50 encodePalettedPngWithMetadata :: Metadatas -> Image a -> Image Pixel8 -> Either String Lb.ByteString 51 52instance PngPaletteSaveable PixelRGB8 where 53 encodePalettedPngWithMetadata metas pal img 54 | w <= 0 || w > 256 || h /= 1 = Left "Invalid palette" 55 | VS.any isTooBig $ imageData img = 56 Left "Image contains indexes absent from the palette" 57 | otherwise = Right $ genericEncodePng (Just pal) Nothing PngIndexedColor metas img 58 where w = imageWidth pal 59 h = imageHeight pal 60 isTooBig v = fromIntegral v >= w 61 62instance PngPaletteSaveable PixelRGBA8 where 63 encodePalettedPngWithMetadata metas pal img 64 | w <= 0 || w > 256 || h /= 1 = Left "Invalid palette" 65 | VS.any isTooBig $ imageData img = 66 Left "Image contains indexes absent from the palette" 67 | otherwise = Right $ genericEncodePng (Just opaquePalette) (Just alphaPal) PngIndexedColor metas img 68 where 69 w = imageWidth pal 70 h = imageHeight pal 71 opaquePalette = dropAlphaLayer pal 72 alphaPal = imageData $ extractComponent PlaneAlpha pal 73 isTooBig v = fromIntegral v >= w 74 75-- | Encode an image into a png if possible. 76class PngSavable a where 77 -- | Transform an image into a png encoded bytestring, ready 78 -- to be written as a file. 79 encodePng :: Image a -> Lb.ByteString 80 encodePng = encodePngWithMetadata mempty 81 82 -- | Encode a png using some metadatas. The following metadata keys will 83 -- be stored in a `tEXt` field : 84 -- 85 -- * 'Codec.Picture.Metadata.Title' 86 -- * 'Codec.Picture.Metadata.Description' 87 -- * 'Codec.Picture.Metadata.Author' 88 -- * 'Codec.Picture.Metadata.Copyright' 89 -- * 'Codec.Picture.Metadata.Software' 90 -- * 'Codec.Picture.Metadata.Comment' 91 -- * 'Codec.Picture.Metadata.Disclaimer' 92 -- * 'Codec.Picture.Metadata.Source' 93 -- * 'Codec.Picture.Metadata.Warning' 94 -- * 'Codec.Picture.Metadata.Unknown' using the key present in the constructor. 95 -- 96 -- the followings metadata will bes tored in the `gAMA` chunk. 97 -- 98 -- * 'Codec.Picture.Metadata.Gamma' 99 -- 100 -- The followings metadata will be stored in a `pHYs` chunk 101 -- 102 -- * 'Codec.Picture.Metadata.DpiX' 103 -- * 'Codec.Picture.Metadata.DpiY' 104 encodePngWithMetadata :: Metadatas -> Image a -> Lb.ByteString 105 106preparePngHeader :: Image a -> PngImageType -> Word8 -> PngIHdr 107preparePngHeader (Image { imageWidth = w, imageHeight = h }) imgType depth = PngIHdr 108 { width = fromIntegral w 109 , height = fromIntegral h 110 , bitDepth = depth 111 , colourType = imgType 112 , compressionMethod = 0 113 , filterMethod = 0 114 , interlaceMethod = PngNoInterlace 115 } 116 117-- | Helper function to directly write an image as a png on disk. 118writePng :: (PngSavable pixel) => FilePath -> Image pixel -> IO () 119writePng path img = Lb.writeFile path $ encodePng img 120 121endChunk :: PngRawChunk 122endChunk = mkRawChunk iENDSignature mempty 123 124prepareIDatChunk :: Lb.ByteString -> PngRawChunk 125prepareIDatChunk = mkRawChunk iDATSignature 126 127genericEncode16BitsPng :: forall px. (Pixel px, PixelBaseComponent px ~ Word16) 128 => PngImageType -> Metadatas -> Image px -> Lb.ByteString 129genericEncode16BitsPng imgKind metas 130 image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) = 131 encode PngRawImage { header = hdr 132 , chunks = encodeMetadatas metas 133 <> [ prepareIDatChunk imgEncodedData 134 , endChunk 135 ] 136 } 137 where hdr = preparePngHeader image imgKind 16 138 zero = B.singleton 0 139 compCount = componentCount (undefined :: px) 140 141 lineSize = compCount * w 142 blitToByteString vec = blitVector vec 0 (lineSize * 2) 143 encodeLine line = blitToByteString $ runST $ do 144 finalVec <- M.new $ lineSize * 2 :: ST s (M.STVector s Word8) 145 let baseIndex = line * lineSize 146 forM_ [0 .. lineSize - 1] $ \ix -> do 147 let v = arr `VS.unsafeIndex` (baseIndex + ix) 148 high = fromIntegral $ (v `unsafeShiftR` 8) .&. 0xFF 149 low = fromIntegral $ v .&. 0xFF 150 151 (finalVec `M.unsafeWrite` (ix * 2 + 0)) high 152 (finalVec `M.unsafeWrite` (ix * 2 + 1)) low 153 154 VS.unsafeFreeze finalVec 155 156 imgEncodedData = Z.compress . Lb.fromChunks 157 $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]] 158 159preparePalette :: Palette -> PngRawChunk 160preparePalette pal = PngRawChunk 161 { chunkLength = fromIntegral $ imageWidth pal * 3 162 , chunkType = pLTESignature 163 , chunkCRC = pngComputeCrc [pLTESignature, binaryData] 164 , chunkData = binaryData 165 } 166 where binaryData = Lb.fromChunks [toByteString $ imageData pal] 167 168preparePaletteAlpha :: VS.Vector Pixel8 -> PngRawChunk 169preparePaletteAlpha alphaPal = PngRawChunk 170 { chunkLength = fromIntegral $ VS.length alphaPal 171 , chunkType = tRNSSignature 172 , chunkCRC = pngComputeCrc [tRNSSignature, binaryData] 173 , chunkData = binaryData 174 } 175 where binaryData = Lb.fromChunks [toByteString alphaPal] 176 177type PaletteAlpha = VS.Vector Pixel8 178 179genericEncodePng :: forall px. (Pixel px, PixelBaseComponent px ~ Word8) 180 => Maybe Palette 181 -> Maybe PaletteAlpha 182 -> PngImageType -> Metadatas -> Image px 183 -> Lb.ByteString 184genericEncodePng palette palAlpha imgKind metas 185 image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) = 186 encode PngRawImage { header = hdr 187 , chunks = encodeMetadatas metas 188 <> paletteChunk 189 <> transpChunk 190 <> [ prepareIDatChunk imgEncodedData 191 , endChunk 192 ]} 193 where 194 hdr = preparePngHeader image imgKind 8 195 zero = B.singleton 0 196 compCount = componentCount (undefined :: px) 197 198 paletteChunk = case palette of 199 Nothing -> [] 200 Just p -> [preparePalette p] 201 202 transpChunk = case palAlpha of 203 Nothing -> [] 204 Just p -> [preparePaletteAlpha p] 205 206 lineSize = compCount * w 207 encodeLine line = blitVector arr (line * lineSize) lineSize 208 imgEncodedData = Z.compress 209 . Lb.fromChunks 210 $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]] 211 212instance PngSavable PixelRGBA8 where 213 encodePngWithMetadata = genericEncodePng Nothing Nothing PngTrueColourWithAlpha 214 215instance PngSavable PixelRGB8 where 216 encodePngWithMetadata = genericEncodePng Nothing Nothing PngTrueColour 217 218instance PngSavable Pixel8 where 219 encodePngWithMetadata = genericEncodePng Nothing Nothing PngGreyscale 220 221instance PngSavable PixelYA8 where 222 encodePngWithMetadata = genericEncodePng Nothing Nothing PngGreyscaleWithAlpha 223 224instance PngSavable PixelYA16 where 225 encodePngWithMetadata = genericEncode16BitsPng PngGreyscaleWithAlpha 226 227instance PngSavable Pixel16 where 228 encodePngWithMetadata = genericEncode16BitsPng PngGreyscale 229 230instance PngSavable PixelRGB16 where 231 encodePngWithMetadata = genericEncode16BitsPng PngTrueColour 232 233instance PngSavable PixelRGBA16 where 234 encodePngWithMetadata = genericEncode16BitsPng PngTrueColourWithAlpha 235 236-- | Write a dynamic image in a .png image file if possible. 237-- The same restriction as encodeDynamicPng apply. 238writeDynamicPng :: FilePath -> DynamicImage -> IO (Either String Bool) 239writeDynamicPng path img = case encodeDynamicPng img of 240 Left err -> return $ Left err 241 Right b -> Lb.writeFile path b >> return (Right True) 242 243-- | Encode a dynamic image in PNG if possible, supported images are: 244-- 245-- * 'ImageY8' 246-- 247-- * 'ImageY16' 248-- 249-- * 'ImageYA8' 250-- 251-- * 'ImageYA16' 252-- 253-- * 'ImageRGB8' 254-- 255-- * 'ImageRGB16' 256-- 257-- * 'ImageRGBA8' 258-- 259-- * 'ImageRGBA16' 260-- 261encodeDynamicPng :: DynamicImage -> Either String Lb.ByteString 262encodeDynamicPng (ImageRGB8 img) = Right $ encodePng img 263encodeDynamicPng (ImageRGBA8 img) = Right $ encodePng img 264encodeDynamicPng (ImageY8 img) = Right $ encodePng img 265encodeDynamicPng (ImageY16 img) = Right $ encodePng img 266encodeDynamicPng (ImageYA8 img) = Right $ encodePng img 267encodeDynamicPng (ImageYA16 img) = Right $ encodePng img 268encodeDynamicPng (ImageRGB16 img) = Right $ encodePng img 269encodeDynamicPng (ImageRGBA16 img) = Right $ encodePng img 270encodeDynamicPng _ = Left "Unsupported image format for PNG export" 271