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