JuicyPixels 3.2.7.2 → 3.2.8

raw patch · 17 files changed

+453/−364 lines, 17 filesdep ~basedep ~vectorPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, vector

API changes (from Hackage documentation)

Files

• JuicyPixels.cabal +2/−2
• changelog +6/−0
• src/Codec/Picture.hs +22/−14
• src/Codec/Picture/Bitmap.hs +22/−11
• src/Codec/Picture/ConvGraph.hs +10/−10
• src/Codec/Picture/Gif.hs +21/−8
• src/Codec/Picture/Gif/LZWEncoding.hs +101/−101
• src/Codec/Picture/InternalHelper.hs +51/−51
• src/Codec/Picture/Jpg.hs +3/−3
• src/Codec/Picture/Jpg/Common.hs +11/−1
• src/Codec/Picture/Jpg/Progressive.hs +14/−15
• src/Codec/Picture/Png.hs +30/−36
• src/Codec/Picture/Png/Type.hs +2/−2
• src/Codec/Picture/Tga.hs +27/−19
• src/Codec/Picture/Tiff.hs +44/−46
• src/Codec/Picture/Types.hs +42/−0
• src/Codec/Picture/VectorByteConversion.hs +45/−45

@@ -1,5 +1,5 @@ Name:                JuicyPixels-Version:             3.2.7.2+Version:             3.2.8 Synopsis:            Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance) Description:     <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>>@@ -28,7 +28,7 @@ Source-Repository this     Type:      git     Location:  git://github.com/Twinside/Juicy.Pixels.git-    Tag:       v3.2.7.2+    Tag:       v3.2.8  Flag Mmap     Description: Enable the file loading via mmap (memory map)

@@ -1,6 +1,12 @@ Change log ========== +v3.2.8 September 2016+---------------------+ * Added: possibility to retrieve the parsed palette.+ * Fix: Fixing problem of progressive Jpeg decoding when+		block height is different of block width (#)+ v3.2.7.2 June 2016 ------------------  * Fix: no more libjpeg warning when decoding Juicy.Pixels encoded images.

@@ -21,10 +21,12 @@                      , readImageWithMetadata
                      , decodeImage
                      , decodeImageWithMetadata
+                     , decodeImageWithPaletteAndMetadata
                      , pixelMap
                      , generateImage
                      , generateFoldImage
                      , withImage
+                     , palettedToTrueColor
 
                       -- * RGB helper functions
                      , convertRGB8
@@ -145,13 +147,14 @@ import Control.Applicative( (<$>) )
 #endif
 
+import Control.Arrow( first )
 import Data.Bits( unsafeShiftR )
 import Control.DeepSeq( NFData, deepseq )
 import qualified Control.Exception as Exc ( catch, IOException )
 import Codec.Picture.Metadata( Metadatas )
 import Codec.Picture.Bitmap( BmpEncodable
                            , decodeBitmap
-                           , decodeBitmapWithMetadata
+                           , decodeBitmapWithPaletteAndMetadata
                            , writeBitmap, encodeBitmap
                            , encodeDynamicBitmap, writeDynamicBitmap )
 import Codec.Picture.Jpg( decodeJpeg
@@ -160,7 +163,7 @@                         , encodeJpegAtQuality )
 import Codec.Picture.Png( PngSavable( .. )
                         , decodePng
-                        , decodePngWithMetadata
+                        , decodePngWithPaletteAndMetadata
                         , writePng
                         , encodeDynamicPng
                         , encodePalettedPng
@@ -170,7 +173,7 @@ import Codec.Picture.Gif( GifDelay
                         , GifLooping( .. )
                         , decodeGif
-                        , decodeGifWithMetadata
+                        , decodeGifWithPaletteAndMetadata
                         , decodeGifImages
                         , encodeGifImage
                         , encodeGifImageWithPalette
@@ -187,13 +190,13 @@                         , writeHDR
                         )
 import Codec.Picture.Tiff( decodeTiff
-                         , decodeTiffWithMetadata
+                         , decodeTiffWithPaletteAndMetadata
                          , TiffSaveable
                          , encodeTiff
                          , writeTiff )
 import Codec.Picture.Tga( TgaSaveable
                         , decodeTga
-                        , decodeTgaWithMetadata
+                        , decodeTgaWithPaletteAndMetadata
                         , encodeTga
                         , writeTga
                         )
@@ -358,19 +361,24 @@   ImageCMYK8  img -> convertImage img
   ImageCMYK16 img -> convertImage (decimateBitDepth img :: Image PixelCMYK8)
 
+-- | Equivalent to 'decodeImage', but also provide potential metadatas
+-- present in the given file and the palettes if the format provides them.
+decodeImageWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)
+decodeImageWithPaletteAndMetadata str = eitherLoad str
+    [ ("Jpeg", fmap (first TrueColorImage) . decodeJpegWithMetadata)
+    , ("PNG", decodePngWithPaletteAndMetadata)
+    , ("Bitmap", decodeBitmapWithPaletteAndMetadata)
+    , ("GIF", decodeGifWithPaletteAndMetadata)
+    , ("HDR", fmap (first TrueColorImage) . decodeHDRWithMetadata)
+    , ("Tiff", decodeTiffWithPaletteAndMetadata)
+    , ("TGA", decodeTgaWithPaletteAndMetadata)
+    ]
 
 -- | Equivalent to 'decodeImage', but also provide potential metadatas
 -- present in the given file.
 decodeImageWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
-decodeImageWithMetadata str = eitherLoad str
-    [ ("Jpeg", decodeJpegWithMetadata)
-    , ("PNG", decodePngWithMetadata)
-    , ("Bitmap", decodeBitmapWithMetadata)
-    , ("GIF", decodeGifWithMetadata)
-    , ("HDR", decodeHDRWithMetadata)
-    , ("Tiff", decodeTiffWithMetadata)
-    , ("TGA", decodeTgaWithMetadata)
-    ]
+decodeImageWithMetadata =
+    fmap (first palettedToTrueColor) . decodeImageWithPaletteAndMetadata
 
 -- | Helper function trying to load a png file from a file on disk.
 readPng :: FilePath -> IO (Either String DynamicImage)

@@ -11,6 +11,7 @@                            , encodeBitmapWithMetadata
                            , decodeBitmap
                            , decodeBitmapWithMetadata
+                           , decodeBitmapWithPaletteAndMetadata
                            , encodeDynamicBitmap 
                            , encodeBitmapWithPaletteAndMetadata
                            , writeDynamicBitmap 
@@ -23,10 +24,10 @@ import Control.Applicative( (<$>) )
 #endif
 
-import Control.Monad( when, foldM_, forM_ )
+import Control.Arrow( first )
+import Control.Monad( replicateM, when, foldM_, forM_ )
 import Control.Monad.ST ( ST, runST )
 import Data.Maybe( fromMaybe )
-import qualified Data.Vector as V
 import qualified Data.Vector.Storable as VS
 import qualified Data.Vector.Storable.Mutable as M
 import Data.Binary( Binary( .. ) )
@@ -333,13 +334,13 @@       inner (readIdx + 1) (writeIdx + 1)
 
 
-pixelGet :: Get PixelRGB8
+pixelGet :: Get [Word8]
 pixelGet = do
     b <- getWord8
     g <- getWord8
     r <- getWord8
     _ <- getWord8
-    return $ PixelRGB8 r g b
+    return $ [r, g, b]
 
 metadataOfHeader :: BmpInfoHeader -> Metadatas
 metadataOfHeader hdr = 
@@ -362,7 +363,12 @@ 
 -- | Same as 'decodeBitmap' but also extracts metadata.
 decodeBitmapWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
-decodeBitmapWithMetadata str = flip runGetStrict str $ do
+decodeBitmapWithMetadata byte =
+  first palettedToTrueColor <$> decodeBitmapWithPaletteAndMetadata byte
+
+-- | Same as 'decodeBitmap' but also extracts metadata and provide separated palette.
+decodeBitmapWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)
+decodeBitmapWithPaletteAndMetadata str = flip runGetStrict str $ do
   hdr      <- get :: Get BmpHeader
   bmpHeader <- get :: Get BmpInfoHeader
 
@@ -390,7 +396,8 @@               bitmapCompression bmpHeader) of
     (32, 1, 0) -> do
       rest <- getData
-      return . addMetadata . ImageRGBA8 $ decodeImageRGBA8 bmpHeader (2, 1, 0, 3) rest
+      return . addMetadata . TrueColorImage . ImageRGBA8 
+             $ decodeImageRGBA8 bmpHeader (2, 1, 0, 3) rest
       -- (2, 1, 0, 3) means BGRA pixel order
     (32, 1, 3) -> do
       posRed   <- getBitfield
@@ -398,16 +405,20 @@       posBlue  <- getBitfield
       posAlpha <- getBitfield
       rest     <- getData
-      return . addMetadata . ImageRGBA8 $
+      return . addMetadata . TrueColorImage . ImageRGBA8 $
         decodeImageRGBA8 bmpHeader (posRed, posGreen, posBlue, posAlpha) rest
     (24, 1, 0) -> do
       rest <- getData
-      return . addMetadata . ImageRGB8  $ decodeImageRGB8  bmpHeader rest
+      return . addMetadata . TrueColorImage . ImageRGB8  $ 
+        decodeImageRGB8  bmpHeader rest
     ( 8, 1, 0) -> do
-      table <- V.replicateM paletteColorCount pixelGet
+      table <- replicateM paletteColorCount pixelGet
       rest <- getData
-      let indexer v = table V.! fromIntegral v
-      return . addMetadata . ImageRGB8 . pixelMap indexer $ decodeImageY8 bmpHeader rest
+      let palette = Palette'
+            { _paletteSize = paletteColorCount
+            , _paletteData = VS.fromListN (paletteColorCount * 3) $ concat table
+            }
+      return . addMetadata $ PalettedRGB8 (decodeImageY8 bmpHeader rest) palette
 
     a          -> fail $ "Can't handle BMP file " ++ show a
 

@@ -1,10 +1,10 @@--- $graph
---
--- The following graph describe the differents way to convert between pixel types,
---
--- * Nodes describe pixel type
---
--- * Arrows describe functions
---
--- <<docimages/pixelgraph.svg>>
---
+-- $graph+--+-- The following graph describe the differents way to convert between pixel types,+--+-- * Nodes describe pixel type+--+-- * Arrows describe functions+--+-- <<docimages/pixelgraph.svg>>+--

@@ -6,6 +6,7 @@ module Codec.Picture.Gif ( -- * Reading                            decodeGif                          , decodeGifWithMetadata+                         , decodeGifWithPaletteAndMetadata                          , decodeGifImages                          , getDelaysGifImages @@ -26,6 +27,7 @@ import Control.Applicative( pure, (<*>), (<$>) ) #endif +import Control.Arrow( first ) import Control.Monad( replicateM, replicateM_, unless ) import Control.Monad.ST( runST ) import Control.Monad.Trans.Class( lift )@@ -570,7 +572,7 @@ hasTransparency Nothing = False hasTransparency (Just control) = gceTransparentFlag control -decodeAllGifImages :: GifFile -> [DynamicImage]+decodeAllGifImages :: GifFile -> [PalettedImage] decodeAllGifImages GifFile { gifImages = [] } = [] decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette                                                    , gifScreenDescriptor = wholeDescriptor }@@ -579,11 +581,17 @@       let backImage =               generateImage (\_ _ -> backgroundColor) globalWidth globalHeight           thisPalette = paletteOf palette firstImage+          baseImage = decodeImage firstImage           initState =-            (thisPalette, firstControl, substituteColors thisPalette $ decodeImage firstImage)+            (thisPalette, firstControl, substituteColors thisPalette baseImage)           scanner = gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage+          palette' = Palette'+            { _paletteSize = imageWidth thisPalette+            , _paletteData = imageData thisPalette+            }       in-      [ImageRGB8 img | (_, _, img) <- scanl scanner initState rest]+      PalettedRGB8 baseImage palette' :+        [TrueColorImage $ ImageRGB8 img | (_, _, img) <- tail $ scanl scanner initState rest]    | otherwise =       let backImage :: Image PixelRGBA8@@ -601,7 +609,7 @@           initState = (thisPalette, firstControl, decoded)           scanner =             gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage in-      [ImageRGBA8 img | (_, _, img) <- scanl scanner initState rest]+      [TrueColorImage $ ImageRGBA8 img | (_, _, img) <- scanl scanner initState rest]      where        globalWidth = fromIntegral $ screenWidth wholeDescriptor@@ -662,7 +670,7 @@           val = pixelAt thisPalette (fromIntegral code) 0     pixeler x y = pixelAt oldImage x y -decodeFirstGifImage :: GifFile -> Either String (DynamicImage, Metadatas)+decodeFirstGifImage :: GifFile -> Either String (PalettedImage, Metadatas) decodeFirstGifImage img@GifFile { gifImages = (firstImage:_) } =     case decodeAllGifImages img { gifImages = [firstImage] } of       [] -> Left "No image after decoding"@@ -678,7 +686,7 @@ --  * 'ImageRGBA8' -- decodeGif :: B.ByteString -> Either String DynamicImage-decodeGif img = decode img >>= (fmap fst . decodeFirstGifImage)+decodeGif img = decode img >>= (fmap (palettedToTrueColor . fst) . decodeFirstGifImage)  -- | Transform a raw gif image to an image, without modifying the pixels.  This -- function can output the following images:@@ -690,13 +698,18 @@ -- Metadatas include Width & Height information. -- decodeGifWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)-decodeGifWithMetadata img = decode img >>= decodeFirstGifImage+decodeGifWithMetadata img = first palettedToTrueColor <$> decodeGifWithPaletteAndMetadata img +-- | Return the gif image with metadata and palette.+-- The palette is only returned for the first image of an+-- animation and has no transparency.+decodeGifWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)+decodeGifWithPaletteAndMetadata img = decode img >>= decodeFirstGifImage  -- | Transform a raw gif to a list of images, representing -- all the images of an animation. decodeGifImages :: B.ByteString -> Either String [DynamicImage]-decodeGifImages img = decodeAllGifImages <$> decode img+decodeGifImages img = fmap palettedToTrueColor . decodeAllGifImages <$> decode img  -- | Extract a list of frame delays from a raw gif. getDelaysGifImages :: B.ByteString -> Either String [GifDelay]

@@ -1,101 +1,101 @@-{-# LANGUAGE BangPatterns, CPP #-}
-module Codec.Picture.Gif.LZWEncoding( lzwEncode ) where
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative( (<$>) )
-import Data.Monoid( mempty )
-#endif
-
-import Control.Monad.ST( runST )
-import qualified Data.ByteString.Lazy as L
-import Data.Maybe( fromMaybe )
-import Data.Word( Word8 )
-
-#if MIN_VERSION_containers(0,5,0)
-import qualified Data.IntMap.Strict as I
-#else
-import qualified Data.IntMap as I
-#endif
-import qualified Data.Vector.Storable as V
-
-import Codec.Picture.BitWriter
-
-type Trie = I.IntMap TrieNode
-
-data TrieNode = TrieNode
-    { trieIndex :: {-# UNPACK #-} !Int
-    , trieSub   :: !Trie
-    }
-
-emptyNode :: TrieNode
-emptyNode = TrieNode
-    { trieIndex = -1
-    , trieSub = mempty
-    }
-
-initialTrie :: Trie
-initialTrie = I.fromList
-    [(i, emptyNode { trieIndex = i }) | i <- [0 .. 255]]
-
-lookupUpdate :: V.Vector Word8 -> Int -> Int -> Trie -> (Int, Int, Trie)
-lookupUpdate vector freeIndex firstIndex trie =
-    matchUpdate $ go trie 0 firstIndex 
-  where
-    matchUpdate (lzwOutputIndex, nextReadIndex, sub) =
-        (lzwOutputIndex, nextReadIndex, fromMaybe trie sub)
-
-    maxi = V.length vector
-    go !currentTrie !prevIndex !index
-      | index >= maxi = (prevIndex, index, Nothing)
-      | otherwise = case I.lookup val currentTrie of
-          Just (TrieNode ix subTable) ->
-              let (lzwOutputIndex, nextReadIndex, newTable) =
-                        go subTable ix $ index + 1
-                  tableUpdater t =
-                      I.insert val (TrieNode ix t) currentTrie
-              in
-              (lzwOutputIndex, nextReadIndex, tableUpdater <$> newTable)
-
-          Nothing | index == maxi -> (prevIndex, index, Nothing)
-                  | otherwise -> (prevIndex, index, Just $ I.insert val newNode currentTrie)
-
-      where val = fromIntegral $ vector `V.unsafeIndex` index
-            newNode = emptyNode { trieIndex = freeIndex }
-
-lzwEncode :: Int -> V.Vector Word8 -> L.ByteString
-lzwEncode initialKeySize vec = runST $ do
-    bitWriter <- newWriteStateRef 
-
-    let updateCodeSize 12 writeIdx _
-            | writeIdx == 2 ^ (12 :: Int) - 1 = do
-               writeBitsGif bitWriter (fromIntegral clearCode) 12
-               return (startCodeSize, firstFreeIndex, initialTrie)
-
-        updateCodeSize codeSize writeIdx trie
-            | writeIdx == 2 ^ codeSize =
-                return (codeSize + 1, writeIdx + 1, trie)
-            | otherwise = return (codeSize, writeIdx + 1, trie)
-
-        go readIndex (codeSize, _, _) | readIndex >= maxi =
-            writeBitsGif bitWriter (fromIntegral endOfInfo) codeSize
-        go !readIndex (!codeSize, !writeIndex, !trie) = do
-            let (indexToWrite, endIndex, trie') =
-                    lookuper writeIndex readIndex trie
-            writeBitsGif bitWriter (fromIntegral indexToWrite) codeSize
-            updateCodeSize codeSize writeIndex trie'
-                >>= go endIndex 
-
-    writeBitsGif bitWriter (fromIntegral clearCode) startCodeSize
-    go 0 (startCodeSize, firstFreeIndex, initialTrie)
-
-    finalizeBoolWriter bitWriter
-  where
-    maxi = V.length vec
-
-    startCodeSize = initialKeySize + 1
-
-    clearCode = 2 ^ initialKeySize :: Int
-    endOfInfo = clearCode + 1
-    firstFreeIndex = endOfInfo + 1
-    
-    lookuper = lookupUpdate vec
+{-# LANGUAGE BangPatterns, CPP #-}+module Codec.Picture.Gif.LZWEncoding( lzwEncode ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<$>) )+import Data.Monoid( mempty )+#endif++import Control.Monad.ST( runST )+import qualified Data.ByteString.Lazy as L+import Data.Maybe( fromMaybe )+import Data.Word( Word8 )++#if MIN_VERSION_containers(0,5,0)+import qualified Data.IntMap.Strict as I+#else+import qualified Data.IntMap as I+#endif+import qualified Data.Vector.Storable as V++import Codec.Picture.BitWriter++type Trie = I.IntMap TrieNode++data TrieNode = TrieNode+    { trieIndex :: {-# UNPACK #-} !Int+    , trieSub   :: !Trie+    }++emptyNode :: TrieNode+emptyNode = TrieNode+    { trieIndex = -1+    , trieSub = mempty+    }++initialTrie :: Trie+initialTrie = I.fromList+    [(i, emptyNode { trieIndex = i }) | i <- [0 .. 255]]++lookupUpdate :: V.Vector Word8 -> Int -> Int -> Trie -> (Int, Int, Trie)+lookupUpdate vector freeIndex firstIndex trie =+    matchUpdate $ go trie 0 firstIndex +  where+    matchUpdate (lzwOutputIndex, nextReadIndex, sub) =+        (lzwOutputIndex, nextReadIndex, fromMaybe trie sub)++    maxi = V.length vector+    go !currentTrie !prevIndex !index+      | index >= maxi = (prevIndex, index, Nothing)+      | otherwise = case I.lookup val currentTrie of+          Just (TrieNode ix subTable) ->+              let (lzwOutputIndex, nextReadIndex, newTable) =+                        go subTable ix $ index + 1+                  tableUpdater t =+                      I.insert val (TrieNode ix t) currentTrie+              in+              (lzwOutputIndex, nextReadIndex, tableUpdater <$> newTable)++          Nothing | index == maxi -> (prevIndex, index, Nothing)+                  | otherwise -> (prevIndex, index, Just $ I.insert val newNode currentTrie)++      where val = fromIntegral $ vector `V.unsafeIndex` index+            newNode = emptyNode { trieIndex = freeIndex }++lzwEncode :: Int -> V.Vector Word8 -> L.ByteString+lzwEncode initialKeySize vec = runST $ do+    bitWriter <- newWriteStateRef ++    let updateCodeSize 12 writeIdx _+            | writeIdx == 2 ^ (12 :: Int) - 1 = do+               writeBitsGif bitWriter (fromIntegral clearCode) 12+               return (startCodeSize, firstFreeIndex, initialTrie)++        updateCodeSize codeSize writeIdx trie+            | writeIdx == 2 ^ codeSize =+                return (codeSize + 1, writeIdx + 1, trie)+            | otherwise = return (codeSize, writeIdx + 1, trie)++        go readIndex (codeSize, _, _) | readIndex >= maxi =+            writeBitsGif bitWriter (fromIntegral endOfInfo) codeSize+        go !readIndex (!codeSize, !writeIndex, !trie) = do+            let (indexToWrite, endIndex, trie') =+                    lookuper writeIndex readIndex trie+            writeBitsGif bitWriter (fromIntegral indexToWrite) codeSize+            updateCodeSize codeSize writeIndex trie'+                >>= go endIndex ++    writeBitsGif bitWriter (fromIntegral clearCode) startCodeSize+    go 0 (startCodeSize, firstFreeIndex, initialTrie)++    finalizeBoolWriter bitWriter+  where+    maxi = V.length vec++    startCodeSize = initialKeySize + 1++    clearCode = 2 ^ initialKeySize :: Int+    endOfInfo = clearCode + 1+    firstFreeIndex = endOfInfo + 1+    +    lookuper = lookupUpdate vec

@@ -1,51 +1,51 @@-{-# LANGUAGE CPP #-}
-module Codec.Picture.InternalHelper ( runGet
-                                    , runGetStrict
-                                    , decode
-                                    , getRemainingBytes
-                                    , getRemainingLazyBytes ) where
-
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as L
-import Data.Binary( Binary( get ) )
-import Data.Binary.Get( Get
-                      , getRemainingLazyByteString
-                      )
-import qualified Data.Binary.Get as G
-
-#if MIN_VERSION_binary(0,6,4)
-#else
-import Control.Applicative( (<$>) )
-import qualified Control.Exception as E
--- I feel so dirty. :(
-import System.IO.Unsafe( unsafePerformIO )
-#endif
-
-decode :: (Binary a) => B.ByteString -> Either String a
-decode = runGetStrict get
-
-runGet :: Get a -> L.ByteString -> Either String a
-#if MIN_VERSION_binary(0,6,4)
-runGet act = unpack . G.runGetOrFail act
-    where unpack (Left (_, _, str)) = Left str
-          unpack (Right (_, _, element)) = Right element
-#else
-runGet act str = unsafePerformIO $ E.catch
-    (Right <$> E.evaluate (G.runGet act str))
-    (\msg -> return . Left $ show (msg :: E.SomeException))
-#endif
-
-runGetStrict :: Get a -> B.ByteString -> Either String a
-runGetStrict act buffer = runGet act $ L.fromChunks [buffer]
-
-getRemainingBytes :: Get B.ByteString
-getRemainingBytes = do
-    rest <- getRemainingLazyByteString 
-    return $ case L.toChunks rest of
-        [] -> B.empty
-        [a] -> a
-        lst -> B.concat lst
-
-getRemainingLazyBytes :: Get L.ByteString
-getRemainingLazyBytes = getRemainingLazyByteString 
-
+{-# LANGUAGE CPP #-}+module Codec.Picture.InternalHelper ( runGet+                                    , runGetStrict+                                    , decode+                                    , getRemainingBytes+                                    , getRemainingLazyBytes ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Binary( Binary( get ) )+import Data.Binary.Get( Get+                      , getRemainingLazyByteString+                      )+import qualified Data.Binary.Get as G++#if MIN_VERSION_binary(0,6,4)+#else+import Control.Applicative( (<$>) )+import qualified Control.Exception as E+-- I feel so dirty. :(+import System.IO.Unsafe( unsafePerformIO )+#endif++decode :: (Binary a) => B.ByteString -> Either String a+decode = runGetStrict get++runGet :: Get a -> L.ByteString -> Either String a+#if MIN_VERSION_binary(0,6,4)+runGet act = unpack . G.runGetOrFail act+    where unpack (Left (_, _, str)) = Left str+          unpack (Right (_, _, element)) = Right element+#else+runGet act str = unsafePerformIO $ E.catch+    (Right <$> E.evaluate (G.runGet act str))+    (\msg -> return . Left $ show (msg :: E.SomeException))+#endif++runGetStrict :: Get a -> B.ByteString -> Either String a+runGetStrict act buffer = runGet act $ L.fromChunks [buffer]++getRemainingBytes :: Get B.ByteString+getRemainingBytes = do+    rest <- getRemainingLazyByteString +    return $ case L.toChunks rest of+        [] -> B.empty+        [a] -> a+        lst -> B.concat lst++getRemainingLazyBytes :: Get L.ByteString+getRemainingLazyBytes = getRemainingLazyByteString +

@@ -353,7 +353,7 @@                          , coefficientRange =
                              ( fromIntegral selectionLow
                              , fromIntegral selectionHigh )
-                         , blockIndex = y * ySampling + x
+                         , blockIndex = y * xSampling + x
                          , blockMcuX = x
                          , blockMcuY = y
                          }, unpackerDecision compCount componentSubSampling)
@@ -423,8 +423,8 @@         maxiW = maximum [fst $ subSampling c | (c,_) <- params]
         maxiH = maximum [snd $ subSampling c | (c,_) <- params]
 
-        imageBlockWidth = (imgWidth + 7) `div` 8
-        imageBlockHeight = (imgHeight + 7) `div` 8
+        imageBlockWidth = toBlockSize imgWidth
+        imageBlockHeight = toBlockSize imgHeight
 
         imageMcuWidth = (imageBlockWidth + (maxiW - 1)) `div` maxiW
         imageMcuHeight = (imageBlockHeight + (maxiH - 1)) `div` maxiH

@@ -17,6 +17,7 @@     , rasterMap     , decodeMacroBlock     , decodeRestartInterval+    , toBlockSize     ) where  #if !MIN_VERSION_base(4,8,0)@@ -53,6 +54,12 @@     , coefficientRange     :: !(Int, Int)     , successiveApprox     :: !(Int, Int)     , readerIndex          :: {-# UNPACK #-} !Int+      -- | When in progressive mode, we can have many+      -- color in a scan are only one. The indices changes+      -- on this fact, when mixed, there is whole +      -- MCU for all color components, spanning multiple+      -- block lines. With only one color component we use+      -- the normal raster order.     , indiceVector         :: {-# UNPACK #-} !Int     , blockIndex           :: {-# UNPACK #-} !Int     , blockMcuX            :: {-# UNPACK #-} !Int@@ -60,6 +67,9 @@     }     deriving Show +toBlockSize :: Int -> Int+toBlockSize v = (v + 7) `div` 8+ decodeRestartInterval :: BoolReader s Int32 decodeRestartInterval = return (-1) {-  do   bits <- replicateM 8 getNextBitJpg@@ -195,9 +205,9 @@ unpackMacroBlock :: Int    -- ^ Component count                  -> Int -- ^ Width coefficient                  -> Int -- ^ Height coefficient+                 -> Int -- ^ Component index                  -> Int -- ^ x                  -> Int -- ^ y-                 -> Int    -- ^ Component index                  -> MutableImage s PixelYCbCr8                  -> MutableMacroBlock s Int16                  -> ST s ()

@@ -36,12 +36,9 @@  V.fromList $ VS.fromList <$> [indexSolo, indexMulti]   where compW = fromIntegral $ horizontalSamplingFactor param         compH = fromIntegral $ verticalSamplingFactor param-        imageBlockSize = (imgWidth + 7) `div` 8--        indexSolo =-            [y * mcuWidth * compW + x-                | y <- [0 .. compH - 1], x <- [0 .. imageBlockSize - 1]]+        imageBlockSize = toBlockSize imgWidth +        indexSolo = take (imageBlockSize * compH) [0 ..]         indexMulti =              [(mcu + y * mcuWidth) * compW + x                 | mcu <- [0 .. mcuWidth - 1]@@ -195,13 +192,13 @@                  selection _      _      = decodeRefineAc  data ComponentData s = ComponentData-    { componentIndices    :: V.Vector (VS.Vector Int)-    , componentBlocks     :: V.Vector (MutableMacroBlock s Int16)-    , componentId         :: !Int-    , componentBlockCount :: !Int-    }+  { componentIndices    :: V.Vector (VS.Vector Int)+  , componentBlocks     :: V.Vector (MutableMacroBlock s Int16)+  , componentId         :: !Int+  , componentBlockCount :: !Int+  } --- | Iteration from to n in monadic context, without data+-- | Iteration from 0 to n in monadic context, without data -- keeping. lineMap :: (Monad m) => Int -> (Int -> m ()) -> m () {-# INLINE lineMap #-}@@ -259,6 +256,8 @@             let componentNumber = componentIndex unpackParam             writeIndex <- writeIndices `MS.read` componentNumber             let componentData = allBlocks !! componentNumber+                -- We get back the correct block indices for the number of component+                -- in the current scope (precalculated)                 indexVector =                     componentIndices componentData ! indiceVector unpackParam                 maxIndexLength = VS.length indexVector@@ -305,14 +304,14 @@         imgWidth = fromIntegral $ jpgWidth frame         imgHeight = fromIntegral $ jpgHeight frame -        imageBlockWidth = (imgWidth + 7) `div` 8-        imageBlockHeight = (imgHeight + 7) `div` 8+        imageBlockWidth = toBlockSize imgWidth+        imageBlockHeight = toBlockSize imgHeight -        imageMcuWidth = (imageBlockWidth + (maxiW - 1)) `div` maxiW+        imageMcuWidth =  (imageBlockWidth + (maxiW - 1)) `div` maxiW         imageMcuHeight = (imageBlockHeight + (maxiH - 1)) `div` maxiH          allocateWorkingBlocks (ix, comp) = do-            let blockCount = hSample * vSample * imageMcuWidth+            let blockCount = hSample * vSample * imageMcuWidth * 2             blocks <- V.replicateM blockCount createEmptyMutableMacroBlock             return ComponentData                  { componentBlocks = blocks

@@ -21,6 +21,8 @@ 
                         , decodePng
                         , decodePngWithMetadata
+                        , decodePngWithPaletteAndMetadata
+
                         , writePng
                         , encodeDynamicPng
                         , encodePalettedPng
@@ -32,6 +34,7 @@ import Control.Applicative( (<$>) )
 #endif
 
+import Control.Arrow( first )
 import Control.Monad( forM_, foldM_, when, void )
 import Control.Monad.ST( ST, runST )
 import Data.Monoid( (<>) )
@@ -389,7 +392,7 @@         Right <$> V.unsafeFreeze imgArray
 
 generateGreyscalePalette :: Word8 -> PngPalette
-generateGreyscalePalette bits = Image (maxValue+1) 1 vec
+generateGreyscalePalette bits = Palette' (maxValue+1) vec
     where maxValue = 2 ^ bits - 1
           vec = V.fromListN ((fromIntegral maxValue + 1) * 3) $ concat pixels
           pixels = [[i, i, i] | n <- [0 .. maxValue]
@@ -407,43 +410,31 @@ paletteRGB2 = generateGreyscalePalette 2
 paletteRGB4 = generateGreyscalePalette 4
 
-{-# INLINE bounds #-}
-bounds :: Storable a => V.Vector a -> (Int, Int)
-bounds v = (0, V.length v - 1)
-
-applyPalette :: PngPalette -> V.Vector Word8 -> V.Vector Word8
-applyPalette pal img = V.fromListN ((initSize + 1) * 3) pixels
-    where (_, initSize) = bounds img
-          pixels = concat [[r, g, b] | ipx <- V.toList img
-                                     , let PixelRGB8 r g b = pixelAt pal (fromIntegral ipx) 0]
-
-applyPaletteWithTransparency :: PngPalette -> Lb.ByteString -> V.Vector Word8
-                             -> V.Vector Word8
-applyPaletteWithTransparency pal transpBuffer img = V.fromListN ((initSize + 1) * 4) pixels
-    where (_, initSize) = bounds img
-          maxi = Lb.length transpBuffer
-          pixels = concat
-            [ [r, g, b, opacity]
-                  | ipx <- V.toList img
-                  , let PixelRGB8 r g b = pixelAt pal (fromIntegral ipx) 0
-                        opacity | fromIntegral ipx < maxi = Lb.index transpBuffer $ fromIntegral ipx
-                                | otherwise = 255]
+addTransparencyToPalette :: PngPalette -> Lb.ByteString -> Palette' PixelRGBA8
+addTransparencyToPalette pal transpBuffer = 
+  Palette' (_paletteSize pal) . 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 DynamicImage
+        -> 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 = toImage ihdr ImageY8 ImageY16 $ runST $ deinterlacer ihdr 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 =
-  toImage ihdr ImageRGB8 ImageRGB16 $ runST $ deinterlacer ihdr bytes
+  fmap TrueColorImage . toImage ihdr ImageRGB8 ImageRGB16 $ runST $ deinterlacer ihdr bytes
 unparse ihdr _ _ PngGreyscaleWithAlpha  bytes =
-  toImage ihdr ImageYA8 ImageYA16 $ runST $ deinterlacer ihdr bytes
+  fmap TrueColorImage . toImage ihdr ImageYA8 ImageYA16 $ runST $ deinterlacer ihdr bytes
 unparse ihdr _ _ PngTrueColourWithAlpha bytes =
-  toImage ihdr ImageRGBA8 ImageRGBA16 $ runST $ deinterlacer ihdr 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
 
@@ -461,13 +452,12 @@     h = fromIntegral $ height hdr
 
 palette8 :: PngIHdr -> PngPalette -> [Lb.ByteString] -> Either (V.Vector Word8) t
-         -> Either String DynamicImage
+         -> Either String PalettedImage
 palette8 hdr palette transparency eimg = case (transparency, eimg) of
   ([c], Left img) ->
-    Right . ImageRGBA8 . Image w h
-          $ applyPaletteWithTransparency palette c img
+    Right . PalettedRGBA8 (Image w h img) $ addTransparencyToPalette palette c
   (_, Left img) ->
-    Right . ImageRGB8 . Image w h $ applyPalette palette img
+    return $ PalettedRGB8 (Image w h img) palette
   (_, Right _) ->
     Left "Invalid bit depth for paleted image"
   where
@@ -502,10 +492,14 @@ 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.
-decodePngWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
-decodePngWithMetadata byte =  do
+decodePngWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)
+decodePngWithPaletteAndMetadata byte =  do
   rawImg <- runGetStrict get byte
   let ihdr = header rawImg
       metadatas =

@@ -171,13 +171,13 @@     }
 
 -- | Palette with indices beginning at 0 to elemcount - 1
-type PngPalette = Image PixelRGB8
+type PngPalette = Palette' PixelRGB8
 
 -- | Parse a palette from a png chunk.
 parsePalette :: PngRawChunk -> Either String PngPalette
 parsePalette plte
  | chunkLength plte `mod` 3 /= 0 = Left "Invalid palette size"
- | otherwise = Image pixelCount 1 . V.fromListN (3 * pixelCount) <$> pixels
+ | otherwise = Palette' pixelCount . V.fromListN (3 * pixelCount) <$> pixels
     where pixelUnpacker = replicateM (fromIntegral pixelCount * 3) get
           pixelCount = fromIntegral $ chunkLength plte `div` 3
           pixels = runGet pixelUnpacker (chunkData plte)

@@ -10,6 +10,7 @@ -- Targa (*.tga) files. module Codec.Picture.Tga( decodeTga                         , decodeTgaWithMetadata+                        , decodeTgaWithPaletteAndMetadata                         , TgaSaveable                         , encodeTga                         , writeTga@@ -20,6 +21,7 @@ import Control.Applicative( (<*>), pure, (<$>) ) #endif +import Control.Arrow( first ) import Control.Monad.ST( ST, runST ) import Data.Bits( (.&.)                 , (.|.)@@ -267,16 +269,18 @@     32 -> pure . ImageRGBA8 . flipper $ f Depth32 file     n  -> fail $ "Invalid bit depth (" ++ show n ++ ")" -applyPalette :: (Pixel px)-             => (Image px -> DynamicImage) -> Image px-             -> DynamicImage-             -> Either String DynamicImage-applyPalette f palette (ImageY8 img) =-  pure . f $ pixelMap (\v -> pixelAt palette (fromIntegral v) 0) img-applyPalette _ _ _ =-  fail "Bad colorspace for image"+toPaletted :: (Pixel px)+           => (Image Pixel8 -> Palette' px -> PalettedImage) -> Image px+           -> DynamicImage+           -> Either String PalettedImage+toPaletted f palette (ImageY8 img) = pure $ f img pal where+  pal = Palette' +    { _paletteSize = imageWidth palette+    , _paletteData = imageData palette+    }+toPaletted _ _ _ = fail "Bad colorspace for image" -unparse :: TgaFile -> Either String (DynamicImage, Metadatas)+unparse :: TgaFile -> Either String (PalettedImage, Metadatas) unparse file =   let hdr = _tgaFileHeader file       imageType = _tgaHdrImageType hdr@@ -300,18 +304,18 @@   case imageType of     ImageTypeNoData _ -> fail "No data detected in TGA file"     ImageTypeTrueColor _ ->-      fmap (, metas) $ prepareUnpacker file unpacker+      fmap ((, metas) . TrueColorImage) $ prepareUnpacker file unpacker     ImageTypeMonochrome _ ->-      fmap (, metas) $ prepareUnpacker file unpacker+      fmap ((, metas) . TrueColorImage) $ prepareUnpacker file unpacker     ImageTypeColorMapped _ ->       case decodedPalette of         Left str -> Left str-        Right (ImageY8 img, _) ->-          fmap (, metas) $ prepareUnpacker file unpacker >>= applyPalette ImageY8 img-        Right (ImageRGB8 img, _) ->-          fmap (, metas) $ prepareUnpacker file unpacker >>= applyPalette ImageRGB8 img-        Right (ImageRGBA8 img, _) ->-          fmap (, metas) $ prepareUnpacker file unpacker >>= applyPalette ImageRGBA8 img+        Right (TrueColorImage (ImageY8 img), _) ->+          fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedY8 img+        Right (TrueColorImage (ImageRGB8 img), _) ->+          fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedRGB8 img+        Right (TrueColorImage (ImageRGBA8 img), _) ->+          fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedRGBA8 img         Right _ -> fail "Unknown pixel type"  writeRun :: (Pixel px)@@ -450,11 +454,15 @@ --  * 'ImageRGBA8' -- decodeTga :: B.ByteString -> Either String DynamicImage-decodeTga byte = runGetStrict get byte >>= (fmap fst . unparse)+decodeTga byte = fst <$> decodeTgaWithMetadata byte  -- | Equivalent to decodeTga but also provide metadata decodeTgaWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)-decodeTgaWithMetadata byte = runGetStrict get byte >>= unparse+decodeTgaWithMetadata byte = first palettedToTrueColor <$> decodeTgaWithPaletteAndMetadata byte++-- | Equivalent to decodeTga but with metdata and palette if any+decodeTgaWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)+decodeTgaWithPaletteAndMetadata byte = runGetStrict get byte >>= unparse  -- | This typeclass determine if a pixel can be saved in the -- TGA format.

@@ -27,6 +27,7 @@ -- module Codec.Picture.Tiff( decodeTiff                          , decodeTiffWithMetadata+                         , decodeTiffWithPaletteAndMetadata                          , TiffSaveable                          , encodeTiff                          , writeTiff@@ -37,6 +38,7 @@ import Data.Monoid( mempty ) #endif +import Control.Arrow( first ) import Control.Monad( when, foldM_, unless, forM_ ) import Control.Monad.ST( ST, runST ) import Control.Monad.Writer.Strict( execWriter, tell, Writer )@@ -630,7 +632,13 @@                      >>= predictorOfConstant)         <*> pure (extractTiffMetadata cleaned) -unpack :: B.ByteString -> TiffInfo -> Either String DynamicImage+palette16Of :: Image PixelRGB16 -> Palette' PixelRGB16+palette16Of p = Palette'+    { _paletteSize = imageWidth p+    , _paletteData = imageData p+    }++unpack :: B.ByteString -> TiffInfo -> Either String PalettedImage -- | while mandatory some images don't put correct -- rowperstrip. So replacing 0 with actual image height. unpack file nfo@TiffInfo { tiffRowPerStrip = 0 } =@@ -641,74 +649,60 @@                          , tiffPalette = Just p                          }   | lst == V.singleton 8 && format == [TiffSampleUint] =-      let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0)-          gathered :: Image Pixel8-          gathered = gatherStrips (0 :: Word8) file nfo-      in-      pure . ImageRGB16 $ applyPalette gathered-+      pure . PalettedRGB16 (gatherStrips (0 :: Word8) file nfo) $ palette16Of p   | lst == V.singleton 4 && format == [TiffSampleUint] =-      let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0)-          gathered :: Image Pixel8-          gathered = gatherStrips Pack4 file nfo-      in-      pure . ImageRGB16 $ applyPalette gathered-+      pure . PalettedRGB16 (gatherStrips Pack4 file nfo) $ palette16Of p   | lst == V.singleton 2 && format == [TiffSampleUint] =-      let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0)-          gathered :: Image Pixel8-          gathered = gatherStrips Pack2 file nfo-      in-      pure . ImageRGB16 $ applyPalette gathered+      pure . PalettedRGB16 (gatherStrips Pack2 file nfo) $ palette16Of p  unpack file nfo@TiffInfo { tiffColorspace = TiffCMYK                          , tiffBitsPerSample = lst                          , tiffSampleFormat = format }   | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format =-        pure . ImageCMYK8 $ gatherStrips (0 :: Word8) file nfo+        pure . TrueColorImage . ImageCMYK8 $ gatherStrips (0 :: Word8) file nfo    | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format =-        pure . ImageCMYK16 $ gatherStrips (0 :: Word16) file nfo+        pure . TrueColorImage . ImageCMYK16 $ gatherStrips (0 :: Word16) file nfo  unpack file nfo@TiffInfo { tiffColorspace = TiffMonochromeWhite0 } = do     img <- unpack file (nfo { tiffColorspace = TiffMonochrome })     case img of-      ImageY8 i -> pure . ImageY8 $ pixelMap (maxBound -) i-      ImageY16 i -> pure . ImageY16 $ pixelMap (maxBound -) i-      ImageYA8 i -> let negative (PixelYA8 y a) = PixelYA8 (maxBound - y) a-                    in pure . ImageYA8 $ pixelMap negative i-      ImageYA16 i -> let negative (PixelYA16 y a) = PixelYA16 (maxBound - y) a-                     in pure . ImageYA16 $ pixelMap negative i+      TrueColorImage (ImageY8 i) -> pure . TrueColorImage . ImageY8 $ pixelMap (maxBound -) i+      TrueColorImage (ImageY16 i) -> pure . TrueColorImage . ImageY16 $ pixelMap (maxBound -) i+      TrueColorImage (ImageYA8 i) -> let negative (PixelYA8 y a) = PixelYA8 (maxBound - y) a+                    in pure . TrueColorImage . ImageYA8 $ pixelMap negative i+      TrueColorImage (ImageYA16 i) -> let negative (PixelYA16 y a) = PixelYA16 (maxBound - y) a+                     in pure . TrueColorImage . ImageYA16 $ pixelMap negative i       _ -> fail "Unsupported color type used with colorspace MonochromeWhite0"  unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome                          , tiffBitsPerSample = lst                          , tiffSampleFormat = format }   | lst == V.singleton 2 && all (TiffSampleUint ==) format =-        pure . ImageY8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo+        pure . TrueColorImage . ImageY8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo   | lst == V.singleton 4 && all (TiffSampleUint ==) format =-        pure . ImageY8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo+        pure . TrueColorImage . ImageY8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo   | lst == V.singleton 8 && all (TiffSampleUint ==) format =-        pure . ImageY8 $ gatherStrips (0 :: Word8) file nfo+        pure . TrueColorImage . ImageY8 $ gatherStrips (0 :: Word8) file nfo   | lst == V.singleton 12 && all (TiffSampleUint ==) format =-        pure . ImageY16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo+        pure . TrueColorImage . ImageY16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo   | lst == V.singleton 16 && all (TiffSampleUint ==) format =-        pure . ImageY16 $ gatherStrips (0 :: Word16) file nfo+        pure . TrueColorImage . ImageY16 $ gatherStrips (0 :: Word16) file nfo   | lst == V.singleton 32 && all (TiffSampleUint ==) format =         let toWord16 v = fromIntegral $ v `unsafeShiftR` 16             img = gatherStrips (0 :: Word32) file nfo :: Image Pixel32         in-        pure . ImageY16 $ pixelMap toWord16 img+        pure . TrueColorImage . ImageY16 $ pixelMap toWord16 img   | lst == V.fromList [2, 2] && all (TiffSampleUint ==) format =-        pure . ImageYA8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo+        pure . TrueColorImage . ImageYA8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo   | lst == V.fromList [4, 4] && all (TiffSampleUint ==) format =-        pure . ImageYA8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo+        pure . TrueColorImage . ImageYA8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo   | lst == V.fromList [8, 8] && all (TiffSampleUint ==) format =-        pure . ImageYA8 $ gatherStrips (0 :: Word8) file nfo+        pure . TrueColorImage . ImageYA8 $ gatherStrips (0 :: Word8) file nfo   | lst == V.fromList [12, 12] && all (TiffSampleUint ==) format =-        pure . ImageYA16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo+        pure . TrueColorImage . ImageYA16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo   | lst == V.fromList [16, 16] && all (TiffSampleUint ==) format =-        pure . ImageYA16 $ gatherStrips (0 :: Word16) file nfo+        pure . TrueColorImage . ImageYA16 $ gatherStrips (0 :: Word16) file nfo     where       expand12to16 x = x `unsafeShiftL` 4 + x `unsafeShiftR` (12 - 4) @@ -717,7 +711,7 @@                          , tiffPlaneConfiguration = PlanarConfigContig                          , tiffSampleFormat = format }   | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format =-    pure . ImageYCbCr8 $ gatherStrips cbcrConf  file nfo+    pure . TrueColorImage . ImageYCbCr8 $ gatherStrips cbcrConf  file nfo       where defaulting 0 = 2             defaulting n = n @@ -734,23 +728,23 @@                          , tiffBitsPerSample = lst                          , tiffSampleFormat = format }   | lst == V.fromList [2, 2, 2] && all (TiffSampleUint ==) format =-        pure . ImageRGB8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo+        pure . TrueColorImage . ImageRGB8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo   | lst == V.fromList [4, 4, 4] && all (TiffSampleUint ==) format =-        pure . ImageRGB8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo+        pure . TrueColorImage . ImageRGB8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo   | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format =-        pure . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo+        pure . TrueColorImage . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo   | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format =-        pure . ImageRGBA8 $ gatherStrips (0 :: Word8) file nfo+        pure . TrueColorImage . ImageRGBA8 $ gatherStrips (0 :: Word8) file nfo   | lst == V.fromList [16, 16, 16] && all (TiffSampleUint ==) format =-        pure . ImageRGB16 $ gatherStrips (0 :: Word16) file nfo+        pure . TrueColorImage . ImageRGB16 $ gatherStrips (0 :: Word16) file nfo   | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format =-        pure . ImageRGBA16 $ gatherStrips (0 :: Word16) file nfo+        pure . TrueColorImage . ImageRGBA16 $ gatherStrips (0 :: Word16) file nfo unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome                          , tiffBitsPerSample = lst                          , tiffSampleFormat = format }   -- some files are a little bit borked...   | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format =-        pure . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo+        pure . TrueColorImage . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo  unpack _ _ = fail "Failure to unpack TIFF file" @@ -788,7 +782,11 @@ -- The metadata extracted are the 'Codec.Picture.Metadata.DpiX' & -- 'Codec.Picture.Metadata.DpiY' information alongside the EXIF informations. decodeTiffWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)-decodeTiffWithMetadata file = runGetStrict (getP file) file >>= go+decodeTiffWithMetadata str = first palettedToTrueColor <$> decodeTiffWithPaletteAndMetadata str++-- | Decode TIFF and provide separated palette and metadata+decodeTiffWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)+decodeTiffWithPaletteAndMetadata file = runGetStrict (getP file) file >>= go   where     go tinfo = (, tiffMetadatas tinfo) <$> unpack file tinfo     

@@ -16,7 +16,9 @@                             Image( .. )
                           , MutableImage( .. )
                           , DynamicImage( .. )
+                          , PalettedImage( .. )
                           , Palette
+                          , Palette'( .. )
 
                             -- ** Image functions
                           , createMutableImage
@@ -65,6 +67,8 @@ 
                           , dynamicMap
                           , dynamicPixelMap
+                          , palettedToTrueColor
+                          , palettedAsImage
                           , dropAlphaLayer
                           , withImage
                           , zipPixelComponent3
@@ -388,6 +392,44 @@        -- | An image in the colorspace CMYK and 16 bits precision
      | ImageCMYK16 (Image PixelCMYK16)
     deriving (Typeable)
+
+-- | Type used to expose a palette extracted during reading.
+-- Use palettedAsImage to convert it to a palette usable for
+-- writing.
+data Palette' px = Palette'
+  { -- | Number of element in pixels.
+    _paletteSize :: !Int
+    -- | Real data used by the palette.
+  , _paletteData :: !(V.Vector (PixelBaseComponent px))
+  }
+  deriving Typeable
+
+-- | Convert a palette to an image. Used mainly for
+-- backward compatibility.
+palettedAsImage :: Palette' px -> Image px
+palettedAsImage p = Image (_paletteSize p) 1 $ _paletteData p
+
+-- | Describe an image and it's potential associated
+-- palette. If no palette is present, fallback to a
+-- DynamicImage
+data PalettedImage
+  = TrueColorImage DynamicImage -- ^ Fallback
+  | PalettedY8    (Image Pixel8) (Palette' Pixel8)
+  | PalettedRGB8  (Image Pixel8) (Palette' PixelRGB8)
+  | PalettedRGBA8 (Image Pixel8) (Palette' PixelRGBA8)
+  | PalettedRGB16 (Image Pixel8) (Palette' PixelRGB16)
+  deriving (Typeable)
+
+-- | Flatten a PalettedImage to a DynamicImage
+palettedToTrueColor :: PalettedImage -> DynamicImage
+palettedToTrueColor img = case img of
+  TrueColorImage d -> d
+  PalettedY8    i p -> ImageY8 $ toTrueColor 1 (_paletteData p) i
+  PalettedRGB8  i p -> ImageRGB8 $ toTrueColor 3 (_paletteData p) i
+  PalettedRGBA8 i p -> ImageRGBA8 $ toTrueColor 4 (_paletteData p) i
+  PalettedRGB16 i p -> ImageRGB16 $ toTrueColor 3 (_paletteData p) i
+  where 
+    toTrueColor c vec = pixelMap (unsafePixelAt vec . (c *) . fromIntegral)
 
 -- | Helper function to help extract information from dynamic
 -- image. To get the width of a dynamic image, you can use

@@ -1,45 +1,45 @@-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE CPP #-}
-module Codec.Picture.VectorByteConversion( blitVector
-                                         , toByteString
-                                         , imageFromUnsafePtr ) where
-
-import Data.Word( Word8 )
-import Data.Vector.Storable( Vector, unsafeToForeignPtr, unsafeFromForeignPtr0 )
-import Foreign.Storable( Storable, sizeOf )
-
-#if !MIN_VERSION_base(4,8,0)
-import Foreign.ForeignPtr.Safe( ForeignPtr, castForeignPtr )
-#else
-import Foreign.ForeignPtr( ForeignPtr, castForeignPtr )
-#endif
-
-
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Internal as S
-
-import Codec.Picture.Types
-
-blitVector :: Vector Word8 -> Int -> Int -> B.ByteString
-blitVector vec atIndex = S.PS ptr (offset + atIndex)
-  where (ptr, offset, _length) = unsafeToForeignPtr vec
-
-toByteString :: forall a. (Storable a) => Vector a -> B.ByteString
-toByteString vec = S.PS (castForeignPtr ptr) offset (len * size)
-  where (ptr, offset, len) = unsafeToForeignPtr vec
-        size = sizeOf (undefined :: a)
-
--- | Import a image from an unsafe pointer
--- The pointer must have a size of width * height * componentCount px
-imageFromUnsafePtr :: forall px
-                    . (Pixel px, (PixelBaseComponent px) ~ Word8)
-                   => Int -- ^ Width in pixels
-                   -> Int -- ^ Height in pixels
-                   -> ForeignPtr Word8 -- ^ Pointer to the raw data
-                   -> Image px
-imageFromUnsafePtr width height ptr =
-    Image width height $ unsafeFromForeignPtr0 ptr size
-      where compCount = componentCount (undefined :: px)
-            size = width * height * compCount
-
+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+module Codec.Picture.VectorByteConversion( blitVector+                                         , toByteString+                                         , imageFromUnsafePtr ) where++import Data.Word( Word8 )+import Data.Vector.Storable( Vector, unsafeToForeignPtr, unsafeFromForeignPtr0 )+import Foreign.Storable( Storable, sizeOf )++#if !MIN_VERSION_base(4,8,0)+import Foreign.ForeignPtr.Safe( ForeignPtr, castForeignPtr )+#else+import Foreign.ForeignPtr( ForeignPtr, castForeignPtr )+#endif+++import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as S++import Codec.Picture.Types++blitVector :: Vector Word8 -> Int -> Int -> B.ByteString+blitVector vec atIndex = S.PS ptr (offset + atIndex)+  where (ptr, offset, _length) = unsafeToForeignPtr vec++toByteString :: forall a. (Storable a) => Vector a -> B.ByteString+toByteString vec = S.PS (castForeignPtr ptr) offset (len * size)+  where (ptr, offset, len) = unsafeToForeignPtr vec+        size = sizeOf (undefined :: a)++-- | Import a image from an unsafe pointer+-- The pointer must have a size of width * height * componentCount px+imageFromUnsafePtr :: forall px+                    . (Pixel px, (PixelBaseComponent px) ~ Word8)+                   => Int -- ^ Width in pixels+                   -> Int -- ^ Height in pixels+                   -> ForeignPtr Word8 -- ^ Pointer to the raw data+                   -> Image px+imageFromUnsafePtr width height ptr =+    Image width height $ unsafeFromForeignPtr0 ptr size+      where compCount = componentCount (undefined :: px)+            size = width * height * compCount+