packages feed

JuicyPixels 2.0.2 → 3.3.9

raw patch · 51 files changed

Files

− Codec/Picture.hs 
@@ -1,164 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}
--- | Main module exporting import/export functions into various
--- image formats.
---
--- To use the library without thinking about it, look after 'decodeImage' and
--- 'readImage'.
---
--- Generally, the read* functions read the images from a file and try to decode
--- it, and the decode* functions try to decode a bytestring.
---
--- For an easy image writing use the 'saveBmpImage', 'saveJpgImage' & 'savePngImage'
--- functions
-module Codec.Picture ( 
-                     -- * Generic functions
-                       readImage
-                     , decodeImage
-                     , pixelMap
-                     , generateImage
-                     , generateFoldImage
-
-                     -- * Generic image writing
-                     , saveBmpImage
-                     , saveJpgImage 
-                     , savePngImage 
-
-                     -- * Specific image format functions
-                     -- ** Bitmap handling 
-                     , BmpEncodable
-                     , writeBitmap
-                     , encodeBitmap
-                     , readBitmap
-                     , decodeBitmap
-                     , encodeDynamicBitmap 
-                     , writeDynamicBitmap 
-
-                     -- ** Gif handling
-                     , readGif
-                     , readGifImages
-                     , decodeGif
-                     , decodeGifImages
-
-                     -- ** Jpeg handling
-                     , readJpeg
-                     , decodeJpeg 
-                     , encodeJpeg
-                     , encodeJpegAtQuality
-
-                     -- ** Png handling
-                     , PngSavable( .. )
-                     , readPng
-                     , decodePng
-                     , writePng
-                     , encodeDynamicPng
-                     , writeDynamicPng
-
-                     -- * Image types and pixel types
-                     -- ** Image
-                     , Image( .. )
-                     , DynamicImage( .. )
-                     -- ** Pixels
-                     , Pixel( .. )
-                     , Pixel8
-                     , PixelYA8( .. )
-                     , PixelRGB8( .. )
-                     , PixelRGBA8( .. )
-                     , PixelYCbCr8( .. )
-                     ) where
-
-import Control.Applicative( (<$>) )
-import Control.DeepSeq( NFData, deepseq )
-import qualified Control.Exception as Exc ( catch, IOException )
-import Codec.Picture.Bitmap( BmpEncodable, decodeBitmap
-                           , writeBitmap, encodeBitmap
-                           , encodeDynamicBitmap, writeDynamicBitmap )
-import Codec.Picture.Jpg( decodeJpeg, encodeJpeg, encodeJpegAtQuality )
-import Codec.Picture.Png( PngSavable( .. ), decodePng, writePng
-                        , encodeDynamicPng , writeDynamicPng )
-import Codec.Picture.Gif( decodeGif, decodeGifImages )
-import Codec.Picture.Saving
-import Codec.Picture.Types
-import System.IO ( withFile, IOMode(ReadMode) )
-
-
-import qualified Data.ByteString as B
-
--- | Return the first Right thing, accumulating error
-eitherLoad :: c -> [(String, c -> Either String b)] -> Either String b
-eitherLoad v = inner ""
-    where inner errAcc [] = Left $ "Cannot load file\n" ++ errAcc
-          inner errAcc ((hdr, f) : rest) = case f v of
-                Left  err  -> inner (errAcc ++ hdr ++ " " ++ err ++ "\n") rest
-                Right rez  -> Right rez
-
-withImageDecoder :: (NFData a)
-                 => (B.ByteString -> Either String a) -> FilePath
-                 -> IO (Either String a)
-withImageDecoder decoder path = Exc.catch doit
-                    (\e -> return . Left $ show (e :: Exc.IOException))
-    where doit = withFile path ReadMode $ \h ->
-                    force . decoder <$> B.hGetContents h
-          -- force appeared in deepseq 1.3, Haskell Platform
-          -- provide 1.1
-          force x = x `deepseq` x
-
--- | Load an image file without even thinking about it, it does everything
--- as 'decodeImage'
-readImage :: FilePath -> IO (Either String DynamicImage)
-readImage = withImageDecoder decodeImage 
-
--- | If you want to decode an image in a bytestring without even thinking
--- in term of format or whatever, this is the function to use. It will try
--- to decode in each known format and if one decoding succeed will return
--- the decoded image in it's own colorspace
-decodeImage :: B.ByteString -> Either String DynamicImage
-decodeImage str = eitherLoad str [("Jpeg", decodeJpeg)
-                                 ,("PNG", decodePng)
-                                 ,("GIF", decodeGif)
-                                 ,("Bitmap", decodeBitmap)
-                                 ]
-    
--- | Helper function trying to load a png file from a file on disk.
-readPng :: FilePath -> IO (Either String DynamicImage)
-readPng = withImageDecoder decodePng 
-
--- | Helper function trying to load a gif file from a file on disk.
-readGif :: FilePath -> IO (Either String DynamicImage)
-readGif = withImageDecoder decodeGif
-
--- | Helper function trying to load all the images of an animated
--- gif file.
-readGifImages :: FilePath -> IO (Either String [Image PixelRGB8])
-readGifImages = withImageDecoder decodeGifImages
-
--- | Try to load a jpeg file and decompress. The colorspace is still
--- YCbCr if you want to perform computation on the luma part. You can
--- convert it to RGB using 'colorSpaceConversion'
-readJpeg :: FilePath -> IO (Either String DynamicImage)
-readJpeg = withImageDecoder decodeJpeg
-
--- | Try to load a .bmp file. The colorspace would be RGB or RGBA
-readBitmap :: FilePath -> IO (Either String DynamicImage)
-readBitmap = withImageDecoder decodeBitmap
-
--- | Save an image to a '.jpg' file, will do everything it can to save an image.
-saveJpgImage :: Int -> String -> DynamicImage -> IO ()
-saveJpgImage quality path img = B.writeFile path $ imageToJpg quality img
-
--- | Save an image to a '.png' file, will do everything it can to save an image.
--- For example, a simple transcoder to png
---
--- > transcodeToPng :: FilePath -> FilePath -> IO ()
--- > transcodeToPng pathIn pathOut = do
--- >    eitherImg <- decodeImage pathIn
--- >    case eitherImg of
--- >        Left _ -> return ()
--- >        Right img -> savePngImage img
---
-savePngImage :: String -> DynamicImage -> IO ()
-savePngImage path img = B.writeFile path $ imageToPng img
-
--- | Save an image to a '.bmp' file, will do everything it can to save an image.
-saveBmpImage :: String -> DynamicImage -> IO ()
-saveBmpImage path img = B.writeFile path $ imageToBitmap img
-
− Codec/Picture/BitWriter.hs 
@@ -1,216 +0,0 @@-{-# LANGUAGE Rank2Types #-}
--- | This module implement helper functions to read & write data
--- at bits level.
-module Codec.Picture.BitWriter( BoolWriter
-                              , BoolReader
-                              , writeBits
-                              , byteAlignJpg
-                              , getNextBits
-                              , getNextBitJpg
-                              , setDecodedString
-                              , setDecodedStringJpg
-                              , pushByte
-                              , runBoolWriter
-                              , runBoolReader
-                              ) where
-
-import Control.Monad( when )
-import Control.Monad.ST( ST )
-import qualified Control.Monad.Trans.State.Strict as S
-import Control.Monad.Trans.Class( MonadTrans( .. ) )
-import Data.Word( Word8, Word32 )
-import Data.Bits( Bits, (.&.), (.|.), shiftR, shiftL )
-
-import qualified Data.Vector.Storable.Mutable as M
-import qualified Data.Vector.Storable as VS
-import qualified Data.ByteString as B
-
-{-# INLINE (.>>.) #-}
-{-# INLINE (.<<.) #-}
-(.<<.), (.>>.) :: (Bits a) => a -> Int -> a
-(.<<.) = shiftL
-(.>>.) = shiftR
-
-
---------------------------------------------------
-----            Reader
---------------------------------------------------
--- | Current bit index, current value, string
-type BoolState = (Int, Word8, B.ByteString)
-
--- | Type used to read bits
-type BoolReader s a = S.StateT BoolState (ST s) a
-
-runBoolReader :: BoolReader s a -> ST s a
-runBoolReader action = S.evalStateT action (0, 0, B.empty)
-
--- | Bitify a list of things to decode.
-setDecodedString :: B.ByteString -> BoolReader s ()
-setDecodedString str = case B.uncons str of
-     Nothing        -> S.put (      0, 0, B.empty)
-     Just (v, rest) -> S.put (       0, v,    rest)
-
--- | Drop all bit until the bit of indice 0, usefull to parse restart
--- marker, as they are byte aligned, but Huffman might not.
-byteAlignJpg :: BoolReader s ()
-byteAlignJpg = do
-  (idx, _, chain) <- S.get
-  when (idx /= 7) (setDecodedStringJpg chain)
-
-{-# INLINE getNextBitJpg #-}
-getNextBitJpg :: BoolReader s Bool
-getNextBitJpg = do
-    (idx, v, chain) <- S.get
-    let val = (v .&. (1 `shiftL` idx)) /= 0
-    if idx == 0
-      then setDecodedStringJpg chain
-      else S.put (idx - 1, v, chain)
-    return val
-
-{-# INLINE getNextBits #-}
-getNextBits :: Int -> BoolReader s Word32
-getNextBits count = aux 0 count
-  where aux acc 0 = return acc
-        aux acc n = do
-            bit <- getNextBit
-            let nextVal | bit = acc .|. (1 .<<. (count - n))
-                        | otherwise = acc
-            aux nextVal (n - 1)
-
-{-# INLINE getNextBit #-}
-getNextBit :: BoolReader s Bool
-getNextBit = do
-    (idx, v, chain) <- S.get
-    let val = (v .&. (1 `shiftL` idx)) /= 0
-    if idx == 7
-      then setDecodedString chain
-      else S.put (idx + 1, v, chain)
-    return val
-
--- | Bitify a list of things to decode. Handle Jpeg escape
--- code (0xFF 0x00), thus should be only used in JPEG decoding.
-setDecodedStringJpg :: B.ByteString -> BoolReader s ()
-setDecodedStringJpg str = case B.uncons str of
-     Nothing        -> S.put (maxBound, 0, B.empty)
-     Just (0xFF, rest) -> case B.uncons rest of
-            Nothing                  -> S.put (maxBound, 0, B.empty)
-            Just (0x00, afterMarker) -> S.put (7, 0xFF, afterMarker)
-            Just (_   , afterMarker) -> setDecodedStringJpg afterMarker
-     Just (v, rest) -> S.put (       7, v,    rest)
-
---------------------------------------------------
-----            Writer
---------------------------------------------------
-defaultBufferSize :: Int
-defaultBufferSize = 100 * 1024
-
--- | Run the writer and get the serialized data.
-runBoolWriter :: BoolWriter s b -> ST s B.ByteString
-runBoolWriter writer = do
-    origMv <- M.new defaultBufferSize
-    st <- S.execStateT (writer >> flushWriter) (BoolWriteState origMv [] 0 0 0)
-    st' <- forceBufferFlushing st
-    return . B.concat $ strings st'
-
--- | Current serializer, bit buffer, bit count
-data BoolWriteState s = BoolWriteState
-        { wordWrite    :: M.MVector s Word8
-        , strings      :: ![B.ByteString]
-        , writtenWords :: {-# UNPACK #-} !Int
-        , bitAcc       :: {-# UNPACK #-} !Word8
-        , bitReaded    :: {-# UNPACK #-} !Int
-        }
-
-type BoolWriter s a = S.StateT (BoolWriteState s) (ST s) a
-
-forceBufferFlushing :: BoolWriteState s -> ST s (BoolWriteState s)
-forceBufferFlushing st@(BoolWriteState { wordWrite = vec
-                                       , writtenWords = count
-                                       , strings = lst
-                                       }) = do
-    nmv <- M.new defaultBufferSize
-    str <- byteStringFromVector vec count
-    return $ st { wordWrite = nmv
-                , strings = lst ++ [str]
-                , writtenWords = 0
-                }
-
-flushCurrentBuffer :: BoolWriteState s -> ST s (BoolWriteState s)
-flushCurrentBuffer st | writtenWords st < M.length (wordWrite st) = return st
-flushCurrentBuffer st = forceBufferFlushing st
-
--- Data.Vector.Storable.Mutable
--- unsafeToForeignPtr0 :: Storable a => MVector s a -> (ForeignPtr a, Int)
---
--- Data.ByteString.Unsafe
--- unsafePackCStringFinalizer :: Ptr Word8 -> Int -> IO () -> IO ByteString
---
--- Data.Vector.Storable.Internal
--- getPtr :: ForeignPtr a -> Ptr a
-byteStringFromVector :: M.MVector s Word8 -> Int -> ST s B.ByteString
-byteStringFromVector vec size = do
-    frozen <- VS.unsafeFreeze vec
-    return . B.pack . take size $ VS.toList frozen
-
-setBitCount :: Word8 -> Int -> BoolWriter s ()
-setBitCount acc count = S.modify $ \s ->
-    s { bitAcc = acc, bitReaded = count }
-
-resetBitCount :: BoolWriter s ()
-resetBitCount = setBitCount 0 0
-
-pushByte :: Word8 -> BoolWriter s ()
-pushByte v = do
-    st <- S.get
-    st'@(BoolWriteState { writtenWords = idx })
-        <- lift $ flushCurrentBuffer st
-    lift $ M.write (wordWrite st') idx v
-    S.put $ st' { writtenWords = idx + 1 }
-
--- | If some bits are not serialized yet, write
--- them in the MSB of a word.
-flushWriter :: BoolWriter s ()
-flushWriter = do
-    st <- S.get
-    let count = bitReaded st
-    when (count > 0)
-         (do let newContext = st { bitAcc = 0, bitReaded = 0 }
-             S.put newContext
-             pushByte $ bitAcc st `shiftL` (8 - count))
-
--- | Append some data bits to a Put monad.
-writeBits :: Word32     -- ^ The real data to be stored. Actual data should be in the LSB
-          -> Int        -- ^ Number of bit to write from 1 to 32
-          -> BoolWriter s ()
-writeBits d c = do
-    currWord <- S.gets bitAcc
-    currCount <- S.gets bitReaded
-    serialize d c currWord currCount
-  where dumpByte 0xFF = pushByte 0xFF >> pushByte 0x00
-        dumpByte    i = pushByte i
-
-        serialize bitData bitCount currentWord count
-            | bitCount + count == 8 = do
-                     resetBitCount
-                     dumpByte (fromIntegral $ (currentWord .<<. bitCount) .|.
-                                                fromIntegral cleanData)
-
-            | bitCount + count < 8 =
-                let newVal = currentWord .<<. bitCount
-                in setBitCount (newVal .|. fromIntegral cleanData) $ count + bitCount
-
-            | otherwise =
-                let leftBitCount = 8 - count :: Int
-                    highPart = cleanData .>>. (bitCount - leftBitCount) :: Word32
-                    prevPart = fromIntegral currentWord .<<. leftBitCount :: Word32
-
-                    nextMask = (1 .<<. (bitCount - leftBitCount)) - 1 :: Word32
-                    newData = cleanData .&. nextMask :: Word32
-                    newCount = bitCount - leftBitCount :: Int
-
-                    toWrite = fromIntegral $ prevPart .|. highPart :: Word8
-                in resetBitCount >> dumpByte toWrite >> serialize newData newCount 0 0
-
-              where cleanMask = (1 `shiftL` bitCount) - 1 :: Word32
-                    cleanData = bitData .&. cleanMask     :: Word32
-
− Codec/Picture/Bitmap.hs 
@@ -1,318 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeSynonymInstances #-}
--- | Modules used for Bitmap file (.bmp) file loading and writing
-module Codec.Picture.Bitmap( -- * Functions
-                             writeBitmap
-                           , encodeBitmap
-                           , decodeBitmap
-                           , encodeDynamicBitmap 
-                           , writeDynamicBitmap 
-                             -- * Accepted formt in output
-                           , BmpEncodable( )
-                           ) where
-import Foreign.Storable ( Storable )
-import Control.Monad( when, forM_ )
-import Control.Monad.ST ( runST )
-import Control.Monad.Primitive ( PrimMonad, PrimState )
-import qualified Data.Vector.Storable as V
-import qualified Data.Vector.Storable.Mutable as M
-import Data.Serialize( Serialize( .. )
-                     , putWord16le, putWord32le
-                     , getWord16le, getWord32le
-                     , Get, Put, runGet, runPut
-                     , remaining, getBytes, putByteString )
-import Data.Word( Word32, Word16, Word8 )
-import qualified Data.ByteString as B
-
-import Codec.Picture.BitWriter
-import Codec.Picture.Types
-
-data BmpHeader = BmpHeader
-    { magicIdentifier :: !Word16
-    , fileSize        :: !Word32 -- ^ in bytes
-    , reserved1       :: !Word16
-    , reserved2       :: !Word16
-    , dataOffset      :: !Word32
-    }
-
-bitmapMagicIdentifier :: Word16
-bitmapMagicIdentifier = 0x4D42
-
-instance Serialize BmpHeader where
-    put hdr = do
-        putWord16le $ magicIdentifier hdr
-        putWord32le $ fileSize hdr
-        putWord16le $ reserved1 hdr
-        putWord16le $ reserved2 hdr
-        putWord32le $ dataOffset hdr
-
-    get = do
-        ident <- getWord16le
-        when (ident /= bitmapMagicIdentifier)
-             (fail "Invalid Bitmap magic identifier")
-        fsize <- getWord32le
-        r1 <- getWord16le
-        r2 <- getWord16le
-        offset <- getWord32le
-        return BmpHeader
-            { magicIdentifier = ident
-            , fileSize = fsize
-            , reserved1 = r1
-            , reserved2 = r2
-            , dataOffset = offset
-            }
-
-
-data BmpInfoHeader = BmpInfoHeader
-    { size              :: !Word32 -- Header size in bytes
-    , width             :: !Word32
-    , height            :: !Word32
-    , planes            :: !Word16 -- Number of colour planes
-    , bitPerPixel       :: !Word16
-    , bitmapCompression :: !Word32
-    , byteImageSize     :: !Word32
-    , xResolution       :: !Word32 -- ^ Pixels per meter
-    , yResolution       :: !Word32 -- ^ Pixels per meter
-    , colorCount        :: !Word32
-    , importantColours  :: !Word32
-    }
-
-sizeofBmpHeader, sizeofBmpInfo  :: Word32
-sizeofBmpHeader = 2 + 4 + 2 + 2 + 4
-sizeofBmpInfo = 3 * 4 + 2 * 2 + 6 * 4
-
-instance Serialize BmpInfoHeader where
-    put hdr = do
-        putWord32le $ size hdr
-        putWord32le $ width hdr
-        putWord32le $ height hdr
-        putWord16le $ planes hdr
-        putWord16le $ bitPerPixel hdr
-        putWord32le $ bitmapCompression hdr
-        putWord32le $ byteImageSize hdr
-        putWord32le $ xResolution hdr
-        putWord32le $ yResolution hdr
-        putWord32le $ colorCount hdr
-        putWord32le $ importantColours hdr
-
-    get = do
-        readSize <- getWord32le
-        readWidth <- getWord32le
-        readHeight <- getWord32le
-        readPlanes <- getWord16le
-        readBitPerPixel <- getWord16le
-        readBitmapCompression <- getWord32le
-        readByteImageSize <- getWord32le
-        readXResolution <- getWord32le
-        readYResolution <- getWord32le
-        readColorCount <- getWord32le
-        readImportantColours <- getWord32le
-        return BmpInfoHeader {
-            size = readSize,
-            width = readWidth,
-            height = readHeight,
-            planes = readPlanes,
-            bitPerPixel = readBitPerPixel,
-            bitmapCompression = readBitmapCompression,
-            byteImageSize = readByteImageSize,
-            xResolution = readXResolution,
-            yResolution = readYResolution,
-            colorCount = readColorCount,
-            importantColours = readImportantColours
-        }
-
-newtype BmpPalette = BmpPalette [(Word8, Word8, Word8, Word8)]
-
-putPalette :: BmpPalette -> Put
-putPalette (BmpPalette p) = mapM_ (\(r, g, b, a) -> put r >> put g >> put b >> put a) p
-
--- | All the instance of this class can be written as a bitmap file
--- using this library.
-class BmpEncodable pixel where
-    bitsPerPixel   :: pixel -> Int
-    bmpEncode      :: Image pixel -> Put
-    defaultPalette :: pixel -> BmpPalette
-    defaultPalette _ = BmpPalette []
-
-{-# INLINE (!!!) #-}
-(!!!) :: (Storable e) => V.Vector e -> Int -> e
-(!!!) = V.unsafeIndex
-
-{-# INLINE stridePut #-}
-stridePut :: Int -> BoolWriter s ()
-stridePut 0 = return ()
-stridePut 1 = pushByte 0
-stridePut n = pushByte 0 >> stridePut (n - 1)
-
-instance BmpEncodable Pixel8 where
-    defaultPalette _ = BmpPalette [(x,x,x, 255) | x <- [0 .. 255]]
-    bitsPerPixel _ = 8
-    bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = 
-      putByteString $ runST $ runBoolWriter . putLine $ h - 1
-        where stride = fromIntegral $ linePadding 8 w
-
-              putLine line | line < 0 = return ()
-              putLine line = do
-                  let lineIdx = line * w
-                      inner col | col >= w = return ()
-                                | otherwise = pushByte (arr !!! (lineIdx + col)) >> inner (col + 1)
-                  inner 0
-                  stridePut stride
-                  putLine (line - 1)
-
-instance BmpEncodable PixelRGBA8 where
-    bitsPerPixel _ = 32
-    bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = 
-        putByteString $ runST $ runBoolWriter . putLine $ h - 1
-      where putLine line | line < 0 = return ()
-            putLine line = do
-                let initialIndex = line * w * 4
-                    inner col _ | col >= w = return ()
-                    inner col readIdx = do
-                        pushByte (arr !!! (readIdx + 2))
-                        pushByte (arr !!! (readIdx + 1))
-                        pushByte (arr !!! readIdx)
-                        pushByte (arr !!! (readIdx + 3))
-                        inner (col + 1) (readIdx + 4)
-                inner 0 initialIndex
-                putLine (line - 1)
-
-instance BmpEncodable PixelRGB8 where
-    bitsPerPixel _ = 24
-    bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) =
-       putByteString $ runST $ runBoolWriter . putLine $ h - 1
-        where stride = fromIntegral . linePadding 24 $ w
-              putLine line | line < 0 = return ()
-              putLine line = do
-                  let initialIndex = line * w * 3
-                      inner col _ | col >= w = return ()
-                      inner col readIdx = do
-                          pushByte (arr !!! (readIdx + 2))
-                          pushByte (arr !!! (readIdx + 1))
-                          pushByte (arr !!! readIdx)
-                          inner (col + 1) (readIdx + 3)
-                  inner 0 initialIndex
-                  stridePut stride
-                  putLine (line - 1)
-
-{-# INLINE (.<-.) #-}
-(.<-.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> a -> m ()
-(.<-.) = M.unsafeWrite
-
-decodeImageRGB8 :: BmpInfoHeader -> B.ByteString -> Image PixelRGB8
-decodeImageRGB8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray
-  where wi = fromIntegral w
-        hi = fromIntegral h
-        stArray = runST $ do
-            arr <- M.replicate (fromIntegral $ w * h * 3) 128
-            forM_ [hi - 1, hi - 2 .. 0] (readLine arr)
-            V.unsafeFreeze arr
-
-        stride = linePadding 24 wi
-        readLine arr line =
-            let readIndex = (wi * 3 + stride) * line
-                lastIndex = wi * (hi - 1 - line + 1) * 3
-                writeIndex = wi * (hi - 1 - line) * 3
-
-                inner _ writeIdx | writeIdx >= lastIndex = return ()
-                inner readIdx writeIdx = do
-                    (arr .<-.  writeIdx     ) (str `B.index` (readIdx + 2))
-                    (arr .<-. (writeIdx + 1)) (str `B.index` (readIdx + 1))
-                    (arr .<-. (writeIdx + 2)) (str `B.index`  readIdx)
-                    inner (readIdx + 3) (writeIdx + 3)
-
-            in inner readIndex writeIndex
-
-
--- | Try to decode a bitmap image.
--- Right now this function can output the following pixel types :
---
---    * PixelRGB8
---
-decodeBitmap :: B.ByteString -> Either String DynamicImage
-decodeBitmap str = flip runGet str $ do
-  _hdr      <- get :: Get BmpHeader
-  bmpHeader <- get :: Get BmpInfoHeader
-  case (bitPerPixel bmpHeader, planes  bmpHeader,
-              bitmapCompression bmpHeader) of
-    -- (32, 1, 0) -> {- ImageRGBA8 <$>-} fail "Meuh"
-    (24, 1, 0) -> do
-        rest <- remaining >>= getBytes
-        return . ImageRGB8 $ decodeImageRGB8 bmpHeader rest
-    _          -> fail "Can't handle BMP file"
-
-
--- | Write an image in a file use the bitmap format.
-writeBitmap :: (BmpEncodable pixel)
-            => FilePath -> Image pixel -> IO ()
-writeBitmap filename img = B.writeFile filename $ encodeBitmap img
-
-linePadding :: Int -> Int -> Int
-linePadding bpp imgWidth = (4 - (bytesPerLine `mod` 4)) `mod` 4
-    where bytesPerLine = imgWidth * (fromIntegral bpp `div` 8)
-
--- | Encode an image into a bytestring in .bmp format ready to be written
--- on disk.
-encodeBitmap :: forall pixel. (BmpEncodable pixel) => Image pixel -> B.ByteString
-encodeBitmap = encodeBitmapWithPalette (defaultPalette (undefined :: pixel))
-
-
--- | Write a dynamic image in a .bmp image file if possible.
--- The same restriction as encodeDynamicBitmap apply.
-writeDynamicBitmap :: FilePath -> DynamicImage -> IO (Either String Bool)
-writeDynamicBitmap path img = case encodeDynamicBitmap img of
-        Left err -> return $ Left err
-        Right b  -> B.writeFile path b >> return (Right True)
-
--- | Encode a dynamic image in bmp if possible, supported pixel type are :
---
---   - RGB8
---
---   - RGBA8
---
---   - Y8
---
-encodeDynamicBitmap :: DynamicImage -> Either String B.ByteString
-encodeDynamicBitmap (ImageRGB8 img) = Right $ encodeBitmap img
-encodeDynamicBitmap (ImageRGBA8 img) = Right $ encodeBitmap img
-encodeDynamicBitmap (ImageY8 img) = Right $ encodeBitmap img
-encodeDynamicBitmap _ = Left "Unsupported image format for bitmap export"
-
-
--- | Convert an image to a bytestring ready to be serialized.
-encodeBitmapWithPalette :: forall pixel. (BmpEncodable pixel)
-                        => BmpPalette -> Image pixel -> B.ByteString
-encodeBitmapWithPalette pal@(BmpPalette palette) img =
-  runPut $ put hdr >> put info >> putPalette pal >> bmpEncode img
-    where imgWidth = fromIntegral $ imageWidth img
-          imgHeight = fromIntegral $ imageHeight img
-
-          paletteSize = fromIntegral $ length palette
-          bpp = bitsPerPixel (undefined :: pixel)
-          padding = linePadding bpp (imgWidth + 1)
-          imagePixelSize = fromIntegral $ (imgWidth + padding) * imgHeight * 4
-          hdr = BmpHeader {
-              magicIdentifier = bitmapMagicIdentifier,
-              fileSize = sizeofBmpHeader + sizeofBmpInfo + 4 * paletteSize + imagePixelSize,
-              reserved1 = 0,
-              reserved2 = 0,
-              dataOffset = sizeofBmpHeader + sizeofBmpInfo + 4 * paletteSize
-          }
-
-          info = BmpInfoHeader {
-              size = sizeofBmpInfo,
-              width = fromIntegral imgWidth,
-              height = fromIntegral imgHeight,
-              planes = 1,
-              bitPerPixel = fromIntegral bpp,
-              bitmapCompression = 0, -- no compression
-              byteImageSize = imagePixelSize,
-              xResolution = 0,
-              yResolution = 0,
-              colorCount = 0,
-              importantColours = paletteSize
-          }
-
-
− Codec/Picture/Gif.hs 
@@ -1,389 +0,0 @@--- | Module implementing GIF decoding.
-module Codec.Picture.Gif ( decodeGif
-                         , decodeGifImages
-                         ) where
-
-import Control.Applicative( pure, (<$>), (<*>) )
-import Control.Monad( replicateM )
-import Control.Monad.ST( runST )
-import Control.Monad.Trans.Class( lift )
-
-import Data.Bits( (.&.), shiftR, testBit )
-import Data.Word( Word8, Word16 )
-
-import qualified Data.ByteString as B
-import qualified Data.Vector.Storable as V
-import qualified Data.Vector.Storable.Mutable as M
-
-import Data.Serialize( Serialize(..)
-                     , Get
-                     , decode
-                     , getWord8
-                     , getWord16le
-                     , getBytes
-                     , lookAhead
-                     {-, decode-}
-                     , remaining
-
-                     {-, Put-}
-                     {-, putWord8-}
-                     {-, putWord16be-}
-                     {-, encode-}
-                     {-, putByteString -}
-                     )
-
-import Codec.Picture.Types
-import Codec.Picture.Gif.LZW
-import Codec.Picture.BitWriter
-
-{-
-   <GIF Data Stream> ::=     Header <Logical Screen> <Data>* Trailer
-
-   <Logical Screen> ::=      Logical Screen Descriptor [Global Color Table]
-
-   <Data> ::=                <Graphic Block>  |
-                             <Special-Purpose Block>
-
-   <Graphic Block> ::=       [Graphic Control Extension] <Graphic-Rendering Block>
-
-   <Graphic-Rendering Block> ::=  <Table-Based Image>  |
-                                  Plain Text Extension
-
-   <Table-Based Image> ::=   Image Descriptor [Local Color Table] Image Data
-
-   <Special-Purpose Block> ::=    Application Extension  |
-                                  Comment Extension
- -}
-
---------------------------------------------------
-----            GifVersion
---------------------------------------------------
-data GifVersion = GIF87a | GIF89a
-
-gif87aSignature, gif89aSignature :: B.ByteString
-gif87aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF87a"
-gif89aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF89a"
-
-instance Serialize GifVersion where
-    put GIF87a = put gif87aSignature
-    put GIF89a = put gif89aSignature
-
-    get = do
-        sig <- getBytes (B.length gif87aSignature)
-        case (sig == gif87aSignature, sig == gif89aSignature) of
-            (True, _)  -> pure GIF87a
-            (_ , True) -> pure GIF89a
-            _          -> fail "Invalid Gif signature"
-
-
---------------------------------------------------
-----         LogicalScreenDescriptor
---------------------------------------------------
--- | Section 18 of spec-gif89a
-data LogicalScreenDescriptor = LogicalScreenDescriptor
-  { -- | Stored on 16 bits
-    screenWidth           :: !Word16
-    -- | Stored on 16 bits
-  , screenHeight          :: !Word16
-    -- | Stored on 8 bits
-  , backgroundIndex       :: !Word8
-
-  -- | Stored on 1 bit
-  , hasGlobalMap          :: !Bool
-  -- | Stored on 3 bits
-  , colorResolution       :: !Word8
-  -- | Stored on 1 bit
-  , isColorTableSorted    :: !Bool
-  -- | Stored on 3 bits
-  , colorTableSize        :: !Word8
-  }
-
-instance Serialize LogicalScreenDescriptor where
-    put _ = undefined
-    get = do
-        w <- getWord16le
-        h <- getWord16le
-        packedField  <- getWord8
-        backgroundColorIndex  <- getWord8
-        _aspectRatio  <- getWord8
-        return LogicalScreenDescriptor
-            { screenWidth           = w
-            , screenHeight          = h
-            , hasGlobalMap          = packedField `testBit` 7
-            , colorResolution       = (packedField `shiftR` 5) .&. 0x7 + 1
-            , isColorTableSorted    = packedField `testBit` 3
-            , colorTableSize        = (packedField .&. 0x7) + 1
-            , backgroundIndex       = backgroundColorIndex
-            }
-
-
---------------------------------------------------
-----            ImageDescriptor
---------------------------------------------------
--- | Section 20 of spec-gif89a
-data ImageDescriptor = ImageDescriptor
-  { gDescPixelsFromLeft         :: !Word16
-  , gDescPixelsFromTop          :: !Word16
-  , gDescImageWidth             :: !Word16
-  , gDescImageHeight            :: !Word16
-  , gDescHasLocalMap            :: !Bool
-  , gDescIsInterlaced           :: !Bool
-  , gDescIsImgDescriptorSorted  :: !Bool
-  , gDescLocalColorTableSize    :: !Word8
-  }
-
-imageSeparator, extensionIntroducer, gifTrailer :: Word8
-imageSeparator      = 0x2C
-extensionIntroducer = 0x21
-gifTrailer          = 0x3B
-
-graphicControlLabel :: Word8
-graphicControlLabel = 0xF9
-
---commentLabel, graphicControlLabel, applicationLabel
---
-{-commentLabel        = 0xFE-}
-{-plainTextLabel      = 0x01-}
-{-applicationLabel    = 0xFF-}
-
-parseDataBlocks :: Get B.ByteString
-parseDataBlocks = B.concat <$> (getWord8 >>= aux)
- where aux    0 = pure []
-       aux size = (:) <$> getBytes (fromIntegral size) <*> (getWord8 >>= aux)
-
-data GraphicControlExtension = GraphicControlExtension
-    { gceDisposalMethod        :: !Word8 -- ^ Stored on 3 bits
-    , gceUserInputFlag         :: !Bool
-    , gceTransparentFlag       :: !Bool
-    , gceDelay                 :: !Word16
-    , gceTransparentColorIndex :: !Word8
-    }
-
-instance Serialize GraphicControlExtension where
-    put _ = undefined
-    get = do
-        _extensionLabel  <- getWord8
-        _size            <- getWord8
-        packedFields     <- getWord8
-        delay            <- getWord16le
-        idx              <- getWord8
-        _blockTerminator <- getWord8
-        return GraphicControlExtension
-            { gceDisposalMethod        = (packedFields `shiftR` 2) .&. 0x07
-            , gceUserInputFlag         = packedFields `testBit` 1
-            , gceTransparentFlag       = packedFields `testBit` 0
-            , gceDelay                 = delay
-            , gceTransparentColorIndex = idx
-            }
-
-data GifImage = GifImage
-    { imgDescriptor   :: !ImageDescriptor
-    , imgLocalPalette :: !(Maybe Palette)
-    , imgLzwRootSize  :: !Word8
-    , imgData         :: B.ByteString
-    }
-
-instance Serialize GifImage where
-    put _ = undefined
-    get = do
-        desc <- get
-        let hasLocalColorTable = gDescHasLocalMap desc
-        palette <- if hasLocalColorTable
-           then Just <$> getPalette (gDescLocalColorTableSize desc)
-           else pure Nothing
-
-        GifImage desc palette <$> getWord8 <*> parseDataBlocks
-
-data Block = BlockImage GifImage
-           | BlockGraphicControl GraphicControlExtension
-
-parseGifBlocks :: Get [Block]
-parseGifBlocks = lookAhead getWord8 >>= blockParse
-  where blockParse v
-          | v == gifTrailer = getWord8 >> pure []
-          | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks
-          | v == extensionIntroducer = do
-                _ <- getWord8
-                extensionCode <- lookAhead getWord8
-                if extensionCode /= graphicControlLabel
-                   then getWord8 >> parseDataBlocks >> parseGifBlocks
-                   else (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks
-
-        blockParse v = do
-            remain <- remaining
-            fail ("Unrecognized gif block " ++ show v ++ " remaining: " ++ show remain)
-
-instance Serialize ImageDescriptor where
-    put _ = undefined
-    get = do
-        _imageSeparator <- getWord8
-        imgLeftPos <- getWord16le
-        imgTopPos  <- getWord16le
-        imgWidth   <- getWord16le
-        imgHeight  <- getWord16le
-        packedFields <- getWord8
-        let tableSize = packedFields .&. 0x7
-        return ImageDescriptor
-            { gDescPixelsFromLeft = imgLeftPos
-            , gDescPixelsFromTop  = imgTopPos
-            , gDescImageWidth     = imgWidth
-            , gDescImageHeight    = imgHeight
-            , gDescHasLocalMap    = packedFields `testBit` 7
-            , gDescIsInterlaced     = packedFields `testBit` 6
-            , gDescIsImgDescriptorSorted = packedFields `testBit` 5
-            , gDescLocalColorTableSize = if tableSize > 0 then tableSize + 1 else 0
-            }
-
-
---------------------------------------------------
-----            Palette
---------------------------------------------------
-type Palette = V.Vector PixelRGB8
-
-getPalette :: Word8 -> Get Palette
-getPalette bitDepth = replicateM size get >>= return . V.fromList
-  where size = 2 ^ (fromIntegral bitDepth :: Int)
-
---------------------------------------------------
-----            GifImage
---------------------------------------------------
-data GifHeader = GifHeader
-  { gifVersion          :: GifVersion
-  , gifScreenDescriptor :: LogicalScreenDescriptor
-  , gifGlobalMap        :: !Palette
-  }
-
-instance Serialize GifHeader where
-    put _ = undefined
-    get = do
-        version    <- get
-        screenDesc <- get
-        palette    <- getPalette $ colorTableSize screenDesc
-        return GifHeader
-            { gifVersion = version
-            , gifScreenDescriptor = screenDesc
-            , gifGlobalMap = palette
-            }
-
-data GifFile = GifFile
-    { gifHeader  :: !GifHeader
-    , gifImages  :: [(Maybe GraphicControlExtension, GifImage)]
-    }
-
-associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)]
-associateDescr [] = []
-associateDescr [BlockGraphicControl _] = []
-associateDescr (BlockGraphicControl _ : rest@(BlockGraphicControl _ : _)) = associateDescr rest
-associateDescr (BlockImage img:xs) = (Nothing, img) : associateDescr xs
-associateDescr (BlockGraphicControl ctrl : BlockImage img : xs) =
-    (Just ctrl, img) : associateDescr xs
-
-instance Serialize GifFile where
-    put _ = undefined
-    get = do
-        hdr <- get
-        blocks <- parseGifBlocks
-        return GifFile { gifHeader = hdr
-                       , gifImages = associateDescr blocks }
-
-substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8
-substituteColors palette = pixelMap swaper
-  where swaper n = palette V.! (fromIntegral n)
-
-decodeImage :: GifImage -> Image Pixel8
-decodeImage img = runST $ runBoolReader $ do
-    outputVector <- lift . M.new $ width * height
-    decodeLzw (imgData img) 12 lzwRoot outputVector
-    frozenData <- lift $ V.unsafeFreeze outputVector
-    return . deinterlaceGif $ Image
-      { imageWidth = width
-      , imageHeight = height
-      , imageData = frozenData
-      }
-  where lzwRoot = fromIntegral $ imgLzwRootSize img
-        width = fromIntegral $ gDescImageWidth descriptor
-        height = fromIntegral $ gDescImageHeight descriptor
-        isInterlaced = gDescIsInterlaced descriptor
-        descriptor = imgDescriptor img
-
-        deinterlaceGif | not isInterlaced = id
-                       | otherwise = deinterlaceGifImage
-
-deinterlaceGifImage :: Image Pixel8 -> Image Pixel8
-deinterlaceGifImage img@(Image { imageWidth = w, imageHeight = h }) = generateImage generator w h
-   where lineIndices = gifInterlacingIndices h
-         generator x y = pixelAt img x y'
-            where y' = lineIndices V.! y
-
-gifInterlacingIndices :: Int -> V.Vector Int
-gifInterlacingIndices height = V.accum (\_ v -> v) (V.replicate height 0) indices
-    where indices = flip zip [0..] $
-                concat [ [0,     8 .. height - 1]
-                       , [4, 4 + 8 .. height - 1]
-                       , [2, 2 + 4 .. height - 1]
-                       , [1, 1 + 2 .. height - 1]
-                       ]
-
-paletteOf :: Palette -> GifImage -> Palette
-paletteOf global GifImage { imgLocalPalette = Nothing } = global
-paletteOf      _ GifImage { imgLocalPalette = Just p  } = p
-
-decodeAllGifImages :: GifFile -> [Image PixelRGB8]
-decodeAllGifImages GifFile { gifImages = [] } = []
-decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette
-                                                   , gifScreenDescriptor = wholeDescriptor
-                                                   }
-                           , gifImages = (_, firstImage) : rest } = map paletteApplyer $
- scanl generator (paletteOf palette firstImage, decodeImage firstImage) rest
-    where globalWidth = fromIntegral $ screenWidth wholeDescriptor
-          globalHeight = fromIntegral $ screenHeight wholeDescriptor
-
-          {-background = backgroundIndex wholeDescriptor-}
-
-          paletteApplyer (pal, img) = substituteColors pal img
-
-          generator (_, img1) (controlExt, img2@(GifImage { imgDescriptor = descriptor })) =
-                        (paletteOf palette img2, generateImage pixeler globalWidth globalHeight)
-               where localWidth = fromIntegral $ gDescImageWidth descriptor
-                     localHeight = fromIntegral $ gDescImageHeight descriptor
-
-                     left = fromIntegral $ gDescPixelsFromLeft descriptor
-                     top = fromIntegral $ gDescPixelsFromTop descriptor
-
-                     isPixelInLocalImage x y =
-                         x >= left && x < left + localWidth && y >= top && y < top + localHeight
-
-                     decoded = decodeImage img2
-
-                     transparent :: Int
-                     transparent = case controlExt of
-                        Nothing  -> 300
-                        Just ext -> if gceTransparentFlag ext
-                            then fromIntegral $ gceTransparentColorIndex ext
-                            else 300
-
-                     pixeler x y
-                        | isPixelInLocalImage x y && fromIntegral val /= transparent = val
-                            where val = pixelAt decoded (x - left) (y - top)
-                     pixeler x y = pixelAt img1 x y
-
-decodeFirstGifImage :: GifFile -> Either String (Image PixelRGB8)
-decodeFirstGifImage
-        GifFile { gifHeader = GifHeader { gifGlobalMap = palette}
-                , gifImages = ((_, gif):_) } = Right . substituteColors palette $ decodeImage gif
-decodeFirstGifImage _ = Left "No image in gif file"
-
--- | Transform a raw gif image to an image, witout
--- modifying the pixels.
--- This function can output the following pixel types :
---
---  * PixelRGB8
---
-decodeGif :: B.ByteString -> Either String DynamicImage
-decodeGif img = ImageRGB8 <$> (decode img >>= decodeFirstGifImage)
-
--- | Transform a raw gif to a list of images, representing
--- all the images of an animation.
-decodeGifImages :: B.ByteString -> Either String [Image PixelRGB8]
-decodeGifImages img = decodeAllGifImages <$> decode img
-
− Codec/Picture/Gif/LZW.hs 
@@ -1,125 +0,0 @@-module Codec.Picture.Gif.LZW( decodeLzw, lzw ) where
-
-import Data.Word( Word8 )
-import Control.Applicative( (<$>) )
-import Control.Monad( when )
-
-{-import Control.Monad.ST( ST )-}
-import Control.Monad.Trans.Class( MonadTrans, lift )
-import Control.Monad.Primitive ( PrimState, PrimMonad )
-
-import Foreign.Storable ( Storable )
-
-import qualified Data.ByteString as B
-import qualified Data.Vector.Storable.Mutable as M
-
-import Codec.Picture.BitWriter
-
-{-# INLINE (.!!!.) #-}
-(.!!!.) :: (PrimMonad m, Storable a)
-        => M.STVector (PrimState m) a -> Int -> m a
-(.!!!.) = M.unsafeRead -- M.read
-
-{-# INLINE (..!!!..) #-}
-(..!!!..) :: (MonadTrans t, PrimMonad m, Storable a)
-        => M.STVector (PrimState m) a -> Int -> t m a
-(..!!!..) v idx = lift $ v .!!!. idx
-
-{-# INLINE (.<-.) #-}
-(.<-.) :: (PrimMonad m, Storable a)
-       => M.STVector (PrimState m) a -> Int -> a -> m ()
-(.<-.) = M.unsafeWrite -- M.write
-
-{-# INLINE (..<-..) #-}
-(..<-..) :: (MonadTrans t, PrimMonad m, Storable a)
-         => M.STVector (PrimState m) a -> Int -> a -> t m ()
-(..<-..) v idx = lift . (v .<-. idx)
-
-
-duplicateData :: (MonadTrans t, PrimMonad m, Storable a)
-              => M.STVector (PrimState m) a -> M.STVector (PrimState m) a
-              -> Int -> Int -> Int -> t m ()
-duplicateData src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex
-  where endIndex = sourceIndex + size
-        aux i _ | i == endIndex  = return ()
-        aux i j = do
-          src .!!!. i >>= (dest .<-. j)
-          aux (i + 1) (j + 1)
-
-rangeSetter :: (PrimMonad m, Storable a, Num a)
-            => Int -> M.STVector (PrimState m) a
-            -> m (M.STVector (PrimState m) a)
-rangeSetter count vec = aux 0
-  where aux n | n == count = return vec
-        aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1)
-
-decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8
-          -> BoolReader s ()
-decodeLzw str maxBitKey initialKey outVec = do
-    setDecodedString str
-    lzw maxBitKey initialKey outVec
-
--- | Gif image constraint from spec-gif89a, code size max : 12 bits.
-lzw :: Int -> Int -> M.STVector s Word8
-    -> BoolReader s ()
-lzw nMaxBitKeySize initialKeySize outVec = do
-    -- Allocate buffer of maximum size.
-    lzwData <- lift (M.new maxDataSize) >>= resetArray
-    lzwOffsetTable <- lift (M.new tableEntryCount) >>= resetArray
-    lzwSizeTable <- lift $ M.new tableEntryCount
-    lift $ lzwSizeTable `M.set` 1
-
-    let maxWrite = M.length outVec
-        loop outWriteIdx writeIdx dicWriteIdx codeSize code
-          | outWriteIdx >= maxWrite = return ()
-          | code == endOfInfo = return ()
-          | code == clearCode =
-              getNextCode startCodeSize >>=
-                loop outWriteIdx firstFreeIndex firstFreeIndex startCodeSize
-
-          | otherwise = do
-              dataOffset <- lzwOffsetTable ..!!!.. code
-              dataSize <- lzwSizeTable  ..!!!.. code
-
-              when (writeIdx < tableEntryCount) $ do
-                  when (outWriteIdx /= 0) $ do
-                     firstVal <- lzwData ..!!!.. dataOffset
-                     (lzwData ..<-.. (dicWriteIdx - 1)) firstVal
-
-                  when (dicWriteIdx + dataSize <= maxDataSize) $
-                       duplicateData lzwData lzwData dataOffset dataSize dicWriteIdx
-
-
-                  (lzwSizeTable ..<-.. writeIdx) $ dataSize + 1
-                  (lzwOffsetTable ..<-.. writeIdx) dicWriteIdx
-
-              when (outWriteIdx + dataSize <= maxWrite) $
-                   duplicateData lzwData outVec dataOffset dataSize outWriteIdx
-
-              getNextCode codeSize >>=
-                loop (outWriteIdx + dataSize)
-                     (writeIdx + 1)
-                     (dicWriteIdx + dataSize + 1) (updateCodeSize codeSize $ writeIdx + 1)
-
-    getNextCode startCodeSize >>=
-        loop 0 firstFreeIndex firstFreeIndex startCodeSize
-
-  where tableEntryCount =  2 ^ min 12 nMaxBitKeySize
-        maxDataSize = tableEntryCount `div` 2 * (1 + tableEntryCount)
-
-        initialElementCount = 2 ^ initialKeySize :: Int
-        clearCode = initialElementCount
-        endOfInfo = clearCode + 1
-        startCodeSize = initialKeySize + 1
-
-        firstFreeIndex = endOfInfo + 1
-
-        resetArray a = lift $ rangeSetter initialElementCount a
-
-        updateCodeSize codeSize writeIdx
-            | writeIdx == 2 ^ codeSize = min 12 $ codeSize + 1
-            | otherwise = codeSize
-
-        getNextCode s = fromIntegral <$> getNextBits s
-
-
− Codec/Picture/Jpg.hs 
@@ -1,1088 +0,0 @@-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# OPTIONS_GHC -fspec-constr-count=5 #-}
--- | Module used for JPEG file loading and writing.
-module Codec.Picture.Jpg( decodeJpeg, encodeJpegAtQuality, encodeJpeg ) where
-
-import Control.Arrow( (>>>) )
-import Control.Applicative( (<$>), (<*>))
-import Control.Monad( when, replicateM, forM, forM_, foldM_, unless )
-import Control.Monad.ST( ST, runST )
-import Control.Monad.Trans( lift )
-import qualified Control.Monad.Trans.State.Strict as S
-
-import Data.List( find, foldl' )
-import Data.Bits( (.|.), (.&.), shiftL, shiftR )
-import Data.Int( Int16, Int32 )
-import Data.Word(Word8, Word16, Word32)
-import Data.Serialize( Serialize(..), Get, Put
-                     , getWord8, putWord8
-                     , getWord16be, putWord16be
-                     , remaining, lookAhead, skip
-                     , getBytes, decode
-                     , encode, putByteString 
-                     )
-import Data.Maybe( fromJust )
-import qualified Data.Vector as V
-import Data.Vector.Unboxed( (!) )
-import qualified Data.Vector.Unboxed as VU
-import qualified Data.Vector.Storable as VS
-import qualified Data.Vector.Storable.Mutable as M
--- import Data.Array.Unboxed( Array, UArray, elems, listArray, (!) )
-import qualified Data.ByteString as B
-import Foreign.Storable ( Storable )
-
-import Codec.Picture.BitWriter
-import Codec.Picture.Types
-import Codec.Picture.Jpg.Types
-import Codec.Picture.Jpg.DefaultTable
-import Codec.Picture.Jpg.FastIdct
-import Codec.Picture.Jpg.FastDct
-
---------------------------------------------------
-----            Types
---------------------------------------------------
-data JpgFrameKind =
-      JpgBaselineDCTHuffman
-    | JpgExtendedSequentialDCTHuffman
-    | JpgProgressiveDCTHuffman
-    | JpgLosslessHuffman
-    | JpgDifferentialSequentialDCTHuffman
-    | JpgDifferentialProgressiveDCTHuffman
-    | JpgDifferentialLosslessHuffman
-    | JpgExtendedSequentialArithmetic
-    | JpgProgressiveDCTArithmetic
-    | JpgLosslessArithmetic
-    | JpgDifferentialSequentialDCTArithmetic
-    | JpgDifferentialProgressiveDCTArithmetic
-    | JpgDifferentialLosslessArithmetic
-    | JpgQuantizationTable
-    | JpgHuffmanTableMarker
-    | JpgStartOfScan
-    | JpgAppSegment Word8
-    | JpgExtensionSegment Word8
-
-    | JpgRestartInterval
-    deriving (Eq, Show)
-
-
-data JpgFrame =
-      JpgAppFrame        !Word8 B.ByteString
-    | JpgExtension       !Word8 B.ByteString
-    | JpgQuantTable      ![JpgQuantTableSpec]
-    | JpgHuffmanTable    ![(JpgHuffmanTableSpec, HuffmanTree)]
-    | JpgScanBlob        !JpgScanHeader !B.ByteString
-    | JpgScans           !JpgFrameKind !JpgFrameHeader
-    | JpgIntervalRestart !Word16
-    deriving Show
-
-data JpgFrameHeader = JpgFrameHeader
-    { jpgFrameHeaderLength   :: !Word16
-    , jpgSamplePrecision     :: !Word8
-    , jpgHeight              :: !Word16
-    , jpgWidth               :: !Word16
-    , jpgImageComponentCount :: !Word8
-    , jpgComponents          :: ![JpgComponent]
-    }
-    deriving Show
-
-instance SizeCalculable JpgFrameHeader where
-    calculateSize hdr = 2 + 1 + 2 + 2 + 1 
-                      + sum [calculateSize c | c <- jpgComponents hdr]
-
-data JpgComponent = JpgComponent
-    { componentIdentifier       :: !Word8
-      -- | Stored with 4 bits
-    , horizontalSamplingFactor  :: !Word8
-      -- | Stored with 4 bits
-    , verticalSamplingFactor    :: !Word8
-    , quantizationTableDest     :: !Word8
-    }
-    deriving Show
-
-instance SizeCalculable JpgComponent where
-    calculateSize _ = 3
-
-data JpgImage = JpgImage { jpgFrame :: [JpgFrame]}
-    deriving Show
-
-data JpgScanSpecification = JpgScanSpecification
-    { componentSelector :: !Word8
-      -- | Encoded as 4 bits
-    , dcEntropyCodingTable :: !Word8
-      -- | Encoded as 4 bits
-    , acEntropyCodingTable :: !Word8
-
-    }
-    deriving Show
-
-instance SizeCalculable JpgScanSpecification where
-    calculateSize _ = 2
-
-data JpgScanHeader = JpgScanHeader
-    { scanLength :: !Word16
-    , scanComponentCount :: !Word8
-    , scans :: [JpgScanSpecification]
-
-      -- | (begin, end)
-    , spectralSelection    :: (Word8, Word8)
-
-      -- | Encoded as 4 bits
-    , successiveApproxHigh :: !Word8
-
-      -- | Encoded as 4 bits
-    , successiveApproxLow :: !Word8
-    }
-    deriving Show
-
-instance SizeCalculable JpgScanHeader where
-    calculateSize hdr = 2 + 1
-                      + sum [calculateSize c | c <- scans hdr]
-                      + 2
-                      + 1
-    
-data JpgQuantTableSpec = JpgQuantTableSpec
-    { -- | Stored on 4 bits
-      quantPrecision     :: !Word8
-
-      -- | Stored on 4 bits
-    , quantDestination   :: !Word8
-
-    , quantTable         :: MacroBlock Int16
-    }
-    deriving Show
-
--- | Type introduced only to avoid some typeclass overlapping
--- problem
-newtype TableList a = TableList [a]
-
-class SizeCalculable a where
-    calculateSize :: a -> Int
-
-instance (SizeCalculable a, Serialize a) => Serialize (TableList a) where
-    put (TableList lst) = do
-        putWord16be . fromIntegral $ sum [calculateSize table | table <- lst] + 2
-        mapM_ put lst
-
-    get = TableList <$> (getWord16be >>= \s -> innerParse (fromIntegral s - 2))
-      where innerParse :: Int -> Get [a]
-            innerParse 0    = return []
-            innerParse size = do
-                onStart <- fromIntegral <$> remaining
-                table <- get
-                onEnd <- fromIntegral <$> remaining
-                (table :) <$> innerParse (size - (onStart - onEnd))
-
-instance SizeCalculable JpgQuantTableSpec where
-    calculateSize table =
-        1 + (fromIntegral (quantPrecision table) + 1) * 64
-
-instance Serialize JpgQuantTableSpec where
-    put table = do
-        let precision = quantPrecision table
-        put4BitsOfEach precision (quantDestination table)
-        forM_ (VS.toList $ quantTable table) $ \coeff ->
-            if precision == 0 then putWord8 $ fromIntegral coeff
-                             else putWord16be $ fromIntegral coeff
-
-    get = do
-        (precision, dest) <- get4BitOfEach
-        coeffs <- replicateM 64 $ if precision == 0
-                then fromIntegral <$> getWord8
-                else fromIntegral <$> getWord16be
-        return JpgQuantTableSpec
-            { quantPrecision = precision
-            , quantDestination = dest
-            , quantTable = VS.fromListN 64 coeffs
-            }
-
-data JpgHuffmanTableSpec = JpgHuffmanTableSpec
-    { -- | 0 : DC, 1 : AC, stored on 4 bits
-      huffmanTableClass       :: !DctComponent
-      -- | Stored on 4 bits
-    , huffmanTableDest        :: !Word8
-
-    , huffSizes :: !(VU.Vector Word8)
-    , huffCodes :: !(V.Vector (VU.Vector Word8))
-    }
-    deriving Show
-
-buildPackedHuffmanTree :: V.Vector (VU.Vector Word8) -> HuffmanTree
-buildPackedHuffmanTree = buildHuffmanTree . map VU.toList . V.toList
-
--- | Decode a list of huffman values, not optimized for speed, but it
--- should work.
-huffmanDecode :: HuffmanTree -> BoolReader s Word8
-huffmanDecode originalTree = getNextBitJpg >>= huffDecode originalTree
-  where huffDecode Empty                   _ = return 0
-        huffDecode (Branch (Leaf v) _) False = return v
-        huffDecode (Branch l       _ ) False = getNextBitJpg >>= huffDecode l
-        huffDecode (Branch _ (Leaf v)) True  = return v
-        huffDecode (Branch _       r ) True  = getNextBitJpg >>= huffDecode r
-        huffDecode (Leaf v) _ = return v
-
---------------------------------------------------
-----            Serialization instances
---------------------------------------------------
-commonMarkerFirstByte :: Word8
-commonMarkerFirstByte = 0xFF
-
-checkMarker :: Word8 -> Word8 -> Get ()
-checkMarker b1 b2 = do
-    rb1 <- getWord8
-    rb2 <- getWord8
-    when (rb1 /= b1 || rb2 /= b2)
-         (fail "Invalid marker used")
-
-eatUntilCode :: Get ()
-eatUntilCode = do
-    code <- lookAhead getWord8
-    unless (code == 0xFF)
-           (skip 1 >> eatUntilCode)
-
-instance SizeCalculable JpgHuffmanTableSpec where
-    calculateSize table = 1 + 16 + sum [fromIntegral e | e <- VU.toList $ huffSizes table]
-
-instance Serialize JpgHuffmanTableSpec where
-    put table = do
-        let classVal = if huffmanTableClass table == DcComponent
-                          then 0 else 1
-        put4BitsOfEach classVal $ huffmanTableDest table
-        mapM_ put . VU.toList $ huffSizes table
-        forM_ [0 .. 15] $ \i ->
-            when (huffSizes table ! i /= 0)
-                 (let elements = VU.toList $ huffCodes table V.! i
-                  in mapM_ put elements)
-
-    get = do
-        (huffClass, huffDest) <- get4BitOfEach
-        sizes <- replicateM 16 getWord8
-        codes <- forM sizes $ \s ->
-            VU.replicateM (fromIntegral s) getWord8
-        return JpgHuffmanTableSpec
-            { huffmanTableClass =
-                if huffClass == 0 then DcComponent else AcComponent
-            , huffmanTableDest = huffDest
-            , huffSizes = VU.fromListN 16 sizes
-            , huffCodes = V.fromListN 16 codes
-            }
-
-instance Serialize JpgImage where
-    put (JpgImage { jpgFrame = frames }) =
-        putWord8 0xFF >> putWord8 0xD8 >> mapM_ putFrame frames
-            >> putWord8 0xFF >> putWord8 0xD9
-
-    get = do
-        let startOfImageMarker = 0xD8
-            -- endOfImageMarker = 0xD9
-        checkMarker commonMarkerFirstByte startOfImageMarker
-        eatUntilCode
-        frames <- parseFrames
-        {-checkMarker commonMarkerFirstByte endOfImageMarker-}
-        return JpgImage { jpgFrame = frames }
-
-takeCurrentFrame :: Get B.ByteString
-takeCurrentFrame = do
-    size <- getWord16be
-    getBytes (fromIntegral size - 2)
-
-putFrame :: JpgFrame -> Put
-putFrame (JpgAppFrame appCode str) =
-    put (JpgAppSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str
-putFrame (JpgExtension appCode str) =
-    put (JpgExtensionSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str
-putFrame (JpgQuantTable tables) =
-    put JpgQuantizationTable >> put (TableList tables)
-putFrame (JpgHuffmanTable tables) =
-    put JpgHuffmanTableMarker >> put (TableList $ map fst tables)
-putFrame (JpgIntervalRestart size) =
-    put JpgRestartInterval >> put (RestartInterval size)
-putFrame (JpgScanBlob hdr blob) =
-    put JpgStartOfScan >> put hdr >> putByteString blob
-putFrame (JpgScans kind hdr) =
-    put kind >> put hdr
-
-parseFrames :: Get [JpgFrame]
-parseFrames = do
-    kind <- get
-    case kind of
-        JpgAppSegment c ->
-            (\frm lst -> JpgAppFrame c frm : lst) <$> takeCurrentFrame <*> parseFrames
-        JpgExtensionSegment c ->
-            (\frm lst -> JpgExtension c frm : lst) <$> takeCurrentFrame <*> parseFrames
-        JpgQuantizationTable ->
-            (\(TableList quants) lst -> JpgQuantTable quants : lst) <$> get <*> parseFrames
-        JpgRestartInterval ->
-            (\(RestartInterval i) lst -> JpgIntervalRestart i : lst) <$> get <*> parseFrames
-        JpgHuffmanTableMarker ->
-            (\(TableList huffTables) lst ->
-                    JpgHuffmanTable [(t, buildPackedHuffmanTree $ huffCodes t) | t <- huffTables] : lst)
-                    <$> get <*> parseFrames
-        JpgStartOfScan ->
-            (\frm imgData -> [JpgScanBlob frm imgData])
-                            <$> get <*> (remaining >>= getBytes)
-
-        _ -> (\hdr lst -> JpgScans kind hdr : lst) <$> get <*> parseFrames
-
-secondStartOfFrameByteOfKind :: JpgFrameKind -> Word8
-secondStartOfFrameByteOfKind JpgBaselineDCTHuffman = 0xC0
-secondStartOfFrameByteOfKind JpgExtendedSequentialDCTHuffman = 0xC1
-secondStartOfFrameByteOfKind JpgProgressiveDCTHuffman = 0xC2
-secondStartOfFrameByteOfKind JpgLosslessHuffman = 0xC3
-secondStartOfFrameByteOfKind JpgDifferentialSequentialDCTHuffman = 0xC5
-secondStartOfFrameByteOfKind JpgDifferentialProgressiveDCTHuffman = 0xC6
-secondStartOfFrameByteOfKind JpgDifferentialLosslessHuffman = 0xC7
-secondStartOfFrameByteOfKind JpgExtendedSequentialArithmetic = 0xC9
-secondStartOfFrameByteOfKind JpgProgressiveDCTArithmetic = 0xCA
-secondStartOfFrameByteOfKind JpgLosslessArithmetic = 0xCB
-secondStartOfFrameByteOfKind JpgHuffmanTableMarker = 0xC4
-secondStartOfFrameByteOfKind JpgDifferentialSequentialDCTArithmetic = 0xCD
-secondStartOfFrameByteOfKind JpgDifferentialProgressiveDCTArithmetic = 0xCE
-secondStartOfFrameByteOfKind JpgDifferentialLosslessArithmetic = 0xCF
-secondStartOfFrameByteOfKind JpgQuantizationTable = 0xDB
-secondStartOfFrameByteOfKind JpgStartOfScan = 0xDA
-secondStartOfFrameByteOfKind JpgRestartInterval = 0xDD
-secondStartOfFrameByteOfKind (JpgAppSegment a) = a
-secondStartOfFrameByteOfKind (JpgExtensionSegment a) = a
-
-instance Serialize JpgFrameKind where
-    put v = putWord8 0xFF >> put (secondStartOfFrameByteOfKind v)
-    get = do
-        word <- getWord8
-        word2 <- getWord8
-        when (word /= 0xFF) (do leftData <- remaining
-                                fail $ "Invalid Frame marker (" ++ show word
-                                    ++ ", remaining : " ++ show leftData ++ ")")
-        return $ case word2 of
-            0xC0 -> JpgBaselineDCTHuffman
-            0xC1 -> JpgExtendedSequentialDCTHuffman
-            0xC2 -> JpgProgressiveDCTHuffman
-            0xC3 -> JpgLosslessHuffman
-            0xC4 -> JpgHuffmanTableMarker
-            0xC5 -> JpgDifferentialSequentialDCTHuffman
-            0xC6 -> JpgDifferentialProgressiveDCTHuffman
-            0xC7 -> JpgDifferentialLosslessHuffman
-            0xC9 -> JpgExtendedSequentialArithmetic
-            0xCA -> JpgProgressiveDCTArithmetic
-            0xCB -> JpgLosslessArithmetic
-            0xCD -> JpgDifferentialSequentialDCTArithmetic
-            0xCE -> JpgDifferentialProgressiveDCTArithmetic
-            0xCF -> JpgDifferentialLosslessArithmetic
-            0xDA -> JpgStartOfScan
-            0xDB -> JpgQuantizationTable
-            0xDD -> JpgRestartInterval
-            a | a >= 0xF0 -> JpgExtensionSegment a
-              | a >= 0xE0 -> JpgAppSegment a
-              | otherwise -> error ("Invalid frame marker (" ++ show a ++ ")")
-
-put4BitsOfEach :: Word8 -> Word8 -> Put
-put4BitsOfEach a b = put $ (a `shiftL` 4) .|. b
-
-get4BitOfEach :: Get (Word8, Word8)
-get4BitOfEach = do
-    val <- get
-    return ((val `shiftR` 4) .&. 0xF, val .&. 0xF)
-
-newtype RestartInterval = RestartInterval Word16
-
-instance Serialize RestartInterval where
-    put (RestartInterval i) = putWord16be 4 >> putWord16be i
-    get = do
-        size <- getWord16be
-        when (size /= 4) (fail "Invalid jpeg restart interval size")
-        RestartInterval <$> getWord16be
-
-instance Serialize JpgComponent where
-    get = do
-        ident <- getWord8
-        (horiz, vert) <- get4BitOfEach
-        quantTableIndex <- getWord8
-        return JpgComponent
-            { componentIdentifier = ident
-            , horizontalSamplingFactor = horiz
-            , verticalSamplingFactor = vert
-            , quantizationTableDest = quantTableIndex
-            }
-    put v = do
-        put $ componentIdentifier v
-        put4BitsOfEach (horizontalSamplingFactor v) $ verticalSamplingFactor v
-        put $ quantizationTableDest v
-
-instance Serialize JpgFrameHeader where
-    get = do
-        beginOffset <- remaining
-        frmHLength <- getWord16be
-        samplePrec <- getWord8
-        h <- getWord16be
-        w <- getWord16be
-        compCount <- getWord8
-        components <- replicateM (fromIntegral compCount) get
-        endOffset <- remaining
-        when (beginOffset - endOffset < fromIntegral frmHLength)
-             (skip $ fromIntegral frmHLength - (beginOffset - endOffset))
-        return JpgFrameHeader
-            { jpgFrameHeaderLength = frmHLength
-            , jpgSamplePrecision = samplePrec
-            , jpgHeight = h
-            , jpgWidth = w
-            , jpgImageComponentCount = compCount
-            , jpgComponents = components
-            }
-
-    put v = do
-        putWord16be $ jpgFrameHeaderLength v
-        putWord8    $ jpgSamplePrecision v
-        putWord16be $ jpgHeight v
-        putWord16be $ jpgWidth v
-        putWord8    $ jpgImageComponentCount v
-        mapM_ put   $ jpgComponents v
-
-instance Serialize JpgScanSpecification where
-    put v = do
-        put $ componentSelector v
-        put4BitsOfEach (dcEntropyCodingTable v) $ acEntropyCodingTable v
-
-    get = do
-        compSel <- get
-        (dc, ac) <- get4BitOfEach
-        return JpgScanSpecification {
-            componentSelector = compSel
-          , dcEntropyCodingTable = dc
-          , acEntropyCodingTable = ac
-          }
-
-instance Serialize JpgScanHeader where
-    get = do
-        thisScanLength <- getWord16be
-        compCount <- getWord8
-        comp <- replicateM (fromIntegral compCount) get
-        specBeg <- get
-        specEnd <- get
-        (approxHigh, approxLow) <- get4BitOfEach
-        return JpgScanHeader {
-            scanLength = thisScanLength,
-            scanComponentCount = compCount,
-            scans = comp,
-            spectralSelection = (specBeg, specEnd),
-            successiveApproxHigh = approxHigh,
-            successiveApproxLow = approxLow
-        }
-
-    put v = do
-        putWord16be $ scanLength v
-        putWord8 $ scanComponentCount v
-        mapM_ put $ scans v
-        putWord8 . fst $ spectralSelection v
-        putWord8 . snd $ spectralSelection v
-        put4BitsOfEach (successiveApproxHigh v) $ successiveApproxLow v
-
-{-quantize :: MacroBlock Int16 -> MutableMacroBlock s Int32-}
-         {--> ST s (MutableMacroBlock s Int32)-}
-{-quantize table = mutate (\idx val -> val `quot` fromIntegral (table !!! idx))-}
-
-quantize :: MacroBlock Int16 -> MutableMacroBlock s Int32
-         -> ST s (MutableMacroBlock s Int32)
-quantize table = mutate (\idx val -> val `quotient` fromIntegral (table !!! idx))
-    where quotient val q = (val + (q `div` 2)) `quot` q -- rounded integer division
-
--- | Apply a quantization matrix to a macroblock
-{-# INLINE deQuantize #-}
-deQuantize :: MacroBlock Int16 -> MutableMacroBlock s Int16
-           -> ST s (MutableMacroBlock s Int16)
-deQuantize table = mutate (\ix val -> val * (table !!! ix))
-
-inverseDirectCosineTransform :: MutableMacroBlock s Int16
-                             -> ST s (MutableMacroBlock s Int16)
-inverseDirectCosineTransform mBlock =
-    fastIdct mBlock >>= mutableLevelShift
-
-zigZagOrder :: MacroBlock Word8
-zigZagOrder = makeMacroBlock $ concat
-    [[ 0, 1, 5, 6,14,15,27,28]
-    ,[ 2, 4, 7,13,16,26,29,42]
-    ,[ 3, 8,12,17,25,30,41,43]
-    ,[ 9,11,18,24,31,40,44,53]
-    ,[10,19,23,32,39,45,52,54]
-    ,[20,22,33,38,46,51,55,60]
-    ,[21,34,37,47,50,56,59,61]
-    ,[35,36,48,49,57,58,62,63]
-    ]
-
-zigZagReorderForwardv :: (Storable a, Num a) => VS.Vector a -> VS.Vector a
-zigZagReorderForwardv vec = runST $ do
-    v <- M.new 64
-    mv <- VS.thaw vec
-    zigZagReorderForward v mv >>= VS.freeze
-
-zigZagReorderForward :: (Storable a, Num a)
-                     => MutableMacroBlock s a
-                     -> MutableMacroBlock s a
-                     -> ST s (MutableMacroBlock s a)
-zigZagReorderForward zigzaged block = do
-    let update i =  do
-            let idx = zigZagOrder !!! i
-            v <- block .!!!. fromIntegral i
-            (zigzaged .<-. fromIntegral idx) v
-
-        reorder 64 = return ()
-        reorder i  = update i >> reorder (i + 1)
-
-    reorder (0 :: Int)
-    return zigzaged
-
-zigZagReorder :: (Storable a, Num a)
-              => MutableMacroBlock s a -> ST s (MutableMacroBlock s a)
-zigZagReorder block = do
-    zigzaged <- M.replicate 64 0
-    let update i =  do
-            let idx = zigZagOrder !!! i
-            v <- block .!!!. fromIntegral idx
-            (zigzaged .<-. i) v
-
-        reorder 63 = update 63
-        reorder i  = update i >> reorder (i + 1)
-
-    reorder (0 :: Int)
-    return zigzaged
-
-
--- | This is one of the most important function of the decoding,
--- it form the barebone decoding pipeline for macroblock. It's all
--- there is to know for macro block transformation
-decodeMacroBlock :: MacroBlock DctCoefficients
-                 -> MutableMacroBlock s Int16
-                 -> ST s (MutableMacroBlock s Int16)
-decodeMacroBlock quantizationTable block =
-    deQuantize quantizationTable block >>= zigZagReorder
-                                       >>= inverseDirectCosineTransform
-
-packInt :: [Bool] -> Int32
-packInt = foldl' bitStep 0
-    where bitStep acc True = (acc `shiftL` 1) + 1
-          bitStep acc False = acc `shiftL` 1
-
--- | Unpack an int of the given size encoded from MSB to LSB.
-unpackInt :: Int32 -> BoolReader s Int32
-unpackInt bitCount = packInt <$> replicateM (fromIntegral bitCount) getNextBitJpg
-
-powerOf :: Int32 -> Word32
-powerOf 0 = 0
-powerOf n = limit 1 0
-    where val = abs n
-          limit range i | val < range = i
-          limit range i = limit (2 * range) (i + 1)
-
-encodeInt :: Word32 -> Int32 -> BoolWriter s ()
-encodeInt ssss n | n > 0 = writeBits (fromIntegral n) (fromIntegral ssss)
-encodeInt ssss n         = writeBits (fromIntegral $ n - 1) (fromIntegral ssss)
-
-decodeInt :: Int32 -> BoolReader s Int32
-decodeInt ssss = do
-    signBit <- getNextBitJpg
-    let dataRange = 1 `shiftL` fromIntegral (ssss - 1)
-        leftBitCount = ssss - 1
-    -- First following bits store the sign of the coefficient, and counted in
-    -- SSSS, so the bit count for the int, is ssss - 1
-    if signBit
-       then (\w -> dataRange + fromIntegral w) <$> unpackInt leftBitCount
-       else (\w -> 1 - dataRange * 2 + fromIntegral w) <$> unpackInt leftBitCount
-
-dcCoefficientDecode :: HuffmanTree -> BoolReader s DcCoefficient
-dcCoefficientDecode dcTree = do
-    ssss <- huffmanDecode dcTree
-    if ssss == 0
-       then return 0
-       else fromIntegral <$> decodeInt (fromIntegral ssss)
-
--- | Assume the macro block is initialized with zeroes
-acCoefficientsDecode :: HuffmanTree -> MutableMacroBlock s Int16
-                     -> BoolReader s (MutableMacroBlock s Int16)
-acCoefficientsDecode acTree mutableBlock = parseAcCoefficient 1 >> return mutableBlock
-  where parseAcCoefficient n | n >= 64 = return ()
-                             | otherwise = do
-            rrrrssss <- huffmanDecode acTree
-            let rrrr = fromIntegral $ (rrrrssss `shiftR` 4) .&. 0xF
-                ssss =  rrrrssss .&. 0xF
-            case (rrrr, ssss) of
-                (  0, 0) -> return ()
-                (0xF, 0) -> parseAcCoefficient (n + 16)
-                _        -> do
-                    decoded <- fromIntegral <$> decodeInt (fromIntegral ssss)
-                    lift $ (mutableBlock .<-. (n + rrrr)) decoded
-                    parseAcCoefficient (n + rrrr + 1)
-
--- | Decompress a macroblock from a bitstream given the current configuration
--- from the frame.
-decompressMacroBlock :: HuffmanTree         -- ^ Tree used for DC coefficient
-                     -> HuffmanTree         -- ^ Tree used for Ac coefficient
-                     -> MacroBlock Int16    -- ^ Current quantization table
-                     -> DcCoefficient       -- ^ Previous dc value
-                     -> BoolReader s (DcCoefficient, MutableMacroBlock s Int16)
-decompressMacroBlock dcTree acTree quantizationTable previousDc = do
-    dcDeltaCoefficient <- dcCoefficientDecode dcTree
-    block <- lift createEmptyMutableMacroBlock
-    let neoDcCoefficient = previousDc + dcDeltaCoefficient
-    lift $ (block .<-. 0) neoDcCoefficient
-    fullBlock <- acCoefficientsDecode acTree block
-    decodedBlock <- lift $ decodeMacroBlock quantizationTable fullBlock
-    return (neoDcCoefficient, decodedBlock)
-
-gatherQuantTables :: JpgImage -> [JpgQuantTableSpec]
-gatherQuantTables img = concat [t | JpgQuantTable t <- jpgFrame img]
-
-gatherHuffmanTables :: JpgImage -> [(JpgHuffmanTableSpec, HuffmanTree)]
-gatherHuffmanTables img = concat [lst | JpgHuffmanTable lst <- jpgFrame img]
-
-gatherScanInfo :: JpgImage -> (JpgFrameKind, JpgFrameHeader)
-gatherScanInfo img = fromJust $ unScan <$> find scanDesc (jpgFrame img)
-    where scanDesc (JpgScans _ _) = True
-          scanDesc _ = False
-
-          unScan (JpgScans a b) = (a,b)
-          unScan _ = error "If this can happen, the JPEG image is ill-formed"
-
-pixelClamp :: Int16 -> Word8
-pixelClamp n = fromIntegral . min 255 $ max 0 n
-
--- | Given a size coefficient (how much a pixel span horizontally
--- and vertically), the position of the macroblock, return a list
--- of indices and value to be stored in an array (like the final
--- image)
-unpackMacroBlock :: Int    -- ^ Component count
-                 -> Int    -- ^ Component index
-                 -> Int -- ^ Width coefficient
-                 -> Int -- ^ Height coefficient
-                 -> Int -- ^ x
-                 -> Int -- ^ y
-                 -> MutableImage s PixelYCbCr8
-                 -> MutableMacroBlock s Int16
-                 -> ST s ()
-    -- Simple case, a macroblock value => a pixel
-unpackMacroBlock compCount compIdx  wCoeff hCoeff x y 
-                 (MutableImage { mutableImageWidth = imgWidth,
-                                 mutableImageHeight = imgHeight, mutableImageData = img })
-                 block =
-  forM_ pixelIndices $ \(i, j, wDup, hDup) -> do
-      let xPos = (i + x * 8) * wCoeff + wDup
-          yPos = (j + y * 8) * hCoeff + hDup
-      when (0 <= xPos && xPos < imgWidth && 0 <= yPos && yPos < imgHeight)
-           (do compVal <- pixelClamp <$> (block .!!!. (i + j * 8))
-               let mutableIdx = (xPos + yPos * imgWidth) * compCount + compIdx
-               (img .<-. mutableIdx) compVal)
-
-    where pixelIndices = [(i, j, wDup, hDup) | i <- [0 .. 7], j <- [0 .. 7]
-                                -- Repetition to spread macro block
-                                , wDup <- [0 .. wCoeff - 1]
-                                , hDup <- [0 .. hCoeff - 1]
-                                ]
-
--- | Type only used to make clear what kind of integer we are carrying
--- Might be transformed into newtype in the future
-type DcCoefficient = Int16
-
--- | Same as for DcCoefficient, to provide nicer type signatures
-type DctCoefficients = DcCoefficient
-
-decodeRestartInterval :: BoolReader s Int32
-decodeRestartInterval = return (-1) {-  do
-  bits <- replicateM 8 getNextBitJpg
-  if bits == replicate 8 True
-     then do
-         marker <- replicateM 8 getNextBitJpg
-         return $ packInt marker
-     else return (-1)
-        -}
-
-
-decodeImage :: Int                        -- ^ Component count
-            -> JpegDecoder s              -- ^ Function to call to decode an MCU
-            -> MutableImage s PixelYCbCr8 -- ^ Result image to write into
-            -> BoolReader s ()
-decodeImage compCount decoder img = do
-    let blockIndices = [(x,y) | y <- [0 ..   verticalMcuCount decoder - 1]
-                              , x <- [0 .. horizontalMcuCount decoder - 1] ]
-        mcuDecode = mcuDecoder decoder
-        blockBeforeRestart = restartInterval decoder
-
-        folder f = foldM_ f blockBeforeRestart blockIndices
-
-    dcArray <- lift (M.replicate compCount 0  :: ST s (M.STVector s DcCoefficient))
-    folder (\resetCounter (x,y) -> do
-        when (resetCounter == 0)
-             (do forM_ [0.. compCount - 1] $
-                     \c -> lift $ (dcArray .<-. c) 0
-                 byteAlignJpg
-                 _restartCode <- decodeRestartInterval
-                 -- if 0xD0 <= restartCode && restartCode <= 0xD7
-                 return ())
-
-        forM_ mcuDecode $ \(comp, dataUnitDecoder) -> do
-            dc <- lift $ dcArray .!!!. comp
-            dcCoeff <- dataUnitDecoder x y img $ fromIntegral dc
-            lift $ (dcArray .<-. comp) dcCoeff
-            return ()
-
-        if resetCounter /= 0 then return $ resetCounter - 1
-                                         -- we use blockBeforeRestart - 1 to count
-                                         -- the current MCU
-                            else return $ blockBeforeRestart - 1)
-
--- | Type of a data unit (as in the ITU 81) standard
-type DataUnitDecoder s  =
-    (Int, Int -> Int -> MutableImage s PixelYCbCr8 -> DcCoefficient -> BoolReader s DcCoefficient)
-
-data JpegDecoder s = JpegDecoder
-    { restartInterval    :: Int
-    , horizontalMcuCount :: Int
-    , verticalMcuCount   :: Int
-    , mcuDecoder         :: [DataUnitDecoder s]
-    }
-
-allElementsEqual :: (Eq a) => [a] -> Bool
-allElementsEqual []     = True
-allElementsEqual (x:xs) = all (== x) xs
-
--- | An MCU (Minimal coded unit) is an unit of data for all components
--- (Y, Cb & Cr), taking into account downsampling.
-buildJpegImageDecoder :: JpgImage -> JpegDecoder s
-buildJpegImageDecoder img = JpegDecoder { restartInterval = mcuBeforeRestart
-                                        , horizontalMcuCount = horizontalBlockCount
-                                        , verticalMcuCount = verticalBlockCount
-                                        , mcuDecoder = mcus }
-  where huffmans = gatherHuffmanTables img
-        huffmanForComponent dcOrAc dest =
-            head [t | (h,t) <- huffmans, huffmanTableClass h == dcOrAc
-                                       , huffmanTableDest h == dest]
-
-        mcuBeforeRestart = case [i | JpgIntervalRestart i <- jpgFrame img] of
-            []    -> maxBound -- HUUUUUUGE value (enough to parse all MCU)
-            (x:_) -> fromIntegral x
-
-        quants = gatherQuantTables img
-        quantForComponent dest =
-            head [quantTable q | q <- quants, quantDestination q == dest]
-
-        hdr = head [h | JpgScanBlob h _ <- jpgFrame img]
-
-        (_, scanInfo) = gatherScanInfo img
-        imgWidth = fromIntegral $ jpgWidth scanInfo
-        imgHeight = fromIntegral $ jpgHeight scanInfo
-
-        blockSizeOfDim fullDim maxBlockSize = block + (if rest /= 0 then 1 else 0)
-                where (block, rest) = fullDim `divMod` maxBlockSize
-
-        horizontalSamplings = [horiz | (horiz, _, _, _, _) <- componentsInfo]
-
-        imgComponentCount = fromIntegral $ jpgImageComponentCount scanInfo
-        isImageLumanOnly = imgComponentCount == 1
-        maxHorizFactor | not isImageLumanOnly &&
-                            not (allElementsEqual horizontalSamplings) = maximum horizontalSamplings
-                       | otherwise = 1
-
-        verticalSamplings = [vert | (_, vert, _, _, _) <- componentsInfo]
-        maxVertFactor | not isImageLumanOnly &&
-                            not (allElementsEqual verticalSamplings) = maximum verticalSamplings
-                      | otherwise = 1
-
-        horizontalBlockCount =
-           blockSizeOfDim imgWidth $ fromIntegral (maxHorizFactor * 8)
-
-        verticalBlockCount =
-           blockSizeOfDim imgHeight $ fromIntegral (maxVertFactor * 8)
-
-        fetchTablesForComponent component = (horizCount, vertCount, dcTree, acTree, qTable)
-            where idx = componentIdentifier component
-                  descr = head [c | c <- scans hdr, componentSelector c  == idx]
-                  dcTree = huffmanForComponent DcComponent $ dcEntropyCodingTable descr
-                  acTree = huffmanForComponent AcComponent $ acEntropyCodingTable descr
-                  qTable = quantForComponent $ if idx == 1 then 0 else 1
-                  horizCount = if not isImageLumanOnly
-                        then fromIntegral $ horizontalSamplingFactor component
-                        else 1
-                  vertCount = if not isImageLumanOnly
-                        then fromIntegral $ verticalSamplingFactor component
-                        else 1
-
-        componentsInfo = map fetchTablesForComponent $ jpgComponents scanInfo
-
-        mcus = [(compIdx, \x y writeImg dc -> do
-                           (dcCoeff, block) <- decompressMacroBlock dcTree acTree qTable dc
-                           lift $ unpacker (x * horizCount + xd) (y * vertCount + yd) writeImg block
-                           return dcCoeff)
-                     | (compIdx, (horizCount, vertCount, dcTree, acTree, qTable))
-                                   <- zip [0..] componentsInfo
-                     , let xScalingFactor = maxHorizFactor - horizCount + 1
-                           yScalingFactor = maxVertFactor - vertCount + 1
-                     , yd <- [0 .. vertCount - 1]
-                     , xd <- [0 .. horizCount - 1]
-                     , let unpacker = unpackMacroBlock imgComponentCount compIdx 
-                                                    xScalingFactor yScalingFactor
-                     ]
-
--- | Try to decompress a jpeg file and decompress. The colorspace is still
--- YCbCr if you want to perform computation on the luma part. You can
--- convert it to RGB using 'convertImage' from the 'ColorSpaceConvertible'
--- typeclass.
---
--- This function can output the following pixel types :
---
---    * PixelY8
---
---    * PixelYCbCr8
---
-decodeJpeg :: B.ByteString -> Either String DynamicImage
-decodeJpeg file = case decode file of
-  Left err -> Left err
-  Right img -> case compCount of
-                 1 -> Right . ImageY8 $ Image imgWidth imgHeight pixelData
-                 3 -> Right . ImageYCbCr8 $ Image imgWidth imgHeight pixelData
-                 _ -> Left "Wrong component count"
-
-      where (imgData:_) = [d | JpgScanBlob _kind d <- jpgFrame img]
-            (_, scanInfo) = gatherScanInfo img
-            compCount = length $ jpgComponents scanInfo
-
-            imgWidth = fromIntegral $ jpgWidth scanInfo
-            imgHeight = fromIntegral $ jpgHeight scanInfo
-
-            imageSize = imgWidth * imgHeight * compCount
-
-            pixelData = runST $ VS.unsafeFreeze =<< S.evalStateT (do
-                resultImage <- lift $ M.replicate imageSize 0
-                let wrapped = MutableImage imgWidth imgHeight resultImage
-                setDecodedStringJpg imgData
-                decodeImage compCount (buildJpegImageDecoder img) wrapped
-                return resultImage) (-1, 0, B.empty)
-
-extractBlock :: Image PixelYCbCr8       -- ^ Source image
-             -> MutableMacroBlock s Int16      -- ^ Mutable block where to put extracted block
-             -> Int                     -- ^ Plane
-             -> Int                     -- ^ X sampling factor
-             -> Int                     -- ^ Y sampling factor
-             -> Int                     -- ^ Sample per pixel
-             -> Int                     -- ^ Block x
-             -> Int                     -- ^ Block y
-             -> ST s (MutableMacroBlock s Int16)
-extractBlock (Image { imageWidth = w, imageHeight = h, imageData = src })
-             block 1 1 sampCount plane bx by | (bx * 8) + 7 < w && (by * 8) + 7 < h = do
-    let baseReadIdx = (by * 8 * w) + bx * 8
-    sequence_ [(block .<-. (y * 8 + x)) val
-                        | y <- [0 .. 7]
-                        , let blockReadIdx = baseReadIdx + y * w
-                        , x <- [0 .. 7]
-                        , let val = fromIntegral $ src !!! ((blockReadIdx + x) * sampCount + plane)
-                        ]
-    return block
-extractBlock (Image { imageWidth = w, imageHeight = h, imageData = src })
-             block sampWidth sampHeight sampCount plane bx by = do
-    let accessPixel x y | x < w && y < h = let idx = (y * w + x) * sampCount + plane in src !!! idx
-                        | x >= w = accessPixel (w - 1) y
-                        | otherwise = accessPixel x (h - 1)
-
-        pixelPerCoeff = fromIntegral $ sampWidth * sampHeight
-
-        blockVal x y = sum [fromIntegral $ accessPixel (xBase + dx) (yBase + dy)
-                                | dy <- [0 .. sampHeight - 1]
-                                , dx <- [0 .. sampWidth - 1] ] `div` pixelPerCoeff
-            where xBase = blockXBegin + x * sampWidth
-                  yBase = blockYBegin + y * sampHeight
-
-        blockXBegin = bx * 8 * sampWidth
-        blockYBegin = by * 8 * sampHeight
-
-    sequence_ [(block .<-. (y * 8 + x)) $ blockVal x y | y <- [0 .. 7], x <- [0 .. 7] ]
-    return block
-
-serializeMacroBlock :: HuffmanWriterCode -> HuffmanWriterCode
-                    -> MutableMacroBlock s Int32
-                    -> BoolWriter s ()
-serializeMacroBlock dcCode acCode blk =
- lift (blk .!!!. 0) >>= (fromIntegral >>> encodeDc) >> writeAcs (0, 1) >> return ()
-  where writeAcs acc@(_, 63) =
-            lift (blk .!!!. 63) >>= (fromIntegral >>> encodeAcCoefs acc) >> return ()
-        writeAcs acc@(_, i ) =
-            lift (blk .!!!.  i) >>= (fromIntegral >>> encodeAcCoefs acc) >>= writeAcs
-
-        encodeDc n = writeBits (fromIntegral code) (fromIntegral bitCount)
-                        >> when (ssss /= 0) (encodeInt ssss n)
-            where ssss = powerOf $ fromIntegral n
-                  (bitCount, code) = dcCode V.! fromIntegral ssss
-
-        encodeAc 0         0 = writeBits (fromIntegral code) $ fromIntegral bitCount
-            where (bitCount, code) = acCode V.! 0
-
-        encodeAc zeroCount n | zeroCount >= 16 =
-          writeBits (fromIntegral code) (fromIntegral bitCount) >>  encodeAc (zeroCount - 16) n
-            where (bitCount, code) = acCode V.! 0xF0
-        encodeAc zeroCount n =
-          writeBits (fromIntegral code) (fromIntegral bitCount) >> encodeInt ssss n
-            where rrrr = zeroCount `shiftL` 4
-                  ssss = powerOf $ fromIntegral n
-                  rrrrssss = rrrr .|. ssss
-                  (bitCount, code) = acCode V.! fromIntegral rrrrssss
-
-        encodeAcCoefs (            _, 63) 0 = encodeAc 0 0 >> return (0, 64)
-        encodeAcCoefs (zeroRunLength,  i) 0 = return (zeroRunLength + 1, i + 1)
-        encodeAcCoefs (zeroRunLength,  i) n =
-            encodeAc zeroRunLength n >> return (0, i + 1)
-
-encodeMacroBlock :: QuantificationTable
-                 -> MutableMacroBlock s Int32
-                 -> MutableMacroBlock s Int32
-                 -> Int16
-                 -> MutableMacroBlock s Int16
-                 -> ST s (Int32, MutableMacroBlock s Int32)
-encodeMacroBlock quantTableOfComponent workData finalData prev_dc block = do
- -- the inverse level shift is performed internally by the fastDCT routine
- blk <- fastDctLibJpeg workData block
-        >>= zigZagReorderForward finalData
-        >>= quantize quantTableOfComponent
- dc <- blk .!!!. 0
- (blk .<-. 0) $ dc - fromIntegral prev_dc
- return (dc, blk)
-
-divUpward :: (Integral a) => a -> a -> a
-divUpward n dividor = val + (if rest /= 0 then 1 else 0)
-    where (val, rest) = n `divMod` dividor
-
-prepareHuffmanTable :: DctComponent -> Word8 -> HuffmanTable
-                    -> (JpgHuffmanTableSpec, HuffmanTree)
-prepareHuffmanTable classVal dest tableDef = 
-   (JpgHuffmanTableSpec { huffmanTableClass = classVal
-                        , huffmanTableDest  = dest
-                        , huffSizes = sizes
-                        , huffCodes = V.fromListN 16
-                            [VU.fromListN (fromIntegral $ sizes ! i) lst
-                                                | (i, lst) <- zip [0..] tableDef ]
-                        }, Empty)
-      where sizes = VU.fromListN 16 $ map (fromIntegral . length) tableDef   
-
--- | Encode an image in jpeg at a reasonnable quality level.
--- If you want better quality or reduced file size, you should
--- use `encodeJpegAtQuality`
-encodeJpeg :: Image PixelYCbCr8 -> B.ByteString
-encodeJpeg = encodeJpegAtQuality 50
-
--- | Function to call to encode an image to jpeg.
--- The quality factor should be between 0 and 100 (100 being
--- the best quality).
-encodeJpegAtQuality :: Word8                -- ^ Quality factor
-                    -> Image PixelYCbCr8    -- ^ Image to encode
-                    -> B.ByteString         -- ^ Encoded JPEG
-encodeJpegAtQuality quality img@(Image { imageWidth = w, imageHeight = h }) =
-    encode finalImage
-  where finalImage = JpgImage [ JpgQuantTable quantTables
-                              , JpgScans JpgBaselineDCTHuffman hdr
-                              , JpgHuffmanTable huffTables
-                              , JpgScanBlob scanHeader encodedImage
-                              ]
-
-        huffTables = [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
-                     , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
-                     , prepareHuffmanTable DcComponent 1 defaultDcChromaHuffmanTable
-                     , prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable
-                     ]
-
-        outputComponentCount = 3
-
-        scanHeader = scanHeader'{ scanLength = fromIntegral $ calculateSize scanHeader' }
-        scanHeader' = JpgScanHeader
-            { scanLength = 0
-            , scanComponentCount = outputComponentCount
-            , scans = [ JpgScanSpecification { componentSelector = 1
-                                             , dcEntropyCodingTable = 0
-                                             , acEntropyCodingTable = 0
-                                             }
-                      , JpgScanSpecification { componentSelector = 2
-                                             , dcEntropyCodingTable = 1
-                                             , acEntropyCodingTable = 1
-                                             }
-                      , JpgScanSpecification { componentSelector = 3
-                                             , dcEntropyCodingTable = 1
-                                             , acEntropyCodingTable = 1
-                                             }
-                      ]
-
-            , spectralSelection = (0, 63)
-            , successiveApproxHigh = 0
-            , successiveApproxLow  = 0
-            }
-
-        hdr = hdr' { jpgFrameHeaderLength   = fromIntegral $ calculateSize hdr' }
-        hdr' = JpgFrameHeader{ jpgFrameHeaderLength   = 0
-                              , jpgSamplePrecision     = 8
-                              , jpgHeight              = fromIntegral h
-                              , jpgWidth               = fromIntegral w
-                              , jpgImageComponentCount = outputComponentCount
-                              , jpgComponents          = [
-                                    JpgComponent { componentIdentifier      = 1
-                                                 , horizontalSamplingFactor = 2
-                                                 , verticalSamplingFactor   = 2
-                                                 , quantizationTableDest    = 0
-                                                 }
-                                  , JpgComponent { componentIdentifier      = 2
-                                                 , horizontalSamplingFactor = 1
-                                                 , verticalSamplingFactor   = 1
-                                                 , quantizationTableDest    = 1
-                                                 }
-                                  , JpgComponent { componentIdentifier      = 3
-                                                 , horizontalSamplingFactor = 1
-                                                 , verticalSamplingFactor   = 1
-                                                 , quantizationTableDest    = 1
-                                                 }
-                                  ]
-                              }
-
-        lumaQuant = scaleQuantisationMatrix (fromIntegral quality)
-                        defaultLumaQuantizationTable 
-        chromaQuant = scaleQuantisationMatrix (fromIntegral quality)
-                            defaultChromaQuantizationTable
-
-        zigzagedLumaQuant = zigZagReorderForwardv lumaQuant
-        zigzagedChromaQuant = zigZagReorderForwardv chromaQuant 
-        quantTables = [ JpgQuantTableSpec { quantPrecision = 0, quantDestination = 0
-                                          , quantTable = zigzagedLumaQuant }
-                      , JpgQuantTableSpec { quantPrecision = 0, quantDestination = 1
-                                          , quantTable = zigzagedChromaQuant }
-                      ]
-
-        encodedImage = runST toExtract
-        toExtract = runBoolWriter $ do
-            let horizontalMetaBlockCount = w `divUpward` (8 * maxSampling)
-                verticalMetaBlockCount = h `divUpward` (8 * maxSampling)
-                maxSampling = 2
-                lumaSamplingSize = ( maxSampling, maxSampling, zigzagedLumaQuant
-                                   , makeInverseTable defaultDcLumaHuffmanTree
-                                   , makeInverseTable defaultAcLumaHuffmanTree)
-                chromaSamplingSize = ( maxSampling - 1, maxSampling - 1, zigzagedChromaQuant
-                                     , makeInverseTable defaultDcChromaHuffmanTree
-                                     , makeInverseTable defaultAcChromaHuffmanTree)
-                componentDef = [lumaSamplingSize, chromaSamplingSize, chromaSamplingSize]
-  
-                imageComponentCount = length componentDef
-            block <- lift $ M.replicate 64 0
-            dc_table <- lift $ M.replicate 3 0
-            let blockList = [(comp, table, dc, ac, extractBlock img block xSamplingFactor ySamplingFactor
-                                                  imageComponentCount comp blockX blockY)
-                                    | my <- [0 .. verticalMetaBlockCount - 1]
-                                    , mx <- [0 .. horizontalMetaBlockCount - 1]
-                                    , (comp, (sizeX, sizeY, table, dc, ac)) <- zip [0..] componentDef
-                                    , subY <- [0 .. sizeY - 1]
-                                    , subX <- [0 .. sizeX - 1]
-                                    , let blockX = mx * sizeX + subX
-                                          blockY = my * sizeY + subY
-                                          xSamplingFactor = maxSampling - sizeX + 1
-                                          ySamplingFactor = maxSampling - sizeY + 1
-                                    ]
-  
-            workData <- lift createEmptyMutableMacroBlock
-            zigzaged <- lift createEmptyMutableMacroBlock
-            forM_ blockList $ \(comp, table, dc, ac, extractor) -> do
-                prev_dc <- lift $ dc_table .!!!. comp
-                (dc_coeff, neo_block) <- lift (extractor >>= 
-                                        encodeMacroBlock table workData zigzaged prev_dc)
-                lift . (dc_table .<-. comp) $ fromIntegral dc_coeff
-                serializeMacroBlock dc ac neo_block
-
− Codec/Picture/Jpg/DefaultTable.hs 
@@ -1,239 +0,0 @@-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE FlexibleContexts #-}
--- | Module used by the jpeg decoder internally, shouldn't be used
--- in user code.
-module Codec.Picture.Jpg.DefaultTable( DctComponent( .. )
-									 , HuffmanTree( .. )
-									 , HuffmanTable
-									 , MacroBlock
-									 , QuantificationTable
-									 , HuffmanWriterCode 
-									 , scaleQuantisationMatrix
-									 , makeMacroBlock
-									 , makeInverseTable
-									 , buildHuffmanTree
-
-									 , defaultChromaQuantizationTable
-
-									 , defaultLumaQuantizationTable
-
-									 , defaultAcChromaHuffmanTree
-									 , defaultAcChromaHuffmanTable
-
-									 , defaultAcLumaHuffmanTree 
-									 , defaultAcLumaHuffmanTable 
-
-									 , defaultDcChromaHuffmanTree 
-									 , defaultDcChromaHuffmanTable
-
-                                     , defaultDcLumaHuffmanTree
-									 , defaultDcLumaHuffmanTable
-									 ) where
-
-import Foreign.Storable ( Storable )
-import qualified Data.Vector.Storable as SV
-import qualified Data.Vector as V
-import Data.Bits( shiftL, (.|.) )
-import Data.Int( Int16 )
-import Data.Word( Word8, Word16 )
-import Data.List( foldl' )
-
--- | Tree storing the code used for huffman encoding.
-data HuffmanTree = Branch HuffmanTree HuffmanTree -- ^ If bit is 0 take the first subtree, if 1, the right.
-                 | Leaf Word8       -- ^ We should output the value
-                 | Empty            -- ^ no value present
-                 deriving (Eq, Show)
-
-type HuffmanWriterCode = V.Vector (Word8, Word16)
-
-makeInverseTable :: HuffmanTree -> HuffmanWriterCode
-makeInverseTable t = V.replicate 255 (0,0) V.// inner 0 0 t
-  where inner _     _     Empty   = []
-        inner depth code (Leaf v) = [(fromIntegral v, (depth, code))]
-        inner depth code (Branch l r) =
-          inner (depth + 1) shifted l ++ inner (depth + 1) (shifted .|. 1) r
-            where shifted = code `shiftL` 1
-
--- | Represent a compact array of 8 * 8 values. The size
--- is not guarenteed by type system, but if makeMacroBlock is
--- used, everything should be fine size-wise
-type MacroBlock a = SV.Vector a
-
-type QuantificationTable = MacroBlock Int16
-
--- | Helper function to create pure macro block of the good size.
-makeMacroBlock :: (Storable a) => [a] -> MacroBlock a
-makeMacroBlock = SV.fromListN 64
-
--- | Enumeration used to search in the tables for different components.
-data DctComponent = DcComponent | AcComponent
-    deriving (Eq, Show)
-
--- | Transform parsed coefficients from the jpeg header to a
--- tree which can be used to decode data.
-buildHuffmanTree :: [[Word8]] -> HuffmanTree
-buildHuffmanTree table = foldl' insertHuffmanVal Empty
-                       . concatMap (\(i, t) -> map (i + 1,) t)
-                       $ zip ([0..] :: [Int]) table
-  where isTreeFullyDefined Empty = False
-        isTreeFullyDefined (Leaf _) = True
-        isTreeFullyDefined (Branch l r) = isTreeFullyDefined l && isTreeFullyDefined r
-
-        insertHuffmanVal Empty (0, val) = Leaf val
-        insertHuffmanVal Empty (d, val) = Branch (insertHuffmanVal Empty (d - 1, val)) Empty
-        insertHuffmanVal (Branch l r) (d, val)
-            | isTreeFullyDefined l = Branch l (insertHuffmanVal r (d - 1, val))
-            | otherwise            = Branch (insertHuffmanVal l (d - 1, val)) r
-        insertHuffmanVal (Leaf _) _ = error "Inserting in value, shouldn't happen"
-
-scaleQuantisationMatrix :: Int -> QuantificationTable -> QuantificationTable 
-scaleQuantisationMatrix quality
-    | quality < 50 = let qq = 5000 `div` quality
-                     in SV.map (scale qq)
-    | otherwise    = SV.map (scale q)
-          where q = 200 - quality * 2
-                scale coeff i = fromIntegral . min 255 
-                                             . max 1 
-                                             $ fromIntegral i * coeff `div` 100
-
-defaultLumaQuantizationTable :: QuantificationTable
-defaultLumaQuantizationTable = makeMacroBlock
-    [16, 11, 10, 16,  24,  40,  51,  61
-    ,12, 12, 14, 19,  26,  58,  60,  55
-    ,14, 13, 16, 24,  40,  57,  69,  56
-    ,14, 17, 22, 29,  51,  87,  80,  62
-    ,18, 22, 37, 56,  68, 109, 103,  77
-    ,24, 35, 55, 64,  81, 104, 113,  92
-    ,49, 64, 78, 87, 103, 121, 120, 101
-    ,72, 92, 95, 98, 112, 100, 103,  99
-    ]
-
-defaultChromaQuantizationTable :: QuantificationTable
-defaultChromaQuantizationTable = makeMacroBlock
-    [17, 18, 24, 47, 99, 99, 99, 99
-    ,18, 21, 26, 66, 99, 99, 99, 99
-    ,24, 26, 56, 99, 99, 99, 99, 99
-    ,47, 66, 99, 99, 99, 99, 99, 99
-    ,99, 99, 99, 99, 99, 99, 99, 99
-    ,99, 99, 99, 99, 99, 99, 99, 99
-    ,99, 99, 99, 99, 99, 99, 99, 99
-    ,99, 99, 99, 99, 99, 99, 99, 99
-    ]
-
-defaultDcLumaHuffmanTree :: HuffmanTree
-defaultDcLumaHuffmanTree = buildHuffmanTree defaultDcLumaHuffmanTable
-
--- | From the Table K.3 of ITU-81 (p153)
-defaultDcLumaHuffmanTable :: HuffmanTable
-defaultDcLumaHuffmanTable =
-    [ []
-    , [0]
-    , [1, 2, 3, 4, 5]
-    , [6]
-    , [7]
-    , [8]
-    , [9]
-    , [10]
-    , [11]
-    , []
-    , []
-    , []
-    , []
-    , []
-    , []
-    , []
-    ]
-
-defaultDcChromaHuffmanTree :: HuffmanTree
-defaultDcChromaHuffmanTree = buildHuffmanTree defaultDcChromaHuffmanTable
-
--- | From the Table K.4 of ITU-81 (p153)
-defaultDcChromaHuffmanTable :: HuffmanTable
-defaultDcChromaHuffmanTable = 
-    [ []
-    , [0, 1, 2]
-    , [3]
-    , [4]
-    , [5]
-    , [6]
-    , [7]
-    , [8]
-    , [9]
-    , [10]
-    , [11]
-    , []
-    , []
-    , []
-    , []
-    , []
-    ]
-
-defaultAcLumaHuffmanTree :: HuffmanTree
-defaultAcLumaHuffmanTree = buildHuffmanTree defaultAcLumaHuffmanTable
-
--- | From the Table K.5 of ITU-81 (p154)
-defaultAcLumaHuffmanTable :: HuffmanTable
-defaultAcLumaHuffmanTable =
-    [ []
-    , [0x01, 0x02]
-    , [0x03]
-    , [0x00, 0x04, 0x11]
-    , [0x05, 0x12, 0x21]
-    , [0x31, 0x41]
-    , [0x06, 0x13, 0x51, 0x61]
-    , [0x07, 0x22, 0x71]
-    , [0x14, 0x32, 0x81, 0x91, 0xA1]
-    , [0x08, 0x23, 0x42, 0xB1, 0xC1]
-    , [0x15, 0x52, 0xD1, 0xF0]
-    , [0x24, 0x33, 0x62, 0x72]
-    , []
-    , []
-    , [0x82]
-    , [0x09, 0x0A, 0x16, 0x17, 0x18, 0x19, 0x1A, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x34, 0x35
-      ,0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4A, 0x53, 0x54
-      ,0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73
-      ,0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A
-      ,0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7
-      ,0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7, 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4
-      ,0xC5, 0xC6, 0xC7, 0xC8, 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9, 0xDA
-      ,0xE1, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5
-      ,0xF6, 0xF7, 0xF8, 0xF9, 0xFA]
-    ]
-
-type HuffmanTable = [[Word8]]
-
-defaultAcChromaHuffmanTree :: HuffmanTree
-defaultAcChromaHuffmanTree = buildHuffmanTree defaultAcChromaHuffmanTable 
-
-defaultAcChromaHuffmanTable :: HuffmanTable
-defaultAcChromaHuffmanTable = 
-    [ []
-    , [0x00, 0x01]
-    , [0x02]
-    , [0x03, 0x11]
-    , [0x04, 0x05, 0x21, 0x31]
-    , [0x06, 0x12, 0x41, 0x51]
-    , [0x07, 0x61, 0x71]
-    , [0x13, 0x22, 0x32, 0x81]
-    , [0x08, 0x14, 0x42, 0x91, 0xA1, 0xB1, 0xC1]
-    , [0x09, 0x23, 0x33, 0x52, 0xF0]
-    , [0x15, 0x62, 0x72, 0xD1]
-    , [0x0A, 0x16, 0x24, 0x34]
-    , []
-    , [0xE1]
-    , [0x25, 0xF1]
-    , [ 0x17, 0x18, 0x19, 0x1A, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x35
-      , 0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47
-      , 0x48, 0x49, 0x4A, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59
-      , 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73
-      , 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x82, 0x83, 0x84
-      , 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A, 0x92, 0x93, 0x94, 0x95
-      , 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6
-      , 0xA7, 0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7
-      , 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, 0xC8
-      , 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9
-      , 0xDA, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA
-      , 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0xFA
-      ]
-    ]
-
− Codec/Picture/Jpg/FastDct.hs 
@@ -1,209 +0,0 @@-module Codec.Picture.Jpg.FastDct( referenceDct, fastDctLibJpeg ) where
-
-import Control.Applicative( (<$>) )
-import Data.Int( Int16, Int32 )
-import Data.Bits( Bits, shiftR, shiftL )
-import Control.Monad.ST( ST )
-
-import qualified Data.Vector.Storable.Mutable as M
-
-import Codec.Picture.Jpg.Types
-import Control.Monad( forM, forM_ )
-
-{-# INLINE (.>>.) #-}
-{-# INLINE (.<<.) #-}
-(.>>.), (.<<.) :: (Bits a) => a -> Int -> a
-(.>>.) = shiftR
-(.<<.) = shiftL
-
--- | Reference implementation of the DCT, directly implementing the formula
--- of ITU-81. It's slow as hell, perform to many operations, but is accurate
--- and a good reference point.
-referenceDct :: MutableMacroBlock s Int32
-             -> MutableMacroBlock s Int16
-             -> ST s (MutableMacroBlock s Int32)
-referenceDct workData block = forM_ [(u, v) | u <- [0 :: Int .. 7], v <- [0..7]] (\(u,v) -> do
-    val <- at (u,v)
-    (workData .<-. (v * 8 + u)) . truncate $ (1 / 4) * c u * c v * val)
-    >> return workData
- where -- at :: (Int, Int) -> ST s Float
-       at (u,v) = sum <$> (forM [(x,y) | x <- [0..7], y <- [0..7 :: Int]] $ \(x,y) -> do
-           sample <- fromIntegral <$> (block .!!!. (y * 8 + x))
-           return $ sample * cos ((2 * fromIntegral x + 1) * fromIntegral u * (pi :: Float)/ 16) 
-                           * cos ((2 * fromIntegral y + 1) * fromIntegral v * pi / 16))
-       c 0 = 1 / sqrt 2
-       c _ = 1
-
-pASS1_BITS, cONST_BITS :: Int
-cONST_BITS = 13
-pASS1_BITS =  2
-
-
-fIX_0_298631336, fIX_0_390180644, fIX_0_541196100,
-    fIX_0_765366865, fIX_0_899976223, fIX_1_175875602,
-    fIX_1_501321110, fIX_1_847759065, fIX_1_961570560,
-    fIX_2_053119869, fIX_2_562915447, fIX_3_072711026 :: Int32
-fIX_0_298631336 =(2446)    -- FIX(0.298631336) */
-fIX_0_390180644 =(3196)    -- FIX(0.390180644) */
-fIX_0_541196100 =(4433)    -- FIX(0.541196100) */
-fIX_0_765366865 =(6270)    -- FIX(0.765366865) */
-fIX_0_899976223 =(7373)    -- FIX(0.899976223) */
-fIX_1_175875602 =(9633)    -- FIX(1.175875602) */
-fIX_1_501321110 =(12299)    -- FIX(1.501321110) */
-fIX_1_847759065 =(15137)    -- FIX(1.847759065) */
-fIX_1_961570560 =(16069)    -- FIX(1.961570560) */
-fIX_2_053119869 =(16819)    -- FIX(2.053119869) */
-fIX_2_562915447 =(20995)    -- FIX(2.562915447) */
-fIX_3_072711026 =(25172)    -- FIX(3.072711026) */
-
-cENTERJSAMPLE :: Int32
-cENTERJSAMPLE = 128
-
--- | Fast DCT extracted from libjpeg
-fastDctLibJpeg :: MutableMacroBlock s Int32
-        -> MutableMacroBlock s Int16
-        -> ST s (MutableMacroBlock s Int32)
-fastDctLibJpeg workData sample_block = do
- firstPass workData  0
- secondPass workData 7
- {-_ <- mutate (\_ a -> a `quot` 8) workData-}
- return workData
-  where -- Pass 1: process rows.
-        -- Note results are scaled up by sqrt(8) compared to a true DCT;
-        -- furthermore, we scale the results by 2**PASS1_BITS.
-        firstPass         _ 8 = return ()
-        firstPass dataBlock i = do
-            let baseIdx = i * 8
-                readAt idx = fromIntegral <$> sample_block .!!!. (baseIdx + idx)
-                mult = (*)
-                writeAt idx n = (dataBlock .<-. (baseIdx + idx)) n
-                writeAtPos idx n = (dataBlock .<-. (baseIdx + idx))
-                                    (n .>>. (cONST_BITS - pASS1_BITS))
-
-            blk0 <- readAt 0
-            blk1 <- readAt 1
-            blk2 <- readAt 2
-            blk3 <- readAt 3
-            blk4 <- readAt 4
-            blk5 <- readAt 5
-            blk6 <- readAt 6
-            blk7 <- readAt 7
-
-            let tmp0 = blk0 + blk7
-                tmp1 = blk1 + blk6
-                tmp2 = blk2 + blk5
-                tmp3 = blk3 + blk4
-
-                tmp10 = tmp0 + tmp3
-                tmp12 = tmp0 - tmp3
-                tmp11 = tmp1 + tmp2
-                tmp13 = tmp1 - tmp2
-
-                tmp0' = blk0 - blk7
-                tmp1' = blk1 - blk6
-                tmp2' = blk2 - blk5
-                tmp3' = blk3 - blk4
-
-            -- Stage 4 and output
-            writeAt 0 $ (tmp10 + tmp11 - 8 * cENTERJSAMPLE) .<<. pASS1_BITS
-            writeAt 4 $ (tmp10 - tmp11) .<<. pASS1_BITS
-
-            let z1 = mult (tmp12 + tmp13) fIX_0_541196100
-                     + (1 .<<. (cONST_BITS - pASS1_BITS - 1))
-
-            writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865
-            writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065
-
-            let tmp10' = tmp0' + tmp3'
-                tmp11' = tmp1' + tmp2'
-                tmp12' = tmp0' + tmp2'
-                tmp13' = tmp1' + tmp3'
-                z1' = mult (tmp12' + tmp13') fIX_1_175875602 --  c3 */
-                        -- Add fudge factor here for final descale. */
-                        + (1 .<<. (cONST_BITS - pASS1_BITS-1))
-                tmp0'' = mult tmp0' fIX_1_501321110
-                tmp1'' = mult tmp1' fIX_3_072711026
-                tmp2'' = mult tmp2' fIX_2_053119869
-                tmp3'' = mult tmp3' fIX_0_298631336
-
-                tmp10'' = mult tmp10' (- fIX_0_899976223)
-                tmp11'' = mult tmp11' (- fIX_2_562915447)
-                tmp12'' = mult tmp12' (- fIX_0_390180644) + z1'
-                tmp13'' = mult tmp13' (- fIX_1_961570560) + z1'
-
-            writeAtPos 1 $ tmp0'' + tmp10'' + tmp12''
-            writeAtPos 3 $ tmp1'' + tmp11'' + tmp13''
-            writeAtPos 5 $ tmp2'' + tmp11'' + tmp12''
-            writeAtPos 7 $ tmp3'' + tmp10'' + tmp13''
-
-            firstPass dataBlock $ i + 1
-
-        -- Pass 2: process columns.
-        -- We remove the PASS1_BITS scaling, but leave the results scaled up
-        -- by an overall factor of 8.
-        secondPass :: M.STVector s Int32 -> Int -> ST s ()
-        secondPass _     (-1) = return ()
-        secondPass block i = do
-            let readAt idx = block .!!!. ((7 - i) + idx * 8)
-                mult = (*)
-                writeAt idx n = (block .<-. (8 * idx + (7 - i))) n
-                writeAtPos idx n = (block .<-. (8 * idx + (7 - i))) $ n .>>. (cONST_BITS + pASS1_BITS + 3)
-            blk0 <- readAt 0
-            blk1 <- readAt 1
-            blk2 <- readAt 2
-            blk3 <- readAt 3
-            blk4 <- readAt 4
-            blk5 <- readAt 5
-            blk6 <- readAt 6
-            blk7 <- readAt 7
-
-            let tmp0 = blk0 + blk7
-                tmp1 = blk1 + blk6
-                tmp2 = blk2 + blk5
-                tmp3 = blk3 + blk4
-
-                -- Add fudge factor here for final descale. */
-                tmp10 = tmp0 + tmp3 + (1 .<<. (pASS1_BITS-1))
-                tmp12 = tmp0 - tmp3
-                tmp11 = tmp1 + tmp2
-                tmp13 = tmp1 - tmp2
-
-                tmp0' = blk0 - blk7
-                tmp1' = blk1 - blk6
-                tmp2' = blk2 - blk5
-                tmp3' = blk3 - blk4
-
-            writeAt 0 $ (tmp10 + tmp11) .>>. (pASS1_BITS + 3)
-            writeAt 4 $ (tmp10 - tmp11) .>>. (pASS1_BITS + 3)
-
-            let z1 = mult (tmp12 + tmp13) fIX_0_541196100
-                    + (1 .<<. (cONST_BITS + pASS1_BITS - 1))
-
-            writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865
-            writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065
-
-            let tmp10' = tmp0' + tmp3'
-                tmp11' = tmp1' + tmp2'
-                tmp12' = tmp0' + tmp2'
-                tmp13' = tmp1' + tmp3'
-
-                z1' = mult (tmp12' + tmp13') fIX_1_175875602
-                    -- Add fudge factor here for final descale. */
-                   + 1 .<<. (cONST_BITS+pASS1_BITS-1);
-
-                tmp0''  = mult tmp0'    fIX_1_501321110
-                tmp1''  = mult tmp1'    fIX_3_072711026
-                tmp2''  = mult tmp2'    fIX_2_053119869
-                tmp3''  = mult tmp3'    fIX_0_298631336
-                tmp10'' = mult tmp10' (- fIX_0_899976223)
-                tmp11'' = mult tmp11' (- fIX_2_562915447)
-                tmp12'' = mult tmp12' (- fIX_0_390180644)
-                            + z1'
-                tmp13'' = mult tmp13' (- fIX_1_961570560)
-                            + z1'
-            writeAtPos 1 $ tmp0'' + tmp10'' + tmp12''
-            writeAtPos 3 $ tmp1'' + tmp11'' + tmp13''
-            writeAtPos 5 $ tmp2'' + tmp11'' + tmp12''
-            writeAtPos 7 $ tmp3'' + tmp10'' + tmp13''
-
-            secondPass block (i - 1)
− Codec/Picture/Jpg/FastIdct.hs 
@@ -1,230 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}
--- | Module providing a 'fast' implementation of IDCT
---
--- inverse two dimensional DCT, Chen-Wang algorithm       
--- (cf. IEEE ASSP-32, pp. 803-816, Aug. 1984)             
--- 32-bit integer arithmetic (8 bit coefficients)         
--- 11 mults, 29 adds per DCT                              
---                                      sE, 18.8.91       
---
--- coefficients extended to 12 bit for IEEE1180-1990      
--- compliance                           sE,  2.1.94       
---
--- this code assumes >> to be a two's-complement arithmetic
--- right shift: (-2)>>1 == -1 , (-3)>>1 == -2               
-module Codec.Picture.Jpg.FastIdct( MutableMacroBlock
-                                 , fastIdct
-                                 , mutableLevelShift
-                                 , createEmptyMutableMacroBlock
-                                 ) where
-
-import qualified Data.Vector.Storable as V
-import Control.Monad( forM_ )
-import Control.Monad.ST( ST )
-import Data.Bits( shiftL, shiftR )
-import Data.Int( Int16 )
-
-import Codec.Picture.Jpg.Types
-
-iclip :: V.Vector Int16
-iclip = V.fromListN 1024 [ val i| i <- [(-512) .. 511] ]
-    where val i | i < (-256) = -256
-                | i > 255    =  255
-                | otherwise  =  i
-
-{-# INLINE clip #-}
-clip :: Int -> Int16
-clip i -- = iclip !!! (i + 512)
-       | i < 511 = if i > -512 then iclip !!! (i + 512)
-                               else iclip !!! 0
-    
-       | otherwise = iclip !!! 1023
-
-{-# INLINE (.<<.) #-}
-{-# INLINE (.>>.) #-}
-(.<<.), (.>>.) :: Int -> Int -> Int
-(.<<.) = shiftL
-(.>>.) = shiftR
-
-data IDctStage = IDctStage { 
-        x0 :: {-# UNPACK #-} !Int,
-        x1 :: {-# UNPACK #-} !Int,
-        x2 :: {-# UNPACK #-} !Int,
-        x3 :: {-# UNPACK #-} !Int,
-        x4 :: {-# UNPACK #-} !Int,
-        x5 :: {-# UNPACK #-} !Int,
-        x6 :: {-# UNPACK #-} !Int,
-        x7 :: {-# UNPACK #-} !Int,
-        x8 :: {-# UNPACK #-} !Int
-    }
-
-w1, w2, w3, w5, w6, w7 :: Int
-w1 = 2841 -- 2048*sqrt(2)*cos(1*pi/16)
-w2 = 2676 -- 2048*sqrt(2)*cos(2*pi/16)
-w3 = 2408 -- 2048*sqrt(2)*cos(3*pi/16)
-w5 = 1609 -- 2048*sqrt(2)*cos(5*pi/16)
-w6 = 1108 -- 2048*sqrt(2)*cos(6*pi/16)
-w7 = 565  -- 2048*sqrt(2)*cos(7*pi/16)
-
--- row (horizontal) IDCT
---
---           7                       pi         1
--- dst[k] = sum c[l] * src[l] * cos( -- * ( k + - ) * l )
---          l=0                      8          2
---
--- where: c[0]    = 128
---        c[1..7] = 128*sqrt(2)
-idctRow :: MutableMacroBlock s Int16 -> Int ->  ST s ()
-idctRow blk idx = do
-  xx0 <- blk .!!!. (0 + idx)
-  xx1 <- blk .!!!. (4 + idx) 
-  xx2 <- blk .!!!. (6 + idx)
-  xx3 <- blk .!!!. (2 + idx)
-  xx4 <- blk .!!!. (1 + idx)
-  xx5 <- blk .!!!. (7 + idx)
-  xx6 <- blk .!!!. (5 + idx)
-  xx7 <- blk .!!!. (3 + idx)
-  let initialState = IDctStage { x0 = (fromIntegral xx0 .<<. 11) + 128
-                               , x1 =  fromIntegral xx1 .<<. 11
-                               , x2 =  fromIntegral xx2
-                               , x3 =  fromIntegral xx3
-                               , x4 =  fromIntegral xx4
-                               , x5 =  fromIntegral xx5
-                               , x6 =  fromIntegral xx6
-                               , x7 =  fromIntegral xx7
-                               , x8 = 0
-                               } 
-
-      firstStage c = c { x4 = x8'  + (w1 - w7) * x4 c
-                       , x5 = x8'  - (w1 + w7) * x5 c
-                       , x6 = x8'' - (w3 - w5) * x6 c
-                       , x7 = x8'' - (w3 + w5) * x7 c
-                       , x8 = x8''
-                       }
-          where x8' = w7 * (x4 c + x5 c)
-                x8'' = w3 * (x6 c + x7 c)
-
-      secondStage c = c { x0 = x0 c - x1 c
-                        , x8 = x0 c + x1 c 
-                        , x1 = x1''
-                        , x2 = x1' - (w2 + w6) * x2 c
-                        , x3 = x1' + (w2 - w6) * x3 c
-                        , x4 = x4 c - x6 c
-                        , x6 = x5 c + x7 c
-                        , x5 = x5 c - x7 c
-                        }
-            where x1'  = w6 * (x3 c + x2 c)
-                  x1'' = x4 c + x6 c
-
-      thirdStage c = c { x7 = x8 c + x3 c
-                       , x8 = x8 c - x3 c
-                       , x3 = x0 c + x2 c
-                       , x0 = x0 c - x2 c
-                       , x2 = (181 * (x4 c + x5 c) + 128) .>>. 8
-                       , x4 = (181 * (x4 c - x5 c) + 128) .>>. 8
-                       }
-      scaled c = c { x0 = (x7 c + x1 c) .>>. 8
-                   , x1 = (x3 c + x2 c) .>>. 8
-                   , x2 = (x0 c + x4 c) .>>. 8
-                   , x3 = (x8 c + x6 c) .>>. 8
-                   , x4 = (x8 c - x6 c) .>>. 8
-                   , x5 = (x0 c - x4 c) .>>. 8
-                   , x6 = (x3 c - x2 c) .>>. 8
-                   , x7 = (x7 c - x1 c) .>>. 8
-                   }
-      transformed = scaled . thirdStage . secondStage $ firstStage initialState
-
-  (blk .<-. (0 + idx)) . fromIntegral $ x0 transformed
-  (blk .<-. (1 + idx)) . fromIntegral $ x1 transformed
-  (blk .<-. (2 + idx)) . fromIntegral $ x2 transformed
-  (blk .<-. (3 + idx)) . fromIntegral $ x3 transformed
-  (blk .<-. (4 + idx)) . fromIntegral $ x4 transformed
-  (blk .<-. (5 + idx)) . fromIntegral $ x5 transformed
-  (blk .<-. (6 + idx)) . fromIntegral $ x6 transformed
-  (blk .<-. (7 + idx)) . fromIntegral $ x7 transformed
-
--- column (vertical) IDCT
---
---             7                         pi         1
--- dst[8*k] = sum c[l] * src[8*l] * cos( -- * ( k + - ) * l )
---            l=0                        8          2
---
--- where: c[0]    = 1/1024
---        c[1..7] = (1/1024)*sqrt(2)
---
-idctCol :: MutableMacroBlock s Int16 -> Int -> ST s ()
-idctCol blk idx = do
-  xx0 <- blk .!!!. (    0 + idx)
-  xx1 <- blk .!!!. (8 * 4 + idx)
-  xx2 <- blk .!!!. (8 * 6 + idx)
-  xx3 <- blk .!!!. (8 * 2 + idx)
-  xx4 <- blk .!!!. (8     + idx)
-  xx5 <- blk .!!!. (8 * 7 + idx)
-  xx6 <- blk .!!!. (8 * 5 + idx)
-  xx7 <- blk .!!!. (8 * 3 + idx)
-  let initialState = IDctStage { x0 = (fromIntegral xx0 .<<. 8) + 8192
-                               , x1 =  fromIntegral xx1 .<<. 8
-                               , x2 =  fromIntegral xx2
-                               , x3 =  fromIntegral xx3
-                               , x4 =  fromIntegral xx4
-                               , x5 =  fromIntegral xx5
-                               , x6 =  fromIntegral xx6
-                               , x7 =  fromIntegral xx7
-                               , x8 = 0
-                               } 
-      firstStage c = c { x4 = (x8'  + (w1 - w7) * x4 c) .>>. 3
-                       , x5 = (x8'  - (w1 + w7) * x5 c) .>>. 3
-                       , x6 = (x8'' - (w3 - w5) * x6 c) .>>. 3
-                       , x7 = (x8'' - (w3 + w5) * x7 c) .>>. 3
-                       , x8 = x8''
-                       }
-          where x8'  = w7 * (x4 c + x5 c) + 4
-                x8'' = w3 * (x6 c + x7 c) + 4
-
-      secondStage c = c { x8 = x0 c + x1 c
-                        , x0 = x0 c - x1 c
-                        , x2 = (x1' - (w2 + w6) * x2 c) .>>. 3
-                        , x3 = (x1' + (w2 - w6) * x3 c) .>>. 3
-                        , x4 = x4 c - x6 c
-                        , x1 = x1''
-                        , x6 = x5 c + x7 c
-                        , x5 = x5 c - x7 c
-                        }
-          where x1'  = w6 * (x3 c + x2 c) + 4
-                x1'' = x4 c + x6 c
-  
-      thirdStage c = c { x7 = x8 c + x3 c
-                       , x8 = x8 c - x3 c
-                       , x3 = x0 c + x2 c
-                       , x0 = x0 c - x2 c
-                       , x2 = (181 * (x4 c + x5 c) + 128) .>>. 8
-                       , x4 = (181 * (x4 c - x5 c) + 128) .>>. 8
-                       }
-
-      f = thirdStage . secondStage $ firstStage initialState
-  (blk .<-. (idx + 8*0)) . clip $ (x7 f + x1 f) .>>. 14
-  (blk .<-. (idx + 8  )) . clip $ (x3 f + x2 f) .>>. 14
-  (blk .<-. (idx + 8*2)) . clip $ (x0 f + x4 f) .>>. 14
-  (blk .<-. (idx + 8*3)) . clip $ (x8 f + x6 f) .>>. 14
-  (blk .<-. (idx + 8*4)) . clip $ (x8 f - x6 f) .>>. 14
-  (blk .<-. (idx + 8*5)) . clip $ (x0 f - x4 f) .>>. 14
-  (blk .<-. (idx + 8*6)) . clip $ (x3 f - x2 f) .>>. 14
-  (blk .<-. (idx + 8*7)) . clip $ (x7 f - x1 f) .>>. 14
-
-
-{-# INLINE fastIdct #-}
--- | Algorithm to call to perform an IDCT, return the same
--- block that the one given as input.
-fastIdct :: MutableMacroBlock s Int16
-         -> ST s (MutableMacroBlock s Int16)
-fastIdct block = do
-    forM_ [0..7] (\i -> idctRow block (8 * i))
-    forM_ [0..7] (idctCol block)
-    return block
-
-{-# INLINE mutableLevelShift #-}
--- | Perform a Jpeg level shift in a mutable fashion.
-mutableLevelShift :: MutableMacroBlock s Int16
-                  -> ST s (MutableMacroBlock s Int16)
-mutableLevelShift = mutate (\_ v -> v + 128)
-
− Codec/Picture/Jpg/Types.hs 
@@ -1,61 +0,0 @@-module Codec.Picture.Jpg.Types( MutableMacroBlock
-                              , createEmptyMutableMacroBlock
-                              , mutate
-                              , printMacroBlock
-                              , (!!!),  (.!!!.), (.<-.)
-                              ) where
-
-import Control.Monad.ST( ST )
-import Foreign.Storable ( Storable )
-import Control.Monad.Primitive ( PrimState, PrimMonad )
-import qualified Data.Vector.Storable as V
-import qualified Data.Vector.Storable.Mutable as M
--- import Data.Vector.Storable( (!) )
-
-import Text.Printf
-
-{-# INLINE (!!!) #-}
-(!!!) :: (Storable e) => V.Vector e -> Int -> e
-(!!!) = -- (!) 
-        V.unsafeIndex
-
-{-# INLINE (.!!!.) #-}
-(.!!!.) :: (PrimMonad m, Storable a)
-        => M.STVector (PrimState m) a -> Int -> m a
-(.!!!.) = -- M.read
-          M.unsafeRead
-
-{-# INLINE (.<-.) #-}
-(.<-.) :: (PrimMonad m, Storable a)
-       => M.STVector (PrimState m) a -> Int -> a -> m ()
-(.<-.) = -- M.write 
-         M.unsafeWrite
-
--- | Macroblock that can be transformed.
-type MutableMacroBlock s a = M.STVector s a
-
-{-# INLINE createEmptyMutableMacroBlock #-}
--- | Create a new macroblock with the good array size
-createEmptyMutableMacroBlock :: (Storable a, Num a) => ST s (MutableMacroBlock s a)
-createEmptyMutableMacroBlock = M.replicate 64 0
-
-{-# INLINE mutate #-}
--- | Return the transformed block
-mutate :: Storable a
-       => (Int -> a -> a)   -- ^ The updating function
-       -> MutableMacroBlock s a -> ST s (MutableMacroBlock s a)
-mutate f block = update 0 >> return block
-   where updateVal i = (block .!!!. i) >>= (block .<-. i) . f i
-
-         update 63 = updateVal 63
-         update n  = updateVal n >> update (n + 1)
-
-printMacroBlock :: (Storable a, PrintfArg a)
-                => MutableMacroBlock s a -> ST s String
-printMacroBlock block = pLn 0
-    where pLn 64 = return "===============================\n"
-          pLn i = do
-              v <- block .!!!. i
-              vn <- pLn (i+1)
-              return $ printf (if i `mod` 8 == 0 then "\n%5d " else "%5d ") v ++ vn
-
− Codec/Picture/Png.hs 
@@ -1,461 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeSynonymInstances #-}
--- | Module used for loading & writing \'Portable Network Graphics\' (PNG)
--- files. The API has two layers, the high level, which load the image without
--- looking deeply about it and the low level, allowing access to data chunks contained
--- in the PNG image.
---
--- For general use, please use 'decodePng' function.
---
--- The loader has been validated against the pngsuite (http://www.libpng.org/pub/png/pngsuite.html)
-module Codec.Picture.Png( -- * High level functions
-                          PngSavable( .. )
-
-                        , decodePng
-                        , writePng
-                        , encodeDynamicPng
-                        , writeDynamicPng
-
-                        ) where
-
-import Control.Monad( foldM_, forM_, when )
-import Control.Monad.ST( ST, runST )
-import Control.Monad.Trans( lift )
-import Control.Monad.Primitive ( PrimState, PrimMonad )
-import qualified Control.Monad.Trans.State.Strict as S
-import Data.Serialize( Serialize, runGet, get)
-
-import qualified Data.Vector.Storable as V
-import qualified Data.Vector.Storable.Mutable as M
-import Data.Bits( (.&.), (.|.), shiftL, shiftR )
-import Data.List( find, zip4 )
-import Data.Word( Word8, Word16, Word32 )
-import qualified Codec.Compression.Zlib as Z
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as Lb
-import Foreign.Storable ( Storable )
-
-import Codec.Picture.Types
-import Codec.Picture.Png.Type
-import Codec.Picture.Png.Export
-
--- | Simple structure used to hold information about Adam7 deinterlacing.
--- A structure is used to avoid pollution of the module namespace.
-data Adam7MatrixInfo = Adam7MatrixInfo
-    { adam7StartingRow  :: [Int]
-    , adam7StartingCol  :: [Int]
-    , adam7RowIncrement :: [Int]
-    , adam7ColIncrement :: [Int]
-    , adam7BlockHeight  :: [Int]
-    , adam7BlockWidth   :: [Int]
-    }
-
--- | The real info about the matrix.
-adam7MatrixInfo :: Adam7MatrixInfo
-adam7MatrixInfo = Adam7MatrixInfo
-    { adam7StartingRow  = [0, 0, 4, 0, 2, 0, 1]
-    , adam7StartingCol  = [0, 4, 0, 2, 0, 1, 0]
-    , adam7RowIncrement = [8, 8, 8, 4, 4, 2, 2]
-    , adam7ColIncrement = [8, 8, 4, 4, 2, 2, 1]
-    , adam7BlockHeight  = [8, 8, 4, 4, 2, 2, 1]
-    , adam7BlockWidth   = [8, 4, 4, 2, 2, 1, 1]
-    }
-
-unparsePngFilter :: Word8 -> Either String PngFilter
-unparsePngFilter 0 = Right FilterNone
-unparsePngFilter 1 = Right FilterSub
-unparsePngFilter 2 = Right FilterUp
-unparsePngFilter 3 = Right FilterAverage
-unparsePngFilter 4 = Right FilterPaeth
-unparsePngFilter _ = Left "Invalid scanline filter"
-
-type ByteReader s a = S.StateT B.ByteString (ST s) a
-
-{-# INLINE getNextByte #-}
-getNextByte :: ByteReader s Word8
-getNextByte = do str <- S.get
-                 case B.uncons str of
-                    Just (v, rest) -> S.put rest >> return v
-                    Nothing -> return 0
-
-{-# INLINE (!!!) #-}
-(!!!) :: (Storable e) => V.Vector e -> Int -> e
-(!!!) = V.unsafeIndex
-
-{-# INLINE (.!!!.) #-}
-(.!!!.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> m a
-(.!!!.) = M.unsafeRead
-
-{-# INLINE (.<-.) #-}
-(.<-.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> a -> m ()
-(.<-.) = M.unsafeWrite
-
-{-# INLINE getBounds #-}
-getBounds :: (Monad m, Storable a) => M.STVector s a -> m (Int, Int)
-getBounds v = return (0, M.length v - 1)
-
--- | Apply a filtering method on a reduced image. Apply the filter
--- on each line, using the previous line (the one above it) to perform
--- some prediction on the value.
-pngFiltering :: LineUnpacker s -> Int -> (Int, Int)    -- ^ Image size
-             -> ByteReader s ()
-pngFiltering _ _ (imgWidth, imgHeight) | imgWidth <= 0 || imgHeight <= 0 = return ()
-pngFiltering unpacker beginZeroes (imgWidth, imgHeight) = do
-    thisLine <- lift $ M.replicate (beginZeroes + imgWidth) 0
-    otherLine <- lift $ M.replicate (beginZeroes + imgWidth) 0
-    foldM_ (\(previousLine, currentLine) lineIndex -> do
-               byte <- getNextByte
-               let lineFilter = case unparsePngFilter byte of
-                       Right FilterNone    -> filterNone
-                       Right FilterSub     -> filterSub
-                       Right FilterAverage -> filterAverage
-                       Right FilterUp      -> filterUp
-                       Right FilterPaeth   -> filterPaeth
-                       _ -> filterNone
-               lineFilter (previousLine, currentLine)
-               lift $ unpacker lineIndex (stride, currentLine)
-               return (currentLine, previousLine)
-        ) (thisLine, otherLine) [0 .. imgHeight - 1]
-
-    where stride = fromIntegral beginZeroes
-          lastIdx = beginZeroes + imgWidth - 1
-
-          -- The filter implementation are... well non-idiomatic
-          -- to say the least, but my benchmarks proved me one thing,
-          -- they are faster than mapM_, gained something like 5% with
-          -- a rewrite from mapM_ to this direct version
-          filterNone, filterSub, filterUp, filterPaeth,
-                filterAverage :: (PngLine s, PngLine s) -> ByteReader s ()
-          filterNone (_previousLine, thisLine) = inner beginZeroes
-            where inner idx | idx > lastIdx = return ()
-                            | otherwise = do byte <- getNextByte
-                                             lift $ (thisLine .<-. idx) byte
-                                             inner (idx + 1)
-
-          filterSub (_previousLine, thisLine) = inner beginZeroes
-            where inner idx | idx > lastIdx = return ()
-                            | otherwise = do byte <- getNextByte
-                                             val <- lift $ thisLine .!!!. (idx - stride)
-                                             lift . (thisLine .<-. idx) $ byte + val
-                                             inner (idx + 1)
-
-          filterUp (previousLine, thisLine) = inner beginZeroes
-            where inner idx | idx > lastIdx = return ()
-                            | otherwise = do byte <- getNextByte
-                                             val <- lift $ previousLine .!!!. idx
-                                             lift . (thisLine .<-. idx) $ val + byte
-                                             inner (idx + 1)
-
-          filterAverage (previousLine, thisLine) = inner beginZeroes
-            where inner idx | idx > lastIdx = return ()
-                            | otherwise = do byte <- getNextByte
-                                             valA <- lift $ thisLine .!!!. (idx - stride)
-                                             valB <- lift $ previousLine .!!!. idx
-                                             let a' = fromIntegral valA
-                                                 b' = fromIntegral valB
-                                                 average = fromIntegral ((a' + b') `div` (2 :: Word16)) 
-                                                 writeVal = byte + average 
-                                             lift . (thisLine .<-. idx) $ writeVal
-                                             inner (idx + 1)
-
-          filterPaeth (previousLine, thisLine) = inner beginZeroes
-            where inner idx | idx > lastIdx = return ()
-                            | otherwise = do byte <- getNextByte
-                                             valA <- lift $ thisLine .!!!. (idx - stride)
-                                             valC <- lift $ previousLine .!!!. (idx - stride)
-                                             valB <- lift $ previousLine .!!!. idx
-                                             lift . (thisLine .<-. idx) $ byte + paeth valA valB valC
-                                             inner (idx + 1)
-
--- | Directly stolen from the definition in the standard (on W3C page),
--- pixel predictor.
-paeth :: Word8 -> Word8 -> Word8 -> Word8
-paeth a b c
-  | pa <= pb && pa <= pc = a
-  | pb <= pc             = b
-  | otherwise            = c
-    where a' = fromIntegral a :: Int
-          b' = fromIntegral b
-          c' = fromIntegral c
-          p = a' + b' - c'
-          pa = abs $ p - a'
-          pb = abs $ p - b'
-          pc = abs $ p - c'
-
-type PngLine s = M.STVector s Word8
-type LineUnpacker s = Int -> (Int, PngLine s) -> ST s ()
-
-type StrideInfo  = (Int, Int)
-
-type BeginOffset = (Int, Int)
-
-
--- | Unpack lines where bit depth is 8
-byteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
-byteUnpacker sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
-             (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do
-    (_, maxIdx) <- getBounds line
-    let realTop = beginTop + h * strideHeight
-        lineIndex = realTop * imgWidth
-        pixelToRead = min (imgWidth - 1) $ (maxIdx - beginIdx) `div` sampleCount
-        inner pixelIndex | pixelIndex > pixelToRead = return ()
-                         | otherwise = do
-            let destPixelIndex = lineIndex + pixelIndex * strideWidth + beginLeft 
-                destSampleIndex = destPixelIndex * sampleCount
-                srcPixelIndex = pixelIndex * sampleCount + beginIdx
-                perPixel sample | sample >= sampleCount = return ()
-                                | otherwise = do
-                    val <- line .!!!. (srcPixelIndex + sample)
-                    let writeIdx = destSampleIndex + sample
-                    (arr .<-. writeIdx) val
-                    perPixel (sample + 1)
-            perPixel 0
-            inner (pixelIndex + 1)
-    inner 0
-             
-
--- | Unpack lines where bit depth is 1
-bitUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
-bitUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
-              (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do
-    (_, endLine) <- getBounds line
-    let realTop = beginTop + h * strideHeight
-        lineIndex = realTop * imgWidth
-        (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth
-        subPadd | subImageRest > 0 = 1
-                | otherwise = 0
-        (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 8
-    forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do
-        val <- line .!!!. (pixelIndex  + beginIdx)
-        let writeIdx n = lineIndex + (pixelIndex * 8 + n) * strideWidth + beginLeft 
-        forM_ [0 .. 7] $ \bit -> (arr .<-. writeIdx (7 - bit)) ((val `shiftR` bit) .&. 1)
-
-    when (lineRest /= 0)
-         (do val <- line .!!!. endLine
-             let writeIdx n = lineIndex + (pixelToRead * 8 + n) * strideWidth + beginLeft
-             forM_ [0 .. lineRest - 1] $ \bit ->
-                (arr .<-. writeIdx bit) ((val `shiftR` (7 - bit)) .&. 0x1))
-
-
--- | Unpack lines when bit depth is 2
-twoBitsUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
-twoBitsUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
-                  (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do
-    (_, endLine) <- getBounds line
-    let realTop = beginTop + h * strideHeight
-        lineIndex = realTop * imgWidth
-        (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth
-        subPadd | subImageRest > 0 = 1
-                | otherwise = 0
-        (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 4
-
-    forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do
-        val <- line .!!!. (pixelIndex  + beginIdx)
-        let writeIdx n = lineIndex + (pixelIndex * 4 + n) * strideWidth + beginLeft 
-        (arr .<-. writeIdx 0) $ (val `shiftR` 6) .&. 0x3
-        (arr .<-. writeIdx 1) $ (val `shiftR` 4) .&. 0x3
-        (arr .<-. writeIdx 2) $ (val `shiftR` 2) .&. 0x3
-        (arr .<-. writeIdx 3) $ val .&. 0x3
-
-    when (lineRest /= 0)
-         (do val <- line .!!!. endLine
-             let writeIdx n = lineIndex + (pixelToRead * 4 + n) * strideWidth + beginLeft
-             forM_ [0 .. lineRest - 1] $ \bit ->
-                (arr .<-. writeIdx bit) ((val `shiftR` (6 - 2 * bit)) .&. 0x3))
-
-halfByteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
-halfByteUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
-                   (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do
-    (_, endLine) <- getBounds line
-    let realTop = beginTop + h * strideHeight
-        lineIndex = realTop * imgWidth
-        (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth
-        subPadd | subImageRest > 0 = 1
-                | otherwise = 0
-        (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 2
-    forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do
-        val <- line .!!!. (pixelIndex  + beginIdx)
-        let writeIdx n = lineIndex + (pixelIndex * 2 + n) * strideWidth + beginLeft 
-        (arr .<-. writeIdx 0) $ (val `shiftR` 4) .&. 0xF
-        (arr .<-. writeIdx 1) $ val .&. 0xF
-    
-    when (lineRest /= 0)
-         (do val <- line .!!!. endLine
-             let writeIdx = lineIndex + (pixelToRead * 2) * strideWidth + beginLeft 
-             (arr .<-. writeIdx) $ (val `shiftR` 4) .&. 0xF)
-
-shortUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
-shortUnpacker sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
-             (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do
-    (_, maxIdx) <- getBounds line
-    let realTop = beginTop + h * strideHeight
-        lineIndex = realTop * imgWidth
-        pixelToRead = min (imgWidth - 1) $ (maxIdx - beginIdx) `div` (sampleCount * 2)
-    forM_ [0 .. pixelToRead] $ \pixelIndex -> do
-        let destPixelIndex = lineIndex + pixelIndex * strideWidth + beginLeft 
-            destSampleIndex = destPixelIndex * sampleCount
-            srcPixelIndex = pixelIndex * sampleCount * 2 + beginIdx
-        forM_ [0 .. sampleCount - 1] $ \sample -> do
-            highBits <- line .!!!. (srcPixelIndex + sample * 2 + 0)
-            lowBits <- line .!!!. (srcPixelIndex + sample * 2 + 1)
-            let fullValue = fromIntegral lowBits .|. (fromIntegral highBits `shiftL` 8) :: Word32
-                word8Max = 2 ^ (8 :: Word32) - 1 :: Word32
-                word16Max = 2 ^ (16 :: Word32) - 1 :: Word32
-                val = fullValue * word8Max `div` word16Max
-                writeIdx = destSampleIndex + sample
-            (arr .<-. writeIdx) $ fromIntegral val
-
--- | Transform a scanline to a bunch of bytes. Bytes are then packed
--- into pixels at a further step.
-scanlineUnpacker :: Int -> Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
-scanlineUnpacker 1 = bitUnpacker
-scanlineUnpacker 2 = twoBitsUnpacker
-scanlineUnpacker 4 = halfByteUnpacker
-scanlineUnpacker 8 = byteUnpacker
-scanlineUnpacker 16 = shortUnpacker
-scanlineUnpacker _ = error "Impossible bit depth"
-
-byteSizeOfBitLength :: Int -> Int -> Int -> Int
-byteSizeOfBitLength pixelBitDepth sampleCount dimension = size + (if rest /= 0 then 1 else 0)
-   where (size, rest) = (pixelBitDepth * dimension * sampleCount) `quotRem` 8
-
-scanLineInterleaving :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s)
-                     -> ByteReader s ()
-scanLineInterleaving depth sampleCount (imgWidth, imgHeight) unpacker =
-    pngFiltering (unpacker (1,1) (0, 0)) strideInfo (byteWidth, imgHeight)
-        where byteWidth = byteSizeOfBitLength depth sampleCount imgWidth
-              strideInfo | depth < 8 = 1
-                         | otherwise = sampleCount * (depth `div` 8)
-
--- | Given data and image size, recreate an image with deinterlaced
--- data for PNG's adam 7 method.
-adam7Unpack :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s)
-            -> ByteReader s ()
-adam7Unpack depth sampleCount (imgWidth, imgHeight) unpacker = sequence_
-  [pngFiltering (unpacker (incrW, incrH) (beginW, beginH)) strideInfo (byteWidth, passHeight)
-                | (beginW, incrW, beginH, incrH) <- zip4 startCols colIncrement startRows rowIncrement
-                , let passWidth = sizer imgWidth beginW incrW
-                      passHeight = sizer imgHeight beginH incrH
-                      byteWidth = byteSizeOfBitLength depth sampleCount passWidth
-                ]
-    where Adam7MatrixInfo { adam7StartingRow  = startRows
-                          , adam7RowIncrement = rowIncrement
-                          , adam7StartingCol  = startCols
-                          , adam7ColIncrement = colIncrement } = adam7MatrixInfo
-
-          strideInfo | depth < 8 = 1
-                     | otherwise = sampleCount * (depth `div` 8)
-          sizer dimension begin increment
-            | dimension <= begin = 0
-            | otherwise = outDim + (if restDim /= 0 then 1 else 0)
-                where (outDim, restDim) = (dimension - begin) `quotRem` increment
-
--- | deinterlace picture in function of the method indicated
--- in the iHDR
-deinterlacer :: PngIHdr -> ByteReader s (M.STVector s Word8)
-deinterlacer (PngIHdr { width = w, height = h, colourType  = imgKind
-                      , interlaceMethod = method, bitDepth = depth  }) = do
-    let compCount = sampleCountOfImageType imgKind 
-        arraySize = fromIntegral $ w * h * compCount
-        deinterlaceFunction = case method of
-            PngNoInterlace -> scanLineInterleaving
-            PngInterlaceAdam7 -> adam7Unpack
-        iBitDepth = fromIntegral depth
-    imgArray <- lift $ M.replicate arraySize 0
-    let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray
-    deinterlaceFunction iBitDepth 
-                        (fromIntegral compCount)
-                        (fromIntegral w, fromIntegral h)
-                        (scanlineUnpacker iBitDepth (fromIntegral compCount)
-                                                    mutableImage)
-    return imgArray
-
-generateGreyscalePalette :: Word8 -> PngPalette
-generateGreyscalePalette times = V.fromListN (fromIntegral possibilities + 1) pixels
-    where possibilities = 2 ^ times - 1
-          pixels = [PixelRGB8 i i i | n <- [0..possibilities]
-                                    , let i = n * (255 `div` possibilities)]
-
-sampleCountOfImageType :: PngImageType -> Word32
-sampleCountOfImageType PngGreyscale = 1
-sampleCountOfImageType PngTrueColour = 3
-sampleCountOfImageType PngIndexedColor = 1
-sampleCountOfImageType PngGreyscaleWithAlpha = 2
-sampleCountOfImageType PngTrueColourWithAlpha = 4
-
-paletteRGBA1, paletteRGBA2, paletteRGBA4 :: PngPalette
-paletteRGBA1 = generateGreyscalePalette 1
-paletteRGBA2 = generateGreyscalePalette 2
-paletteRGBA4 = 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 = pal !!! fromIntegral ipx]
-
--- | Transform a raw png image to an image, without modifying the
--- underlying pixel type. If the image is greyscale and < 8 bits,
--- a transformation to RGBA8 is performed. This should change
--- in the future.
--- The resulting image let you manage the pixel types.
---
--- This function can output the following pixel types :
---
---    * PixelY8
---
---    * PixelYA8
---
---    * PixelRGB8
---
---    * PixelRGBA8
---
-decodePng :: B.ByteString -> Either String DynamicImage
-decodePng byte = do
-    rawImg <- runGet get byte
-    let ihdr@(PngIHdr { width = w, height = h }) = header rawImg
-        compressedImageData =
-              B.concat [chunkData chunk | chunk <- chunks rawImg
-                                        , chunkType chunk == iDATSignature]
-        zlibHeaderSize = 1 {- compression method/flags code -}
-                       + 1 {- Additional flags/check bits -}
-                       + 4 {-CRC-}
-
-        imager = Image (fromIntegral w) (fromIntegral h)
-
-        unparse _ PngGreyscale bytes
-            | bitDepth ihdr == 1 = unparse (Just paletteRGBA1) PngIndexedColor bytes
-            | bitDepth ihdr == 2 = unparse (Just paletteRGBA2) PngIndexedColor bytes
-            | bitDepth ihdr == 4 = unparse (Just paletteRGBA4) PngIndexedColor bytes
-            | otherwise = Right . ImageY8 . imager $ runST stArray
-                where stArray = S.evalStateT (deinterlacer ihdr) bytes >>= V.unsafeFreeze
-        unparse Nothing PngIndexedColor  _ = Left "no valid palette found"
-        unparse _ PngTrueColour          bytes =
-            Right . ImageRGB8 . imager $ runST stArray
-                where stArray = S.evalStateT (deinterlacer ihdr) bytes >>= V.unsafeFreeze
-        unparse _ PngGreyscaleWithAlpha  bytes =
-            Right . ImageYA8 . imager $ runST stArray
-                where stArray = S.evalStateT (deinterlacer ihdr) bytes >>= V.unsafeFreeze
-        unparse _ PngTrueColourWithAlpha bytes =
-            Right . ImageRGBA8 . imager $ runST stArray
-                where stArray = S.evalStateT (deinterlacer ihdr) bytes >>= V.unsafeFreeze
-        unparse (Just plte) PngIndexedColor bytes =
-            Right . ImageRGB8 . imager $ applyPalette plte uarray
-                where stArray = S.evalStateT (deinterlacer ihdr) bytes >>= V.unsafeFreeze
-                      uarray = runST stArray
-
-    if B.length compressedImageData <= zlibHeaderSize
-       then Left "Invalid data size"
-       else let imgData = Z.decompress $ Lb.fromChunks [compressedImageData]
-       	        parseableData = B.concat $ Lb.toChunks imgData
-                palette = case find (\c -> pLTESignature == chunkType c) $ chunks rawImg of
-                    Nothing -> Nothing
-                    Just p -> case parsePalette p of
-                            Left _ -> Nothing
-                            Right plte -> Just plte
-            in unparse palette (colourType ihdr) parseableData
-
− Codec/Picture/Png/Export.hs 
@@ -1,105 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeSynonymInstances #-}
--- | Module implementing a basic png export, no filtering is applyed, but
--- export at least valid images.
-module Codec.Picture.Png.Export( PngSavable( .. )
-                               , writePng
-                               , encodeDynamicPng
-                               , writeDynamicPng
-                               ) where
-
-import Data.Serialize(encode)
-import Data.Vector.Storable ( (!) )
-import Data.Word(Word8)
-import qualified Codec.Compression.Zlib as Z
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as Lb
-
-import Codec.Picture.Types
-import Codec.Picture.Png.Type
-
--- | Encode an image into a png if possible.
-class PngSavable a where
-    -- | Transform an image into a png encoded bytestring, ready
-    -- to be writte as a file.
-    encodePng :: Image a -> B.ByteString
-
-preparePngHeader :: Image a -> PngImageType -> Word8 -> PngIHdr
-preparePngHeader (Image { imageWidth = w, imageHeight = h }) imgType depth = PngIHdr
-    { width             = fromIntegral w
-    , height            = fromIntegral h
-    , bitDepth          = depth
-    , colourType        = imgType
-    , compressionMethod = 0
-    , filterMethod      = 0
-    , interlaceMethod   = PngNoInterlace
-    }
-
--- | Helper function to directly write an image as a png on disk.
-writePng :: (PngSavable pixel) => FilePath -> Image pixel -> IO ()
-writePng path img = B.writeFile path $ encodePng img
-
-endChunk :: PngRawChunk
-endChunk = PngRawChunk { chunkLength = 0
-                       , chunkType = iENDSignature
-                       , chunkCRC = pngComputeCrc [iENDSignature]
-                       , chunkData = B.empty
-                       }
-
-
-prepareIDatChunk :: B.ByteString -> PngRawChunk
-prepareIDatChunk imgData = PngRawChunk
-    { chunkLength = fromIntegral $ B.length imgData
-    , chunkType   = iDATSignature
-    , chunkCRC    = pngComputeCrc [iDATSignature, imgData]
-    , chunkData   = imgData
-    }
-
-genericEncodePng :: PngImageType -> Int -> Image a -> B.ByteString
-genericEncodePng imgKind compCount 
-                 image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) =
-  encode PngRawImage { header = hdr, chunks = [prepareIDatChunk strictEncoded, endChunk]}
-    where hdr = preparePngHeader image imgKind 8
-          compBound = compCount - 1
-          encodeLine line =
-            0 : [arr ! ((line * w + column) * compCount + comp) | column <- [0 .. w - 1]
-                                                                , comp <- [0 .. compBound]]
-          imgEncodedData = Z.compress . Lb.pack 
-                         $ concat [encodeLine line | line <- [0 .. h - 1]]
-          strictEncoded = B.concat $ Lb.toChunks imgEncodedData
-
-instance PngSavable PixelRGBA8 where
-    encodePng = genericEncodePng PngTrueColourWithAlpha 4
-        
-instance PngSavable PixelRGB8 where
-    encodePng = genericEncodePng PngTrueColour 3
-
-instance PngSavable Pixel8 where
-    encodePng = genericEncodePng PngGreyscale 1
-
-instance PngSavable PixelYA8 where
-    encodePng = genericEncodePng PngGreyscaleWithAlpha 2
-
--- | 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 path img = case encodeDynamicPng img of
-        Left err -> return $ Left err
-        Right b  -> B.writeFile path b >> return (Right True)
-
--- | Encode a dynamic image in bmp if possible, supported pixel type are :
---
---   - Y8
---
---   - YA8
---
---   - RGB8
---
---   - RGBA8
---
-encodeDynamicPng :: DynamicImage -> Either String B.ByteString
-encodeDynamicPng (ImageRGB8 img) = Right $ encodePng img
-encodeDynamicPng (ImageRGBA8 img) = Right $ encodePng img
-encodeDynamicPng (ImageY8 img) = Right $ encodePng img
-encodeDynamicPng (ImageYA8 img) = Right $ encodePng img
-encodeDynamicPng _ = Left "Unsupported image format for PNG export"
− Codec/Picture/Png/Type.hs 
@@ -1,316 +0,0 @@--- | Low level png module, you should import 'Codec.Picture.Png' instead.
-module Codec.Picture.Png.Type( PngIHdr( .. )
-                             , PngFilter( .. )
-                             , PngInterlaceMethod( .. )
-                             , PngPalette
-                             , PngImageType( .. )
-                             , parsePalette 
-                             , pngComputeCrc
-                             , pLTESignature
-                             , iDATSignature
-                             , iENDSignature
-                             -- * Low level types
-                             , ChunkSignature
-                             , PngRawImage( .. )
-                             , PngChunk( .. )
-                             , PngRawChunk( .. )
-                             , PngLowLevel( .. )
-                             ) where
-
-import Control.Applicative( (<$>) )
-import Control.Monad( when, replicateM )
-import Data.Bits( xor, (.&.), shiftR )
-import Data.Serialize( Serialize(..), Get, get, runGet, runPut
-                     , putWord8, getWord8
-                     , putWord32be, getWord32be
-                     , getByteString, putByteString )
-import Data.Vector.Unboxed( Vector, fromListN, (!) )
-import qualified Data.Vector.Storable as V
-import Data.List( foldl' )
-import Data.Word( Word32, Word8 )
-import qualified Data.ByteString as B
-
-import Codec.Picture.Types
-
---------------------------------------------------
-----            Types
---------------------------------------------------
-
--- | Value used to identify a png chunk, must be 4 bytes long.
-type ChunkSignature = B.ByteString
-
--- | Generic header used in PNG images.
-data PngIHdr = PngIHdr
-    { width             :: Word32       -- ^ Image width in number of pixel
-    , height            :: Word32       -- ^ Image height in number of pixel
-    , bitDepth          :: Word8        -- ^ Number of bit per sample
-    , colourType        :: PngImageType -- ^ Kind of png image (greyscale, true color, indexed...)
-    , compressionMethod :: Word8        -- ^ Compression method used
-    , filterMethod      :: Word8        -- ^ Must be 0
-    , interlaceMethod   :: PngInterlaceMethod   -- ^ If the image is interlaced (for progressive rendering)
-    }
-    deriving Show
-
--- | What kind of information is encoded in the IDAT section
--- of the PngFile
-data PngImageType =
-      PngGreyscale
-    | PngTrueColour
-    | PngIndexedColor
-    | PngGreyscaleWithAlpha
-    | PngTrueColourWithAlpha
-    deriving Show
-
--- | Raw parsed image which need to be decoded.
-data PngRawImage = PngRawImage
-    { header       :: PngIHdr
-    , chunks       :: [PngRawChunk]
-    }
-
--- | Palette with indices beginning at 0 to elemcount - 1
-type PngPalette = V.Vector 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 = V.fromListN pixelCount <$> runGet pixelUnpacker (chunkData plte)
-    where pixelUnpacker = replicateM (fromIntegral pixelCount) get
-          pixelCount = fromIntegral $ chunkLength plte `div` 3
-
--- | Data structure during real png loading/parsing
-data PngRawChunk = PngRawChunk
-    { chunkLength :: Word32
-    , chunkType   :: ChunkSignature
-    , chunkCRC    :: Word32
-    , chunkData   :: B.ByteString
-    }
-
--- | PNG chunk representing some extra information found in the parsed file.
-data PngChunk = PngChunk
-    { pngChunkData        :: B.ByteString  -- ^ The raw data inside the chunk
-    , pngChunkSignature   :: ChunkSignature -- ^ The name of the chunk.
-    }
-
--- | Low level access to PNG information
-data PngLowLevel a = PngLowLevel
-    { pngImage  :: Image a      -- ^ The real uncompressed image
-    , pngChunks :: [PngChunk]   -- ^ List of raw chunk where some user data might be present.
-    }
-
--- | The pixels value should be :
--- +---+---+
--- | c | b |
--- +---+---+
--- | a | x |
--- +---+---+
--- x being the current filtered pixel
-data PngFilter =
-    -- | Filt(x) = Orig(x), Recon(x) = Filt(x)
-      FilterNone
-    -- | Filt(x) = Orig(x) - Orig(a), 	Recon(x) = Filt(x) + Recon(a)
-    | FilterSub
-    -- | Filt(x) = Orig(x) - Orig(b), 	Recon(x) = Filt(x) + Recon(b)
-    | FilterUp
-    -- | Filt(x) = Orig(x) - floor((Orig(a) + Orig(b)) / 2),
-    -- Recon(x) = Filt(x) + floor((Recon(a) + Recon(b)) / 2)
-    | FilterAverage
-    -- | Filt(x) = Orig(x) - PaethPredictor(Orig(a), Orig(b), Orig(c)),
-    -- Recon(x) = Filt(x) + PaethPredictor(Recon(a), Recon(b), Recon(c))
-    | FilterPaeth
-    deriving (Enum, Show)
-
--- | Different known interlace methods for PNG image
-data PngInterlaceMethod =
-      -- | No interlacing, basic data ordering, line by line
-      -- from left to right.
-      PngNoInterlace
-
-      -- | Use the Adam7 ordering, see `adam7Reordering`
-    | PngInterlaceAdam7
-    deriving (Enum, Show)
-
---------------------------------------------------
-----            Instances
---------------------------------------------------
-instance Serialize PngFilter where
-    put = putWord8 . toEnum . fromEnum
-    get = getWord8 >>= \w -> case w of
-        0 -> return FilterNone
-        1 -> return FilterSub
-        2 -> return FilterUp
-        3 -> return FilterAverage
-        4 -> return FilterPaeth
-        _ -> fail "Invalid scanline filter"
-
-instance Serialize PngRawImage where
-    put img = do
-        putByteString pngSignature
-        put $ header img
-        mapM_ put $ chunks img
-
-    get = parseRawPngImage
-
-instance Serialize PngRawChunk where
-    put chunk = do
-        putWord32be $ chunkLength chunk
-        putByteString $ chunkType chunk
-        when (chunkLength chunk /= 0)
-             (putByteString $ chunkData chunk)
-        putWord32be $ chunkCRC chunk
-
-    get = do
-        size <- getWord32be
-        chunkSig <- getByteString (B.length iHDRSignature)
-        imgData <- if size == 0
-            then return B.empty
-            else getByteString (fromIntegral size)
-        crc <- getWord32be
-
-        let computedCrc = pngComputeCrc [chunkSig, imgData]
-        when (computedCrc `xor` crc /= 0)
-             (fail $ "Invalid CRC : " ++ show computedCrc ++ ", "
-                                      ++ show crc)
-        return PngRawChunk {
-        	chunkLength = size,
-        	chunkData = imgData,
-        	chunkCRC = crc,
-        	chunkType = chunkSig
-        }
-
-instance Serialize PngIHdr where
-    put hdr = do
-        putWord32be 13
-        let inner = runPut $ do
-                putByteString iHDRSignature
-                putWord32be $ width hdr
-                putWord32be $ height hdr
-                putWord8    $ bitDepth hdr
-                put $ colourType hdr
-                put $ compressionMethod hdr
-                put $ filterMethod hdr
-                put $ interlaceMethod hdr
-            crc = pngComputeCrc [inner]
-        putByteString inner
-        putWord32be crc
-
-    get = do
-        _size <- getWord32be
-        ihdrSig <- getByteString (B.length iHDRSignature)
-        when (ihdrSig /= iHDRSignature)
-             (fail "Invalid PNG file, wrong ihdr")
-        w <- getWord32be
-        h <- getWord32be
-        depth <- get
-        colorType <- get
-        compression <- get
-        filtermethod <- get
-        interlace <- get
-        _crc <- getWord32be
-        return PngIHdr {
-        	width = w,
-        	height = h,
-        	bitDepth = depth,
-        	colourType = colorType,
-            compressionMethod = compression,
-            filterMethod = filtermethod,
-            interlaceMethod = interlace
-        }
-
--- | Parse method for a png chunk, without decompression.
-parseChunks :: Get [PngRawChunk]
-parseChunks = do
-    chunk <- get
-
-    if chunkType chunk == iENDSignature
-       then return [chunk]
-       else (chunk:) <$> parseChunks
-
-
-instance Serialize PngInterlaceMethod where
-    get = getWord8 >>= \w -> case w of
-        0 -> return PngNoInterlace
-        1 -> return PngInterlaceAdam7
-        _ -> fail "Invalid interlace method"
-
-    put PngNoInterlace    = putWord8 0
-    put PngInterlaceAdam7 = putWord8 1
-
--- | Implementation of the get method for the PngRawImage,
--- unpack raw data, without decompressing it.
-parseRawPngImage :: Get PngRawImage
-parseRawPngImage = do
-    sig <- getByteString (B.length pngSignature)
-    when (sig /= pngSignature)
-         (fail "Invalid PNG file, signature broken")
-
-    ihdr <- get
-
-    chunkList <- parseChunks
-    return PngRawImage { header = ihdr, chunks = chunkList }
-
---------------------------------------------------
-----            functions
---------------------------------------------------
-
--- | Signature signalling that the following data will be a png image
--- in the png bit stream
-pngSignature :: ChunkSignature
-pngSignature = signature [137, 80, 78, 71, 13, 10, 26, 10]
-
--- | Helper function to help pack signatures.
-signature :: [Word8] -> ChunkSignature
-signature = B.pack . map (toEnum . fromEnum)
-
--- | Signature for the header chunk of png (must be the first)
-iHDRSignature :: ChunkSignature 
-iHDRSignature = signature [73, 72, 68, 82]
-
--- | Signature for a palette chunk in the pgn file. Must
--- occure before iDAT.
-pLTESignature :: ChunkSignature
-pLTESignature = signature [80, 76, 84, 69]
-
--- | Signature for a data chuck (with image parts in it)
-iDATSignature :: ChunkSignature
-iDATSignature = signature [73, 68, 65, 84]
-
--- | Signature for the last chunk of a png image, telling
--- the end.
-iENDSignature :: ChunkSignature
-iENDSignature = signature [73, 69, 78, 68]
-
-instance Serialize PngImageType where
-    put PngGreyscale = putWord8 0
-    put PngTrueColour = putWord8 2
-    put PngIndexedColor = putWord8 3
-    put PngGreyscaleWithAlpha = putWord8 4
-    put PngTrueColourWithAlpha = putWord8 6
-
-    get = get >>= imageTypeOfCode
-
-imageTypeOfCode :: Word8 -> Get PngImageType
-imageTypeOfCode 0 = return PngGreyscale
-imageTypeOfCode 2 = return PngTrueColour
-imageTypeOfCode 3 = return PngIndexedColor
-imageTypeOfCode 4 = return PngGreyscaleWithAlpha
-imageTypeOfCode 6 = return PngTrueColourWithAlpha
-imageTypeOfCode _ = fail "Invalid png color code"
-
--- | From the Annex D of the png specification.
-pngCrcTable :: Vector Word32
-pngCrcTable = fromListN 256 [ foldl' updateCrcConstant c [zero .. 7] | c <- [0 .. 255] ]
-    where zero = 0 :: Int -- To avoid defaulting to Integer
-          updateCrcConstant c _ | c .&. 1 /= 0 = magicConstant `xor` (c `shiftR` 1)
-                                | otherwise = c `shiftR` 1
-          magicConstant = 0xedb88320 :: Word32
-
--- | Compute the CRC of a raw buffer, as described in annex D of the PNG
--- specification.
-pngComputeCrc :: [B.ByteString] -> Word32
-pngComputeCrc = (0xFFFFFFFF `xor`) . B.foldl' updateCrc 0xFFFFFFFF . B.concat
-    where updateCrc crc val =
-              let u32Val = fromIntegral val
-                  lutVal = pngCrcTable ! (fromIntegral ((crc `xor` u32Val) .&. 0xFF))
-              in lutVal `xor` (crc `shiftR` 8)
-
− Codec/Picture/Saving.hs 
@@ -1,46 +0,0 @@-module Codec.Picture.Saving( imageToJpg
-                           , imageToPng
-                           , imageToBitmap
-                           ) where
-
-import qualified Data.ByteString as B
-import Codec.Picture.Bitmap
-import Codec.Picture.Jpg
-import Codec.Picture.Png
-import Codec.Picture.Types
-
--- | This function will try to do anything to encode an image
--- as JPEG, make all color conversion and such. Equivalent
--- of 'decodeImage' for jpeg encoding
-imageToJpg :: Int -> DynamicImage -> B.ByteString
-imageToJpg quality dynImage =
-    let encodeAtQuality = encodeJpegAtQuality (fromIntegral quality)
-    in case dynImage of
-        ImageYCbCr8 img -> encodeAtQuality img
-        ImageRGB8   img -> encodeAtQuality (convertImage img)
-        ImageRGBA8  img -> encodeAtQuality (convertImage $ dropAlphaLayer img)
-        ImageY8     img -> encodeAtQuality . convertImage
-                                           $ (promoteImage img :: Image PixelRGB8)
-        ImageYA8    img -> encodeAtQuality $
-                            convertImage (promoteImage $ dropAlphaLayer img :: Image PixelRGB8)
-
--- | This function will try to do anything to encode an image
--- as PNG, make all color conversion and such. Equivalent
--- of 'decodeImage' for PNG encoding
-imageToPng :: DynamicImage -> B.ByteString
-imageToPng (ImageYCbCr8 img) = encodePng (convertImage img :: Image PixelRGB8)
-imageToPng (ImageRGB8   img) = encodePng img
-imageToPng (ImageRGBA8  img) = encodePng img
-imageToPng (ImageY8     img) = encodePng img
-imageToPng (ImageYA8    img) = encodePng (promoteImage img :: Image PixelRGBA8)
-
--- | This function will try to do anything to encode an image
--- as bitmap, make all color conversion and such. Equivalent
--- of 'decodeImage' for Bitmap encoding
-imageToBitmap :: DynamicImage -> B.ByteString
-imageToBitmap (ImageYCbCr8 img) = encodeBitmap (convertImage img :: Image PixelRGB8)
-imageToBitmap (ImageRGB8   img) = encodeBitmap img
-imageToBitmap (ImageRGBA8  img) = encodeBitmap img
-imageToBitmap (ImageY8     img) = encodeBitmap img
-imageToBitmap (ImageYA8    img) = encodeBitmap (promoteImage img :: Image PixelRGBA8)
-
− Codec/Picture/Types.hs 
@@ -1,837 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
--- | Module providing the basic types for image manipulation in the library.
--- Defining the types used to store all those _Juicy Pixels_
-module Codec.Picture.Types( -- * Types
-                            -- ** Image types
-                            Image( .. )
-                          , MutableImage( .. )
-                          , DynamicImage( .. )
-                          , PixelType( .. )
-                            -- ** Pixel types
-                          , Pixel8
-                          , PixelYA8( .. )
-                          , PixelRGB8( .. )
-                          , PixelRGBA8( .. )
-                          , PixelYCbCr8( .. )
-
-                          -- * Type classes
-                          , ColorConvertible( .. )
-                          , Pixel(..)
-                          , ColorSpaceConvertible( .. )
-                          , LumaPlaneExtractable( .. )
-                          , TransparentPixel( .. )
-
-                            -- * Helper functions
-                          , canConvertTo
-                          , pixelMap
-                          , dropAlphaLayer
-                          , generateImage
-                          , generateFoldImage
-
-                            -- * Color plane extraction
-                          , ColorPlane ( )
-
-                          , PlaneRed( .. )
-                          , PlaneGreen( .. )
-                          , PlaneBlue( .. )
-                          , PlaneAlpha( .. )
-                          , PlaneLuma( .. )
-                          , PlaneCr( .. )
-                          , PlaneCb( .. )
-
-                          , extractComponent
-                          , unsafeExtractComponent
-                          ) where
-
-import Control.Monad( forM_, foldM )
-import Control.Applicative( (<$>), (<*>) )
-import Control.DeepSeq( NFData( .. ) )
-import Control.Monad.ST( ST, runST )
-import Control.Monad.Primitive ( PrimMonad, PrimState )
-import Foreign.Storable ( Storable, sizeOf, alignment, peek, poke )
-import Foreign.Ptr ( plusPtr )
-import Data.Word( Word8 )
-import Data.Vector.Storable ( (!) )
-import qualified Data.Vector.Storable as V
-import qualified Data.Vector.Storable.Mutable as M
-import Data.Serialize( Serialize, put, get )
-
-
--- | Image or pixel buffer, the coordinates are assumed to start
--- from the upper-left corner of the image, with the horizontal
--- position first, then the vertical one.
-data Image a = Image
-    { -- | Width of the image in pixels
-      imageWidth  :: {-# UNPACK #-} !Int
-      -- | Height of the image in pixels.
-    , imageHeight :: {-# UNPACK #-} !Int
-
-      -- | The real image, to extract pixels at some position
-      -- you should use the helpers functions.
-    , imageData   :: V.Vector Word8
-    }
-
-{-# INLINE (!!!) #-}
-(!!!) :: (Storable e) => V.Vector e -> Int -> e
-(!!!) = V.unsafeIndex
-
--- | Class used to describle plane present in the pixel
--- type. If a pixel has a plane description associated,
--- you can use the plane name to extract planes independently.
-class ColorPlane pixel planeToken where
-    -- | Retrieve the index of the component in the
-    -- given pixel type.
-    toComponentIndex :: pixel -> planeToken -> Int
-
--- | Define the plane for the red color component
-data PlaneRed = PlaneRed
-
--- | Define the plane for the green color component
-data PlaneGreen = PlaneGreen
-
--- | Define the plane for the blue color component
-data PlaneBlue = PlaneBlue
-
--- | Define the plane for the alpha (transparency) component
-data PlaneAlpha = PlaneAlpha
-
--- | Define the plane for the luma component
-data PlaneLuma = PlaneLuma 
-
--- | Define the plane for the Cr component
-data PlaneCr = PlaneCr
-
--- | Define the plane for the Cb component
-data PlaneCb = PlaneCb
-
-instance ColorPlane PixelYCbCr8 PlaneLuma where
-    toComponentIndex _ _ = 0
-
-instance ColorPlane PixelYCbCr8 PlaneCb where
-    toComponentIndex _ _ = 1
-
-instance ColorPlane PixelYCbCr8 PlaneCr where
-    toComponentIndex _ _ = 2
-
-instance ColorPlane PixelYA8 PlaneLuma where
-    toComponentIndex _ _ = 0
-
-instance ColorPlane PixelYA8 PlaneAlpha where
-    toComponentIndex _ _ = 1
-    
-instance ColorPlane PixelRGB8 PlaneRed where
-    toComponentIndex _ _ = 0
-
-instance ColorPlane PixelRGB8 PlaneGreen where
-    toComponentIndex _ _ = 1
-
-instance ColorPlane PixelRGB8 PlaneBlue where
-    toComponentIndex _ _ = 2
-
-instance ColorPlane PixelRGBA8 PlaneRed where
-    toComponentIndex _ _ = 0
-
-instance ColorPlane PixelRGBA8 PlaneGreen where
-    toComponentIndex _ _ = 1
-
-instance ColorPlane PixelRGBA8 PlaneBlue where
-    toComponentIndex _ _ = 2
-
-instance ColorPlane PixelRGBA8 PlaneAlpha where
-    toComponentIndex _ _ = 3
-
--- | Extract a color plane from an image given a present plane in the image
--- examples :
---
--- @
---  extractRedPlane :: Image PixelRGB8-> Image Pixel8
---  extractRedPlane = extractComponent PlaneRed
--- @
---
-extractComponent :: forall px plane. (Pixel px, ColorPlane px plane)
-                 => plane -> Image px -> Image Pixel8
-extractComponent plane = unsafeExtractComponent idx
-    where idx = toComponentIndex (undefined :: px) plane
-
--- | Extract an image plane of an image, returning an image which
--- can be represented by a gray scale image.
--- If you ask a component out of bound, the `error` function will
--- be called
-unsafeExtractComponent :: forall a. (Pixel a) 
-                       => Int     -- ^ The component index, beginning at 0 ending at (componentCount - 1)
-                       -> Image a -- ^ Source image
-                       -> Image Pixel8
-unsafeExtractComponent comp img@(Image { imageWidth = w, imageHeight = h })
-  | comp >= padd = error $ "extractComponent : invalid component index (" 
-                         ++ show comp ++ ", max:" ++ show padd ++ ")"
-  | otherwise = Image { imageWidth = w, imageHeight = h, imageData = plane }
-      where plane = stride img 1 padd comp
-            padd = componentCount (undefined :: a)
-
--- | For any image with an alpha component (transparency),
--- drop it, returning a pure opaque image.
-dropAlphaLayer :: (TransparentPixel a b) => Image a -> Image b
-dropAlphaLayer = pixelMap dropTransparency
-
--- | Class modeling transparent pixel, should provide a method
--- to combine transparent pixels
-class (Pixel a, Pixel b) => TransparentPixel a b | a -> b where
-    -- | Just return the opaque pixel value
-    dropTransparency :: a -> b
-
-instance TransparentPixel PixelYA8 Pixel8 where
-    {-# INLINE dropTransparency #-}
-    dropTransparency (PixelYA8 y _) = y
-
-instance TransparentPixel PixelRGBA8 PixelRGB8 where
-    {-# INLINE dropTransparency #-}
-    dropTransparency (PixelRGBA8 r g b _) = PixelRGB8 r g b
-
-stride :: Image a -> Int -> Int -> Int -> V.Vector Word8
-stride Image { imageWidth = w, imageHeight = h, imageData = array }
-        run padd firstComponent = runST $ do
-    let cell_count = w * h * run
-    outArray <- M.new cell_count
-
-    let strideWrite write_idx _ | write_idx == cell_count = return ()
-        strideWrite write_idx read_idx = do
-            forM_ [0 .. run - 1] $ \i ->
-                (outArray .<-. (write_idx + i)) $ array !!! (read_idx + i)
-            strideWrite (write_idx + run) (read_idx + padd)
-            
-    strideWrite 0 firstComponent
-    V.unsafeFreeze outArray
-
-instance NFData (Image a) where
-    rnf (Image width height dat) = width  `seq`
-                                   height `seq`
-                                   dat    `seq`
-                                   ()
-
--- | Image or pixel buffer, the coordinates are assumed to start
--- from the upper-left corner of the image, with the horizontal
--- position first, then the vertical one. The image can be transformed in place.
-data MutableImage s a = MutableImage 
-    { -- | Width of the image in pixels
-	  mutableImageWidth  :: {-# UNPACK #-} !Int
-
-      -- | Height of the image in pixels.
-	, mutableImageHeight :: {-# UNPACK #-} !Int
-
-      -- | The real image, to extract pixels at some position
-      -- you should use the helpers functions.
-    , mutableImageData   :: M.STVector s Word8
-    }
-
-instance NFData (MutableImage s a) where
-    rnf (MutableImage width height dat) = width  `seq`
-                                          height `seq`
-                                          dat    `seq`
-                                          ()
-
--- | Type allowing the loading of an image with different pixel
--- structures
-data DynamicImage =
-       -- | A greyscale image.
-       ImageY8   (Image Pixel8)
-       -- | An image in greyscale with an alpha channel.
-     | ImageYA8  (Image PixelYA8)
-       -- | An image in true color.
-     | ImageRGB8 (Image PixelRGB8)
-       -- | An image in true color and an alpha channel.
-     | ImageRGBA8 (Image PixelRGBA8)
-       -- | An image in the colorspace used by Jpeg images.
-     | ImageYCbCr8 (Image PixelYCbCr8)
-
-instance NFData DynamicImage where
-    rnf (ImageY8 img)     = rnf img
-    rnf (ImageYA8 img)    = rnf img
-    rnf (ImageRGB8 img)   = rnf img
-    rnf (ImageRGBA8 img)  = rnf img
-    rnf (ImageYCbCr8 img) = rnf img
-
--- | Simple alias for greyscale value in 8 bits.
-type Pixel8 = Word8
-
--- | Pixel type storing Luminance (Y) and alpha information
--- on 8 bits.
--- Value are stored in the following order :
---
---  * Luminance
---
---  * Alpha
---
-data PixelYA8 = PixelYA8 {-# UNPACK #-} !Word8  -- Luminance
-                         {-# UNPACK #-} !Word8  -- Alpha value
-
--- | Pixel type storing classic pixel on 8 bits
--- Value are stored in the following order :
---
---  * Red
---
---  * Green
---
---  * Blue
---
-data PixelRGB8 = PixelRGB8 {-# UNPACK #-} !Word8 -- Red
-                           {-# UNPACK #-} !Word8 -- Green
-                           {-# UNPACK #-} !Word8 -- Blue
-
--- | Pixel storing data in the YCbCr colorspace,
--- value are stored in the following order :
---
---  * Y (luminance)
---
---  * Cr
---
---  * Cb
---
-data PixelYCbCr8 = PixelYCbCr8 {-# UNPACK #-} !Word8 -- Y luminance
-                               {-# UNPACK #-} !Word8 -- Cr red difference
-                               {-# UNPACK #-} !Word8 -- Cb blue difference
-
--- | Pixel type storing a classic pixel, with an alpha component.
--- Values are stored in the following order
---
---  * Red
---
---  * Green
---
---  * Blue
---
---  * Alpha
---
-data PixelRGBA8 = PixelRGBA8 {-# UNPACK #-} !Word8 -- Red
-                             {-# UNPACK #-} !Word8 -- Green
-                             {-# UNPACK #-} !Word8 -- Blue
-                             {-# UNPACK #-} !Word8 -- Alpha
-
-instance Serialize PixelYA8 where
-    {-# INLINE put #-}
-    put (PixelYA8 y a) = put y >> put a
-    {-# INLINE get #-}
-    get = PixelYA8 <$> get <*> get
-
-instance Storable PixelYA8 where
-    {-# INLINE sizeOf #-}
-    sizeOf _ = sizeOf (undefined :: Word8) * 2
-    {-# INLINE alignment #-}
-    alignment _ = alignment (undefined :: Word8)
-    {-# INLINE peek #-}
-    peek ptr = do
-      let __   = undefined :: Word8
-          yOff = sizeOf __ * 0
-          aOff = sizeOf __ * 1
-      y <- peek $ ptr `plusPtr` yOff
-      a <- peek $ ptr `plusPtr` aOff
-      return (PixelYA8 y a)
-    {-# INLINE poke #-}
-    poke ptr (PixelYA8 y a) = do
-      let __   = undefined :: Word8
-          yOff = sizeOf __ * 0
-          aOff = sizeOf __ * 1
-      poke (ptr `plusPtr` yOff) y
-      poke (ptr `plusPtr` aOff) a
-
-instance Serialize PixelRGB8 where
-    {-# INLINE put #-}
-    put (PixelRGB8 r g b) = put r >> put g >> put b
-    {-# INLINE get #-}
-    get = PixelRGB8 <$> get <*> get <*> get
-
-instance Storable PixelRGB8 where
-    {-# INLINE sizeOf #-}
-    sizeOf _ = sizeOf (undefined :: Word8) * 3
-    {-# INLINE alignment #-}
-    alignment _ = alignment (undefined :: Word8)
-    {-# INLINE peek #-}
-    peek ptr = do
-      let __   = undefined :: Word8
-          rOff = sizeOf __ * 0
-          gOff = sizeOf __ * 1
-          bOff = sizeOf __ * 2
-      r <- peek $ ptr `plusPtr` rOff
-      g <- peek $ ptr `plusPtr` gOff
-      b <- peek $ ptr `plusPtr` bOff
-      return (PixelRGB8 r g b)
-    {-# INLINE poke #-}
-    poke ptr (PixelRGB8 r g b) = do
-      let __   = undefined :: Word8
-          rOff = sizeOf __ * 0
-          gOff = sizeOf __ * 1
-          bOff = sizeOf __ * 2
-      poke (ptr `plusPtr` rOff) r
-      poke (ptr `plusPtr` gOff) g
-      poke (ptr `plusPtr` bOff) b
-
-instance Serialize PixelYCbCr8 where
-    {-# INLINE put #-}
-    put (PixelYCbCr8 y cb cr) = put y >> put cb >> put cr
-    {-# INLINE get #-}
-    get = PixelYCbCr8 <$> get <*> get <*> get
-
-instance Storable PixelYCbCr8 where
-    {-# INLINE sizeOf #-}
-    sizeOf _ = sizeOf (undefined :: Word8) * 3
-    {-# INLINE alignment #-}
-    alignment _ = alignment (undefined :: Word8)
-    {-# INLINE peek #-}
-    peek ptr = do
-      let __   = undefined :: Word8
-          yOff = sizeOf __ * 0
-          cbOff = sizeOf __ * 1
-          crOff = sizeOf __ * 2
-      y  <- peek $ ptr `plusPtr` yOff
-      cb <- peek $ ptr `plusPtr` cbOff
-      cr <- peek $ ptr `plusPtr` crOff
-      return (PixelYCbCr8 y cb cr)
-    {-# INLINE poke #-}
-    poke ptr (PixelYCbCr8 y cb cr) = do
-      let __   = undefined :: Word8
-          yOff  = sizeOf __ * 0
-          cbOff = sizeOf __ * 1
-          crOff = sizeOf __ * 2
-      poke (ptr `plusPtr`  yOff) y
-      poke (ptr `plusPtr` cbOff) cb
-      poke (ptr `plusPtr` crOff) cr
-
-instance Serialize PixelRGBA8 where
-    {-# INLINE put #-}
-    put (PixelRGBA8 r g b a) = put r >> put g >> put b >> put a
-    {-# INLINE get #-}
-    get = PixelRGBA8 <$> get <*> get <*> get <*> get
-
-instance Storable PixelRGBA8 where
-    {-# INLINE sizeOf #-}
-    sizeOf _ = sizeOf (undefined :: Word8) * 4
-    {-# INLINE alignment #-}
-    alignment _ = alignment (undefined :: Word8)
-    {-# INLINE peek #-}
-    peek ptr = do
-      let __   = undefined :: Word8
-          rOff = sizeOf __ * 0
-          gOff = sizeOf __ * 1
-          bOff = sizeOf __ * 2
-          aOff = sizeOf __ * 3
-      r <- peek $ ptr `plusPtr` rOff
-      g <- peek $ ptr `plusPtr` gOff
-      b <- peek $ ptr `plusPtr` bOff
-      a <- peek $ ptr `plusPtr` aOff
-      return (PixelRGBA8 r g b a)
-    {-# INLINE poke #-}
-    poke ptr (PixelRGBA8 r g b a) = do
-      let __   = undefined :: Word8
-          rOff = sizeOf __ * 0
-          gOff = sizeOf __ * 1
-          bOff = sizeOf __ * 2
-          aOff = sizeOf __ * 3
-      poke (ptr `plusPtr` rOff) r
-      poke (ptr `plusPtr` gOff) g
-      poke (ptr `plusPtr` bOff) b
-      poke (ptr `plusPtr` aOff) a
-
--- | Describe pixel kind at runtime
-data PixelType = PixelMonochromatic         -- ^ For 2 bits pixels
-               | PixelGreyscale
-               | PixelGreyscaleAlpha
-               | PixelRedGreenBlue8
-               | PixelRedGreenBlueAlpha8
-               | PixelYChromaRChromaB8
-               deriving Eq
-
--- | Typeclass used to query a type about it's properties
--- regarding casting to other pixel types
-class (Serialize a) => Pixel a where
-    -- | Tell if a pixel can be converted to another pixel,
-    -- the first value should not be used, and 'undefined' can
-    -- be used as a valid value.
-    canPromoteTo :: a -> PixelType -> Bool
-
-    -- | Return the number of component of the pixel
-    componentCount :: a -> Int
-
-    -- | Calculate the index for the begining of the pixel
-    pixelBaseIndex :: Image a -> Int -> Int -> Int
-    pixelBaseIndex (Image { imageWidth = w }) x y =
-            (x + y * w) * componentCount (undefined :: a)
-
-    -- | Calculate theindex for the begining of the pixel at position x y
-    mutablePixelBaseIndex :: MutableImage s a -> Int -> Int -> Int
-    mutablePixelBaseIndex (MutableImage { mutableImageWidth = w }) x y =
-            (x + y * w) * componentCount (undefined :: a)
-
-    -- | Return the constructor associated to the type, again
-    -- the value in the first parameter is not used, so you can use undefined
-    promotionType :: a -> PixelType
-
-    -- | Extract a pixel at a given position, (x, y), the origin
-    -- is assumed to be at the corner top left, positive y to the
-    -- bottom of the image
-    pixelAt :: Image a -> Int -> Int -> a
-
-    -- | Same as pixelAt but for mutable images.
-    readPixel :: MutableImage s a -> Int -> Int -> ST s a
-
-    -- | Write a pixel in a mutable image at position x y
-    writePixel :: MutableImage s a -> Int -> Int -> a -> ST s ()
-
--- | Tell if you can convert between two pixel types, both arguments
--- are unused.
-canConvertTo :: (Pixel a, Pixel b) => a -> b -> Bool
-canConvertTo a b = canPromoteTo a $ promotionType b
-
--- | Implement upcasting for pixel types
--- Minimal declaration declaration `promotePixel`
--- It is strongly recommanded to overload promoteImage to keep
--- performance acceptable
-class (Pixel a, Pixel b) => ColorConvertible a b where
-    -- | Convert a pixel type to another pixel type. This
-    -- operation should never loss any data.
-    promotePixel :: a -> b
-
-    -- | Change the underlying pixel type of an image by performing a full copy
-    -- of it.
-    promoteImage :: Image a -> Image b
-    promoteImage = pixelMap promotePixel
-
--- | This class abstract colorspace conversion. This
--- conversion can be lossy, which ColorConvertible cannot
-class (Pixel a, Pixel b) => ColorSpaceConvertible a b where
-    -- | Pass a pixel from a colorspace (say RGB) to the second one
-    -- (say YCbCr)
-    convertPixel :: a -> b
-
-    -- | Helper function to convert a whole image by taking a
-    -- copy it.
-    convertImage :: Image a -> Image b
-    convertImage = pixelMap convertPixel
-
--- | Create an image given a function to generate pixels.
--- The function will receive value from 0 to width-1 for the x parameter
--- and 0 to height-1 for the y parameter. The coordinate 0,0 is the upper
--- left corner of the image, and (width-1, height-1) the lower right corner.
---
--- for example, to create a small gradient image :
---
--- > imageCreator :: String -> Image PixelRGB8
--- > imageCreator path = writePng path $ generateImage pixelRenderer 250 300
--- >    where pixelRenderer x y = PixelRGB8 x y 128
---
-generateImage :: forall a. (Pixel a)
-              => (Int -> Int -> a)  -- ^ Generating function, with `x` and `y` params.
-              -> Int        -- ^ Width in pixels
-              -> Int        -- ^ Height in pixels
-              -> Image a
-generateImage f w h = Image { imageWidth = w, imageHeight = h, imageData = generated }
-  where compCount = componentCount (undefined :: a)
-        generated = runST $ do
-            arr <- M.new (w * h * compCount)
-            let mutImage = MutableImage {
-                                mutableImageWidth = w,
-                                mutableImageHeight = h,
-                                mutableImageData = arr }
-            forM_ [(x,y) | y <- [0 .. h-1], x <- [0 .. w-1]] $ \(x,y) ->
-                writePixel mutImage x y $ f x y
-            V.unsafeFreeze arr
-
--- | Create an image given a function to generate pixels.
--- The function will receive value from 0 to width-1 for the x parameter
--- and 0 to height-1 for the y parameter. The coordinate 0,0 is the upper
--- left corner of the image, and (width-1, height-1) the lower right corner.
---
--- the acc parameter is a user defined one.
---
--- The function is called for each pixel in the line from left to right (0 to width - 1)
--- and for each line (0 to height - 1).
-generateFoldImage :: forall a acc. (Pixel a)
-                  => (acc -> Int -> Int -> (acc, a)) -- ^ Function taking the state, x and y
-                  -> acc        -- ^ Initial state
-                  -> Int        -- ^ Width in pixels
-                  -> Int        -- ^ Height in pixels
-                  -> (acc, Image a)
-generateFoldImage f intialAcc w h =
- (finalState, Image { imageWidth = w, imageHeight = h, imageData = generated })
-  where compCount = componentCount (undefined :: a)
-        (finalState, generated) = runST $ do
-            arr <- M.new (w * h * compCount)
-            let mutImage = MutableImage {
-                                mutableImageWidth = w,
-                                mutableImageHeight = h,
-                                mutableImageData = arr }
-            foldResult <- foldM (\acc (x,y) -> do
-                    let (acc', px) = f acc x y
-                    writePixel mutImage x y px
-                    return acc') intialAcc [(x,y) | y <- [0 .. h-1], x <- [0 .. w-1]]
-                
-            frozen <- V.unsafeFreeze arr
-            return (foldResult, frozen)
-
-{-# INLINE pixelMap #-}
--- | `map` equivalent for an image, working at the pixel level.
--- Little example : a brightness function for an rgb image
---
--- > brightnessRGB8 :: Int -> Image PixelRGB8 -> Image PixelRGB8
--- > brightnessRGB8 add = pixelMap brightFunction
--- >      where up v = fromIntegral (fromIntegral v + add)
--- >            brightFunction (PixelRGB8 r g b) =
--- >                    PixelRGB8 (up r) (up g) (up b)
---
-pixelMap :: forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
-pixelMap f image@(Image { imageWidth = w, imageHeight = h }) =
-    Image w h pixels
-        where pixels = runST $ do
-                newArr <- M.replicate (w * h * componentCount (undefined :: b)) 0
-                let wrapped = MutableImage w h newArr
-                    promotedPixel :: Int -> Int -> b
-                    promotedPixel x y = f $ pixelAt image x y
-                sequence_ [writePixel wrapped x y $ promotedPixel x y
-                                    | y <- [0 .. h - 1], x <- [0 .. w - 1] ]
-                -- unsafeFreeze avoids making a second copy and it will be
-                -- safe because newArray can't be referenced as a mutable array
-                -- outside of this where block
-                V.unsafeFreeze newArr
-
--- | Helper class to help extract a luma plane out
--- of an image or a pixel
-class (Pixel a) => LumaPlaneExtractable a where
-    -- | Compute the luminance part of a pixel
-    computeLuma      :: a -> Pixel8
-
-    -- | Extract a luma plane out of an image. This
-    -- method is in the typeclass to help performant
-    -- implementation.
-    extractLumaPlane :: Image a -> Image Pixel8
-    extractLumaPlane = pixelMap computeLuma
-
-instance LumaPlaneExtractable Pixel8 where
-    {-# INLINE computeLuma #-}
-    computeLuma = id
-    extractLumaPlane = id
-
-instance LumaPlaneExtractable PixelRGB8 where
-    {-# INLINE computeLuma #-}
-    computeLuma (PixelRGB8 r g b) = floor $ 0.3 * toRational r + 
-                                            0.59 * toRational g +
-                                            0.11 * toRational b
-
-instance LumaPlaneExtractable PixelRGBA8 where
-    {-# INLINE computeLuma #-}
-    computeLuma (PixelRGBA8 r g b _) = floor $ 0.3 * toRational r + 
-                                             0.59 * toRational g +
-                                             0.11 * toRational b
-
-instance LumaPlaneExtractable PixelYA8 where
-    {-# INLINE computeLuma #-}
-    computeLuma (PixelYA8 y _) = y
-    extractLumaPlane = extractComponent PlaneLuma
-
-instance LumaPlaneExtractable PixelYCbCr8 where
-    {-# INLINE computeLuma #-}
-    computeLuma (PixelYCbCr8 y _ _) = y
-    extractLumaPlane = extractComponent PlaneLuma
-
--- | Free promotion for identic pixel types
-instance (Pixel a) => ColorConvertible a a where
-    {-# INLINE promotePixel #-}
-    promotePixel = id
-
-    {-# INLINE promoteImage #-}
-    promoteImage = id
-
-{-# INLINE (.!!!.) #-}
-(.!!!.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> m a
-(.!!!.) = M.read -- unsafeRead
-
-{-# INLINE (.<-.) #-}
-(.<-.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> a -> m ()
-(.<-.)  = M.write -- unsafeWrite
-
---------------------------------------------------
-----            Pixel8 instances
---------------------------------------------------
-instance Pixel Pixel8 where
-    canPromoteTo _ a = a /= PixelMonochromatic 
-    promotionType _ = PixelGreyscale
-    componentCount _ = 1
-    pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w)
-
-    readPixel image@(MutableImage { mutableImageData = arr }) x y =
-        arr .!!!. mutablePixelBaseIndex image x y
-    
-    writePixel image@(MutableImage { mutableImageData = arr }) x y =
-        arr .<-. mutablePixelBaseIndex image x y
-
-instance ColorConvertible Pixel8 PixelYA8 where
-    {-# INLINE promotePixel #-}
-    promotePixel c = PixelYA8 c 255
-
-instance ColorConvertible Pixel8 PixelRGB8 where
-    {-# INLINE promotePixel #-}
-    promotePixel c = PixelRGB8 c c c
-
-instance ColorConvertible Pixel8 PixelRGBA8 where
-    {-# INLINE promotePixel #-}
-    promotePixel c = PixelRGBA8 c c c 255
-
---------------------------------------------------
-----            PixelYA8 instances
---------------------------------------------------
-instance Pixel PixelYA8 where
-    canPromoteTo _ a = a == PixelRedGreenBlueAlpha8 
-    promotionType _  = PixelGreyscaleAlpha
-    componentCount _ = 2
-    pixelAt image@(Image { imageData = arr }) x y = PixelYA8 (arr ! (baseIdx + 0))
-                                                             (arr ! (baseIdx + 1))
-        where baseIdx = pixelBaseIndex image x y
-
-    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
-        yv <- arr .!!!. baseIdx
-        av <- arr .!!!. (baseIdx + 1)
-        return $ PixelYA8 yv av
-        where baseIdx = mutablePixelBaseIndex image x y
-    
-    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA8 yv av) = do
-        let baseIdx = mutablePixelBaseIndex image x y
-        (arr .<-. (baseIdx + 0)) yv
-        (arr .<-. (baseIdx + 1)) av
-
-
-instance ColorConvertible PixelYA8 PixelRGB8 where
-    {-# INLINE promotePixel #-}
-    promotePixel (PixelYA8 y _) = PixelRGB8 y y y
-
-instance ColorConvertible PixelYA8 PixelRGBA8 where
-    {-# INLINE promotePixel #-}
-    promotePixel (PixelYA8 y a) = PixelRGBA8 y y y a
-
---------------------------------------------------
-----            PixelRGB8 instances
---------------------------------------------------
-instance Pixel PixelRGB8 where
-    canPromoteTo _ PixelMonochromatic = False
-    canPromoteTo _ PixelGreyscale = False
-    canPromoteTo _ _ = True
-
-    componentCount _ = 3
-
-    promotionType _ = PixelRedGreenBlue8
-
-    pixelAt image@(Image { imageData = arr }) x y = PixelRGB8 (arr ! (baseIdx + 0))
-                                                              (arr ! (baseIdx + 1))
-                                                              (arr ! (baseIdx + 2))
-        where baseIdx = pixelBaseIndex image x y
-
-    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
-        rv <- arr .!!!. baseIdx
-        gv <- arr .!!!. (baseIdx + 1)
-        bv <- arr .!!!. (baseIdx + 2)
-        return $ PixelRGB8 rv gv bv
-        where baseIdx = mutablePixelBaseIndex image x y
-    
-    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB8 rv gv bv) = do
-        let baseIdx = mutablePixelBaseIndex image x y
-        (arr .<-. (baseIdx + 0)) rv
-        (arr .<-. (baseIdx + 1)) gv
-        (arr .<-. (baseIdx + 2)) bv
-
-instance ColorConvertible PixelRGB8 PixelRGBA8 where
-    {-# INLINE promotePixel #-}
-    promotePixel (PixelRGB8 r g b) = PixelRGBA8 r g b 255
-
---------------------------------------------------
-----            PixelRGBA8 instances
---------------------------------------------------
-instance Pixel PixelRGBA8 where
-    canPromoteTo _ PixelRedGreenBlueAlpha8 = True
-    canPromoteTo _ _ = False
-
-    promotionType _ = PixelRedGreenBlueAlpha8
-
-    componentCount _ = 4
-
-    pixelAt image@(Image { imageData = arr }) x y = PixelRGBA8 (arr ! (baseIdx + 0))
-                                                               (arr ! (baseIdx + 1))
-                                                               (arr ! (baseIdx + 2))
-                                                               (arr ! (baseIdx + 3))
-        where baseIdx = pixelBaseIndex image x y
-
-    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
-        rv <- arr .!!!. baseIdx
-        gv <- arr .!!!. (baseIdx + 1)
-        bv <- arr .!!!. (baseIdx + 2)
-        av <- arr .!!!. (baseIdx + 3)
-        return $ PixelRGBA8 rv gv bv av
-        where baseIdx = mutablePixelBaseIndex image x y
-    
-    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA8 rv gv bv av) = do
-        let baseIdx = mutablePixelBaseIndex image x y
-        (arr .<-. (baseIdx + 0)) rv
-        (arr .<-. (baseIdx + 1)) gv
-        (arr .<-. (baseIdx + 2)) bv
-        (arr .<-. (baseIdx + 3)) av
-
---------------------------------------------------
-----            PixelYCbCr8 instances
---------------------------------------------------
-instance Pixel PixelYCbCr8 where
-    canPromoteTo _ _ = False
-    promotionType _ = PixelYChromaRChromaB8
-    componentCount _ = 3
-    pixelAt image@(Image { imageData = arr }) x y = PixelYCbCr8 (arr ! (baseIdx + 0))
-                                                                (arr ! (baseIdx + 1))
-                                                                (arr ! (baseIdx + 2))
-        where baseIdx = pixelBaseIndex image x y
-
-    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
-        yv <- arr .!!!. baseIdx
-        cbv <- arr .!!!. (baseIdx + 1)
-        crv <- arr .!!!. (baseIdx + 2)
-        return $ PixelYCbCr8 yv cbv crv
-        where baseIdx = mutablePixelBaseIndex image x y
-    
-    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCr8 yv cbv crv) = do
-        let baseIdx = mutablePixelBaseIndex image x y
-        (arr .<-. (baseIdx + 0)) yv
-        (arr .<-. (baseIdx + 1)) cbv
-        (arr .<-. (baseIdx + 2)) crv
-
-instance (Pixel a) => ColorSpaceConvertible a a where
-    convertPixel = id
-    convertImage = id
-
-instance ColorSpaceConvertible PixelRGB8 PixelYCbCr8 where
-    {-# INLINE convertPixel #-}
-    convertPixel (PixelRGB8 r g b) = PixelYCbCr8 (truncate y)
-                                                 (truncate cb)
-                                                 (truncate cr)
-      where rf = fromIntegral r :: Float
-            gf = fromIntegral g
-            bf = fromIntegral b
-
-
-            y  =  0.29900 * rf + 0.58700 * gf + 0.11400 * bf
-            cb = -0.16874 * rf - 0.33126 * gf + 0.50000 * bf + 128
-            cr =  0.50000 * rf - 0.41869 * gf - 0.08131 * bf + 128
-
-instance ColorSpaceConvertible PixelYCbCr8 PixelRGB8 where
-    {-# INLINE convertPixel #-}
-    convertPixel (PixelYCbCr8 y_w8 cb_w8 cr_w8) = PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b)
-        where y :: Float
-              y  = fromIntegral y_w8 - 128.0
-              cb = fromIntegral cb_w8 - 128.0
-              cr = fromIntegral cr_w8 - 128.0
-
-              clampWord8 = truncate . max 0.0 . min 255.0 . (128 +)
-
-              cred = 0.299
-              cgreen = 0.587
-              cblue = 0.114
-
-              r = cr * (2 - 2 * cred) + y
-              b = cb * (2 - 2 * cblue) + y
-              g = (y - cblue * b - cred * r) / cgreen
-
JuicyPixels.cabal view
@@ -1,50 +1,35 @@ Name:                JuicyPixels
-Version:             2.0.2
-Synopsis:            Picture loading/serialization (in png, jpeg, bitmap and gif)
+Version:             3.3.9
+Synopsis:            Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance)
 Description:
-    This library can load and store images in PNG/Bitmap and Jpeg, and
-    read Gif images.
-    .
-    Version 2.0.2 changelog:
-    .
-      * Decoding of interleaved gif image, and delta coded gif animation.
-    .
-      * Bumping dependencies.
-    .
-    Version 2.0.1 changelog:
-    .
-      * Documentation enhancements.
-    .
-      * Fixing some huge gif file loading.
-    .
-      * Fixing performance problem of Bitmap and Jpeg savings.
-    .
-    Version 2.0 changelog:
-    .
-      * New extractComponent version with type safe plane
-        extraction
-    .
-      * Gif file reading
-    .
-    Version 1.3 changelog:
-    .
-      * Fix extractComponent function
-    .
-      * Adding saving for YA8 functions
+    <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>>
     .
+    This library can load and store images in PNG,Bitmap, Jpeg, Radiance, Tiff and Gif images.
 
 homepage:            https://github.com/Twinside/Juicy.Pixels
 License:             BSD3
 License-file:        LICENSE
 Author:              Vincent Berthoux
 Maintainer:          vincent.berthoux@gmail.com
-Category:            Codec, Graphics
+Category:            Codec, Graphics, Image
+Stability:           Stable
 Build-type:          Simple
-
--- Extra-source-files:  
+cabal-version: 1.18
+tested-with:
+  GHC == 9.8.1
+  GHC == 9.6.4
+  GHC == 9.4.8
+  GHC == 9.2.8
+  GHC == 9.0.2
+  GHC == 8.10.7
+  GHC == 8.8.4
+  GHC == 8.6.5
+  GHC == 8.4.4
+  GHC == 8.2.2
+  GHC == 8.0.2
 
--- Constraint on the version of Cabal needed to build this package.
-Cabal-version:       >= 1.10
+extra-doc-files: changelog, docimages/*.png, docimages/*.svg, README.md
+extra-doc-files: docimages/*.png, docimages/*.svg
 
 Source-Repository head
     Type:      git
@@ -53,36 +38,61 @@ Source-Repository this
     Type:      git
     Location:  git://github.com/Twinside/Juicy.Pixels.git
-    Tag:       v2.0.2
+    Tag:       v3.3.8
 
+Flag Mmap
+    Description: Enable the file loading via mmap (memory map)
+    Default: False
+
 Library
+  hs-source-dirs: src
   Default-Language: Haskell2010
+  default-extensions: TypeOperators
   Exposed-modules:  Codec.Picture,
                     Codec.Picture.Bitmap,
                     Codec.Picture.Gif,
                     Codec.Picture.Png,
                     Codec.Picture.Jpg,
+                    Codec.Picture.HDR,
+                    Codec.Picture.Tga,
+                    Codec.Picture.Tiff,
+                    Codec.Picture.Metadata,
+                    Codec.Picture.Metadata.Exif,
                     Codec.Picture.Saving,
-                    Codec.Picture.Types
+                    Codec.Picture.Types,
+                    Codec.Picture.ColorQuant,
+                    Codec.Picture.Jpg.Internal.DefaultTable,
+                    Codec.Picture.Jpg.Internal.Metadata,
+                    Codec.Picture.Jpg.Internal.FastIdct,
+                    Codec.Picture.Jpg.Internal.FastDct,
+                    Codec.Picture.Jpg.Internal.Types,
+                    Codec.Picture.Jpg.Internal.Common,
+                    Codec.Picture.Jpg.Internal.Progressive,
+                    Codec.Picture.Gif.Internal.LZW,
+                    Codec.Picture.Gif.Internal.LZWEncoding,
+                    Codec.Picture.Png.Internal.Export,
+                    Codec.Picture.Png.Internal.Type,
+                    Codec.Picture.Png.Internal.Metadata,
+                    Codec.Picture.Tiff.Internal.Metadata,
+                    Codec.Picture.Tiff.Internal.Types
 
   Ghc-options: -O3 -Wall
-  Build-depends: base                >= 4       && < 5,
-                 bytestring          >= 0.9     && < 0.11,
-                 mtl                 >= 1.1     && < 2.2,
-                 cereal              >= 0.3.3.0 && < 0.4,
-                 zlib                >= 0.5.3.1 && < 0.6,
-                 transformers        >= 0.2.2   && < 0.4,
-                 vector              >= 0.10    && < 0.11,
-                 primitive           >= 0.5     && < 0.6,
-                 deepseq             >= 1.1     && < 1.4
+  Build-depends: base                >= 4.8     && < 5,
+                 bytestring          >= 0.9     && < 0.13,
+                 mtl                 >= 1.1     && < 2.4,
+                 binary              >= 0.8.1   && < 0.9,
+                 zlib                >= 0.5.3.1 && < 0.8,
+                 transformers        >= 0.2,
+                 vector              >= 0.12.3.1,
+                 primitive           >= 0.4,
+                 deepseq             >= 1.1     && < 1.6,
+                 containers          >= 0.4.2   && < 0.8
 
   -- Modules not exported by this package.
-  Other-modules: Codec.Picture.Jpg.DefaultTable,
-                 Codec.Picture.Jpg.FastIdct,
-                 Codec.Picture.Jpg.FastDct,
-                 Codec.Picture.Jpg.Types,
-                 Codec.Picture.Gif.LZW,
-                 Codec.Picture.Png.Export,
-                 Codec.Picture.Png.Type,
-                 Codec.Picture.BitWriter
+  Other-modules: Codec.Picture.BitWriter,
+                 Codec.Picture.InternalHelper,
+                 Codec.Picture.VectorByteConversion
+
+  Install-Includes: src/Codec/Picture/ConvGraph.hs
+  Include-Dirs: src/Codec/Picture
+ README.md view
@@ -0,0 +1,119 @@+![Juicy logo](https://raw.github.com/Twinside/Juicy.Pixels/master/docimages/juicy.png)
+
+
+[![Hackage](https://img.shields.io/hackage/v/JuicyPixels.svg)](http://hackage.haskell.org/package/JuicyPixels)
+
+Juicy.Pixels
+============
+
+This library provides saving & loading of different picture formats for the
+Haskell language. The aim of the library is to be as lightweight as possible,
+you ask it to load an image, and it'll dump you a big Vector full of juicy
+pixels. Or squared pixels, or whatever, as long as they're unboxed.
+
+Documentation
+-------------
+
+The library documentation can be accessed on [Hackage](http://hackage.haskell.org/package/JuicyPixels)
+
+Wrappers
+--------
+
+For the user of:
+
+ * [REPA](http://www.haskell.org/haskellwiki/Numeric_Haskell:_A_Repa_Tutorial), check-out JuicyPixels-repa on [GitHub](https://github.com/TomMD/JuicyPixels-repa) or [Hackage](http://hackage.haskell.org/package/JuicyPixels-repa)
+
+ * [Gloss](http://hackage.haskell.org/package/gloss), check-out gloss-juicy on [GitHub](https://github.com/alpmestan/gloss-juicy) or [Hackage](http://hackage.haskell.org/package/gloss-juicy)
+
+Status
+------
+
+ - PNG    (.png) 
+    * Reading 
+        - 1,2,4,8 bits loading, Grayscale, 24bits, 24 bits with alpha,
+          interleaved & filtered (fully compliant with the standard,
+          tested against png suite).
+
+    * Writing
+        - 8bits RGB (non interleaved)
+        - 8bits RGBA (non interleaved)
+        - 8bits greyscale (non interleaved)
+        - 16bits greyscale (non interleaved)
+        - 16bits RGB (non interleaved)
+        - 16bits RGBA (non interleaved)
+        - 8bits RGB paletted image
+        - 8bits RGBA paletted image
+
+    * Metadata (reading/writing)
+        * in a tEXT chunk: 'Title', 'Description', 'Author', 'Copyright',
+          'Software', 'Comment', 'Disclaimer', 'Source', 'Warning'
+        * any other tEXT chunk.
+        * in a gAMA field : 'Gamma'
+        * DPI information in a pHYs chunk.
+
+ - Bitmap (.bmp)
+    * Reading
+        - 16 or 32 bit RGBA images
+        - 16, 24, 32 bit RGB images
+        - 1, 4, or 8 bit (greyscale & paletted) images
+        - RLE encoded or uncompressed
+        - Windows 2.0/3.1/95/98 style bitmaps all supported
+
+    * Writing
+        - 32bits (RGBA) per pixel images
+        - 24bits (RGB) per pixel images
+        - 8 bits greyscale (with palette)
+
+    * Metadata (reading/writing): DPI information
+
+ - Jpeg   (.jpg, .jpeg)
+    * Reading normal and interlaced baseline DCT image
+        - YCbCr (default) CMYK/YCbCrK/RGB colorspaces
+
+    * Writing non-interlaced JPG
+        - YCbCr (favored), Y, RGB & CMYK colorspaces
+
+    * Metadata:
+        - Reading and writing DpiX & DpiY from JFIF header.
+        - Reading & writing EXIF metadata. No GPS information
+          can be written now.
+
+ - Gif (.gif)
+    * Reading single image & animated Gif image, handles interlaced images.
+    * Writing single & animated Gif images.
+    * No metadata.
+
+ - Radiance (.pic, .hdr)
+    * Reading
+    * Writing
+    * No metadata.
+
+ - Tga
+    * Reading
+        - 8, 16, 24 & 32 bits
+        - paletted and unpaletted
+        - RLE encoded or uncompressed
+    * Writing
+        - uncompressed 8bits (Pixel8)
+        - uncompressed 24bits (PixelRGB8)
+        - uncompressed 32bits (PixelRGBA8)
+    * No metadata
+
+ - Tiff
+    * Reading
+        - 2, 4, 8, 16 int bit depth reading (planar and contiguous for each)
+        - 32 bit floating point reading
+          
+        - CMYK, YCbCr, RGB, RGBA, Paletted, Greyscale
+        - Uncompressed, PackBits, LZW
+
+    * Writing
+        - 8 and 16 bits
+        - CMYK, YCbCr, RGB, RGBA, Greyscale
+        - Uncompressed
+    * Metadata: reading DpiX, DpiY and EXIF informations.
+
+_I love juicy pixels_
+
+You can make [donations on this page](http://twinside.github.com/Juicy.Pixels/).
+
+ changelog view
@@ -0,0 +1,459 @@+Change log
+==========
+
+v3.3.9 June 2024
+----------------
+
+ * Something something compilation
+
+v3.3.7 July 2022
+----------------
+
+ * Dependence fidling
+ * Jpg: do not call "error" in the parser, use fail instead.
+
+v3.3.7 March 2022
+-----------------
+
+ * Jpg: Fixing renderng bug with MCUs with single block in width and
+   multiple in height
+
+v3.3.6 October 2021
+-------------------
+
+ * Bytestring bound bump
+ * Fix bug #187.  (Some JPEGs are misidentified as SourceTiff.)
+ * Fix EXIF handling of strings of four characters or fewer.
+ * Fix endianness bug in short ExifString and ExifUndefined.
+
+
+v3.3.5 January 2020
+-------------------
+
+Maintenance release to push various pull requests onto
+hackage
+
+ * Exporting Pixel32 (will)
+ * Palettization of transparent frames in Gif (flutterlice)
+ * Documentation fixes (lehins)
+
+v3.3.4 September 2019
+---------------------
+
+ * support reading compressed zTXt metadata from PNG files (claudeha)
+ * Add helper functions to convert a DynamicImage to RGB16 (uglyoldbob)
+ * Fix RGB to CMYK conversion (lehins)
+
+v3.3.3.1 June 2019
+------------------
+
+ * New GHC maintenance (thanks to ekmett)
+
+v3.3.3 December 2018
+--------------------
+
+ * Enhanced: loading of bitmap format (thanks to CLowcay)
+ * Refactoring: exposing more internal modules (thanks to wyager)
+ * Refactoring: exposing dynamicMap & dynamicPixelMap
+   through `Codec.Picture` (thnks to LightAndLight)
+
+ * v3.3.3.1: fixing compilation with older GHC
+
+v3.3.2 October 2018
+-------------------
+
+ * Fix: GHC-8.6 compilation fix (no upper bound on base)
+ * Fix: upper bound on containers (pull request phadej)
+ * Fix: palette validation for gifs (pull request omedan)
+ * New: More complete gif creation API (pull request omedan)
+
+v3.3.1 August 2018
+------------------
+
+ * Fix: gif decoding of 1bit palette (fix Ornedan)
+ * Fix: end of stream handling for gif's lzw encoding (fix Ornedan)
+
+v3.3 July 2018
+--------------
+
+ * New: Eq instances for image
+ * Fix: color gif resolution offset
+ * New: support for Float Tiff
+ * Breaking change: New `ImageY32` constructor for `Dynamic`
+					hence the version bump.
+
+v3.2.9.5 March 2018
+-------------------
+ 
+ * Fix: uniform color quantization
+
+v3.2.9.4 January 2018
+----------------------
+
+ * Compat for GHC-8.4 (pull request)
+ * Fix: a character in latin1 which was still around. Whatever.
+        So tired of this.
+
+
+v3.2.9.3 December 2017
+----------------------
+
+ * Fix: remove bad invisible unicde char
+
+v3.2.9.2 December 2017
+----------------------
+
+ * Fix: Progressive jpeg decoding when number of blocks of the MCU
+		is below line size
+
+v3.2.9.1 November 2017
+----------------------
+
+ * Feature: Paletted alpha png saving
+
+v3.2.9 November 2017
+----------------------
+
+ * Fix: Adding correct import of Exif Flash for Jpeg (thanks to Alexander Kjeldaas)
+ * Feature: Jpg Exif writing
+
+
+v3.2.8.3 August 2017
+------------------
+
+ * Fix: Jpeg loading of extended sequential jpg, not sure of all
+		the implications, works with the sample
+
+v3.2.8.2 June 2017
+------------------
+
+ * Fix: usage of fail in Either monad, giving an unwanted exception
+
+v3.2.8.1 March 2016
+-------------------
+
+ * Fix: proper flushing of jpeg writing, avoiding warning from libjpeg.
+ * Fix: RGB jpeg get an Adobe's APP14 block to help MacOS & Photoshop reading
+
+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.
+
+v3.2.7.1 May 2016
+-----------------
+ * Fix: some wrongly infinitely looping JPEG decoding
+
+v3.2.7 January 2016
+-------------------
+ * Addition: convertRGB8 and convertRGBA8 helper functions
+ * Addition: new output colorspace for JPEG format: Y, RGB & CMYK
+ * Addition: RGBA8 bitmap reading (thanks to mtolly)
+ * Enhancement: Optimized JPG & Tiff reading (thanks to Calvin Beck)
+ * Enhancement: INLINE SPECIALIZE for pixelMap (Pixel8 -> Pixel8) (thx to Calvin Beck)
+ * Fix: GHC 8.0 compilation (thanks to phadej)
+
+v3.2.6.5 December 2015
+----------------------
+ * Fix: Compilation on GHC 7.6/7.8
+
+v3.2.6.4 December 2015
+----------------------
+ * Fix: previous broken bugfix.
+
+v3.2.6.3 November 2015
+----------------------
+ * Fix: Fixing unwanted sharing with createMutableImage due to
+		wrongly used INLINE pragma
+
+v3.2.6.2 November 2015
+----------------------
+ * Fix: Using minimal GIF version if outputing a single image.
+
+v3.2.6.1 August 2015
+--------------------
+ * Fix: handling of negative height & width in bitmap format.
+ * Fix: regression on Tiff parsing.
+
+V3.2.6 August 2015
+--------------------
+
+ * Added: imageToTga saving helper function.
+ * Fix: don't invert TGA alpha channel.
+ * Fix: various typo in documentation.
+
+V3.2.5.3 July 2015
+------------------
+
+ * Fix: bumping vector upper bounds.
+
+V3.2.5.2 June 2015
+------------------
+
+ * Adding: Width & Height metdata to help querying image information
+	without decompressing the whole.
+ * Adding: Source format metadata.
+
+v3.2.5.1 May 2015
+---------------
+
+ * Fixing: utf-8 encoding of Jpg/Types causing problems with Haddock.
+
+v3.2.5 May 2015
+---------------
+
+ * Adding: Metadata extraction for various file format.
+ * Adding: Metadata writing for various file format.
+ * Adding: light EXIF mapping.
+ * Fix: handling of Tiff with predictors (thanks to Patrick Pelletier)
+ 
+v3.2.4 April 2015
+-----------------
+
+ * Adding: Traversals compatible with the lens library.
+
+v3.2.3.2 April 2015
+-------------------
+
+ * Bumping: zlib max bound
+
+v3.2.3.1 March 2015
+-------------------
+
+ * Bumping: primitive to allow 0.6
+ * Fix: BMP output generated wrong size (thanks to mtolly).
+ * Fix: 7.10.1 warning free
+
+v3.2.3 March 2015
+-----------------
+
+ * Adding: Support for RGB in jpeg (yeah, that exist...)
+ * Adding: Support of CMYK & YCrCbK color space in jpeg files.
+ * Addinng: a pixelFoldMap functions analog to the `foldMap` function
+  of the Foldable type class.
+ * Fix: better performances for the pixelFold* functions
+
+v3.2.2 January 2015
+-------------------
+
+ * Fix: Squashing GHC 7.10 warnings
+
+v3.2.1 December 2014
+--------------------
+ * Fix: Bumping deepseq dependencies preparing for GHC 7.10
+   release.
+
+v3.2 December 2014
+------------------
+
+*BREAKING CHANGES*: the Codec.Picture.Gif functions has changed interfaces.
+
+ * Adding: TGA reading.
+ * Adding: TGA writing.
+ * Adding: Packeable pixel unpack.
+ * Fix: Returning gif with transparency (breaking Codec.Picture.Gif interface)
+
+v3.1.7.1 August 2014
+--------------------
+
+ * Previous gif fix was not working withing the readImage
+   function, only in specialized gif images. Correcting
+   miscorection
+
+v3.1.7 August 2014
+------------------
+
+ * Making Juicy.Pixels compatible with GHC 7.9 HEAD (ggreif)
+ * Adding writing to uncompressed radiance file, due to
+   problems with Mac OS X "preview" application
+ * Fixing problem of gif parsing without global palette
+ * Some inlining annotations on some functions
+
+v3.1.6.1 August 2014
+--------------------
+
+ * Fix of Gif palette creation (jeffreyrosenbluth)
+ * Restoring transformers 0.3.* compat
+
+v3.1.6 August 2014
+------------------
+
+ * Fix bad disposal handling in GIF animations.
+ * Added ColorConvertible instance for PixelRGB8 -> PixelRGBA16 (KaiHa)
+ * Fixing a bad handling of tRNS causing bad transprency decoding in
+   some circonstances.
+ * Adding the concept of Packeable pixel for faster pixel filling
+   using mutable array.
+
+v3.1.5.2 May 2014
+-----------------
+
+ * Bumping the transformers dependency
+
+v3.1.5.1 May 2014
+-----------------
+
+ * Adding some INLINE annotations for some pixel functions
+
+v3.1.5 March 2014
+-----------------
+
+ * Typos and documentation proof reading fixes
+   (pull request from iger).
+ * Fix of progressive jpeg loading with more than two
+   huffman tables (4 allowed).
+ * Fix of progressive jpeg rendering (was too noisy before)
+ * Added loading of paletted bitmap files.
+ * Function to load gif images with frame duration
+   information (pull request from bit-shift)
+ * Fixing bug showing when loading JPEG with component
+   ID starting at 0.
+ * Adding reading for YA8 et YA16 Tiff images (pull 
+   request from iger)
+ * Adding a mixWithAlpha method, to help work on transparent
+   pixel types
+
+
+v3.1.4.1 February 2014
+----------------------
+
+ * Putting back data URI logo for cabal description, it's
+   apparently not supported by Hackage :-(
+
+v3.1.4 February 2014
+--------------------
+
+ * Adding a pixelOpacity method to the pixel type class.
+ * Adding handling greyscale BMP files (phischu)
+ * Fixing promotePixel for Pixel8 -> Pixel16
+ * Some type fixes in the documentation
+ * Updating the pixel conversion graph
+ * Removed URI-encoded images, now using clean cabal embedding
+
+v3.1.3.3 February 2014
+----------------------
+
+ * Lowering cabal version limit to be compiled with older GHCs
+
+v3.1.3.2 January 2014
+---------------------
+
+ * Hacking around Binary to accept old version of it, down to version 0.5
+   allowing Juicy.Pixels to be compiled with GHC 6.3
+
+v3.1.3.1 January 2014
+---------------------
+
+ * Fixing color counting function in color quantisation.
+ * Adding missing documentation for foreign pointer import.
+
+v3.1.3 January 2014
+-------------------
+
+ * Adding palette creation (color Quantization) by Jeffrey Rosenbluth.
+ * Adding support for Gif writing
+ * Adding support for Gif animation writing
+ * Fixing some progressive Jpeg decoding problems (#39)
+
+v3.1.2 December 2013
+--------------------
+
+ * Adding support for progressive jpeg.
+ * Adding support for plane separated MCU jpeg.
+ * Adding support for grayscale 32bit decoding (with reduced precision to
+	16bits).
+ * Fixing erroneous bitmap decoding in case of excessive padding (#31).
+
+v3.1.1.1 October 2013
+---------------------
+
+ * Fixing some spurious crash while decoding some JPEG image (#30).
+
+v3.1.1  October 2013
+--------------------
+
+ * Adding uncompresed TIFF saving.
+ * Adding error message to avoid loading progressive loading.
+ * Made MMAP optional, controled by a cabal flag.
+ * adding dynamicPixelMap helper function.
+ * Handling png transparency using color key (#26).
+
+v3.1 June 2013
+--------------
+
+ * Adding basic handling of 16bits pixel types.
+ * Addition of Tiff reading:
+    - 2, 4, 8, 16 bit depth reading (planar and contiguous for each).
+    - CMYK, YCbCr, RGB, Paletted, Greyscale.
+    - Uncompressed, PackBits, LZW.
+ * Some new tiny helper functions (nothing too fancy).
+ * Huge performances improvement.
+
+v3.0 January 2013
+-----------------
+
+ * Simplification of the 'Pixel' typeclass, removed many unused part.
+ * Removal of some Storable instances for pixel types.
+ * Amelioration of the documentation.
+ * Support for High Dynamic range images, opening support for different pixel
+   base component.
+ * Support for the Radiance file format (or RGBE, file extension .pic and .hdr).
+ * Dropped the cereal library in favor of the last version of Binary, present 
+   in the Haskell platform. Every dependencies are now present in the platform.
+
+v2.0.2 October 2012
+-------------------
+
+ * Decoding of interleaved gif image.
+ * Decoding delta coded gif animation.
+ * Bumping dependencies.
+
+v2.0.1 September 2012
+---------------------
+
+ * Documentation enhancements.
+ * Fixing some huge gif file loading.
+ * Fixing performance problem of Bitmap and Jpeg savings.
+
+v2.0 September 2012
+-------------------
+
+ * New extractComponent version with type safe plane extraction.
+ * Gif file reading.
+
+v1.3 June 2012
+--------------
+
+ * Fix extractComponent function.
+ * Adding saving for YA8 functions.
+
+v1.2.1 April 2012
+-----------------
+
+ * Dependencies version bump.
+ * Dropping array dependency.
+
+v1.2 March 2012
+---------------
+
+ * Adding a generateImage helper function.
+ * Adding NFData instances for image.
+ * Adding JPEG writing.
+
+v1.1 February 2012
+------------------
+
+ * Switching to vector for arrays, big performance improvement.
+
+v1.0 January 2012
+-----------------
+
+ * Initial release
+
+ docimages/juicy.png view

binary file changed (absent → 322 bytes)

+ docimages/pixelgraph.svg view
@@ -0,0 +1,264 @@+<?xml version="1.0" encoding="UTF-8" standalone="no"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<!-- Generated by graphviz version 2.22.2 (20090313.1817)+ -->+<!-- Title: pixelGraphic Pages: 1 -->+<svg width="620pt" height="464pt"+ viewBox="0.00 0.00 620.00 464.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">+<g id="graph1" class="graph" transform="scale(1 1) rotate(0) translate(4 460)">+<title>pixelGraphic</title>+<polygon fill="white" stroke="white" points="-4,5 -4,-460 617,-460 617,5 -4,5"/>+<!-- PixelRGB8 -->+<g id="node1" class="node"><title>PixelRGB8</title>+<ellipse fill="none" stroke="black" cx="246" cy="-438" rx="31.7878" ry="18"/>+<text text-anchor="middle" x="246" y="-436.3" font-family="sans-serif" font-size="8.00">PixelRGB8</text>+</g>+<!-- PixelRGBA8 -->+<g id="node6" class="node"><title>PixelRGBA8</title>+<ellipse fill="none" stroke="black" cx="441" cy="-354" rx="34.8223" ry="18"/>+<text text-anchor="middle" x="441" y="-352.3" font-family="sans-serif" font-size="8.00">PixelRGBA8</text>+</g>+<!-- PixelRGB8&#45;&gt;PixelRGBA8 -->+<g id="edge4" class="edge"><title>PixelRGB8&#45;&gt;PixelRGBA8</title>+<path fill="none" stroke="black" d="M274.25,-429.506C295.421,-422.833 324.934,-412.874 350,-402 351.523,-401.339 381.994,-385.244 407.261,-371.871"/>+<polygon fill="black" stroke="black" points="409.071,-374.874 416.272,-367.102 405.796,-368.687 409.071,-374.874"/>+<text text-anchor="middle" x="393" y="-394.3" font-family="sans-serif" font-size="8.00">promotePixel</text>+</g>+<!-- PixelRGBF -->+<g id="node8" class="node"><title>PixelRGBF</title>+<ellipse fill="none" stroke="black" cx="33" cy="-102" rx="31.7878" ry="18"/>+<text text-anchor="middle" x="33" y="-100.3" font-family="sans-serif" font-size="8.00">PixelRGBF</text>+</g>+<!-- PixelRGB8&#45;&gt;PixelRGBF -->+<g id="edge6" class="edge"><title>PixelRGB8&#45;&gt;PixelRGBF</title>+<path fill="none" stroke="black" d="M214.594,-434.005C148.276,-424.689 0,-398.847 0,-354 0,-354 0,-354 0,-186 0,-165.437 8.67323,-143.88 17.1268,-127.753"/>+<polygon fill="black" stroke="black" points="20.228,-129.378 22.0115,-118.934 14.1045,-125.986 20.228,-129.378"/>+<text text-anchor="middle" x="23" y="-268.3" font-family="sans-serif" font-size="8.00">promotePixel</text>+</g>+<!-- Pixel8 -->+<g id="node20" class="node"><title>Pixel8</title>+<ellipse fill="none" stroke="black" cx="308" cy="-270" rx="27" ry="18"/>+<text text-anchor="middle" x="308" y="-268.3" font-family="sans-serif" font-size="8.00">Pixel8</text>+</g>+<!-- PixelRGB8&#45;&gt;Pixel8 -->+<g id="edge60" class="edge"><title>PixelRGB8&#45;&gt;Pixel8</title>+<path fill="none" stroke="black" d="M214.516,-433.811C149.341,-423.852 9.37863,-395.049 55,-336 81.2893,-301.973 207.23,-282.163 270.929,-274.163"/>+<polygon fill="black" stroke="black" points="271.46,-277.624 280.961,-272.936 270.61,-270.676 271.46,-277.624"/>+<text text-anchor="middle" x="80" y="-352.3" font-family="sans-serif" font-size="8.00">computeLuma</text>+</g>+<!-- PixelCMYK8 -->+<g id="node28" class="node"><title>PixelCMYK8</title>+<ellipse fill="none" stroke="black" cx="253" cy="-354" rx="34.8223" ry="18"/>+<text text-anchor="middle" x="253" y="-352.3" font-family="sans-serif" font-size="8.00">PixelCMYK8</text>+</g>+<!-- PixelRGB8&#45;&gt;PixelCMYK8 -->+<g id="edge40" class="edge"><title>PixelRGB8&#45;&gt;PixelCMYK8</title>+<path fill="none" stroke="black" d="M224.748,-423.894C213.935,-414.831 204.182,-402.459 210,-390 212.758,-384.095 217.013,-378.817 221.794,-374.241"/>+<polygon fill="black" stroke="black" points="224.225,-376.77 229.601,-367.64 219.705,-371.424 224.225,-376.77"/>+<text text-anchor="middle" x="232" y="-394.3" font-family="sans-serif" font-size="8.00">convertPixel</text>+</g>+<!-- PixelYCbCr8 -->+<g id="node30" class="node"><title>PixelYCbCr8</title>+<ellipse fill="none" stroke="black" cx="150" cy="-354" rx="35.9084" ry="18"/>+<text text-anchor="middle" x="150" y="-352.3" font-family="sans-serif" font-size="8.00">PixelYCbCr8</text>+</g>+<!-- PixelRGB8&#45;&gt;PixelYCbCr8 -->+<g id="edge42" class="edge"><title>PixelRGB8&#45;&gt;PixelYCbCr8</title>+<path fill="none" stroke="black" d="M214.399,-434.415C177.053,-429.451 118.29,-419.109 105,-402 97.106,-391.837 104.874,-381.324 116.049,-372.736"/>+<polygon fill="black" stroke="black" points="118.35,-375.401 124.612,-366.856 114.387,-369.631 118.35,-375.401"/>+<text text-anchor="middle" x="127" y="-394.3" font-family="sans-serif" font-size="8.00">convertPixel</text>+</g>+<!-- PixelRGB16 -->+<g id="node2" class="node"><title>PixelRGB16</title>+<ellipse fill="none" stroke="black" cx="429" cy="-102" rx="34.1425" ry="18"/>+<text text-anchor="middle" x="429" y="-100.3" font-family="sans-serif" font-size="8.00">PixelRGB16</text>+</g>+<!-- PixelRGBA16 -->+<g id="node4" class="node"><title>PixelRGBA16</title>+<ellipse fill="none" stroke="black" cx="343" cy="-18" rx="37.1721" ry="18"/>+<text text-anchor="middle" x="343" y="-16.3" font-family="sans-serif" font-size="8.00">PixelRGBA16</text>+</g>+<!-- PixelRGB16&#45;&gt;PixelRGBA16 -->+<g id="edge2" class="edge"><title>PixelRGB16&#45;&gt;PixelRGBA16</title>+<path fill="none" stroke="black" d="M400.098,-92.2134C386.67,-86.4097 371.409,-77.8363 361,-66 355.909,-60.2106 352.202,-52.8433 349.526,-45.6287"/>+<polygon fill="black" stroke="black" points="352.846,-44.5187 346.482,-36.0479 346.174,-46.6383 352.846,-44.5187"/>+<text text-anchor="middle" x="384" y="-58.3" font-family="sans-serif" font-size="8.00">promotePixel</text>+</g>+<!-- Pixel16 -->+<g id="node16" class="node"><title>Pixel16</title>+<ellipse fill="none" stroke="black" cx="296" cy="-186" rx="27" ry="18"/>+<text text-anchor="middle" x="296" y="-184.3" font-family="sans-serif" font-size="8.00">Pixel16</text>+</g>+<!-- PixelRGB16&#45;&gt;Pixel16 -->+<g id="edge58" class="edge"><title>PixelRGB16&#45;&gt;Pixel16</title>+<path fill="none" stroke="black" d="M424.573,-120.149C421.265,-130.199 415.765,-142.199 407,-150 386.436,-168.304 356.427,-177.32 332.795,-181.75"/>+<polygon fill="black" stroke="black" points="332.056,-178.325 322.773,-183.431 333.214,-185.228 332.056,-178.325"/>+<text text-anchor="middle" x="441" y="-142.3" font-family="sans-serif" font-size="8.00">computeLuma</text>+</g>+<!-- PixelCMYK16 -->+<g id="node26" class="node"><title>PixelCMYK16</title>+<ellipse fill="none" stroke="black" cx="553" cy="-18" rx="37.1721" ry="18"/>+<text text-anchor="middle" x="553" y="-16.3" font-family="sans-serif" font-size="8.00">PixelCMYK16</text>+</g>+<!-- PixelRGB16&#45;&gt;PixelCMYK16 -->+<g id="edge38" class="edge"><title>PixelRGB16&#45;&gt;PixelCMYK16</title>+<path fill="none" stroke="black" d="M451.832,-88.3606C462.615,-81.7841 475.593,-73.6731 487,-66 499.46,-57.6189 512.915,-47.9503 524.406,-39.4968"/>+<polygon fill="black" stroke="black" points="526.807,-42.074 532.761,-33.3106 522.641,-36.4482 526.807,-42.074"/>+<text text-anchor="middle" x="525" y="-58.3" font-family="sans-serif" font-size="8.00">convertPixel</text>+</g>+<!-- PixelRGBA16&#45;&gt;PixelRGB16 -->+<g id="edge44" class="edge"><title>PixelRGBA16&#45;&gt;PixelRGB16</title>+<path fill="none" stroke="black" d="M371.789,-29.3863C383.871,-35.2918 397.329,-43.4955 407,-54 412.378,-59.8422 416.636,-67.2266 419.915,-74.4406"/>+<polygon fill="black" stroke="black" points="416.794,-76.0584 423.794,-84.0115 423.282,-73.4291 416.794,-76.0584"/>+<text text-anchor="middle" x="449" y="-58.3" font-family="sans-serif" font-size="8.00">dropTransparency</text>+</g>+<!-- PixelRGBA8&#45;&gt;PixelRGB8 -->+<g id="edge46" class="edge"><title>PixelRGBA8&#45;&gt;PixelRGB8</title>+<path fill="none" stroke="black" d="M437.029,-372.038C433.845,-382.309 428.318,-394.571 419,-402 399.083,-417.88 332.208,-428.306 287.678,-433.672"/>+<polygon fill="black" stroke="black" points="287.239,-430.2 277.712,-434.834 288.05,-437.153 287.239,-430.2"/>+<text text-anchor="middle" x="463" y="-394.3" font-family="sans-serif" font-size="8.00">dropTransparency</text>+</g>+<!-- PixelRGBA8&#45;&gt;Pixel8 -->+<g id="edge52" class="edge"><title>PixelRGBA8&#45;&gt;Pixel8</title>+<path fill="none" stroke="black" d="M413.829,-342.599C399.476,-336.131 381.815,-327.451 367,-318 354.878,-310.267 342.394,-300.428 332.048,-291.673"/>+<polygon fill="black" stroke="black" points="334.114,-288.833 324.258,-284.946 329.539,-294.131 334.114,-288.833"/>+<text text-anchor="middle" x="392" y="-310.3" font-family="sans-serif" font-size="8.00">computeLuma</text>+</g>+<!-- PixelF -->+<g id="node14" class="node"><title>PixelF</title>+<ellipse fill="none" stroke="black" cx="106" cy="-186" rx="27" ry="18"/>+<text text-anchor="middle" x="106" y="-184.3" font-family="sans-serif" font-size="8.00">PixelF</text>+</g>+<!-- PixelRGBF&#45;&gt;PixelF -->+<g id="edge56" class="edge"><title>PixelRGBF&#45;&gt;PixelF</title>+<path fill="none" stroke="black" d="M27.0137,-120.147C24.9943,-129.716 24.4635,-141.251 30,-150 38.9021,-164.067 54.9514,-172.745 70.015,-178.044"/>+<polygon fill="black" stroke="black" points="69.0981,-181.424 79.6867,-181.06 71.1825,-174.741 69.0981,-181.424"/>+<text text-anchor="middle" x="55" y="-142.3" font-family="sans-serif" font-size="8.00">computeLuma</text>+</g>+<!-- PixelYA16 -->+<g id="node9" class="node"><title>PixelYA16</title>+<ellipse fill="none" stroke="black" cx="259" cy="-102" rx="31.7878" ry="18"/>+<text text-anchor="middle" x="259" y="-100.3" font-family="sans-serif" font-size="8.00">PixelYA16</text>+</g>+<!-- PixelYA16&#45;&gt;PixelRGBA16 -->+<g id="edge8" class="edge"><title>PixelYA16&#45;&gt;PixelRGBA16</title>+<path fill="none" stroke="black" d="M258.152,-83.5434C258.613,-73.883 260.687,-62.36 267,-54 275.273,-43.0444 287.722,-35.28 300.163,-29.8405"/>+<polygon fill="black" stroke="black" points="301.586,-33.0421 309.607,-26.1198 299.02,-26.5294 301.586,-33.0421"/>+<text text-anchor="middle" x="290" y="-58.3" font-family="sans-serif" font-size="8.00">promotePixel</text>+</g>+<!-- PixelYA16&#45;&gt;Pixel16 -->+<g id="edge48" class="edge"><title>PixelYA16&#45;&gt;Pixel16</title>+<path fill="none" stroke="black" d="M229.98,-109.854C206.015,-117.845 177.897,-131.656 191,-150 199.293,-161.611 233.125,-171.835 260.175,-178.391"/>+<polygon fill="black" stroke="black" points="259.609,-181.853 270.143,-180.72 261.201,-175.037 259.609,-181.853"/>+<text text-anchor="middle" x="225" y="-142.3" font-family="sans-serif" font-size="8.00">dropTransparency</text>+</g>+<!-- PixelYA8 -->+<g id="node11" class="node"><title>PixelYA8</title>+<ellipse fill="none" stroke="black" cx="439" cy="-186" rx="28.8445" ry="18"/>+<text text-anchor="middle" x="439" y="-184.3" font-family="sans-serif" font-size="8.00">PixelYA8</text>+</g>+<!-- PixelYA8&#45;&gt;PixelRGB8 -->+<g id="edge12" class="edge"><title>PixelYA8&#45;&gt;PixelRGB8</title>+<path fill="none" stroke="black" d="M464.762,-194.278C489.627,-203.81 525.815,-222.121 542,-252 574.918,-312.769 554.613,-358.387 501,-402 484.752,-415.217 355.671,-428.373 287.639,-434.476"/>+<polygon fill="black" stroke="black" points="287.321,-430.99 277.669,-435.359 287.938,-437.963 287.321,-430.99"/>+<text text-anchor="middle" x="580" y="-310.3" font-family="sans-serif" font-size="8.00">promotePixel</text>+</g>+<!-- PixelYA8&#45;&gt;PixelRGBA8 -->+<g id="edge10" class="edge"><title>PixelYA8&#45;&gt;PixelRGBA8</title>+<path fill="none" stroke="black" d="M460.035,-198.84C467.824,-204.817 475.781,-212.68 480,-222 497.598,-260.871 496.093,-278.904 479,-318 476.725,-323.204 473.295,-328.013 469.411,-332.309"/>+<polygon fill="black" stroke="black" points="466.792,-329.975 462.079,-339.464 471.681,-334.985 466.792,-329.975"/>+<text text-anchor="middle" x="515" y="-268.3" font-family="sans-serif" font-size="8.00">promotePixel</text>+</g>+<!-- PixelYA8&#45;&gt;Pixel8 -->+<g id="edge50" class="edge"><title>PixelYA8&#45;&gt;Pixel8</title>+<path fill="none" stroke="black" d="M412.102,-193.018C393.267,-198.789 368.145,-208.269 349,-222 340.05,-228.419 331.808,-237.196 325.098,-245.49"/>+<polygon fill="black" stroke="black" points="322.247,-243.456 318.929,-253.518 327.797,-247.721 322.247,-243.456"/>+<text text-anchor="middle" x="383" y="-226.3" font-family="sans-serif" font-size="8.00">dropTransparency</text>+</g>+<!-- PixelYA8&#45;&gt;Pixel8 -->+<g id="edge62" class="edge"><title>PixelYA8&#45;&gt;Pixel8</title>+<path fill="none" stroke="black" d="M434.558,-204.131C431.244,-214.175 425.744,-226.175 417,-234 397.039,-251.864 367.99,-260.893 344.899,-265.441"/>+<polygon fill="black" stroke="black" points="344.002,-262.045 334.763,-267.23 345.219,-268.938 344.002,-262.045"/>+<text text-anchor="middle" x="451" y="-226.3" font-family="sans-serif" font-size="8.00">computeLuma</text>+</g>+<!-- PixelF&#45;&gt;PixelRGBF -->+<g id="edge14" class="edge"><title>PixelF&#45;&gt;PixelRGBF</title>+<path fill="none" stroke="black" d="M100.45,-168.312C96.8232,-158.653 91.3784,-146.886 84,-138 78.5966,-131.492 71.7476,-125.606 64.8367,-120.568"/>+<polygon fill="black" stroke="black" points="66.3898,-117.392 56.1539,-114.657 62.4504,-123.178 66.3898,-117.392"/>+<text text-anchor="middle" x="115" y="-142.3" font-family="sans-serif" font-size="8.00">promotePixel</text>+</g>+<!-- Pixel16&#45;&gt;PixelRGB16 -->+<g id="edge18" class="edge"><title>Pixel16&#45;&gt;PixelRGB16</title>+<path fill="none" stroke="black" d="M313.43,-172.019C326.239,-162.023 344.257,-148.532 361,-138 371.689,-131.277 383.756,-124.61 394.725,-118.875"/>+<polygon fill="black" stroke="black" points="396.336,-121.982 403.628,-114.295 393.134,-115.757 396.336,-121.982"/>+<text text-anchor="middle" x="384" y="-142.3" font-family="sans-serif" font-size="8.00">promotePixel</text>+</g>+<!-- Pixel16&#45;&gt;PixelRGBA16 -->+<g id="edge16" class="edge"><title>Pixel16&#45;&gt;PixelRGBA16</title>+<path fill="none" stroke="black" d="M305.084,-168.741C307.903,-162.903 310.835,-156.272 313,-150 325.048,-115.091 333.609,-73.3023 338.424,-46.2333"/>+<polygon fill="black" stroke="black" points="341.89,-46.732 340.143,-36.2822 334.992,-45.5405 341.89,-46.732"/>+<text text-anchor="middle" x="353" y="-100.3" font-family="sans-serif" font-size="8.00">promotePixel</text>+</g>+<!-- Pixel16&#45;&gt;PixelYA16 -->+<g id="edge20" class="edge"><title>Pixel16&#45;&gt;PixelYA16</title>+<path fill="none" stroke="black" d="M280.78,-170.7C275.635,-164.701 270.35,-157.469 267,-150 264.277,-143.93 262.473,-137.052 261.279,-130.438"/>+<polygon fill="black" stroke="black" points="264.727,-129.827 259.862,-120.415 257.796,-130.807 264.727,-129.827"/>+<text text-anchor="middle" x="290" y="-142.3" font-family="sans-serif" font-size="8.00">promotePixel</text>+</g>+<!-- Pixel8&#45;&gt;PixelRGB8 -->+<g id="edge24" class="edge"><title>Pixel8&#45;&gt;PixelRGB8</title>+<path fill="none" stroke="black" d="M312.919,-288.095C319.136,-314.953 326.712,-366.057 306,-402 300.622,-411.332 291.773,-418.518 282.501,-423.926"/>+<polygon fill="black" stroke="black" points="280.83,-420.85 273.581,-428.577 284.067,-427.057 280.83,-420.85"/>+<text text-anchor="middle" x="342" y="-352.3" font-family="sans-serif" font-size="8.00">promotePixel</text>+</g>+<!-- Pixel8&#45;&gt;PixelRGBA8 -->+<g id="edge22" class="edge"><title>Pixel8&#45;&gt;PixelRGBA8</title>+<path fill="none" stroke="black" d="M334.939,-272.185C360.073,-275.561 397.177,-284.15 421,-306 426.855,-311.37 431.048,-318.72 434.03,-326.054"/>+<polygon fill="black" stroke="black" points="430.836,-327.531 437.387,-335.858 437.458,-325.263 430.836,-327.531"/>+<text text-anchor="middle" x="452" y="-310.3" font-family="sans-serif" font-size="8.00">promotePixel</text>+</g>+<!-- Pixel8&#45;&gt;PixelYA8 -->+<g id="edge26" class="edge"><title>Pixel8&#45;&gt;PixelYA8</title>+<path fill="none" stroke="black" d="M290.77,-255.865C280.734,-245.919 271.57,-232.553 280,-222 287.559,-212.538 356.092,-199.635 400.682,-192.122"/>+<polygon fill="black" stroke="black" points="401.335,-195.562 410.626,-190.469 400.187,-188.657 401.335,-195.562"/>+<text text-anchor="middle" x="303" y="-226.3" font-family="sans-serif" font-size="8.00">promotePixel</text>+</g>+<!-- Pixel8&#45;&gt;PixelF -->+<g id="edge28" class="edge"><title>Pixel8&#45;&gt;PixelF</title>+<path fill="none" stroke="black" d="M281.145,-267.812C249.741,-264.331 196.969,-255.554 157,-234 145.577,-227.84 134.814,-218.473 126.146,-209.643"/>+<polygon fill="black" stroke="black" points="128.492,-207.028 119.104,-202.117 123.381,-211.81 128.492,-207.028"/>+<text text-anchor="middle" x="180" y="-226.3" font-family="sans-serif" font-size="8.00">promotePixel</text>+</g>+<!-- Pixel8&#45;&gt;Pixel16 -->+<g id="edge30" class="edge"><title>Pixel8&#45;&gt;Pixel16</title>+<path fill="none" stroke="black" d="M282.206,-263.957C256.398,-257.327 219.359,-246.018 211,-234 196.025,-212.469 230.216,-199.429 259.604,-192.482"/>+<polygon fill="black" stroke="black" points="260.687,-195.828 269.71,-190.275 259.193,-188.989 260.687,-195.828"/>+<text text-anchor="middle" x="234" y="-226.3" font-family="sans-serif" font-size="8.00">promotePixel</text>+</g>+<!-- PixelCMYK16&#45;&gt;PixelRGB16 -->+<g id="edge32" class="edge"><title>PixelCMYK16&#45;&gt;PixelRGB16</title>+<path fill="none" stroke="black" d="M564.03,-35.4654C568.707,-45.2873 571.707,-57.2873 565,-66 553.678,-80.7091 507.858,-90.6423 472.496,-96.2857"/>+<polygon fill="black" stroke="black" points="471.73,-92.862 462.373,-97.8319 472.787,-99.7817 471.73,-92.862"/>+<text text-anchor="middle" x="590" y="-58.3" font-family="sans-serif" font-size="8.00">convertPixel</text>+</g>+<!-- PixelCMYK8&#45;&gt;PixelRGB8 -->+<g id="edge34" class="edge"><title>PixelCMYK8&#45;&gt;PixelRGB8</title>+<path fill="none" stroke="black" d="M257.173,-372.299C258.645,-381.28 259.584,-392.241 258,-402 257.535,-404.865 256.875,-407.811 256.1,-410.724"/>+<polygon fill="black" stroke="black" points="252.737,-409.753 253.143,-420.34 259.427,-411.811 252.737,-409.753"/>+<text text-anchor="middle" x="280" y="-394.3" font-family="sans-serif" font-size="8.00">convertPixel</text>+</g>+<!-- PixelYCbCr8&#45;&gt;PixelRGB8 -->+<g id="edge36" class="edge"><title>PixelYCbCr8&#45;&gt;PixelRGB8</title>+<path fill="none" stroke="black" d="M149.836,-372.162C150.645,-381.97 153.174,-393.727 160,-402 171.431,-415.854 189.112,-424.462 205.475,-429.768"/>+<polygon fill="black" stroke="black" points="204.847,-433.23 215.426,-432.663 206.802,-426.509 204.847,-433.23"/>+<text text-anchor="middle" x="182" y="-394.3" font-family="sans-serif" font-size="8.00">convertPixel</text>+</g>+<!-- PixelYCbCr8&#45;&gt;Pixel8 -->+<g id="edge54" class="edge"><title>PixelYCbCr8&#45;&gt;Pixel8</title>+<path fill="none" stroke="black" d="M174.688,-340.875C202.411,-326.136 247.432,-302.201 277.376,-286.281"/>+<polygon fill="black" stroke="black" points="279.34,-289.201 286.527,-281.416 276.054,-283.02 279.34,-289.201"/>+<text text-anchor="middle" x="263" y="-310.3" font-family="sans-serif" font-size="8.00">computeLuma</text>+</g>+</g>+</svg>
+ src/Codec/Picture.hs view
@@ -0,0 +1,511 @@+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
+-- | Main module for image import/export into various image formats.
+--
+-- To use the library without thinking about it, look after 'decodeImage' and
+-- 'readImage'.
+--
+-- Generally, the @read*@ functions read the images from a file and try to decode
+-- it, and the @decode*@ functions try to decode a bytestring.
+--
+-- For an easy image writing use the 'saveBmpImage', 'saveJpgImage' & 'savePngImage'
+-- functions
+module Codec.Picture (
+                     -- * Generic functions
+                       readImage
+                     , readImageWithMetadata
+                     , decodeImage
+                     , decodeImageWithMetadata
+                     , decodeImageWithPaletteAndMetadata
+                     , pixelMap
+                     , dynamicMap
+                     , dynamicPixelMap
+                     , generateImage
+                     , generateFoldImage
+                     , withImage
+                     , palettedToTrueColor
+
+                      -- * RGB helper functions
+                     , convertRGB8
+                     , convertRGB16
+                     , convertRGBA8
+
+                     -- * Lens compatibility
+                     , Traversal
+                     , imagePixels
+                     , imageIPixels
+
+                     -- * Generic image writing
+                     , saveBmpImage
+                     , saveJpgImage
+                     , saveGifImage
+                     , savePngImage
+                     , saveTiffImage
+                     , saveRadianceImage
+
+                     -- * Specific image format functions
+                     -- ** Bitmap handling
+                     , BmpEncodable
+                     , writeBitmap
+                     , encodeBitmap
+                     , readBitmap
+                     , decodeBitmap
+                     , encodeDynamicBitmap
+                     , writeDynamicBitmap
+
+                     -- ** Gif handling
+                     , readGif
+                     , readGifImages
+                     , decodeGif
+                     , decodeGifImages
+
+                     , encodeGifImage
+                     , writeGifImage
+                     , encodeGifImageWithPalette
+                     , writeGifImageWithPalette
+                     , encodeColorReducedGifImage
+                     , writeColorReducedGifImage 
+                     , encodeGifImages
+                     , writeGifImages
+
+                     -- *** Gif animation
+                     , GifDelay
+                     , GifLooping( .. )
+                     , encodeGifAnimation
+                     , writeGifAnimation
+
+                     -- ** Jpeg handling
+                     , readJpeg
+                     , decodeJpeg
+                     , encodeJpeg
+                     , encodeJpegAtQuality
+
+                     -- ** Png handling
+                     , PngSavable( .. )
+                     , readPng
+                     , decodePng
+                     , writePng
+                     , encodePalettedPng
+                     , encodeDynamicPng
+                     , writeDynamicPng
+
+                     -- ** TGA handling
+                     , readTGA
+                     , decodeTga
+                     , TgaSaveable
+                     , encodeTga
+                     , writeTga
+
+                     -- ** Tiff handling
+                     , readTiff
+                     , TiffSaveable
+                     , decodeTiff
+                     , encodeTiff
+                     , writeTiff
+
+                     -- ** HDR (Radiance/RGBE) handling
+                     , readHDR
+                     , decodeHDR
+                     , encodeHDR
+                     , writeHDR
+
+                     -- ** Color Quantization
+                     , PaletteCreationMethod(..)
+                     , PaletteOptions(..)
+                     , palettize
+
+                     -- * Image types and pixel types
+                     -- ** Image
+                     , Image( .. )
+                     , DynamicImage( .. )
+                     , Palette
+                     -- ** Pixels
+                     , Pixel( .. )
+                     -- $graph
+                     , Pixel8
+                     , Pixel16
+                     , Pixel32
+                     , PixelF
+
+                     , PixelYA8( .. )
+                     , PixelYA16( .. )
+                     , PixelRGB8( .. )
+                     , PixelRGB16( .. )
+                     , PixelRGBF( .. )
+                     , PixelRGBA8( .. )
+                     , PixelRGBA16( .. )
+                     , PixelYCbCr8( .. )
+                     , PixelCMYK8( .. )
+                     , PixelCMYK16( .. )
+
+                     -- * Foreign unsafe import
+                     , imageFromUnsafePtr
+                     ) where
+
+#if !MIN_VERSION_base(4,8,0)
+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
+                           , decodeBitmapWithPaletteAndMetadata
+                           , writeBitmap, encodeBitmap
+                           , encodeDynamicBitmap, writeDynamicBitmap )
+import Codec.Picture.Jpg( decodeJpeg
+                        , decodeJpegWithMetadata
+                        , encodeJpeg
+                        , encodeJpegAtQuality )
+import Codec.Picture.Png( PngSavable( .. )
+                        , decodePng
+                        , decodePngWithPaletteAndMetadata
+                        , writePng
+                        , encodeDynamicPng
+                        , encodePalettedPng
+                        , writeDynamicPng
+                        )
+
+import Codec.Picture.Gif( GifDelay
+                        , GifLooping( .. )
+                        , decodeGif
+                        , decodeGifWithPaletteAndMetadata
+                        , decodeGifImages
+                        , encodeGifImage
+                        , encodeGifImageWithPalette
+                        , encodeGifImages
+
+                        , writeGifImage
+                        , writeGifImageWithPalette
+                        , writeGifImages
+                        )
+
+import Codec.Picture.HDR( decodeHDR
+                        , decodeHDRWithMetadata
+                        , encodeHDR
+                        , writeHDR
+                        )
+import Codec.Picture.Tiff( decodeTiff
+                         , decodeTiffWithPaletteAndMetadata
+                         , TiffSaveable
+                         , encodeTiff
+                         , writeTiff )
+import Codec.Picture.Tga( TgaSaveable
+                        , decodeTga
+                        , decodeTgaWithPaletteAndMetadata
+                        , encodeTga
+                        , writeTga
+                        )
+import Codec.Picture.Saving
+import Codec.Picture.Types
+import Codec.Picture.ColorQuant
+import Codec.Picture.VectorByteConversion( imageFromUnsafePtr )
+-- import System.IO ( withFile, IOMode(ReadMode) )
+#ifdef WITH_MMAP_BYTESTRING
+import System.IO.MMap ( mmapFileByteString )
+#endif
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Vector.Storable as VS
+
+-- | Return the first Right thing, accumulating error
+eitherLoad :: c -> [(String, c -> Either String b)] -> Either String b
+eitherLoad v = inner ""
+    where inner errAcc [] = Left $ "Cannot load file\n" ++ errAcc
+          inner errAcc ((hdr, f) : rest) = case f v of
+                Left  err  -> inner (errAcc ++ hdr ++ " " ++ err ++ "\n") rest
+                Right rez  -> Right rez
+
+-- | Encode a full color image to a gif by applying a color quantization
+-- algorithm on it.
+encodeColorReducedGifImage :: Image PixelRGB8 -> Either String L.ByteString
+encodeColorReducedGifImage img = encodeGifImageWithPalette indexed pal
+  where (indexed, pal) = palettize defaultPaletteOptions img
+
+-- | Write a full color image to a gif by applying a color quantization
+-- algorithm on it.
+writeColorReducedGifImage :: FilePath -> Image PixelRGB8 -> Either String (IO ())
+writeColorReducedGifImage path img =
+    L.writeFile path <$> encodeColorReducedGifImage img
+
+
+-- | Helper function to create a gif animation.
+-- All the images of the animation are separated
+-- by the same delay.
+encodeGifAnimation :: GifDelay -> GifLooping
+                   -> [Image PixelRGB8] -> Either String L.ByteString
+encodeGifAnimation delay looping lst =
+    encodeGifImages looping
+        [(pal, delay, img)
+                | (img, pal) <- palettize defaultPaletteOptions <$> lst]
+
+-- | Helper function to write a gif animation on disk.
+-- See encodeGifAnimation
+writeGifAnimation :: FilePath -> GifDelay -> GifLooping
+                  -> [Image PixelRGB8] -> Either String (IO ())
+writeGifAnimation path delay looping img =
+    L.writeFile path <$> encodeGifAnimation delay looping img
+
+withImageDecoder :: (NFData a)
+                 => (B.ByteString -> Either String a) -> FilePath
+                 -> IO (Either String a)
+withImageDecoder decoder path = Exc.catch doit
+                    (\e -> return . Left $ show (e :: Exc.IOException))
+    where doit = force . decoder <$> get
+#ifdef WITH_MMAP_BYTESTRING
+          get = mmapFileByteString path Nothing
+#else
+          get = B.readFile path
+#endif
+          -- force appeared in deepseq 1.3, Haskell Platform
+          -- provides 1.1
+          force x = x `deepseq` x
+
+-- | Load an image file without even thinking about it, it does everything
+-- as 'decodeImage'
+readImage :: FilePath -> IO (Either String DynamicImage)
+readImage = withImageDecoder decodeImage
+
+-- | Equivalent to 'readImage'  but also providing metadatas.
+readImageWithMetadata :: FilePath -> IO (Either String (DynamicImage, Metadatas))
+readImageWithMetadata = withImageDecoder decodeImageWithMetadata
+
+
+-- | If you want to decode an image in a bytestring without even thinking
+-- in term of format or whatever, this is the function to use. It will try
+-- to decode in each known format and if one decoding succeeds, it will return
+-- the decoded image in it's own colorspace.
+decodeImage :: B.ByteString -> Either String DynamicImage
+decodeImage = fmap fst . decodeImageWithMetadata 
+
+class Decimable px1 px2 where
+   decimateBitDepth :: Image px1 -> Image px2
+
+decimateWord16 :: ( Pixel px1, Pixel px2
+                  , PixelBaseComponent px1 ~ Pixel16
+                  , PixelBaseComponent px2 ~ Pixel8
+                  ) => Image px1 -> Image px2
+decimateWord16 (Image w h da) =
+  Image w h $ VS.map (\v -> fromIntegral $ v `unsafeShiftR` 8) da
+
+decimateWord3216 :: ( Pixel px1, Pixel px2
+                  , PixelBaseComponent px1 ~ Pixel32
+                  , PixelBaseComponent px2 ~ Pixel16
+                  ) => Image px1 -> Image px2
+decimateWord3216 (Image w h da) =
+  Image w h $ VS.map (\v -> fromIntegral $ v `unsafeShiftR` 16) da
+  
+decimateWord32 :: ( Pixel px1, Pixel px2
+                  , PixelBaseComponent px1 ~ Pixel32
+                  , PixelBaseComponent px2 ~ Pixel8
+                  ) => Image px1 -> Image px2
+decimateWord32 (Image w h da) =
+  Image w h $ VS.map (\v -> fromIntegral $ v `unsafeShiftR` 24) da
+
+decimateFloat :: ( Pixel px1, Pixel px2
+                 , PixelBaseComponent px1 ~ PixelF
+                 , PixelBaseComponent px2 ~ Pixel8
+                 ) => Image px1 -> Image px2
+decimateFloat (Image w h da) =
+  Image w h $ VS.map (floor . (255*) . max 0 . min 1) da
+
+decimateFloat16 :: ( Pixel px1, Pixel px2
+                 , PixelBaseComponent px1 ~ PixelF
+                 , PixelBaseComponent px2 ~ Pixel16
+                 ) => Image px1 -> Image px2
+decimateFloat16 (Image w h da) =
+  Image w h $ VS.map (floor . (65535*) . max 0 . min 1) da
+
+instance Decimable Pixel16 Pixel8 where
+   decimateBitDepth = decimateWord16
+
+instance Decimable Pixel32 Pixel16 where
+   decimateBitDepth = decimateWord3216
+
+instance Decimable Pixel32 Pixel8 where
+   decimateBitDepth = decimateWord32
+
+instance Decimable PixelYA16 PixelYA8 where
+   decimateBitDepth = decimateWord16
+
+instance Decimable PixelRGB16 PixelRGB8 where
+   decimateBitDepth = decimateWord16
+
+instance Decimable PixelRGBA16 PixelRGBA8 where
+   decimateBitDepth = decimateWord16
+
+instance Decimable PixelCMYK16 PixelCMYK8 where
+   decimateBitDepth = decimateWord16
+
+instance Decimable PixelF Pixel8 where
+   decimateBitDepth = decimateFloat
+
+instance Decimable PixelF Pixel16 where
+   decimateBitDepth = decimateFloat16
+
+instance Decimable PixelRGBF PixelRGB8 where
+   decimateBitDepth = decimateFloat
+
+instance Decimable PixelRGBF PixelRGB16 where
+   decimateBitDepth = decimateFloat16
+
+-- | Convert by any means possible a dynamic image to an image
+-- in RGBA. The process can lose precision while converting from
+-- 16bits pixels or Floating point pixels.
+convertRGBA8 :: DynamicImage -> Image PixelRGBA8
+convertRGBA8 dynImage = case dynImage of
+  ImageY8     img -> promoteImage img
+  ImageY16    img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+  ImageY32    img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+  ImageYF     img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+  ImageYA8    img -> promoteImage img
+  ImageYA16   img -> promoteImage (decimateBitDepth img :: Image PixelYA8)
+  ImageRGB8   img -> promoteImage img
+  ImageRGB16  img -> promoteImage (decimateBitDepth img :: Image PixelRGB8)
+  ImageRGBF   img -> promoteImage (decimateBitDepth img :: Image PixelRGB8)
+  ImageRGBA8  img -> promoteImage img
+  ImageRGBA16 img -> decimateBitDepth img
+  ImageYCbCr8 img -> promoteImage (convertImage img :: Image PixelRGB8)
+  ImageCMYK8  img -> promoteImage (convertImage img :: Image PixelRGB8)
+  ImageCMYK16 img ->
+    promoteImage (convertImage (decimateBitDepth img :: Image PixelCMYK8) :: Image PixelRGB8)
+
+-- | Convert by any means possible a dynamic image to an image
+-- in RGB. The process can lose precision while converting from
+-- 16bits pixels or Floating point pixels. Any alpha layer will
+-- be dropped
+convertRGB8 :: DynamicImage -> Image PixelRGB8
+convertRGB8 dynImage = case dynImage of
+  ImageY8     img -> promoteImage img
+  ImageY16    img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+  ImageY32    img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+  ImageYF     img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+  ImageYA8    img -> promoteImage img
+  ImageYA16   img -> promoteImage (decimateBitDepth img :: Image PixelYA8)
+  ImageRGB8   img -> img
+  ImageRGB16  img -> decimateBitDepth img
+  ImageRGBF   img -> decimateBitDepth img :: Image PixelRGB8
+  ImageRGBA8  img -> dropAlphaLayer img
+  ImageRGBA16 img -> dropAlphaLayer (decimateBitDepth img :: Image PixelRGBA8)
+  ImageYCbCr8 img -> convertImage img
+  ImageCMYK8  img -> convertImage img
+  ImageCMYK16 img -> convertImage (decimateBitDepth img :: Image PixelCMYK8)
+  
+-- | Convert by any means possible a dynamic image to an image
+-- in RGB. The process can lose precision while converting from
+-- 32bits pixels or Floating point pixels. Any alpha layer will
+-- be dropped
+convertRGB16 :: DynamicImage -> Image PixelRGB16
+convertRGB16 dynImage = case dynImage of
+  ImageY8     img -> promoteImage img
+  ImageY16    img -> promoteImage img
+  ImageY32    img -> promoteImage (decimateBitDepth img :: Image Pixel16)
+  ImageYF     img -> promoteImage (decimateBitDepth img :: Image Pixel16)
+  ImageYA8    img -> promoteImage img
+  ImageYA16   img -> promoteImage img
+  ImageRGB8   img -> promoteImage img
+  ImageRGB16  img -> img
+  ImageRGBF   img -> decimateBitDepth img :: Image PixelRGB16
+  ImageRGBA8  img -> dropAlphaLayer (promoteImage img :: Image PixelRGBA16)
+  ImageRGBA16 img -> dropAlphaLayer img
+  ImageYCbCr8 img -> promoteImage (convertImage img :: Image PixelRGB8)
+  ImageCMYK8  img -> promoteImage (convertImage img :: Image PixelRGB8)
+  ImageCMYK16 img -> convertImage img
+
+-- | 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 =
+    fmap (first palettedToTrueColor) . decodeImageWithPaletteAndMetadata
+
+-- | Helper function trying to load a png file from a file on disk.
+readPng :: FilePath -> IO (Either String DynamicImage)
+readPng = withImageDecoder decodePng
+
+-- | Helper function trying to load a gif file from a file on disk.
+readGif :: FilePath -> IO (Either String DynamicImage)
+readGif = withImageDecoder decodeGif
+
+-- | Helper function trying to load tiff file from a file on disk.
+readTiff :: FilePath -> IO (Either String DynamicImage)
+readTiff = withImageDecoder decodeTiff
+
+-- | Helper function trying to load all the images of an animated
+-- gif file.
+readGifImages :: FilePath -> IO (Either String [DynamicImage])
+readGifImages = withImageDecoder decodeGifImages
+
+-- | Try to load a jpeg file and decompress. The colorspace is still
+-- YCbCr if you want to perform computation on the luma part. You can
+-- convert it to RGB using 'colorSpaceConversion'.
+readJpeg :: FilePath -> IO (Either String DynamicImage)
+readJpeg = withImageDecoder decodeJpeg
+
+-- | Try to load a .bmp file. The colorspace would be RGB, RGBA or Y.
+readBitmap :: FilePath -> IO (Either String DynamicImage)
+readBitmap = withImageDecoder decodeBitmap
+
+-- | Try to load a .pic file. The colorspace can only be
+-- RGB with floating point precision.
+readHDR :: FilePath -> IO (Either String DynamicImage)
+readHDR = withImageDecoder decodeHDR
+
+-- | Try to load a .tga file from disk.
+readTGA :: FilePath -> IO (Either String DynamicImage)
+readTGA = withImageDecoder decodeTga
+
+-- | Save an image to a '.jpg' file, will do everything it can to save an image.
+saveJpgImage :: Int -> FilePath -> DynamicImage -> IO ()
+saveJpgImage quality path img = L.writeFile path $ imageToJpg quality img
+
+-- | Save an image to a '.gif' file, will do everything it can to save it.
+saveGifImage :: FilePath -> DynamicImage -> Either String (IO ())
+saveGifImage path img = L.writeFile path <$> imageToGif img
+
+-- | Save an image to a '.tiff' file, will do everything it can to save an image.
+saveTiffImage :: FilePath -> DynamicImage -> IO ()
+saveTiffImage path img = L.writeFile path $ imageToTiff img
+
+-- | Save an image to a '.hdr' file, will do everything it can to save an image.
+saveRadianceImage :: FilePath -> DynamicImage -> IO ()
+saveRadianceImage path = L.writeFile path . imageToRadiance
+
+-- | Save an image to a '.png' file, will do everything it can to save an image.
+-- For example, a simple transcoder to png
+--
+-- > transcodeToPng :: FilePath -> FilePath -> IO ()
+-- > transcodeToPng pathIn pathOut = do
+-- >    eitherImg <- readImage pathIn
+-- >    case eitherImg of
+-- >        Left _ -> return ()
+-- >        Right img -> savePngImage pathOut img
+--
+savePngImage :: FilePath -> DynamicImage -> IO ()
+savePngImage path img = L.writeFile path $ imageToPng img
+
+-- | Save an image to a '.bmp' file, will do everything it can to save an image.
+saveBmpImage :: FilePath -> DynamicImage -> IO ()
+saveBmpImage path img = L.writeFile path $ imageToBitmap img
+
+ src/Codec/Picture/BitWriter.hs view
@@ -0,0 +1,358 @@+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+-- | This module implement helper functions to read & write data
+-- at bits level.
+module Codec.Picture.BitWriter( BoolReader
+                              , emptyBoolState
+                              , BoolState
+                              , byteAlignJpg
+                              , getNextBitsLSBFirst
+                              , getNextBitsMSBFirst 
+                              , getNextBitJpg
+                              , getNextIntJpg
+                              , setDecodedString
+                              , setDecodedStringMSB
+                              , setDecodedStringJpg
+                              , runBoolReader
+
+                              , BoolWriteStateRef 
+                              , newWriteStateRef
+                              , finalizeBoolWriter
+                              , finalizeBoolWriterGif
+                              , writeBits'
+                              , writeBitsGif
+
+                              , initBoolState 
+                              , initBoolStateJpg
+                              , execBoolReader
+                              , runBoolReaderWith
+                              ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<*>), (<$>) )
+#endif
+
+import Data.STRef
+import Control.Monad( when )
+import Control.Monad.ST( ST )
+import qualified Control.Monad.Trans.State.Strict as S
+import Data.Int ( Int32 )
+import Data.Word( Word8, Word32 )
+import Data.Bits( (.&.), (.|.), unsafeShiftR, unsafeShiftL )
+
+import Codec.Picture.VectorByteConversion( blitVector )
+import qualified Data.Vector.Storable.Mutable as M
+import qualified Data.Vector.Storable as VS
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+
+
+--------------------------------------------------
+----            Reader
+--------------------------------------------------
+-- | Current bit index, current value, string
+data BoolState = BoolState {-# UNPACK #-} !Int
+                           {-# UNPACK #-} !Word8
+                           !B.ByteString
+
+emptyBoolState :: BoolState
+emptyBoolState = BoolState (-1) 0 B.empty
+
+-- | Type used to read bits
+type BoolReader s a = S.StateT BoolState (ST s) a
+
+runBoolReader :: BoolReader s a -> ST s a
+runBoolReader action = S.evalStateT action $ BoolState 0 0 B.empty
+
+runBoolReaderWith :: BoolState -> BoolReader s a -> ST s (a, BoolState)
+runBoolReaderWith st action = S.runStateT action st
+
+execBoolReader :: BoolState -> BoolReader s a -> ST s BoolState
+execBoolReader st reader = S.execStateT reader st
+
+initBoolState :: B.ByteString -> BoolState
+initBoolState str = case B.uncons str of
+     Nothing -> BoolState 0 0 B.empty
+     Just (v, rest) -> BoolState 0 v rest
+
+initBoolStateJpg :: B.ByteString -> BoolState
+initBoolStateJpg str = 
+   case B.uncons str of
+     Nothing -> BoolState 0 0 B.empty
+     Just (0xFF, rest) -> case B.uncons rest of
+            Nothing                  -> BoolState 7 0 B.empty
+            Just (0x00, afterMarker) -> BoolState 7 0xFF afterMarker
+            Just (_   , afterMarker) -> initBoolStateJpg afterMarker
+     Just (v, rest) -> BoolState 7 v rest
+
+-- | Bitify a list of things to decode.
+setDecodedString :: B.ByteString -> BoolReader s ()
+setDecodedString str = case B.uncons str of
+     Nothing        -> S.put $ BoolState      0 0 B.empty
+     Just (v, rest) -> S.put $ BoolState      0 v    rest
+
+-- | Drop all bit until the bit of indice 0, usefull to parse restart
+-- marker, as they are byte aligned, but Huffman might not.
+byteAlignJpg :: BoolReader s ()
+byteAlignJpg = do
+  BoolState idx _ chain <- S.get
+  when (idx /= 7) (setDecodedStringJpg chain)
+
+getNextBitJpg :: BoolReader s Bool
+{-# INLINE getNextBitJpg #-}
+getNextBitJpg = do
+    BoolState idx v chain <- S.get
+    let val = (v .&. (1 `unsafeShiftL` idx)) /= 0
+    if idx == 0
+      then setDecodedStringJpg chain
+      else S.put $ BoolState (idx - 1) v chain
+    return val
+
+getNextIntJpg :: Int -> BoolReader s Int32
+{-# INLINE getNextIntJpg #-}
+getNextIntJpg = go 0 where
+  go !acc !0 = return acc
+  go !acc !n = do
+    BoolState idx v chain <- S.get
+    let !leftBits = 1 + fromIntegral idx
+    if n >= leftBits then do
+      setDecodedStringJpg chain
+      let !remaining = n - leftBits
+          !mask = (1 `unsafeShiftL` leftBits) - 1
+          !finalV = fromIntegral v .&. mask
+          !theseBits = finalV `unsafeShiftL` remaining
+      go (acc .|. theseBits) remaining
+    else do
+      let !remaining = leftBits - n
+          !mask = (1 `unsafeShiftL` n) - 1
+          !finalV = fromIntegral v `unsafeShiftR` remaining
+      S.put $ BoolState (fromIntegral remaining - 1) v chain
+      return $ (finalV .&. mask) .|. acc
+
+
+setDecodedStringMSB :: B.ByteString -> BoolReader s ()
+setDecodedStringMSB str = case B.uncons str of
+  Nothing        -> S.put $ BoolState      8 0 B.empty
+  Just (v, rest) -> S.put $ BoolState      8 v    rest
+
+
+{-# INLINE getNextBitsMSBFirst #-}
+getNextBitsMSBFirst :: Int -> BoolReader s Word32
+getNextBitsMSBFirst requested = go 0 requested where
+  go :: Word32 -> Int -> BoolReader s Word32
+  go !acc !0 = return acc
+  go !acc !n = do
+    BoolState idx v chain <- S.get
+    let !leftBits = fromIntegral idx
+    if n >= leftBits then do
+      setDecodedStringMSB chain
+      let !theseBits = fromIntegral v `unsafeShiftL` (n - leftBits)
+      go (acc .|. theseBits) (n - leftBits)
+    else do
+      let !remaining = leftBits - n
+          !mask = (1 `unsafeShiftL` remaining) - 1
+      S.put $ BoolState (fromIntegral remaining) (v .&. mask) chain
+      return $ (fromIntegral v `unsafeShiftR` remaining) .|. acc
+
+{-# INLINE getNextBitsLSBFirst #-}
+getNextBitsLSBFirst :: Int -> BoolReader s Word32
+getNextBitsLSBFirst count = aux 0 count
+  where aux acc 0 = return acc
+        aux acc n = do
+            bit <- getNextBit
+            let nextVal | bit = acc .|. (1 `unsafeShiftL` (count - n))
+                        | otherwise = acc
+            aux nextVal (n - 1)
+
+{-# INLINE getNextBit #-}
+getNextBit :: BoolReader s Bool
+getNextBit = do
+    BoolState idx v chain <- S.get
+    let val = (v .&. (1 `unsafeShiftL` idx)) /= 0
+    if idx == 7
+      then setDecodedString chain
+      else S.put $ BoolState (idx + 1) v chain
+    return val
+
+-- | Bitify a list of things to decode. Handle Jpeg escape
+-- code (0xFF 0x00), thus should be only used in JPEG decoding.
+setDecodedStringJpg :: B.ByteString -> BoolReader s ()
+setDecodedStringJpg str = case B.uncons str of
+     Nothing        -> S.put $ BoolState 7 0 B.empty
+     Just (0xFF, rest) -> case B.uncons rest of
+            Nothing                  -> S.put $ BoolState 7 0 B.empty
+            Just (0x00, afterMarker) -> -- trace "00" $ 
+                S.put $ BoolState 7 0xFF afterMarker
+            Just (_   , afterMarker) -> setDecodedStringJpg afterMarker
+     Just (v, rest) ->
+        S.put $ BoolState 7 v rest
+
+--------------------------------------------------
+----            Writer
+--------------------------------------------------
+defaultBufferSize :: Int
+defaultBufferSize = 256 * 1024
+
+data BoolWriteStateRef s = BoolWriteStateRef
+        { bwsCurrBuffer   :: STRef s (M.MVector s Word8)
+        , bwsBufferList   :: STRef s [B.ByteString]
+        , bwsWrittenWords :: STRef s Int
+        , bwsBitAcc       :: STRef s Word8
+        , bwsBitReaded    :: STRef s Int
+        }
+
+newWriteStateRef :: ST s (BoolWriteStateRef s)
+newWriteStateRef = do
+    origMv <- M.new defaultBufferSize
+    BoolWriteStateRef <$> newSTRef origMv
+                      <*> newSTRef []
+                      <*> newSTRef 0
+                      <*> newSTRef 0
+                      <*> newSTRef 0
+
+finalizeBoolWriter :: BoolWriteStateRef s -> ST s L.ByteString
+finalizeBoolWriter st = do
+    flushLeftBits' st
+    forceBufferFlushing' st
+    L.fromChunks <$> readSTRef (bwsBufferList st)
+
+forceBufferFlushing' :: BoolWriteStateRef s -> ST s ()
+forceBufferFlushing' (BoolWriteStateRef { bwsCurrBuffer = vecRef
+                                        , bwsWrittenWords = countRef
+                                        , bwsBufferList = lstRef
+                                        }) = do
+    vec <- readSTRef vecRef
+    count <- readSTRef countRef
+    lst <- readSTRef lstRef
+
+    nmv <- M.new defaultBufferSize
+    str <- byteStringFromVector vec count
+
+    writeSTRef vecRef nmv
+    writeSTRef lstRef $ lst ++ [str]
+    writeSTRef countRef 0
+
+flushCurrentBuffer' :: BoolWriteStateRef s -> ST s ()
+flushCurrentBuffer' st = do
+    count <- readSTRef $ bwsWrittenWords st
+    when (count >= defaultBufferSize)
+         (forceBufferFlushing' st)
+
+byteStringFromVector :: M.MVector s Word8 -> Int -> ST s B.ByteString
+byteStringFromVector vec size = do
+    frozen <- VS.unsafeFreeze vec
+    return $ blitVector frozen 0 size
+
+setBitCount' :: BoolWriteStateRef s -> Word8 -> Int -> ST s ()
+{-# INLINE setBitCount' #-}
+setBitCount' st acc count = do
+    writeSTRef (bwsBitAcc st) acc
+    writeSTRef (bwsBitReaded st) count
+
+resetBitCount' :: BoolWriteStateRef s -> ST s ()
+{-# INLINE resetBitCount' #-}
+resetBitCount' st = setBitCount' st 0 0
+
+pushByte' :: BoolWriteStateRef s -> Word8 -> ST s ()
+{-# INLINE pushByte' #-}
+pushByte' st v = do
+    flushCurrentBuffer' st
+    idx <- readSTRef (bwsWrittenWords st)
+    vec <- readSTRef (bwsCurrBuffer st)
+    M.write vec idx v
+    writeSTRef (bwsWrittenWords st) $ idx + 1
+
+flushLeftBits' :: BoolWriteStateRef s -> ST s ()
+flushLeftBits' st = do
+    currCount <- readSTRef $ bwsBitReaded st
+    when (currCount > 0) $ do
+      currWord <- readSTRef $ bwsBitAcc st
+      pushByte' st $ currWord `unsafeShiftL` (8 - currCount)
+
+-- | Append some data bits to a Put monad.
+writeBits' :: BoolWriteStateRef s
+           -> Word32     -- ^ The real data to be stored. Actual data should be in the LSB
+           -> Int        -- ^ Number of bit to write from 1 to 32
+           -> ST s ()
+{-# INLINE writeBits' #-}
+writeBits' st d c = do
+    currWord <- readSTRef $ bwsBitAcc st
+    currCount <- readSTRef $  bwsBitReaded st
+    serialize d c currWord currCount
+  where dumpByte 0xFF = pushByte' st 0xFF >> pushByte' st 0x00
+        dumpByte    i = pushByte' st i
+
+        serialize bitData bitCount currentWord count
+            | bitCount + count == 8 = do
+                     resetBitCount' st
+                     dumpByte (fromIntegral $ (currentWord `unsafeShiftL` bitCount) .|.
+                                                fromIntegral cleanData)
+
+            | bitCount + count < 8 =
+                let newVal = currentWord `unsafeShiftL` bitCount
+                in setBitCount' st (newVal .|. fromIntegral cleanData) $ count + bitCount
+
+            | otherwise =
+                let leftBitCount = 8 - count :: Int
+                    highPart = cleanData `unsafeShiftR` (bitCount - leftBitCount) :: Word32
+                    prevPart = fromIntegral currentWord `unsafeShiftL` leftBitCount :: Word32
+
+                    nextMask = (1 `unsafeShiftL` (bitCount - leftBitCount)) - 1 :: Word32
+                    newData = cleanData .&. nextMask :: Word32
+                    newCount = bitCount - leftBitCount :: Int
+
+                    toWrite = fromIntegral $ prevPart .|. highPart :: Word8
+                in dumpByte toWrite >> serialize newData newCount 0 0
+
+              where cleanMask = (1 `unsafeShiftL` bitCount) - 1 :: Word32
+                    cleanData = bitData .&. cleanMask     :: Word32
+
+-- | Append some data bits to a Put monad.
+writeBitsGif :: BoolWriteStateRef s
+             -> Word32     -- ^ The real data to be stored. Actual data should be in the LSB
+             -> Int        -- ^ Number of bit to write from 1 to 32
+             -> ST s ()
+{-# INLINE writeBitsGif #-}
+writeBitsGif st d c = do
+    currWord <- readSTRef $ bwsBitAcc st
+    currCount <- readSTRef $  bwsBitReaded st
+    serialize d c currWord currCount
+  where dumpByte = pushByte' st
+
+        serialize bitData bitCount currentWord count
+            | bitCount + count == 8 = do
+                     resetBitCount' st
+                     dumpByte (fromIntegral $ currentWord  .|.
+                                                (fromIntegral cleanData `unsafeShiftL` count))
+
+            | bitCount + count < 8 =
+                let newVal = fromIntegral cleanData `unsafeShiftL` count
+                in setBitCount' st (newVal .|. currentWord) $ count + bitCount
+
+            | otherwise =
+                let leftBitCount = 8 - count :: Int
+                    newData = cleanData `unsafeShiftR` leftBitCount :: Word32
+                    newCount = bitCount - leftBitCount :: Int
+                    toWrite = fromIntegral $ fromIntegral currentWord 
+                                            .|. (cleanData `unsafeShiftL` count) :: Word8
+                in dumpByte toWrite >> serialize newData newCount 0 0
+
+              where cleanMask = (1 `unsafeShiftL` bitCount) - 1 :: Word32
+                    cleanData = bitData .&. cleanMask     :: Word32
+
+finalizeBoolWriterGif :: BoolWriteStateRef s -> ST s L.ByteString
+finalizeBoolWriterGif st = do
+    flushLeftBitsGif st
+    forceBufferFlushing' st
+    L.fromChunks <$> readSTRef (bwsBufferList st)
+
+flushLeftBitsGif :: BoolWriteStateRef s -> ST s ()
+flushLeftBitsGif st = do
+    currCount <- readSTRef $ bwsBitReaded st
+    when (currCount > 0) $ do
+      currWord <- readSTRef $ bwsBitAcc st
+      pushByte' st currWord
+
+{-# ANN module "HLint: ignore Reduce duplication" #-}
+
+ src/Codec/Picture/Bitmap.hs view
@@ -0,0 +1,1037 @@+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+-- | Modules used for Bitmap file (.bmp) file loading and writing
+module Codec.Picture.Bitmap( -- * Functions
+                             writeBitmap
+                           , encodeBitmap
+                           , encodeBitmapWithMetadata
+                           , decodeBitmap
+                           , decodeBitmapWithMetadata
+                           , decodeBitmapWithPaletteAndMetadata
+                           , encodeDynamicBitmap
+                           , encodeBitmapWithPaletteAndMetadata
+                           , writeDynamicBitmap
+                             -- * Accepted format in output
+                           , BmpEncodable( )
+                           ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid( mempty )
+import Control.Applicative( (<$>) )
+#endif
+
+import Control.Arrow( first )
+import Control.Monad( replicateM, when, foldM_, forM_, void )
+import Control.Monad.ST ( ST, runST )
+import Data.Maybe( fromMaybe )
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector.Storable.Mutable as M
+import Data.Binary( Binary( .. ) )
+import Data.Binary.Put( Put
+                      , runPut
+                      , putInt32le
+                      , putWord16le
+                      , putWord32le
+                      , putByteString
+                      )
+
+import Data.Binary.Get( Get
+                      , getWord8
+                      , getWord16le
+                      , getWord32le
+                      , getInt32le
+                      , getByteString
+                      , bytesRead
+                      , skip
+                      , label
+                      )
+
+import Data.Bits
+import Data.Int( Int32 )
+import Data.Word( Word32, Word16, Word8 )
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Internal as BI
+import qualified Data.ByteString.Lazy as L
+
+import Codec.Picture.InternalHelper
+import Codec.Picture.Types
+import Codec.Picture.VectorByteConversion
+import qualified Codec.Picture.Metadata as Met
+import Codec.Picture.Metadata ( Metadatas )
+
+data BmpHeader = BmpHeader
+    { magicIdentifier :: !Word16
+    , fileSize        :: !Word32 -- ^ in bytes
+    , reserved1       :: !Word16
+    , reserved2       :: !Word16
+    , dataOffset      :: !Word32
+    }
+
+bitmapMagicIdentifier :: Word16
+bitmapMagicIdentifier = 0x4D42
+
+instance Binary BmpHeader where
+    put hdr = do
+        putWord16le $ magicIdentifier hdr
+        putWord32le $ fileSize hdr
+        putWord16le $ reserved1 hdr
+        putWord16le $ reserved2 hdr
+        putWord32le $ dataOffset hdr
+
+    get = do
+        ident <- getWord16le
+        when (ident /= bitmapMagicIdentifier)
+             (fail "Invalid Bitmap magic identifier")
+        fsize <- getWord32le
+        r1 <- getWord16le
+        r2 <- getWord16le
+        offset <- getWord32le
+        return BmpHeader
+            { magicIdentifier = ident
+            , fileSize = fsize
+            , reserved1 = r1
+            , reserved2 = r2
+            , dataOffset = offset
+            }
+
+-- | The type of color space declared in a Windows BMP file.
+data ColorSpaceType = CalibratedRGB
+                    | DeviceDependentRGB
+                    | DeviceDependentCMYK
+                    | SRGB
+                    | WindowsColorSpace
+                    | ProfileEmbedded
+                    | ProfileLinked
+                    | UnknownColorSpace Word32
+                    deriving (Eq, Show)
+
+-- | BITMAPxHEADER with compatibility up to V5. This header was first introduced
+-- with Windows 2.0 as the BITMAPCOREHEADER, and was later extended in Windows
+-- 3.1, Windows 95 and Windows 98. The original BITMAPCOREHEADER includes all
+-- fields up to 'bitPerPixel'. The Windows 3.1 BITMAPINFOHEADER adds all the
+-- fields up to 'importantColors'.
+--
+-- Some Windows 3.1 bitmaps with 16 or 32 bits per pixel might also have three
+-- bitmasks following the BITMAPINFOHEADER. These bitmasks were later
+-- incorporated into the bitmap header structure in the unreleased
+-- BITMAPV2INFOHEADER. The (also unreleased) BITMAPV3INFOHEADER added another
+-- bitmask for an alpha channel.
+--
+-- The later Windows 95 and Windows 98 extensions to the BITMAPINFOHEADER extend
+-- the BITMAPV3INFOHEADER, adding support for color correction.
+--
+--  * BITMAPV4HEADER (Windows 95) may include a simple color profile in a
+--      proprietary format. The fields in this color profile (which includes gamma
+--      values) are not to be used unless the 'colorSpaceType' field is
+--      'CalibratedRGB'.
+--
+--  * BITMAPV5HEADER (Windows 98) adds support for an ICC color profile. The
+--      presence of an ICC color profile is indicated by setting the 'colorSpaceType'
+--      field to 'ProfileEmbedded' or 'ProfileLinked'. If it is 'ProfileLinked' then
+--      the profile data is actually a Windows-1252 encoded string containing the
+--      fully qualified path to an ICC color profile.
+data BmpV5Header = BmpV5Header
+    { size              :: !Word32 -- Header size in bytes
+    , width             :: !Int32
+    , height            :: !Int32
+    , planes            :: !Word16 -- Number of colour planes
+    , bitPerPixel       :: !Word16
+    , bitmapCompression :: !Word32
+    , byteImageSize     :: !Word32
+    , xResolution       :: !Int32  -- ^ Pixels per meter
+    , yResolution       :: !Int32  -- ^ Pixels per meter
+    , colorCount        :: !Word32 -- ^ Number of colors in the palette
+    , importantColours  :: !Word32
+    -- Fields added to the header in V2
+    , redMask           :: !Word32 -- ^ Red bitfield mask, set to 0 if not used
+    , greenMask         :: !Word32 -- ^ Green bitfield mask, set to 0 if not used
+    , blueMask          :: !Word32 -- ^ Blue bitfield mask, set to 0 if not used
+    -- Fields added to the header in V3
+    , alphaMask         :: !Word32 -- ^ Alpha bitfield mask, set to 0 if not used
+    -- Fields added to the header in V4
+    , colorSpaceType    :: !ColorSpaceType
+    , colorSpace        :: !B.ByteString -- ^ Windows color space, not decoded
+    -- Fields added to the header in V5
+    , iccIntent         :: !Word32
+    , iccProfileData    :: !Word32
+    , iccProfileSize    :: !Word32
+    }
+    deriving Show
+
+-- | Size of the Windows BITMAPV4INFOHEADER color space information.
+sizeofColorProfile :: Int
+sizeofColorProfile = 48
+
+-- | Sizes of basic BMP headers.
+sizeofBmpHeader, sizeofBmpCoreHeader, sizeofBmpInfoHeader :: Word32
+sizeofBmpHeader = 2 + 4 + 2 + 2 + 4
+sizeofBmpCoreHeader = 12
+sizeofBmpInfoHeader = 40
+
+-- | Sizes of extended BMP headers.
+sizeofBmpV2Header, sizeofBmpV3Header, sizeofBmpV4Header, sizeofBmpV5Header :: Word32
+sizeofBmpV2Header = 52
+sizeofBmpV3Header = 56
+sizeofBmpV4Header = 108
+sizeofBmpV5Header = 124
+
+instance Binary ColorSpaceType where
+    put CalibratedRGB         = putWord32le 0
+    put DeviceDependentRGB    = putWord32le 1
+    put DeviceDependentCMYK   = putWord32le 2
+    put ProfileEmbedded       = putWord32le 0x4D424544
+    put ProfileLinked         = putWord32le 0x4C494E4B
+    put SRGB                  = putWord32le 0x73524742
+    put WindowsColorSpace     = putWord32le 0x57696E20
+    put (UnknownColorSpace x) = putWord32le x
+    get = do
+      w <- getWord32le
+      return $ case w of
+        0          -> CalibratedRGB
+        1          -> DeviceDependentRGB
+        2          -> DeviceDependentCMYK
+        0x4D424544 -> ProfileEmbedded
+        0x4C494E4B -> ProfileLinked
+        0x73524742 -> SRGB
+        0x57696E20 -> WindowsColorSpace
+        _          -> UnknownColorSpace w
+
+instance Binary BmpV5Header where
+    put hdr = do
+        putWord32le $ size hdr
+
+        if (size hdr == sizeofBmpCoreHeader) then do
+          putWord16le . fromIntegral $ width hdr
+          putWord16le . fromIntegral $ height hdr
+          putWord16le $ planes hdr
+          putWord16le $ bitPerPixel hdr
+        else do
+          putInt32le $ width hdr
+          putInt32le $ height hdr
+          putWord16le $ planes hdr
+          putWord16le $ bitPerPixel hdr
+
+        when (size hdr > sizeofBmpCoreHeader) $ do
+          putWord32le $ bitmapCompression hdr
+          putWord32le $ byteImageSize hdr
+          putInt32le $ xResolution hdr
+          putInt32le $ yResolution hdr
+          putWord32le $ colorCount hdr
+          putWord32le $ importantColours hdr
+
+        when (size hdr > sizeofBmpInfoHeader || bitmapCompression hdr == 3) $ do
+          putWord32le $ redMask hdr
+          putWord32le $ greenMask hdr
+          putWord32le $ blueMask hdr
+
+        when (size hdr > sizeofBmpV2Header) $
+          putWord32le $ alphaMask hdr
+
+        when (size hdr > sizeofBmpV3Header) $ do
+          put $ colorSpaceType hdr
+          putByteString $ colorSpace hdr
+
+        when (size hdr > sizeofBmpV4Header) $ do
+          put $ iccIntent hdr
+          putWord32le $ iccProfileData hdr
+          putWord32le $ iccProfileSize hdr
+          putWord32le 0 -- reserved field
+
+    get = do
+      readSize <- getWord32le
+      if readSize == sizeofBmpCoreHeader
+        then getBitmapCoreHeader readSize
+        else getBitmapInfoHeader readSize
+
+      where
+        getBitmapCoreHeader readSize = do
+          readWidth <- getWord16le
+          readHeight <- getWord16le
+          readPlanes <- getWord16le
+          readBitPerPixel <- getWord16le
+          return BmpV5Header {
+              size = readSize,
+              width = fromIntegral readWidth,
+              height = fromIntegral readHeight,
+              planes = readPlanes,
+              bitPerPixel = readBitPerPixel,
+              bitmapCompression = 0,
+              byteImageSize = 0,
+              xResolution = 2835,
+              yResolution = 2835,
+              colorCount = 2 ^ readBitPerPixel,
+              importantColours = 0,
+              redMask = 0,
+              greenMask = 0,
+              blueMask = 0,
+              alphaMask = 0,
+              colorSpaceType = DeviceDependentRGB,
+              colorSpace = B.empty,
+              iccIntent = 0,
+              iccProfileData = 0,
+              iccProfileSize = 0
+          }
+
+        getBitmapInfoHeader readSize = do
+          readWidth <- getInt32le
+          readHeight <- getInt32le
+          readPlanes <- getWord16le
+          readBitPerPixel <- getWord16le
+          readBitmapCompression <- getWord32le
+          readByteImageSize <- getWord32le
+          readXResolution <- getInt32le
+          readYResolution <- getInt32le
+          readColorCount <- getWord32le
+          readImportantColours <- getWord32le
+
+          (readRedMask, readGreenMask, readBlueMask) <-
+            if readSize == sizeofBmpInfoHeader && readBitmapCompression /= 3
+              then return (0, 0, 0)
+              else do
+                -- fields added to the header in V2, but sometimes present
+                -- immediately after a plain BITMAPINFOHEADER
+                innerReadRedMask <- getWord32le
+                innerReadGreenMask <- getWord32le
+                innerReadBlueMask <- getWord32le
+                return (innerReadRedMask, innerReadGreenMask, innerReadBlueMask)
+
+          -- field added in V3 (undocumented)
+          readAlphaMask <- if readSize < sizeofBmpV3Header then return 0 else getWord32le
+
+          (readColorSpaceType, readColorSpace) <-
+            if readSize < sizeofBmpV4Header
+              then return (DeviceDependentRGB, B.empty)
+              else do
+                -- fields added in V4 (Windows 95)
+                csType <- get
+                cs <- getByteString sizeofColorProfile
+                return (csType, cs)
+
+          (readIccIntent, readIccProfileData, readIccProfileSize) <-
+            if readSize < sizeofBmpV5Header
+              then return (0, 0, 0)
+              else do
+                -- fields added in V5 (Windows 98)
+                innerIccIntent <- getWord32le
+                innerIccProfileData <- getWord32le
+                innerIccProfileSize <- getWord32le
+                void getWord32le -- reserved field
+                return (innerIccIntent, innerIccProfileData, innerIccProfileSize)
+
+          return BmpV5Header {
+              size = readSize,
+              width = readWidth,
+              height = readHeight,
+              planes = readPlanes,
+              bitPerPixel = readBitPerPixel,
+              bitmapCompression = readBitmapCompression,
+              byteImageSize = readByteImageSize,
+              xResolution = readXResolution,
+              yResolution = readYResolution,
+              colorCount = readColorCount,
+              importantColours = readImportantColours,
+              redMask = readRedMask,
+              greenMask = readGreenMask,
+              blueMask = readBlueMask,
+              alphaMask = readAlphaMask,
+              colorSpaceType = readColorSpaceType,
+              colorSpace = readColorSpace,
+              iccIntent = readIccIntent,
+              iccProfileData = readIccProfileData,
+              iccProfileSize = readIccProfileSize
+          }
+
+newtype BmpPalette = BmpPalette [(Word8, Word8, Word8, Word8)]
+
+putPalette :: BmpPalette -> Put
+putPalette (BmpPalette p) = mapM_ (\(r, g, b, a) -> put r >> put g >> put b >> put a) p
+
+putICCProfile :: Maybe B.ByteString -> Put
+putICCProfile Nothing = return ()
+putICCProfile (Just bytes) = put bytes
+
+-- | All the instance of this class can be written as a bitmap file
+-- using this library.
+class BmpEncodable pixel where
+    bitsPerPixel   :: pixel -> Int
+    bmpEncode      :: Image pixel -> Put
+    hasAlpha       :: Image pixel -> Bool
+    defaultPalette :: pixel -> BmpPalette
+    defaultPalette _ = BmpPalette []
+
+stridePut :: M.STVector s Word8 -> Int -> Int -> ST s ()
+{-# INLINE stridePut #-}
+stridePut vec = inner
+ where inner  _ 0 = return ()
+       inner ix n = do
+           (vec `M.unsafeWrite` ix) 0
+           inner (ix + 1) (n - 1)
+
+instance BmpEncodable Pixel8 where
+    hasAlpha _ = False
+    defaultPalette _ = BmpPalette [(x,x,x, 255) | x <- [0 .. 255]]
+    bitsPerPixel _ = 8
+    bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) =
+      forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ encodeLine l
+        where stride = fromIntegral $ linePadding 8 w
+              putVector vec = putByteString $ blitVector vec 0 lineWidth
+              lineWidth = w + stride
+
+              encodeLine :: forall s. Int -> ST s (VS.Vector Word8)
+              encodeLine line = do
+                  buff <- M.new lineWidth
+
+                  let lineIdx = line * w
+                      inner col | col >= w = return ()
+                      inner col = do
+                          let v = arr `VS.unsafeIndex` (lineIdx + col)
+                          (buff `M.unsafeWrite` col) v
+                          inner (col + 1)
+
+                  inner 0
+
+                  stridePut buff w stride
+                  VS.unsafeFreeze buff
+
+instance BmpEncodable PixelRGBA8 where
+    hasAlpha _ = True
+    bitsPerPixel _ = 32
+    bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) =
+      forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ putLine l
+      where
+        putVector vec = putByteString . blitVector vec 0 $ w * 4
+
+        putLine :: forall s. Int -> ST s (VS.Vector Word8)
+        putLine line = do
+            buff <- M.new $ 4 * w
+            let initialIndex = line * w * 4
+                inner col _ _ | col >= w = return ()
+                inner col writeIdx readIdx = do
+                    let r = arr `VS.unsafeIndex` readIdx
+                        g = arr `VS.unsafeIndex` (readIdx + 1)
+                        b = arr `VS.unsafeIndex` (readIdx + 2)
+                        a = arr `VS.unsafeIndex` (readIdx + 3)
+
+                    (buff `M.unsafeWrite` writeIdx) b
+                    (buff `M.unsafeWrite` (writeIdx + 1)) g
+                    (buff `M.unsafeWrite` (writeIdx + 2)) r
+                    (buff `M.unsafeWrite` (writeIdx + 3)) a
+
+                    inner (col + 1) (writeIdx + 4) (readIdx + 4)
+
+            inner 0 0 initialIndex
+            VS.unsafeFreeze buff
+
+instance BmpEncodable PixelRGB8 where
+    hasAlpha _ = False
+    bitsPerPixel _ = 24
+    bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) =
+       forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ putLine l
+        where
+          stride = fromIntegral . linePadding 24 $ w
+
+          putVector vec = putByteString $ blitVector vec 0 (w * 3 + stride)
+
+          putLine :: forall s. Int -> ST s (VS.Vector Word8)
+          putLine line = do
+              buff <- M.new $ w * 3 + stride
+              let initialIndex = line * w * 3
+                  inner col _ _ | col >= w = return ()
+                  inner col writeIdx readIdx = do
+                      let r = arr `VS.unsafeIndex` readIdx
+                          g = arr `VS.unsafeIndex` (readIdx + 1)
+                          b = arr `VS.unsafeIndex` (readIdx + 2)
+
+                      (buff `M.unsafeWrite` writeIdx) b
+                      (buff `M.unsafeWrite` (writeIdx + 1)) g
+                      (buff `M.unsafeWrite` (writeIdx + 2)) r
+
+                      inner (col + 1) (writeIdx + 3) (readIdx + 3)
+
+              inner 0 0 initialIndex
+              VS.unsafeFreeze buff
+
+-- | Information required to extract data from a bitfield.
+data Bitfield t = Bitfield
+    { bfMask :: !t            -- ^ The original bitmask.
+    , bfShift :: !Int         -- ^ The computed number of bits to shift right.
+    , bfScale :: !Float       -- ^ The scale factor to fit the data into 8 bits.
+    } deriving (Eq, Show)
+
+-- | Four bitfields (red, green, blue, alpha)
+data Bitfields4 t = Bitfields4 !(Bitfield t)
+                               !(Bitfield t)
+                               !(Bitfield t)
+                               !(Bitfield t)
+                               deriving (Eq, Show)
+
+-- | Default bitfields 32 bit bitmaps.
+defaultBitfieldsRGB32 :: Bitfields3 Word32
+defaultBitfieldsRGB32 = Bitfields3 (makeBitfield 0x00FF0000)
+                                   (makeBitfield 0x0000FF00)
+                                   (makeBitfield 0x000000FF)
+
+-- | Default bitfields for 16 bit bitmaps.
+defaultBitfieldsRGB16 :: Bitfields3 Word16
+defaultBitfieldsRGB16 = Bitfields3 (makeBitfield 0x7C00)
+                                   (makeBitfield 0x03E0)
+                                   (makeBitfield 0x001F)
+
+-- | Three bitfields (red, gree, blue).
+data Bitfields3 t = Bitfields3 !(Bitfield t)
+                               !(Bitfield t)
+                               !(Bitfield t)
+                               deriving (Eq, Show)
+
+-- | Pixel formats used to encode RGBA image data.
+data RGBABmpFormat = RGBA32 !(Bitfields4 Word32)
+                   | RGBA16 !(Bitfields4 Word16)
+                   deriving (Eq, Show)
+
+-- | Pixel formats used to encode RGB image data.
+data RGBBmpFormat = RGB32 !(Bitfields3 Word32)
+                  | RGB24
+                  | RGB16 !(Bitfields3 Word16)
+                  deriving (Eq, Show)
+
+-- | Pixel formats used to encode indexed or grayscale images.
+data IndexedBmpFormat = OneBPP | FourBPP | EightBPP deriving Show
+
+-- | Extract pixel data from a bitfield.
+extractBitfield :: (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
+extractBitfield bf t = if bfScale bf == 1
+                        then fromIntegral field
+                        else round $ bfScale bf * fromIntegral field
+  where field = (t .&. bfMask bf) `unsafeShiftR` bfShift bf
+
+-- | Convert a bit mask into a 'BitField'.
+makeBitfield :: (FiniteBits t, Integral t) => t -> Bitfield t
+makeBitfield mask = Bitfield mask shiftBits scale
+  where
+    shiftBits = countTrailingZeros mask
+    scale = 255 / fromIntegral (mask `unsafeShiftR` shiftBits)
+
+-- | Helper method to cast a 'B.ByteString' to a 'VS.Vector' of some type.
+castByteString :: VS.Storable a => B.ByteString -> VS.Vector a
+#if MIN_VERSION_bytestring(0,11,0)
+castByteString (BI.BS fp len) = VS.unsafeCast $ VS.unsafeFromForeignPtr fp 0 len
+#else
+castByteString (BI.PS fp offset len) = VS.unsafeCast $ VS.unsafeFromForeignPtr fp offset len
+#endif
+
+decodeImageRGBA8 :: RGBABmpFormat -> BmpV5Header -> B.ByteString -> Image PixelRGBA8
+decodeImageRGBA8 pixelFormat (BmpV5Header { width = w, height = h, bitPerPixel = bpp }) str = Image wi hi stArray where
+  wi = fromIntegral w
+  hi = abs $ fromIntegral h
+  stArray = runST $ do
+      arr <- M.new (fromIntegral $ w * abs h * 4)
+      if h > 0 then
+        foldM_ (readLine arr) 0 [0 .. hi - 1]
+      else
+        foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0]
+      VS.unsafeFreeze arr
+
+  paddingWords = (8 * linePadding intBPP wi) `div` intBPP
+  intBPP = fromIntegral bpp
+
+  readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int
+  readLine arr readIndex line = case pixelFormat of
+      RGBA32 bitfields -> inner bitfields (castByteString str) readIndex writeIndex
+      RGBA16 bitfields -> inner bitfields (castByteString str) readIndex writeIndex
+    where
+      lastIndex = wi * (hi - 1 - line + 1) * 4
+      writeIndex = wi * (hi - 1 - line) * 4
+
+      inner
+        :: (FiniteBits t, Integral t, M.Storable t, Show t)
+        => Bitfields4 t
+        -> VS.Vector t
+        -> Int
+        -> Int
+        -> ST s Int
+      inner (Bitfields4 r g b a) inStr = inner0
+        where
+          inner0 :: Int -> Int -> ST s Int
+          inner0 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + paddingWords
+          inner0 readIdx writeIdx = do
+            let word = inStr VS.! readIdx
+            (arr `M.unsafeWrite`  writeIdx     ) (extractBitfield r word)
+            (arr `M.unsafeWrite` (writeIdx + 1)) (extractBitfield g word)
+            (arr `M.unsafeWrite` (writeIdx + 2)) (extractBitfield b word)
+            (arr `M.unsafeWrite` (writeIdx + 3)) (extractBitfield a word)
+            inner0 (readIdx + 1) (writeIdx + 4)
+
+decodeImageRGB8 :: RGBBmpFormat -> BmpV5Header -> B.ByteString -> Image PixelRGB8
+decodeImageRGB8 pixelFormat (BmpV5Header { width = w, height = h, bitPerPixel = bpp }) str = Image wi hi stArray where
+  wi = fromIntegral w
+  hi = abs $ fromIntegral h
+  stArray = runST $ do
+      arr <- M.new (fromIntegral $ w * abs h * 3)
+      if h > 0 then
+        foldM_ (readLine arr) 0 [0 .. hi - 1]
+      else
+        foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0]
+      VS.unsafeFreeze arr
+
+  paddingBytes = linePadding intBPP wi
+  paddingWords = (linePadding intBPP wi * 8) `div` intBPP
+  intBPP = fromIntegral bpp
+
+  readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int
+  readLine arr readIndex line = case pixelFormat of
+      RGB16 bitfields -> innerBF bitfields (castByteString str) readIndex writeIndex
+      RGB32 bitfields -> innerBF bitfields (castByteString str) readIndex writeIndex
+      RGB24 -> inner24 readIndex writeIndex
+    where
+      lastIndex = wi * (hi - 1 - line + 1) * 3
+      writeIndex = wi * (hi - 1 - line) * 3
+
+      inner24 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + paddingBytes
+      inner24 readIdx writeIdx = do
+          (arr `M.unsafeWrite`  writeIdx     ) (str `B.index` (readIdx + 2))
+          (arr `M.unsafeWrite` (writeIdx + 1)) (str `B.index` (readIdx + 1))
+          (arr `M.unsafeWrite` (writeIdx + 2)) (str `B.index`  readIdx)
+          inner24 (readIdx + 3) (writeIdx + 3)
+
+      innerBF
+        :: (FiniteBits t, Integral t, M.Storable t, Show t)
+        => Bitfields3 t
+        -> VS.Vector t
+        -> Int
+        -> Int
+        -> ST s Int
+      innerBF (Bitfields3 r g b) inStr = innerBF0
+        where
+          innerBF0 :: Int -> Int -> ST s Int
+          innerBF0 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + paddingWords
+          innerBF0 readIdx writeIdx = do
+            let word = inStr VS.! readIdx
+            (arr `M.unsafeWrite`  writeIdx     ) (extractBitfield r word)
+            (arr `M.unsafeWrite` (writeIdx + 1)) (extractBitfield g word)
+            (arr `M.unsafeWrite` (writeIdx + 2)) (extractBitfield b word)
+            innerBF0 (readIdx + 1) (writeIdx + 3)
+
+decodeImageY8 :: IndexedBmpFormat -> BmpV5Header -> B.ByteString -> Image Pixel8
+decodeImageY8 lowBPP (BmpV5Header { width = w, height = h, bitPerPixel = bpp }) str = Image wi hi stArray where
+  wi = fromIntegral w
+  hi = abs $ fromIntegral h
+  stArray = runST $ do
+      arr <- M.new . fromIntegral $ w * abs h
+      if h > 0 then
+        foldM_ (readLine arr) 0 [0 .. hi - 1]
+      else
+        foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0]
+      VS.unsafeFreeze arr
+
+  padding = linePadding (fromIntegral bpp) wi
+
+  readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int
+  readLine arr readIndex line = case lowBPP of
+      OneBPP -> inner1 readIndex writeIndex
+      FourBPP -> inner4 readIndex writeIndex
+      EightBPP -> inner8 readIndex writeIndex
+    where
+      lastIndex = wi * (hi - 1 - line + 1)
+      writeIndex = wi * (hi - 1 - line)
+
+      inner8 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + padding
+      inner8 readIdx writeIdx = do
+        (arr `M.unsafeWrite` writeIdx) (str `B.index` readIdx)
+        inner8 (readIdx + 1) (writeIdx + 1)
+
+      inner4 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + padding
+      inner4 readIdx writeIdx = do
+        let byte = str `B.index` readIdx
+        if writeIdx >= lastIndex - 1 then do
+          (arr `M.unsafeWrite` writeIdx) (byte `unsafeShiftR` 4)
+          inner4 (readIdx + 1) (writeIdx + 1)
+        else do
+          (arr `M.unsafeWrite` writeIdx) (byte `unsafeShiftR` 4)
+          (arr `M.unsafeWrite` (writeIdx + 1)) (byte .&. 0x0F)
+          inner4 (readIdx + 1) (writeIdx + 2)
+
+      inner1 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + padding
+      inner1 readIdx writeIdx = do
+        let byte = str `B.index` readIdx
+        let toWrite = (lastIndex - writeIdx) `min` 8
+        forM_ [0 .. (toWrite - 1)] $ \i ->
+          when (byte `testBit` (7 - i)) $ (arr `M.unsafeWrite` (writeIdx + i)) 1
+        inner1 (readIdx + 1) (writeIdx + toWrite)
+
+decodeImageY8RLE :: Bool -> BmpV5Header -> B.ByteString -> Image Pixel8
+decodeImageY8RLE is4bpp (BmpV5Header { width = w, height = h, byteImageSize = sz }) str = Image wi hi stArray where
+  wi = fromIntegral w
+  hi = abs $ fromIntegral h
+  xOffsetMax = wi - 1
+
+  stArray = runST $ do
+    arr <- M.new . fromIntegral $ w * abs h
+    decodeRLE arr (B.unpack (B.take (fromIntegral sz) str)) ((hi - 1) * wi, 0)
+    VS.unsafeFreeze arr
+
+  decodeRLE :: forall s . M.MVector s Word8 -> [Word8] -> (Int, Int) -> ST s ()
+  decodeRLE arr = inner
+    where
+      inner :: [Word8] -> (Int, Int) -> ST s ()
+      inner [] _ = return ()
+      inner (0 : 0 : rest) (yOffset, _) = inner rest (yOffset - wi, 0)
+      inner (0 : 1 : _) _ = return ()
+      inner (0 : 2 : hOffset : vOffset : rest) (yOffset, _) =
+        inner rest (yOffset - (wi * fromIntegral vOffset), fromIntegral hOffset)
+      inner (0 : n : rest) writePos =
+        let isPadded = if is4bpp then (n + 3) .&. 0x3 < 2 else odd n
+        in copyN isPadded (fromIntegral n) rest writePos
+      inner (n : b : rest) writePos = writeN (fromIntegral n) b rest writePos
+      inner _ _ = return ()
+
+      -- | Write n copies of a byte to the output array.
+      writeN :: Int -> Word8 -> [Word8] -> (Int, Int) -> ST s ()
+      writeN 0 _ rest writePos = inner rest writePos
+      writeN n b rest writePos =
+        case (is4bpp, n) of
+          (True, 1) ->
+            writeByte (b `unsafeShiftR` 4) writePos >>= writeN (n - 1) b rest
+          (True, _) ->
+            writeByte (b `unsafeShiftR` 4) writePos
+              >>= writeByte (b .&. 0x0F) >>= writeN (n - 2) b rest
+          (False, _) ->
+            writeByte b writePos >>= writeN (n - 1) b rest
+
+      -- | Copy the next byte to the output array, possibly ignoring a padding byte at the end.
+      copyN :: Bool -> Int -> [Word8] -> (Int, Int) -> ST s ()
+      copyN _ _ [] _ = return ()
+      copyN False 0 rest writePos = inner rest writePos
+      copyN True 0 (_:rest) writePos = inner rest writePos
+      copyN isPadded n (b : rest) writePos =
+        case (is4bpp, n) of
+          (True, 1) ->
+            writeByte (b `unsafeShiftR` 4) writePos >>= copyN isPadded (n - 1) rest
+          (True, _) ->
+            writeByte (b `unsafeShiftR` 4) writePos
+              >>= writeByte (b .&. 0x0F) >>= copyN isPadded (n - 2) rest
+          (False, _) ->
+            writeByte b writePos >>= copyN isPadded (n - 1) rest
+
+      -- | Write the next byte to the output array.
+      writeByte :: Word8 -> (Int, Int) -> ST s (Int, Int)
+      writeByte byte (yOffset, xOffset) = do
+        (arr `M.unsafeWrite` (yOffset + xOffset)) byte
+        return (yOffset, (xOffset + 1) `min` xOffsetMax)
+
+pixel4Get :: Get [Word8]
+pixel4Get = do
+    b <- getWord8
+    g <- getWord8
+    r <- getWord8
+    _ <- getWord8
+    return [r, g, b]
+
+pixel3Get :: Get [Word8]
+pixel3Get = do
+    b <- getWord8
+    g <- getWord8
+    r <- getWord8
+    return [r, g, b]
+
+metadataOfHeader :: BmpV5Header -> Maybe B.ByteString -> Metadatas
+metadataOfHeader hdr iccProfile =
+    cs `mappend` Met.simpleMetadata Met.SourceBitmap (width hdr) (abs $ height hdr) dpiX dpiY
+  where
+    dpiX = Met.dotsPerMeterToDotPerInch . fromIntegral $ xResolution hdr
+    dpiY = Met.dotsPerMeterToDotPerInch . fromIntegral $ yResolution hdr
+    cs = case colorSpaceType hdr of
+          CalibratedRGB -> Met.singleton
+            Met.ColorSpace (Met.WindowsBitmapColorSpace $ colorSpace hdr)
+          SRGB -> Met.singleton Met.ColorSpace Met.SRGB
+          ProfileEmbedded -> case iccProfile of
+                              Nothing -> Met.empty
+                              Just profile -> Met.singleton Met.ColorSpace
+                                                (Met.ICCProfile profile)
+          _ -> Met.empty
+
+-- | Try to decode a bitmap image.
+-- Right now this function can output the following image:
+--
+--   - 'ImageY8'
+--
+--   - 'ImageRGB8'
+--
+--   - 'ImageRGBA8'
+--
+decodeBitmap :: B.ByteString -> Either String DynamicImage
+decodeBitmap = fmap fst . decodeBitmapWithMetadata
+
+-- | Same as 'decodeBitmap' but also extracts metadata.
+decodeBitmapWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
+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
+  fileHeader <- get :: Get BmpHeader
+  bmpHeader  <- get :: Get BmpV5Header
+
+  readed <- bytesRead
+  when (readed > fromIntegral (dataOffset fileHeader))
+       (fail "Invalid bmp image, data in header")
+
+  when (width bmpHeader <= 0)
+       (fail $ "Invalid bmp width, " ++ show (width bmpHeader))
+
+  when (height bmpHeader == 0)
+       (fail $ "Invalid bmp height (0) ")
+
+  decodeBitmapWithHeaders fileHeader bmpHeader
+
+-- | Decode the rest of a bitmap, after the headers have been decoded.
+decodeBitmapWithHeaders :: BmpHeader -> BmpV5Header -> Get (PalettedImage, Metadatas)
+decodeBitmapWithHeaders fileHdr hdr = do
+    img <- bitmapData
+    profile <- getICCProfile
+    return $ addMetadata profile img
+
+  where
+    bpp = fromIntegral $ bitPerPixel hdr :: Int
+    paletteColorCount
+      | colorCount hdr == 0 = 2 ^ bpp
+      | otherwise = fromIntegral $ colorCount hdr
+
+    addMetadata profile i = (i, metadataOfHeader hdr profile)
+
+    getData = do
+      readed <- bytesRead
+      label "Start of pixel data" $
+        skip . fromIntegral $ dataOffset fileHdr - fromIntegral readed
+      let pixelBytes = if bitmapCompression hdr == 1 || bitmapCompression hdr == 2
+                          then fromIntegral $ byteImageSize hdr
+                          else sizeofPixelData bpp (fromIntegral $ width hdr)
+                                                   (fromIntegral $ height hdr)
+      label "Pixel data" $ getByteString pixelBytes
+
+    getICCProfile =
+      if size hdr >= sizeofBmpV5Header
+          && colorSpaceType hdr == ProfileLinked
+          && iccProfileData hdr > 0
+          && iccProfileSize hdr > 0
+      then do
+        readSoFar <- bytesRead
+        label "Start of embedded ICC color profile" $
+          skip $ fromIntegral (iccProfileData hdr) - fromIntegral readSoFar
+        profile <- label "Embedded ICC color profile" $
+                      getByteString . fromIntegral $ iccProfileSize hdr
+        return (Just profile)
+      else return Nothing
+
+    bitmapData = case (bitPerPixel hdr, planes hdr, bitmapCompression hdr) of
+      (32, 1, 0) -> do
+        rest <- getData
+        return . TrueColorImage . ImageRGB8 $
+          decodeImageRGB8 (RGB32 defaultBitfieldsRGB32) hdr rest
+        -- (2, 1, 0, 3) means BGRA pixel order
+      (32, 1, 3) -> do
+        r <- getBitfield $ redMask hdr
+        g <- getBitfield $ greenMask hdr
+        b <- getBitfield $ blueMask hdr
+        rest     <- getData
+        if alphaMask hdr == 0
+          then return . TrueColorImage . ImageRGB8 $
+            decodeImageRGB8 (RGB32 $ Bitfields3 r g b) hdr rest
+          else do
+            a <- getBitfield $ alphaMask hdr
+            return . TrueColorImage . ImageRGBA8 $
+              decodeImageRGBA8 (RGBA32 $ Bitfields4 r g b a) hdr rest
+      (24, 1, 0) -> do
+        rest <- getData
+        return . TrueColorImage . ImageRGB8 $
+          decodeImageRGB8 RGB24 hdr rest
+      (16, 1, 0) -> do
+        rest <- getData
+        return . TrueColorImage . ImageRGB8 $
+          decodeImageRGB8 (RGB16 defaultBitfieldsRGB16) hdr rest
+      (16, 1, 3) -> do
+        r <- getBitfield . fromIntegral $ 0xFFFF .&. redMask hdr
+        g <- getBitfield . fromIntegral $ 0xFFFF .&. greenMask hdr
+        b <- getBitfield . fromIntegral $ 0xFFFF .&. blueMask hdr
+        rest     <- getData
+        if alphaMask hdr == 0
+          then return . TrueColorImage . ImageRGB8 $
+            decodeImageRGB8 (RGB16 $ Bitfields3 r g b) hdr rest
+          else do
+            a <- getBitfield . fromIntegral $ 0xFFFF .&. alphaMask hdr
+            return . TrueColorImage . ImageRGBA8 $
+              decodeImageRGBA8 (RGBA16 $ Bitfields4 r g b a) hdr rest
+      ( _, 1, compression) -> do
+        table <- if size hdr == sizeofBmpCoreHeader
+                    then replicateM paletteColorCount pixel3Get
+                    else replicateM paletteColorCount pixel4Get
+        rest <- getData
+        let palette = Palette'
+              { _paletteSize = paletteColorCount
+              , _paletteData = VS.fromListN (paletteColorCount * 3) $ concat table
+              }
+        image <-
+          case (bpp, compression) of
+            (8, 0) -> return $ decodeImageY8 EightBPP hdr rest
+            (4, 0) -> return $ decodeImageY8 FourBPP hdr rest
+            (1, 0) -> return $ decodeImageY8 OneBPP hdr rest
+            (8, 1) -> return $ decodeImageY8RLE False hdr rest
+            (4, 2) -> return $ decodeImageY8RLE True hdr rest
+            (a, b) -> fail $ "Can't handle BMP file " ++ show (a, 1 :: Int, b)
+
+        return $ PalettedRGB8 image palette
+
+      a          -> fail $ "Can't handle BMP file " ++ show a
+
+-- | Decode a bitfield. Will fail if the bitfield is empty.
+#if MIN_VERSION_base(4,13,0)
+getBitfield :: (FiniteBits t, Integral t, Num t, MonadFail m) => t -> m (Bitfield t)
+#else
+getBitfield :: (FiniteBits t, Integral t, Num t, Monad m) => t -> m (Bitfield t)
+#endif
+getBitfield 0 = fail $
+  "Codec.Picture.Bitmap.getBitfield: bitfield cannot be 0"
+getBitfield w = return (makeBitfield w)
+
+-- | Compute the size of the pixel data
+sizeofPixelData :: Int -> Int -> Int -> Int
+sizeofPixelData bpp lineWidth nLines = ((bpp * (abs lineWidth) + 31) `div` 32) * 4 * abs nLines
+
+-- | Write an image in a file use the bitmap format.
+writeBitmap :: (BmpEncodable pixel)
+            => FilePath -> Image pixel -> IO ()
+writeBitmap filename img = L.writeFile filename $ encodeBitmap img
+
+linePadding :: Int -> Int -> Int
+linePadding bpp imgWidth = (4 - (bytesPerLine `mod` 4)) `mod` 4
+  where bytesPerLine = (bpp * imgWidth + 7) `div` 8
+
+-- | Encode an image into a bytestring in .bmp format ready to be written
+-- on disk.
+encodeBitmap :: forall pixel. (BmpEncodable pixel) => Image pixel -> L.ByteString
+encodeBitmap = encodeBitmapWithPalette (defaultPalette (undefined :: pixel))
+
+-- | Equivalent to 'encodeBitmap' but also store
+-- the following metadatas:
+--
+--  * 'Codec.Picture.Metadata.DpiX'
+--  * 'Codec.Picture.Metadata.DpiY'
+--
+encodeBitmapWithMetadata :: forall pixel. BmpEncodable pixel
+                         => Metadatas -> Image pixel -> L.ByteString
+encodeBitmapWithMetadata metas =
+  encodeBitmapWithPaletteAndMetadata metas (defaultPalette (undefined :: pixel))
+
+-- | Write a dynamic image in a .bmp image file if possible.
+-- The same restriction as 'encodeDynamicBitmap' apply.
+writeDynamicBitmap :: FilePath -> DynamicImage -> IO (Either String Bool)
+writeDynamicBitmap path img = case encodeDynamicBitmap img of
+        Left err -> return $ Left err
+        Right b  -> L.writeFile path b >> return (Right True)
+
+-- | Encode a dynamic image in BMP if possible, supported images are:
+--
+--   - 'ImageY8'
+--
+--   - 'ImageRGB8'
+--
+--   - 'ImageRGBA8'
+--
+encodeDynamicBitmap :: DynamicImage -> Either String L.ByteString
+encodeDynamicBitmap (ImageRGB8 img) = Right $ encodeBitmap img
+encodeDynamicBitmap (ImageRGBA8 img) = Right $ encodeBitmap img
+encodeDynamicBitmap (ImageY8 img) = Right $ encodeBitmap img
+encodeDynamicBitmap _ = Left "Unsupported image format for bitmap export"
+
+extractDpiOfMetadata :: Metadatas -> (Word32, Word32)
+extractDpiOfMetadata metas = (fetch Met.DpiX, fetch Met.DpiY) where
+  fetch k = maybe 0 (fromIntegral . Met.dotPerInchToDotsPerMeter) $ Met.lookup k metas
+
+-- | Convert an image to a bytestring ready to be serialized.
+encodeBitmapWithPalette :: forall pixel. (BmpEncodable pixel)
+                        => BmpPalette -> Image pixel -> L.ByteString
+encodeBitmapWithPalette = encodeBitmapWithPaletteAndMetadata mempty
+
+-- | Equivalent to 'encodeBitmapWithPalette' but also store
+-- the following metadatas:
+--
+--  * 'Codec.Picture.Metadata.DpiX'
+--  * 'Codec.Picture.Metadata.DpiY'
+--
+encodeBitmapWithPaletteAndMetadata :: forall pixel. (BmpEncodable pixel)
+                                   => Metadatas -> BmpPalette -> Image pixel
+                                   -> L.ByteString
+encodeBitmapWithPaletteAndMetadata metas pal@(BmpPalette palette) img =
+  runPut $ put hdr >> put info >> putPalette pal >> bmpEncode img
+                   >> putICCProfile colorProfileData
+
+    where imgWidth = fromIntegral $ imageWidth img
+          imgHeight = fromIntegral $ imageHeight img
+          (dpiX, dpiY) = extractDpiOfMetadata metas
+          cs = Met.lookup Met.ColorSpace metas
+          colorType = case cs of
+                        Just Met.SRGB -> SRGB
+                        Just (Met.WindowsBitmapColorSpace _) -> CalibratedRGB
+                        Just (Met.ICCProfile _) -> ProfileEmbedded
+                        Nothing -> DeviceDependentRGB
+
+          colorSpaceInfo = case cs of
+                            Just (Met.WindowsBitmapColorSpace bytes) -> bytes
+                            _ -> B.pack $ replicate sizeofColorProfile 0
+
+          colorProfileData = case cs of
+                              Just (Met.ICCProfile bytes) -> Just bytes
+                              _ -> Nothing
+
+          headerSize | colorType == ProfileEmbedded                = sizeofBmpV5Header
+                     | colorType == CalibratedRGB || hasAlpha img  = sizeofBmpV4Header
+                     | otherwise                                   = sizeofBmpInfoHeader
+
+          paletteSize = fromIntegral $ length palette
+          bpp = bitsPerPixel (undefined :: pixel)
+
+          profileSize = fromIntegral $ maybe 0 B.length colorProfileData
+          imagePixelSize = fromIntegral $ sizeofPixelData bpp imgWidth imgHeight
+          offsetToData = sizeofBmpHeader + headerSize + 4 * paletteSize
+          offsetToICCProfile = offsetToData + imagePixelSize <$ colorProfileData
+          sizeOfFile = sizeofBmpHeader + headerSize + 4 * paletteSize
+                        + imagePixelSize + profileSize
+
+          hdr = BmpHeader {
+              magicIdentifier = bitmapMagicIdentifier,
+              fileSize = sizeOfFile,
+              reserved1 = 0,
+              reserved2 = 0,
+              dataOffset = offsetToData
+          }
+
+          info = BmpV5Header {
+              size = headerSize,
+              width = fromIntegral imgWidth,
+              height = fromIntegral imgHeight,
+              planes = 1,
+              bitPerPixel = fromIntegral bpp,
+              bitmapCompression = if hasAlpha img then 3 else 0,
+              byteImageSize = imagePixelSize,
+              xResolution = fromIntegral dpiX,
+              yResolution = fromIntegral dpiY,
+              colorCount = paletteSize,
+              importantColours = 0,
+              redMask   = if hasAlpha img then 0x00FF0000 else 0,
+              greenMask = if hasAlpha img then 0x0000FF00 else 0,
+              blueMask  = if hasAlpha img then 0x000000FF else 0,
+              alphaMask = if hasAlpha img then 0xFF000000 else 0,
+              colorSpaceType = colorType,
+              colorSpace = colorSpaceInfo,
+              iccIntent = 0,
+              iccProfileData = fromMaybe 0 offsetToICCProfile,
+              iccProfileSize = profileSize
+          }
+
+
+{-# ANN module "HLint: ignore Reduce duplication" #-}
+
+ src/Codec/Picture/ColorQuant.hs view
@@ -0,0 +1,435 @@+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE CPP #-}
+-- | This module provide some color quantisation algorithm
+-- in order to help in the creation of paletted images.
+-- The most important function is `palettize` which will
+-- make everything to create a nice color indexed image
+-- with its palette.
+module Codec.Picture.ColorQuant
+    ( palettize
+    , palettizeWithAlpha
+    , defaultPaletteOptions
+    , PaletteCreationMethod(..)
+    , PaletteOptions( .. )
+    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import           Control.Applicative (Applicative (..), (<$>))
+#endif
+
+import           Data.Bits           (unsafeShiftL, unsafeShiftR, (.&.), (.|.))
+import           Data.List           (elemIndex)
+import           Data.Maybe          (fromMaybe)
+import           Data.Set            (Set)
+import qualified Data.Set            as Set
+import           Data.Word           (Word32)
+
+import           Data.Vector         (Vector, (!))
+import qualified Data.Vector         as V
+import qualified Data.Vector.Unboxed as VU
+import qualified Data.Vector.Storable as VS
+
+import           Codec.Picture.Types
+import           Codec.Picture.Gif (GifFrame(..), GifDisposalMethod, GifDelay)
+
+-------------------------------------------------------------------------------
+----            Palette Creation and Dithering
+-------------------------------------------------------------------------------
+
+-- | Define which palette creation method is used.
+data PaletteCreationMethod =
+      -- | MedianMeanCut method, provide the best results (visualy)
+      -- at the cost of increased calculations.
+      MedianMeanCut
+      -- | Very fast algorithm (one pass), doesn't provide good
+      -- looking results.
+    | Uniform
+
+-- | To specify how the palette will be created.
+data PaletteOptions = PaletteOptions
+    { -- | Algorithm used to find the palette
+      paletteCreationMethod :: PaletteCreationMethod
+
+      -- | Do we want to apply the dithering to the
+      -- image. Enabling it often reduce compression
+      -- ratio but enhance the perceived quality
+      -- of the final image.
+    , enableImageDithering  :: Bool
+
+      -- | Maximum number of color we want in the
+      -- palette
+    , paletteColorCount     :: Int
+    }
+
+-- | Default palette option, which aim at the best quality
+-- and maximum possible colors (256)
+defaultPaletteOptions :: PaletteOptions
+defaultPaletteOptions = PaletteOptions
+    { paletteCreationMethod = MedianMeanCut
+    , enableImageDithering  = True
+    , paletteColorCount     = 256
+    }
+
+-- | Changes all pixels with alpha = 0 to black
+-- converting image to RGB (from RGBA) in meantime
+alphaToBlack :: Image PixelRGBA8 -> Image PixelRGB8
+alphaToBlack = pixelMap f
+  where f (PixelRGBA8 r g b a) =
+          if a == 0 then PixelRGB8 0 0 0
+          else PixelRGB8 r g b
+
+-- | Using second image as a stencil, changes palette index to the transparent
+alphaTo255 :: Image Pixel8 -> Image PixelRGBA8 -> Pixel8 -> Image Pixel8
+alphaTo255 img1 img2 transparentIndex = generateImage f (imageWidth img1) (imageHeight img2)
+  where f x y =
+          if a == 0 then transparentIndex
+          else v
+          where v = pixelAt img1 x y
+                PixelRGBA8 _ _ _ a = pixelAt img2 x y
+
+-- | Converts RGBA image to the array of GifFame's to use in encodeComplexGifImage
+palettizeWithAlpha :: [(GifDelay, Image PixelRGBA8)] -> GifDisposalMethod -> [GifFrame]
+palettizeWithAlpha [] _ = []
+palettizeWithAlpha (x:xs) dispose =
+  GifFrame
+    0 -- Offset X
+    0 -- Offset Y 
+    (Just $ palet)
+    (Just $ transparentIndex)
+    delay
+    dispose
+    (alphaTo255 pixels i (fromIntegral transparentIndex))
+  : palettizeWithAlpha xs dispose
+  where (delay, i) = x
+        img = alphaToBlack i
+        (palet, pixels) =
+          if isBelow
+            then (vecToPalette (belowPaletteVec `V.snoc` PixelRGB8 0 0 0), pixelMap belowPaletteIndex img)
+            else (vecToPalette (genPaletteVec   `V.snoc` PixelRGB8 0 0 0), pixelMap genPaletteIndex img)
+
+        (belowPalette, isBelow) = isColorCountBelow 255 img
+        belowPaletteVec = V.fromList $ Set.toList belowPalette
+        belowPaletteIndex p = nearestColorIdx p belowPaletteVec
+
+        cs = Set.toList . clusters 255 $ img
+        genPaletteVec = mkPaletteVec cs
+        genPaletteIndex p = nearestColorIdx p genPaletteVec
+
+        transparentIndex = length $ if isBelow then belowPaletteVec else genPaletteVec
+
+-- | Reduces an image to a color palette according to `PaletteOptions` and
+--   returns the /indices image/ along with its `Palette`.
+palettize :: PaletteOptions -> Image PixelRGB8 -> (Image Pixel8, Palette)
+palettize opts@PaletteOptions { paletteCreationMethod = method } =
+  case method of
+    MedianMeanCut -> medianMeanCutQuantization opts
+    Uniform       -> uniformQuantization opts
+
+-- | Modified median cut algorithm with optional ordered dithering. Returns an
+-- image of `Pixel8` that acts as a matrix of indices into the `Palette`.
+medianMeanCutQuantization :: PaletteOptions -> Image PixelRGB8
+                          -> (Image Pixel8, Palette)
+medianMeanCutQuantization opts img
+  | isBelow =
+      (pixelMap okPaletteIndex img, vecToPalette okPaletteVec)
+  | enableImageDithering opts = (pixelMap paletteIndex dImg, palette)
+  | otherwise = (pixelMap paletteIndex img, palette)
+  where
+    maxColorCount = paletteColorCount opts
+    (okPalette, isBelow) = isColorCountBelow maxColorCount img
+    okPaletteVec = V.fromList $ Set.toList okPalette
+    okPaletteIndex p = nearestColorIdx p okPaletteVec
+
+    palette = vecToPalette paletteVec
+    paletteIndex p = nearestColorIdx p paletteVec
+    paletteVec = mkPaletteVec cs
+    cs =  Set.toList . clusters maxColorCount $ img
+    dImg = pixelMapXY dither img
+
+-- | A naive one pass Color Quantization algorithm - Uniform Quantization.
+-- Simply take the most significant bits. The maxCols parameter is rounded
+-- down to the nearest power of 2, and the bits are divided among the three
+-- color channels with priority order green, red, blue. Returns an
+-- image of `Pixel8` that acts as a matrix of indices into the `Palette`.
+uniformQuantization :: PaletteOptions -> Image PixelRGB8 -> (Image Pixel8, Palette)
+uniformQuantization opts img
+  -- -| colorCount img <= maxCols = colorQuantExact img
+  | enableImageDithering opts =
+        (pixelMap paletteIndex (pixelMapXY dither img), palette)
+  | otherwise = (pixelMap paletteIndex img, palette)
+  where
+    maxCols = paletteColorCount opts
+    palette = listToPalette paletteList
+    paletteList = [PixelRGB8 r g b | r <- [0,dr..255]
+                                   , g <- [0,dg..255]
+                                   , b <- [0,db..255]]
+    (bg, br, bb) = bitDiv3 maxCols
+    (dr, dg, db) = (2^(8-br), 2^(8-bg), 2^(8-bb))
+    paletteIndex (PixelRGB8 r g b) = fromIntegral $ fromMaybe 0 (elemIndex
+      (PixelRGB8 (r .&. negate dr) (g .&. negate dg) (b .&. negate db))
+      paletteList)
+
+isColorCountBelow :: Int -> Image PixelRGB8 -> (Set.Set PixelRGB8, Bool)
+isColorCountBelow maxColorCount img = go 0 Set.empty
+  where rawData = imageData img
+        maxIndex = VS.length rawData
+        
+        go !idx !allColors
+            | Set.size allColors > maxColorCount = (Set.empty, False)
+            | idx >= maxIndex - 2 = (allColors, True)
+            | otherwise = go (idx + 3) $ Set.insert px allColors
+                where px = unsafePixelAt rawData idx 
+
+vecToPalette :: Vector PixelRGB8 -> Palette
+vecToPalette ps = generateImage (\x _ -> ps ! x) (V.length ps) 1
+
+listToPalette :: [PixelRGB8] -> Palette
+listToPalette ps = generateImage (\x _ -> ps !! x) (length ps) 1
+
+bitDiv3 :: Int -> (Int, Int, Int)
+bitDiv3 n = case r of
+            0 -> (q, q, q)
+            1 -> (q+1, q, q)
+            _ -> (q+1, q+1, q)
+  where
+    r = m `mod` 3
+    q = m `div` 3
+    m = floor . logBase (2 :: Double) $ fromIntegral n
+
+-------------------------------------------------------------------------------
+----            Dithering
+-------------------------------------------------------------------------------
+
+-- Add a dither mask to an image for ordered dithering.
+-- Uses a small, spatially stable dithering algorithm based on magic numbers
+-- and arithmetic inspired by the /a dither/ algorithm of Øyvind Kolås,
+-- pippin@gimp.org, 2013. See, http://pippin.gimp.org/a_dither/.
+dither :: Int -> Int -> PixelRGB8 -> PixelRGB8
+dither x y (PixelRGB8 r g b) = PixelRGB8 (fromIntegral r')
+                                         (fromIntegral g')
+                                         (fromIntegral b')
+  where
+    -- Should view 16 as a parameter that can be optimized for best looking
+    -- results
+    r' = min 255 (fromIntegral r + (x' + y') .&. 16)
+    g' = min 255 (fromIntegral g + (x' + y' + 7973) .&. 16)
+    b' = min 255 (fromIntegral b + (x' + y' + 15946) .&. 16)
+    x' = 119 * x
+    y' = 28084 * y
+
+-------------------------------------------------------------------------------
+----            Small modification of foldl package by Gabriel Gonzalez
+-------------------------------------------------------------------------------
+
+-- Modification to Control.foldl by Gabriel Gonzalez copyright 2013, BSD3.
+-- http://hackage.haskell.org/package/foldl-1.0.1/docs/Control-Foldl.html
+
+{-| Efficient representation of a left fold that preserves the fold's step
+    function, initial accumulator, and extraction function
+
+    This allows the 'Applicative' instance to assemble derived folds that
+    traverse the container only once
+-}
+data Fold a b = forall x . Fold (x -> a -> x) x (x -> b)
+
+{-| Apply a strict left 'Fold' to a 'Foldable' container
+
+    Much slower than 'fold' on lists because 'Foldable' operations currently do
+    not trigger @build/foldr@ fusion
+-}
+fold :: Fold PackedRGB b -> VU.Vector PackedRGB -> b
+fold (Fold step begin done) = done . VU.foldl' step begin
+{-# INLINE fold #-}
+
+{-
+F.foldr :: (a -> b -> b) -> b -> t a -> b
+
+fold :: (Foldable f) => Fold a b -> f a -> b
+fold (Fold step begin done) as = F.foldr step' done as begin
+  where step' x k z = k $! step z x
+-}
+
+data Pair a b = Pair !a !b
+
+instance Functor (Fold a) where
+    fmap f (Fold step begin done) = Fold step begin (f . done)
+    {-# INLINABLE fmap #-}
+
+instance Applicative (Fold a) where
+    pure b    = Fold (\() _ -> ()) () (\() -> b)
+    {-# INLINABLE pure #-}
+    (Fold stepL beginL doneL) <*> (Fold stepR beginR doneR) =
+        let step (Pair xL xR) a = Pair (stepL xL a) (stepR xR a)
+            begin = Pair beginL beginR
+            done (Pair xL xR) = doneL xL $ doneR xR
+        in  Fold step begin done
+    {-# INLINABLE (<*>) #-}
+
+{- | Like 'length', except with a more general 'Num' return value -}
+intLength :: Fold a Int
+intLength = Fold (\n _ -> n + 1) 0 id
+
+-------------------------------------------------------------------------------
+----            Modified Median Cut Algorithm
+-------------------------------------------------------------------------------
+
+-- Based on the OCaml implementation:
+-- http://rosettacode.org/wiki/Color_quantization
+-- which is in turn based on: www.leptonica.org/papers/mediancut.pdf.
+-- We use the product of volume and population to determine the next cluster
+-- to split and determine the placement of each color by compating it to the
+-- mean of the parent cluster. So median cut is a bit of a misnomer, since one
+-- of the modifiations is to use the mean.
+
+mkPaletteVec :: [Cluster] -> Vector PixelRGB8
+mkPaletteVec  = V.fromList . map (toRGB8 . meanColor)
+
+type PackedRGB = Word32
+
+data Cluster = Cluster
+    { value       :: {-# UNPACK #-} !Float
+    , meanColor   :: !PixelRGBF
+    , dims        :: !PixelRGBF
+    , colors      :: VU.Vector PackedRGB
+    }
+
+instance Eq Cluster where
+    a == b =
+        (value a, meanColor a, dims a) == (value b, meanColor b, dims b)
+
+instance Ord Cluster where
+    compare a b =
+        compare (value a, meanColor a, dims a) (value b, meanColor b, dims b)
+
+data Axis = RAxis | GAxis | BAxis
+
+inf :: Float
+inf = read "Infinity"
+
+fromRGB8 :: PixelRGB8 -> PixelRGBF
+fromRGB8 (PixelRGB8 r g b) =
+  PixelRGBF (fromIntegral r) (fromIntegral g) (fromIntegral b)
+
+toRGB8 :: PixelRGBF -> PixelRGB8
+toRGB8 (PixelRGBF r g b) =
+  PixelRGB8 (round r) (round g) (round b)
+
+meanRGB :: Fold PixelRGBF PixelRGBF
+meanRGB = mean <$> intLength <*> pixelSum
+  where
+    pixelSum = Fold (mixWith $ const (+)) (PixelRGBF 0 0 0) id
+    mean n = colorMap (/ nf)
+      where nf = fromIntegral n
+
+minimal :: Fold PixelRGBF PixelRGBF
+minimal = Fold mini (PixelRGBF inf inf inf) id
+  where mini = mixWith $ const min
+
+maximal :: Fold PixelRGBF PixelRGBF
+maximal = Fold maxi (PixelRGBF (-inf) (-inf) (-inf)) id
+  where maxi = mixWith $ const max
+
+extrems :: Fold PixelRGBF (PixelRGBF, PixelRGBF)
+extrems = (,) <$> minimal <*> maximal
+
+volAndDims :: Fold PixelRGBF (Float, PixelRGBF)
+volAndDims = deltify <$> extrems
+  where deltify (mini, maxi) = (dr * dg * db, delta)
+          where delta@(PixelRGBF dr dg db) =
+                        mixWith (const (-)) maxi mini
+
+unpackFold :: Fold PixelRGBF a -> Fold PackedRGB a
+unpackFold (Fold step start done) = Fold (\acc -> step acc . transform) start done
+  where transform = fromRGB8 . rgbIntUnpack
+
+mkCluster :: VU.Vector PackedRGB -> Cluster
+mkCluster ps = Cluster
+    { value = v * fromIntegral l
+    , meanColor = m
+    , dims = ds
+    , colors = ps
+    }
+  where
+    worker = (,,) <$> volAndDims <*> meanRGB <*> intLength
+    ((v, ds), m, l) = fold (unpackFold worker) ps
+
+maxAxis :: PixelRGBF -> Axis
+maxAxis (PixelRGBF r g b) =
+  case (r `compare` g, r `compare` b, g `compare` b) of
+    (GT, GT, _)  -> RAxis
+    (LT, GT, _)  -> GAxis
+    (GT, LT, _)  -> BAxis
+    (LT, LT, GT) -> GAxis
+    (EQ, GT, _)  -> RAxis
+    (_,  _,  _)  -> BAxis
+
+-- Split a cluster about its largest axis using the mean to divide up the
+-- pixels.
+subdivide :: Cluster -> (Cluster, Cluster)
+subdivide cluster = (mkCluster px1, mkCluster px2)
+  where
+    (PixelRGBF mr mg mb) = meanColor cluster
+    (px1, px2) = VU.partition (cond . rgbIntUnpack) $ colors cluster
+    cond = case maxAxis $ dims cluster of
+      RAxis -> \(PixelRGB8 r _ _) -> fromIntegral r < mr
+      GAxis -> \(PixelRGB8 _ g _) -> fromIntegral g < mg
+      BAxis -> \(PixelRGB8 _ _ b) -> fromIntegral b < mb
+
+rgbIntPack :: PixelRGB8 -> PackedRGB
+rgbIntPack (PixelRGB8 r g b) =
+    wr `unsafeShiftL` (2 * 8) .|. wg `unsafeShiftL` 8 .|. wb
+  where wr = fromIntegral r
+        wg = fromIntegral g
+        wb = fromIntegral b
+
+rgbIntUnpack :: PackedRGB -> PixelRGB8
+rgbIntUnpack v = PixelRGB8 r g b
+  where
+    r = fromIntegral $ v `unsafeShiftR` (2 * 8)
+    g = fromIntegral $ v `unsafeShiftR` 8
+    b = fromIntegral v
+
+initCluster :: Image PixelRGB8 -> Cluster
+initCluster img = mkCluster $ VU.generate ((w * h) `div` subSampling) packer
+  where samplingFactor = 3
+        subSampling = samplingFactor * samplingFactor
+        compCount = componentCount (undefined :: PixelRGB8)
+        w = imageWidth img
+        h = imageHeight img
+        rawData = imageData img
+        packer ix =
+            rgbIntPack . unsafePixelAt rawData $ ix * subSampling * compCount
+
+-- Take the cluster with the largest value = (volume * population) and remove it
+-- from the priority queue. Then subdivide it about its largest axis and put the
+-- two new clusters on the queue.
+split :: Set Cluster -> Set Cluster
+split cs = Set.insert c1 . Set.insert c2  $ cs'
+  where
+    (c, cs') = Set.deleteFindMax cs
+    (c1, c2) = subdivide c
+
+-- Keep splitting the initial cluster until there are 256 clusters, then return
+-- a priority queue containing all 256.
+clusters :: Int -> Image PixelRGB8 -> Set Cluster
+clusters maxCols img = clusters' (maxCols - 1)
+  where
+    clusters' :: Int -> Set Cluster
+    clusters' 0 = Set.singleton c
+    clusters' n = split (clusters' (n-1))
+    c = initCluster img
+
+-- Euclidean distance squared, between two pixels.
+dist2Px :: PixelRGB8 -> PixelRGB8 -> Int
+dist2Px (PixelRGB8 r1 g1 b1) (PixelRGB8 r2 g2 b2) = dr*dr + dg*dg + db*db
+  where
+    (dr, dg, db) =
+      ( fromIntegral r1 - fromIntegral r2
+      , fromIntegral g1 - fromIntegral g2
+      , fromIntegral b1 - fromIntegral b2 )
+
+nearestColorIdx :: PixelRGB8 -> Vector PixelRGB8 -> Pixel8
+nearestColorIdx p ps  = fromIntegral $ V.minIndex (V.map (`dist2Px` p) ps)
+ src/Codec/Picture/ConvGraph.hs view
@@ -0,0 +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>>+--
+ src/Codec/Picture/Gif.hs view
@@ -0,0 +1,1006 @@+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
+-- | Module implementing GIF decoding.
+module Codec.Picture.Gif ( -- * Reading
+                           decodeGif
+                         , decodeGifWithMetadata
+                         , decodeGifWithPaletteAndMetadata
+                         , decodeGifImages
+                         , getDelaysGifImages
+
+                           -- * Writing
+                         , GifDelay
+                         , GifDisposalMethod( .. )
+                         , GifEncode( .. )
+                         , GifFrame( .. )
+                         , GifLooping( .. )
+                         , encodeGifImage
+                         , encodeGifImageWithPalette
+                         , encodeGifImages
+                         , encodeComplexGifImage
+
+                         , writeGifImage
+                         , writeGifImageWithPalette
+                         , writeGifImages
+                         , writeComplexGifImage
+                         , greyPalette
+                         ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( pure, (<*>), (<$>) )
+#endif
+
+import Control.Arrow( first )
+import Control.Monad( replicateM, replicateM_, unless, when )
+import Control.Monad.ST( runST )
+import Control.Monad.Trans.Class( lift )
+
+import Data.Bits( (.&.), (.|.)
+                , unsafeShiftR
+                , unsafeShiftL
+                , testBit, setBit )
+import Data.Word( Word8, Word16 )
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Vector.Storable as V
+import qualified Data.Vector.Storable.Mutable as M
+
+import Data.Binary( Binary(..), encode )
+import Data.Binary.Get( Get
+                      , getWord8
+                      , getWord16le
+                      , getByteString
+                      , bytesRead
+                      , skip
+                      )
+
+import Data.Binary.Put( Put
+                      , putWord8
+                      , putWord16le
+                      , putByteString
+                      )
+
+import Codec.Picture.InternalHelper
+import Codec.Picture.Types
+import Codec.Picture.Metadata( Metadatas
+                             , SourceFormat( SourceGif )
+                             , basicMetadata )
+import Codec.Picture.Gif.Internal.LZW
+import Codec.Picture.Gif.Internal.LZWEncoding
+import Codec.Picture.BitWriter
+
+-- | Delay to wait before showing the next Gif image.
+-- The delay is expressed in 100th of seconds.
+type GifDelay = Int
+
+-- | Help to control the behaviour of GIF animation looping.
+data GifLooping =
+      -- | The animation will stop once the end is reached
+      LoopingNever
+      -- | The animation will restart once the end is reached
+    | LoopingForever
+      -- | The animation will repeat n times before stoping
+    | LoopingRepeat Word16
+
+
+-- | GIF image definition for encoding
+data GifEncode = GifEncode
+  { -- | Screen width
+    geWidth      :: Int
+  , -- | Screen height
+    geHeight     :: Int
+  , -- | Global palette, optional
+    gePalette    :: Maybe Palette
+  , -- | Background color index, optional. If given, a global palette is also required
+    geBackground :: Maybe Int
+  , -- | Looping behaviour
+    geLooping    :: GifLooping
+  , -- | Image frames
+    geFrames     :: [GifFrame]
+  }
+
+-- | An individual image frame in a GIF image
+data GifFrame = GifFrame
+  { -- | Image X offset in GIF canvas
+    gfXOffset     :: Int
+  , -- | Image Y offset in GIF canvas
+    gfYOffset     :: Int
+  , -- | Image local palette, optional if a global palette is given
+    gfPalette     :: Maybe Palette
+  , -- | Transparent color index, optional
+    gfTransparent :: Maybe Int
+  , -- | Frame transition delay, in 1/100ths of a second
+    gfDelay       :: GifDelay
+  , -- | Frame disposal method
+    gfDisposal    :: GifDisposalMethod
+  , -- | Image pixels
+    gfPixels      :: Image Pixel8
+  }
+
+
+{-
+   <GIF Data Stream> ::=     Header <Logical Screen> <Data>* Trailer
+
+   <Logical Screen> ::=      Logical Screen Descriptor [Global Color Table]
+
+   <Data> ::=                <Graphic Block>  |
+                             <Special-Purpose Block>
+
+   <Graphic Block> ::=       [Graphic Control Extension] <Graphic-Rendering Block>
+
+   <Graphic-Rendering Block> ::=  <Table-Based Image>  |
+                                  Plain Text Extension
+
+   <Table-Based Image> ::=   Image Descriptor [Local Color Table] Image Data
+
+   <Special-Purpose Block> ::=    Application Extension  |
+                                  Comment Extension
+ -}
+
+--------------------------------------------------
+----            GifVersion
+--------------------------------------------------
+data GifVersion = GIF87a | GIF89a
+
+gif87aSignature, gif89aSignature :: B.ByteString
+gif87aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF87a"
+gif89aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF89a"
+
+instance Binary GifVersion where
+    put GIF87a = putByteString gif87aSignature
+    put GIF89a = putByteString gif89aSignature
+
+    get = do
+        sig <- getByteString (B.length gif87aSignature)
+        case (sig == gif87aSignature, sig == gif89aSignature) of
+            (True, _)  -> pure GIF87a
+            (_ , True) -> pure GIF89a
+            _          -> fail $ "Invalid Gif signature : " ++ (toEnum . fromEnum <$> B.unpack sig)
+
+
+--------------------------------------------------
+----         LogicalScreenDescriptor
+--------------------------------------------------
+-- | Section 18 of spec-gif89a
+data LogicalScreenDescriptor = LogicalScreenDescriptor
+  { -- | Stored on 16 bits
+    screenWidth           :: !Word16
+    -- | Stored on 16 bits
+  , screenHeight          :: !Word16
+    -- | Stored on 8 bits
+  , backgroundIndex       :: !Word8
+
+  -- | Stored on 1 bit
+  , hasGlobalMap          :: !Bool
+  -- | Stored on 3 bits
+  , colorResolution       :: !Word8
+  -- | Stored on 1 bit
+  , isColorTableSorted    :: !Bool
+  -- | Stored on 3 bits
+  , colorTableSize        :: !Word8
+  }
+
+instance Binary LogicalScreenDescriptor where
+    put v = do
+      putWord16le $ screenWidth v
+      putWord16le $ screenHeight v
+      let globalMapField
+            | hasGlobalMap v = 0x80
+            | otherwise = 0
+
+          colorTableSortedField
+            | isColorTableSorted v = 0x08
+            | otherwise = 0
+
+          tableSizeField = (colorTableSize v - 1) .&. 7
+
+          colorResolutionField =
+            ((colorResolution v - 1) .&. 7) `unsafeShiftL` 4
+
+          packedField = globalMapField
+                     .|. colorTableSortedField
+                     .|. tableSizeField
+                     .|. colorResolutionField
+
+      putWord8 packedField
+      putWord8 0 -- aspect ratio
+      putWord8 $ backgroundIndex v
+
+    get = do
+        w <- getWord16le
+        h <- getWord16le
+        packedField  <- getWord8
+        backgroundColorIndex  <- getWord8
+        _aspectRatio  <- getWord8
+        return LogicalScreenDescriptor
+            { screenWidth           = w
+            , screenHeight          = h
+            , hasGlobalMap          = packedField `testBit` 7
+            , colorResolution       = (packedField `unsafeShiftR` 4) .&. 0x7 + 1
+            , isColorTableSorted    = packedField `testBit` 3
+            , colorTableSize        = (packedField .&. 0x7) + 1
+            , backgroundIndex       = backgroundColorIndex
+            }
+
+
+--------------------------------------------------
+----            ImageDescriptor
+--------------------------------------------------
+-- | Section 20 of spec-gif89a
+data ImageDescriptor = ImageDescriptor
+  { gDescPixelsFromLeft         :: !Word16
+  , gDescPixelsFromTop          :: !Word16
+  , gDescImageWidth             :: !Word16
+  , gDescImageHeight            :: !Word16
+  , gDescHasLocalMap            :: !Bool
+  , gDescIsInterlaced           :: !Bool
+  , gDescIsImgDescriptorSorted  :: !Bool
+  , gDescLocalColorTableSize    :: !Word8
+  }
+
+imageSeparator, extensionIntroducer, gifTrailer :: Word8
+imageSeparator      = 0x2C
+extensionIntroducer = 0x21
+gifTrailer          = 0x3B
+
+graphicControlLabel, commentLabel, plainTextLabel, applicationLabel :: Word8
+plainTextLabel = 0x01
+graphicControlLabel = 0xF9
+commentLabel = 0xFE
+applicationLabel    = 0xFF
+
+
+parseDataBlocks :: Get B.ByteString
+parseDataBlocks = B.concat <$> (getWord8 >>= aux)
+ where aux    0 = pure []
+       aux size = (:) <$> getByteString (fromIntegral size) <*> (getWord8 >>= aux)
+
+putDataBlocks :: B.ByteString -> Put
+putDataBlocks wholeString = putSlices wholeString >> putWord8 0
+  where putSlices str | B.length str == 0 = pure ()
+                      | B.length str > 0xFF =
+            let (before, after) = B.splitAt 0xFF str in
+            putWord8 0xFF >> putByteString before >> putSlices after
+        putSlices str =
+            putWord8 (fromIntegral $ B.length str) >> putByteString str
+
+data GifDisposalMethod
+    = DisposalAny
+    | DisposalDoNot
+    | DisposalRestoreBackground
+    | DisposalRestorePrevious
+    | DisposalUnknown Word8
+
+disposalMethodOfCode :: Word8 -> GifDisposalMethod
+disposalMethodOfCode v = case v of
+    0 -> DisposalAny
+    1 -> DisposalDoNot
+    2 -> DisposalRestoreBackground
+    3 -> DisposalRestorePrevious
+    n -> DisposalUnknown n
+
+codeOfDisposalMethod :: GifDisposalMethod -> Word8
+codeOfDisposalMethod v = case v of
+    DisposalAny -> 0
+    DisposalDoNot -> 1
+    DisposalRestoreBackground -> 2
+    DisposalRestorePrevious -> 3
+    DisposalUnknown n -> n
+
+data GraphicControlExtension = GraphicControlExtension
+    { gceDisposalMethod        :: !GifDisposalMethod -- ^ Stored on 3 bits
+    , gceUserInputFlag         :: !Bool
+    , gceTransparentFlag       :: !Bool
+    , gceDelay                 :: !Word16
+    , gceTransparentColorIndex :: !Word8
+    }
+
+instance Binary GraphicControlExtension where
+    put v = do
+        putWord8 extensionIntroducer
+        putWord8 graphicControlLabel
+        putWord8 0x4  -- size
+        let disposalCode = codeOfDisposalMethod $ gceDisposalMethod v
+            disposalField =
+                (disposalCode .&. 0x7) `unsafeShiftL` 2
+
+            userInputField
+                | gceUserInputFlag v = 0 `setBit` 1
+                | otherwise = 0
+
+            transparentField
+                | gceTransparentFlag v = 0 `setBit` 0
+                | otherwise = 0
+
+            packedFields =  disposalField
+                        .|. userInputField
+                        .|. transparentField
+
+        putWord8 packedFields
+        putWord16le $ gceDelay v
+        putWord8 $ gceTransparentColorIndex v
+        putWord8 0 -- blockTerminator
+
+    get = do
+        -- due to missing lookahead
+        {-_extensionLabel  <- getWord8-}
+        _size            <- getWord8
+        packedFields     <- getWord8
+        delay            <- getWord16le
+        idx              <- getWord8
+        _blockTerminator <- getWord8
+        return GraphicControlExtension
+            { gceDisposalMethod        = 
+                disposalMethodOfCode $
+                    (packedFields `unsafeShiftR` 2) .&. 0x07
+            , gceUserInputFlag         = packedFields `testBit` 1
+            , gceTransparentFlag       = packedFields `testBit` 0
+            , gceDelay                 = delay
+            , gceTransparentColorIndex = idx
+            }
+
+data GifImage = GifImage
+    { imgDescriptor   :: !ImageDescriptor
+    , imgLocalPalette :: !(Maybe Palette)
+    , imgLzwRootSize  :: !Word8
+    , imgData         :: B.ByteString
+    }
+
+instance Binary GifImage where
+    put img = do
+        let descriptor = imgDescriptor img
+        put descriptor
+        case ( imgLocalPalette img
+             , gDescHasLocalMap $ imgDescriptor img) of
+          (Nothing, _) -> return ()
+          (Just _, False) -> return ()
+          (Just p, True) ->
+              putPalette (fromIntegral $ gDescLocalColorTableSize descriptor) p
+        putWord8 $ imgLzwRootSize img
+        putDataBlocks $ imgData img
+
+    get = do
+        desc <- get
+        let hasLocalColorTable = gDescHasLocalMap desc
+        palette <- if hasLocalColorTable
+           then Just <$> getPalette (gDescLocalColorTableSize desc)
+           else pure Nothing
+
+        GifImage desc palette <$> getWord8 <*> parseDataBlocks
+
+data Block = BlockImage GifImage
+           | BlockGraphicControl GraphicControlExtension
+
+skipSubDataBlocks :: Get ()
+skipSubDataBlocks = do
+  s <- fromIntegral <$> getWord8
+  unless (s == 0) $
+    skip s >> skipSubDataBlocks
+
+parseGifBlocks :: Get [Block]
+parseGifBlocks = getWord8 >>= blockParse
+  where
+    blockParse v
+      | v == gifTrailer = pure []
+      | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks
+      | v == extensionIntroducer = getWord8 >>= extensionParse
+
+    blockParse v = do
+      readPosition <- bytesRead
+      fail ("Unrecognized gif block " ++ show v ++ " @" ++ show readPosition)
+
+    extensionParse code
+     | code == graphicControlLabel =
+        (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks
+     | code == commentLabel = skipSubDataBlocks >> parseGifBlocks
+     | code `elem` [plainTextLabel, applicationLabel] =
+        fromIntegral <$> getWord8 >>= skip >> skipSubDataBlocks >> parseGifBlocks
+     | otherwise = parseDataBlocks >> parseGifBlocks
+
+
+instance Binary ImageDescriptor where
+    put v = do
+        putWord8 imageSeparator
+        putWord16le $ gDescPixelsFromLeft v
+        putWord16le $ gDescPixelsFromTop v
+        putWord16le $ gDescImageWidth v
+        putWord16le $ gDescImageHeight v
+        let localMapField
+                | gDescHasLocalMap v = 0 `setBit` 7
+                | otherwise = 0
+
+            isInterlacedField
+                | gDescIsInterlaced v = 0 `setBit` 6
+                | otherwise = 0
+
+            isImageDescriptorSorted
+                | gDescIsImgDescriptorSorted v = 0 `setBit` 5
+                | otherwise = 0
+
+            localSize = gDescLocalColorTableSize v
+            tableSizeField
+                | localSize > 0 = (localSize - 1) .&. 0x7
+                | otherwise = 0
+
+            packedFields = localMapField
+                        .|. isInterlacedField
+                        .|. isImageDescriptorSorted
+                        .|. tableSizeField
+        putWord8 packedFields
+
+    get = do
+        -- due to missing lookahead
+        {-_imageSeparator <- getWord8-}
+        imgLeftPos <- getWord16le
+        imgTopPos  <- getWord16le
+        imgWidth   <- getWord16le
+        imgHeight  <- getWord16le
+        packedFields <- getWord8
+        return ImageDescriptor
+            { gDescPixelsFromLeft = imgLeftPos
+            , gDescPixelsFromTop  = imgTopPos
+            , gDescImageWidth     = imgWidth
+            , gDescImageHeight    = imgHeight
+            , gDescHasLocalMap    = packedFields `testBit` 7
+            , gDescIsInterlaced     = packedFields `testBit` 6
+            , gDescIsImgDescriptorSorted = packedFields `testBit` 5
+            , gDescLocalColorTableSize = (packedFields .&. 0x7) + 1
+            }
+
+
+--------------------------------------------------
+----            Palette
+--------------------------------------------------
+getPalette :: Word8 -> Get Palette
+getPalette bitDepth = 
+    Image size 1 . V.fromList <$> replicateM (size * 3) get
+  where size = 2 ^ (fromIntegral bitDepth :: Int)
+
+putPalette :: Int -> Palette -> Put
+putPalette size pal = do
+    V.mapM_ putWord8 (imageData pal)
+    replicateM_ missingColorComponent (putWord8 0)
+  where elemCount = 2 ^ size
+        missingColorComponent = (elemCount - imageWidth pal) * 3
+
+--------------------------------------------------
+----            GifImage
+--------------------------------------------------
+data GifHeader = GifHeader
+  { gifVersion          :: GifVersion
+  , gifScreenDescriptor :: LogicalScreenDescriptor
+  , gifGlobalMap        :: Maybe Palette
+  }
+
+instance Binary GifHeader where
+    put v = do
+      put $ gifVersion v
+      let descr = gifScreenDescriptor v
+      put descr
+      case gifGlobalMap v of
+        Just palette -> putPalette (fromIntegral $ colorTableSize descr) palette
+        Nothing      -> return ()
+
+    get = do
+        version    <- get
+        screenDesc <- get
+        
+        palette <- 
+          if hasGlobalMap screenDesc then
+            return <$> getPalette (colorTableSize screenDesc)
+          else
+            return Nothing
+
+        return GifHeader
+            { gifVersion = version
+            , gifScreenDescriptor = screenDesc
+            , gifGlobalMap = palette
+            }
+
+data GifFile = GifFile
+    { gifHeader      :: !GifHeader
+    , gifImages      :: [(Maybe GraphicControlExtension, GifImage)]
+    , gifLoopingBehaviour :: GifLooping
+    }
+
+putLooping :: GifLooping -> Put
+putLooping LoopingNever = return ()
+putLooping LoopingForever = putLooping $ LoopingRepeat 0
+putLooping (LoopingRepeat count) = do
+    putWord8 extensionIntroducer
+    putWord8 applicationLabel
+    putWord8 11 -- the size
+    putByteString $ BC.pack "NETSCAPE2.0"
+    putWord8 3 -- size of sub block
+    putWord8 1
+    putWord16le count
+    putWord8 0
+
+associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)]
+associateDescr [] = []
+associateDescr [BlockGraphicControl _] = []
+associateDescr (BlockGraphicControl _ : rest@(BlockGraphicControl _ : _)) =
+    associateDescr rest
+associateDescr (BlockImage img:xs) = (Nothing, img) : associateDescr xs
+associateDescr (BlockGraphicControl ctrl : BlockImage img : xs) =
+    (Just ctrl, img) : associateDescr xs
+
+instance Binary GifFile where
+    put v = do
+        put $ gifHeader v
+        let putter (Nothing, i) = put i
+            putter (Just a, i) = put a >> put i
+        putLooping $ gifLoopingBehaviour v
+        mapM_ putter $ gifImages v
+        put gifTrailer
+
+    get = do
+        hdr <- get
+        blocks <- parseGifBlocks
+        return GifFile { gifHeader = hdr
+                       , gifImages = associateDescr blocks
+                       , gifLoopingBehaviour = LoopingNever
+                       }
+
+substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8
+substituteColors palette = pixelMap swaper
+  where swaper n = pixelAt palette (fromIntegral n) 0
+
+substituteColorsWithTransparency :: Int -> Image PixelRGBA8 -> Image Pixel8 -> Image PixelRGBA8
+substituteColorsWithTransparency transparent palette = pixelMap swaper where
+  swaper n | ix == transparent = PixelRGBA8 0 0 0 0
+           | otherwise = promotePixel $ pixelAt palette ix 0
+    where ix = fromIntegral n
+
+
+decodeImage :: GifImage -> Image Pixel8
+decodeImage img = runST $ runBoolReader $ do
+    outputVector <- lift . M.new $ width * height
+    decodeLzw (imgData img) 12 lzwRoot outputVector
+    frozenData <- lift $ V.unsafeFreeze outputVector
+    return . deinterlaceGif $ Image
+      { imageWidth = width
+      , imageHeight = height
+      , imageData = frozenData
+      }
+  where lzwRoot = fromIntegral $ imgLzwRootSize img
+        width = fromIntegral $ gDescImageWidth descriptor
+        height = fromIntegral $ gDescImageHeight descriptor
+        isInterlaced = gDescIsInterlaced descriptor
+        descriptor = imgDescriptor img
+
+        deinterlaceGif | not isInterlaced = id
+                       | otherwise = deinterlaceGifImage
+
+deinterlaceGifImage :: Image Pixel8 -> Image Pixel8
+deinterlaceGifImage img@(Image { imageWidth = w, imageHeight = h }) = generateImage generator w h
+   where lineIndices = gifInterlacingIndices h
+         generator x y = pixelAt img x y'
+            where y' = lineIndices V.! y
+
+gifInterlacingIndices :: Int -> V.Vector Int
+gifInterlacingIndices height = V.accum (\_ v -> v) (V.replicate height 0) indices
+    where indices = flip zip [0..] $
+                concat [ [0,     8 .. height - 1]
+                       , [4, 4 + 8 .. height - 1]
+                       , [2, 2 + 4 .. height - 1]
+                       , [1, 1 + 2 .. height - 1]
+                       ]
+
+paletteOf :: (ColorConvertible PixelRGB8 px)
+          => Image px -> GifImage -> Image px
+paletteOf global GifImage { imgLocalPalette = Nothing } = global
+paletteOf      _ GifImage { imgLocalPalette = Just p  } = promoteImage p
+
+getFrameDelays :: GifFile -> [GifDelay]
+getFrameDelays GifFile { gifImages = [] } = []
+getFrameDelays GifFile { gifImages = imgs } = map extractDelay imgs
+    where extractDelay (ext, _) =
+            case ext of
+                Nothing -> 0
+                Just e -> fromIntegral $ gceDelay e
+
+transparentColorOf :: Maybe GraphicControlExtension -> Int
+transparentColorOf Nothing = 300
+transparentColorOf (Just ext)
+  | gceTransparentFlag ext = fromIntegral $ gceTransparentColorIndex ext
+  | otherwise = 300
+
+hasTransparency :: Maybe GraphicControlExtension -> Bool
+hasTransparency Nothing = False
+hasTransparency (Just control) = gceTransparentFlag control
+
+decodeAllGifImages :: GifFile -> [PalettedImage]
+decodeAllGifImages GifFile { gifImages = [] } = []
+decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette
+                                                   , gifScreenDescriptor = wholeDescriptor }
+                           , gifImages = (firstControl, firstImage) : rest }
+  | not (hasTransparency firstControl) =
+      let backImage =
+              generateImage (\_ _ -> backgroundColor) globalWidth globalHeight
+          thisPalette = paletteOf globalPalette firstImage
+          baseImage = decodeImage firstImage
+          initState =
+            (thisPalette, firstControl, substituteColors thisPalette baseImage)
+          scanner = gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage
+          palette' = Palette'
+            { _paletteSize = imageWidth thisPalette
+            , _paletteData = imageData thisPalette
+            }
+      in
+      PalettedRGB8 baseImage palette' :
+        [TrueColorImage $ ImageRGB8 img | (_, _, img) <- tail $ scanl scanner initState rest]
+
+  | otherwise =
+      let backImage :: Image PixelRGBA8
+          backImage =
+            generateImage (\_ _ -> transparentBackground) globalWidth globalHeight
+
+          thisPalette :: Image PixelRGBA8
+          thisPalette = paletteOf (promoteImage globalPalette) firstImage
+
+          transparentCode = transparentColorOf firstControl
+          decoded = 
+            substituteColorsWithTransparency transparentCode thisPalette $
+                decodeImage firstImage
+
+          initState = (thisPalette, firstControl, decoded)
+          scanner =
+            gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage in
+      [TrueColorImage $ ImageRGBA8 img | (_, _, img) <- scanl scanner initState rest]
+
+    where
+      globalWidth = fromIntegral $ screenWidth wholeDescriptor
+      globalHeight = fromIntegral $ screenHeight wholeDescriptor
+      globalPalette = maybe greyPalette id palette
+
+      transparentBackground = PixelRGBA8 r g b 0
+          where PixelRGB8 r g b = backgroundColor
+
+      backgroundColor
+        | hasGlobalMap wholeDescriptor =
+            pixelAt globalPalette (fromIntegral $ backgroundIndex wholeDescriptor) 0
+        | otherwise = PixelRGB8 0 0 0
+
+gifAnimationApplyer :: forall px.  (ColorConvertible PixelRGB8 px)
+                    => (Int, Int) -> Image px -> Image px
+                    -> (Image px, Maybe GraphicControlExtension, Image px)
+                    -> (Maybe GraphicControlExtension, GifImage)
+                    -> (Image px, Maybe GraphicControlExtension, Image px)
+gifAnimationApplyer (globalWidth, globalHeight) globalPalette backgroundImage
+          (_, prevControl, img1)
+          (controlExt, img2@(GifImage { imgDescriptor = descriptor })) =
+            (thisPalette, controlExt, thisImage)
+  where
+    thisPalette :: Image px
+    thisPalette = paletteOf globalPalette img2
+
+    thisImage = generateImage pixeler globalWidth globalHeight
+    localWidth = fromIntegral $ gDescImageWidth descriptor
+    localHeight = fromIntegral $ gDescImageHeight descriptor
+
+    left = fromIntegral $ gDescPixelsFromLeft descriptor
+    top = fromIntegral $ gDescPixelsFromTop descriptor
+
+    isPixelInLocalImage x y =
+        x >= left && x < left + localWidth && y >= top && y < top + localHeight
+
+    decoded :: Image Pixel8
+    decoded = decodeImage img2
+
+    transparent :: Int
+    transparent = case controlExt of
+        Nothing  -> 300
+        Just ext -> if gceTransparentFlag ext
+            then fromIntegral $ gceTransparentColorIndex ext
+            else 300
+
+    oldImage = case gceDisposalMethod <$> prevControl of
+        Nothing -> img1
+        Just DisposalAny -> img1
+        Just DisposalDoNot -> img1
+        Just DisposalRestoreBackground -> backgroundImage
+        Just DisposalRestorePrevious -> img1
+        Just (DisposalUnknown _) -> img1
+
+    pixeler x y
+      | isPixelInLocalImage x y && code /= transparent = val where
+          code = fromIntegral $ pixelAt decoded (x - left) (y - top)
+          val = pixelAt thisPalette (fromIntegral code) 0
+    pixeler x y = pixelAt oldImage x y
+
+decodeFirstGifImage :: GifFile -> Either String (PalettedImage, Metadatas)
+decodeFirstGifImage img@GifFile { gifImages = (firstImage:_) } =
+    case decodeAllGifImages img { gifImages = [firstImage] } of
+      [] -> Left "No image after decoding"
+      (i:_) -> Right (i, basicMetadata SourceGif (screenWidth hdr) (screenHeight hdr))
+  where hdr = gifScreenDescriptor $ gifHeader img
+decodeFirstGifImage _ = Left "No image in gif file"
+
+-- | Transform a raw gif image to an image, without modifying the pixels. This
+-- function can output the following images:
+--
+--  * 'ImageRGB8'
+--
+--  * 'ImageRGBA8'
+--
+decodeGif :: B.ByteString -> Either String DynamicImage
+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:
+--
+--  * 'ImageRGB8'
+--
+--  * 'ImageRGBA8'
+--
+-- Metadatas include Width & Height information.
+--
+decodeGifWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
+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 = fmap palettedToTrueColor . decodeAllGifImages <$> decode img
+
+-- | Extract a list of frame delays from a raw gif.
+getDelaysGifImages :: B.ByteString -> Either String [GifDelay]
+getDelaysGifImages img = getFrameDelays <$> decode img
+
+-- | Default palette to produce greyscale images.
+greyPalette :: Palette
+greyPalette = generateImage toGrey 256 1
+  where toGrey x _ = PixelRGB8 ix ix ix
+           where ix = fromIntegral x
+
+checkImageSizes :: GifEncode -> Either String ()
+checkImageSizes GifEncode { geWidth = width, geHeight = height, geFrames = frames }
+  | not $ isInBounds width && isInBounds height = Left "Invalid screen bounds"
+  | not $ null outOfBounds = Left $ "GIF frames with invalid bounds: " ++ show (map snd outOfBounds)
+  | otherwise = Right ()
+  where isInBounds dim = dim > 0 && dim <= 0xffff
+        outOfBounds = filter (not . isFrameInBounds . fst) $ zip frames [0 :: Int ..]
+        isFrameInBounds GifFrame { gfPixels = img } = isInBounds (imageWidth img) && isInBounds (imageHeight img)
+
+checkImagesInBounds :: GifEncode -> Either String ()
+checkImagesInBounds GifEncode { geWidth = width, geHeight = height, geFrames = frames } =
+  if null outOfBounds
+  then Right ()
+  else Left $ "GIF frames out of screen bounds: " ++ show (map snd outOfBounds)
+  where outOfBounds = filter (not . isInBounds . fst) $ zip frames [0 :: Int ..]
+        isInBounds GifFrame { gfXOffset = xOff, gfYOffset = yOff, gfPixels = img } =
+          xOff >= 0 && yOff >= 0 &&
+          xOff + imageWidth img <= width && yOff + imageHeight img <= height
+
+checkPaletteValidity :: GifEncode -> Either String ()
+checkPaletteValidity spec
+  | not $ isPaletteValid $ gePalette spec = Left "Invalid global palette size"
+  | not $ null invalidPalettes = Left $ "Invalid palette size in GIF frames: " ++ show (map snd invalidPalettes)
+  | otherwise = Right ()
+  where invalidPalettes = filter (not . isPaletteValid . gfPalette . fst) $ zip (geFrames spec) [0 :: Int ..]
+        isPaletteValid Nothing  = True
+        isPaletteValid (Just p) = let w = imageWidth p
+                                      h = imageHeight p
+                                  in h == 1 && w > 0 && w <= 256
+
+checkIndexAbsentFromPalette :: GifEncode -> Either String ()
+checkIndexAbsentFromPalette GifEncode { gePalette = global, geFrames = frames } =
+  if null missingPalette
+  then Right ()
+  else Left $ "GIF image frames with color indexes missing from palette: " ++ show (map snd missingPalette)
+  where missingPalette = filter (not . checkFrame . fst) $ zip frames [0 :: Int ..]
+        checkFrame frame = V.all (checkIndexInPalette global (gfPalette frame) . fromIntegral) $
+                           imageData $ gfPixels frame
+
+checkBackground :: GifEncode -> Either String ()
+checkBackground GifEncode { geBackground = Nothing } = Right ()
+checkBackground GifEncode { gePalette = global, geBackground = Just background } =
+  if checkIndexInPalette global Nothing background
+  then Right ()
+  else Left "GIF background index absent from global palette"
+
+checkTransparencies :: GifEncode -> Either String ()
+checkTransparencies GifEncode { gePalette = global, geFrames = frames } =
+  if null missingTransparency
+  then Right ()
+  else Left $ "GIF transparent index absent from palettes for frames: " ++ show (map snd missingTransparency)
+  where missingTransparency = filter (not . transparencyOK . fst) $ zip frames [0 :: Int ..]
+        transparencyOK GifFrame { gfTransparent = Nothing } = True
+        transparencyOK GifFrame { gfPalette = local, gfTransparent = Just transparent } =
+          checkIndexInPalette global local transparent
+
+checkIndexInPalette :: Maybe Palette -> Maybe Palette -> Int -> Bool
+checkIndexInPalette Nothing       Nothing      _  = False
+checkIndexInPalette _             (Just local) ix = ix < imageWidth local
+checkIndexInPalette (Just global) _            ix = ix < imageWidth global
+
+checkGifImageSizes :: [(a, b, Image px)] -> Bool
+checkGifImageSizes [] = False
+checkGifImageSizes ((_, _, img) : rest) = all checkDimension rest
+   where width = imageWidth img
+         height = imageHeight img
+
+         checkDimension (_,_,Image { imageWidth = w, imageHeight = h }) =
+             w == width && h == height
+
+computeColorTableSize :: Palette -> Int
+computeColorTableSize Image { imageWidth = itemCount } = go 1
+  where go k | 2 ^ k >= itemCount = k
+             | otherwise = go $ k + 1
+
+-- | Encode a complex gif to a bytestring.
+--
+-- * There must be at least one image.
+--
+-- * The screen and every frame dimensions must be between 1 and 65535.
+--
+-- * Every frame image must fit within the screen bounds.
+--
+-- * Every palette must have between one and 256 colors.
+--
+-- * There must be a global palette or every image must have a local palette.
+--
+-- * The background color index must be present in the global palette.
+--
+-- * Every frame's transparent color index, if set, must be present in the palette used by that frame.
+--
+-- * Every color index used in an image must be present in the palette used by that frame.
+--
+encodeComplexGifImage :: GifEncode -> Either String L.ByteString
+encodeComplexGifImage spec = do
+  when (null $ geFrames spec) $ Left "No GIF frames"
+  checkImageSizes spec
+  checkImagesInBounds spec
+  checkPaletteValidity spec
+  checkBackground spec
+  checkTransparencies spec
+  checkIndexAbsentFromPalette spec
+
+  Right $ encode allFile
+  where
+    GifEncode { geWidth      = width
+              , geHeight     = height
+              , gePalette    = globalPalette
+              , geBackground = background
+              , geLooping    = looping
+              , geFrames     = frames
+              } = spec
+    allFile = GifFile
+      { gifHeader = GifHeader
+        { gifVersion          = version
+        , gifScreenDescriptor = logicalScreen
+        , gifGlobalMap        = globalPalette
+        }
+      , gifImages           = toSerialize
+      , gifLoopingBehaviour = looping
+      }
+
+    version = case frames of
+      [] -> GIF87a
+      [_] -> GIF87a
+      _:_:_ -> GIF89a
+
+    logicalScreen = LogicalScreenDescriptor
+      { screenWidth        = fromIntegral width
+      , screenHeight       = fromIntegral height
+      , backgroundIndex    = maybe 0 fromIntegral background
+      , hasGlobalMap       = maybe False (const True) globalPalette
+      , colorResolution    = 8
+      , isColorTableSorted = False
+      -- Imply a 8 bit global palette size if there's no explicit global palette.
+      , colorTableSize     = maybe 8 (fromIntegral . computeColorTableSize) globalPalette
+      }
+
+    toSerialize = [(controlExtension delay transparent disposal, GifImage
+                     { imgDescriptor = imageDescriptor left top localPalette img
+                     , imgLocalPalette = localPalette
+                     , imgLzwRootSize = fromIntegral lzwKeySize
+                     , imgData = B.concat . L.toChunks . lzwEncode lzwKeySize $ imageData img
+                     })
+                  | GifFrame { gfXOffset     = left
+                             , gfYOffset     = top
+                             , gfPalette     = localPalette
+                             , gfTransparent = transparent
+                             , gfDelay       = delay
+                             , gfDisposal    = disposal
+                             , gfPixels      = img } <- frames
+                  , let palette = case (globalPalette, localPalette) of
+                          (_, Just local)        -> local
+                          (Just global, Nothing) -> global
+                          (Nothing, Nothing)     -> error "No palette for image" -- redundant, we guard for this
+                    -- Some decoders (looking at you, GIMP) don't handle initial LZW key size of 1 correctly.
+                    -- We'll waste some space for the sake of interoperability
+                  , let lzwKeySize = max 2 $ computeColorTableSize palette
+                  ]
+
+    controlExtension 0     Nothing     DisposalAny = Nothing
+    controlExtension delay transparent disposal    = Just GraphicControlExtension
+      { gceDisposalMethod        = disposal
+      , gceUserInputFlag         = False
+      , gceTransparentFlag       = maybe False (const True) transparent
+      , gceDelay                 = fromIntegral delay
+      , gceTransparentColorIndex = maybe 0 fromIntegral transparent
+      }
+
+    imageDescriptor left top localPalette img = ImageDescriptor
+      { gDescPixelsFromLeft         = fromIntegral left
+      , gDescPixelsFromTop          = fromIntegral top
+      , gDescImageWidth             = fromIntegral $ imageWidth img
+      , gDescImageHeight            = fromIntegral $ imageHeight img
+      , gDescHasLocalMap            = maybe False (const True) localPalette
+      , gDescIsInterlaced           = False
+      , gDescIsImgDescriptorSorted  = False
+      , gDescLocalColorTableSize    = maybe 0 (fromIntegral . computeColorTableSize) localPalette
+      }
+
+-- | Encode a gif animation to a bytestring.
+--
+-- * Every image must have the same size
+--
+-- * Every palette must have between one and 256 colors.
+--
+encodeGifImages :: GifLooping -> [(Palette, GifDelay, Image Pixel8)]
+                -> Either String L.ByteString
+encodeGifImages _ [] = Left "No image in list"
+encodeGifImages _ imageList
+    | not $ checkGifImageSizes imageList = Left "Gif images have different size"
+encodeGifImages looping imageList@((firstPalette, _,firstImage):_) =
+  encodeComplexGifImage $ GifEncode (imageWidth firstImage) (imageHeight firstImage) (Just firstPalette) Nothing looping frames
+  where
+    frames = [ GifFrame 0 0 localPalette Nothing delay DisposalAny image
+             | (palette, delay, image) <- imageList
+             , let localPalette = if paletteEqual palette then Nothing else Just palette ]
+
+    paletteEqual p = imageData firstPalette == imageData p
+
+-- | Encode a greyscale image to a bytestring.
+encodeGifImage :: Image Pixel8 -> L.ByteString
+encodeGifImage img = case encodeGifImages LoopingNever [(greyPalette, 0, img)] of
+    Left err -> error $ "Impossible:" ++ err
+    Right v -> v
+
+-- | Encode an image with a given palette.
+-- Can return errors if the palette is ill-formed.
+--
+-- * A palette must have between 1 and 256 colors
+--
+encodeGifImageWithPalette :: Image Pixel8 -> Palette -> Either String L.ByteString
+encodeGifImageWithPalette img palette =
+    encodeGifImages LoopingNever [(palette, 0, img)]
+
+-- | Write a greyscale in a gif file on the disk.
+writeGifImage :: FilePath -> Image Pixel8 -> IO ()
+writeGifImage file = L.writeFile file . encodeGifImage
+
+-- | Write a list of images as a gif animation in a file.
+--
+-- * Every image must have the same size
+--
+-- * Every palette must have between one and 256 colors.
+--
+writeGifImages :: FilePath -> GifLooping -> [(Palette, GifDelay, Image Pixel8)]
+               -> Either String (IO ())
+writeGifImages file looping lst = L.writeFile file <$> encodeGifImages looping lst
+
+-- | Write a gif image with a palette to a file.
+--
+-- * A palette must have between 1 and 256 colors
+--
+writeGifImageWithPalette :: FilePath -> Image Pixel8 -> Palette
+                         -> Either String (IO ())
+writeGifImageWithPalette file img palette =
+    L.writeFile file <$> encodeGifImageWithPalette img palette
+
+writeComplexGifImage :: FilePath -> GifEncode -> Either String (IO ())
+writeComplexGifImage file spec = L.writeFile file <$> encodeComplexGifImage spec
+ src/Codec/Picture/Gif/Internal/LZW.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE CPP #-}
+module Codec.Picture.Gif.Internal.LZW( decodeLzw, decodeLzwTiff ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<$>) )
+#endif
+
+import Data.Word( Word8 )
+import Control.Monad( when, unless )
+
+import Data.Bits( (.&.) )
+
+import Control.Monad.ST( ST )
+import Control.Monad.Trans.Class( MonadTrans, lift )
+
+import Foreign.Storable ( Storable )
+
+import qualified Data.ByteString as B
+import qualified Data.Vector.Storable.Mutable as M
+
+import Codec.Picture.BitWriter
+
+{-# INLINE (.!!!.) #-}
+(.!!!.) :: (Storable a) => M.STVector s a -> Int -> ST s a
+(.!!!.) = M.unsafeRead 
+        {-M.read-}
+
+{-# INLINE (..!!!..) #-}
+(..!!!..) :: (MonadTrans t, Storable a)
+          => M.STVector s a -> Int -> t (ST s) a
+(..!!!..) v idx = lift $ v .!!!. idx
+
+{-# INLINE (.<-.) #-}
+(.<-.) :: (Storable a) => M.STVector s a -> Int -> a -> ST s ()
+(.<-.) = M.unsafeWrite 
+         {-M.write-}
+
+{-# INLINE (..<-..) #-}
+(..<-..) :: (MonadTrans t, Storable a)
+         => M.STVector s a -> Int -> a -> t (ST s) ()
+(..<-..) v idx = lift . (v .<-. idx)
+
+
+duplicateData :: (MonadTrans t, Storable a)
+              => M.STVector s a -> M.STVector s a
+              -> Int -> Int -> Int -> t (ST s) ()
+duplicateData src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex
+  where endIndex = sourceIndex + size
+        aux i _ | i == endIndex  = return ()
+        aux i j = do
+          src .!!!. i >>= (dest .<-. j)
+          aux (i + 1) (j + 1)
+
+rangeSetter :: (Storable a, Num a)
+            => Int -> M.STVector s a
+            -> ST s (M.STVector s a)
+rangeSetter count vec = aux 0
+  where aux n | n == count = return vec
+        aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1)
+
+decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8
+          -> BoolReader s ()
+decodeLzw str maxBitKey initialKey outVec = do
+    setDecodedString str
+    lzw GifVariant maxBitKey initialKey 0 outVec
+
+isOldTiffLZW :: B.ByteString -> Bool
+isOldTiffLZW str = firstByte == 0 && secondByte == 1
+    where firstByte = str `B.index` 0
+          secondByte = (str `B.index` 1) .&. 1
+
+decodeLzwTiff :: B.ByteString -> M.STVector s Word8 -> Int
+              -> BoolReader s()
+decodeLzwTiff str outVec initialWriteIdx = do
+    if isOldTiffLZW str then
+      setDecodedString str
+    else
+      setDecodedStringMSB str
+    let variant | isOldTiffLZW str = OldTiffVariant
+                | otherwise = TiffVariant
+    lzw variant 12 9 initialWriteIdx outVec
+
+data TiffVariant =
+      GifVariant
+    | TiffVariant
+    | OldTiffVariant
+    deriving Eq
+
+-- | Gif image constraint from spec-gif89a, code size max : 12 bits.
+lzw :: TiffVariant -> Int -> Int -> Int -> M.STVector s Word8
+    -> BoolReader s ()
+lzw variant nMaxBitKeySize initialKeySize initialWriteIdx outVec = do
+    -- Allocate buffer of maximum size.
+    lzwData <- lift (M.replicate maxDataSize 0) >>= resetArray
+    lzwOffsetTable <- lift (M.replicate tableEntryCount 0) >>= resetArray
+    lzwSizeTable <- lift $ M.replicate tableEntryCount 0
+    lift $ lzwSizeTable `M.set` 1
+
+    let firstVal code = do
+            dataOffset <- lzwOffsetTable ..!!!.. code
+            lzwData ..!!!.. dataOffset
+
+        writeString at code = do
+            dataOffset <- lzwOffsetTable ..!!!.. code
+            dataSize   <- lzwSizeTable   ..!!!.. code
+
+            when (at + dataSize <= maxWrite) $
+                 duplicateData lzwData outVec dataOffset dataSize at
+
+            return dataSize
+
+        addString pos at code val = do
+            dataOffset <- lzwOffsetTable ..!!!.. code
+            dataSize   <- lzwSizeTable   ..!!!.. code
+
+            when (pos < tableEntryCount) $ do
+              (lzwOffsetTable ..<-.. pos) at
+              (lzwSizeTable ..<-.. pos) $ dataSize + 1
+
+            when (at + dataSize + 1 <= maxDataSize) $ do
+              duplicateData lzwData lzwData dataOffset dataSize at
+              (lzwData ..<-.. (at + dataSize)) val
+
+            return $ dataSize + 1
+
+        maxWrite = M.length outVec
+        loop outWriteIdx writeIdx dicWriteIdx codeSize oldCode code
+          | outWriteIdx >= maxWrite = return ()
+          | code == endOfInfo = return ()
+          | code == clearCode = do
+              toOutput <- getNextCode startCodeSize
+              unless (toOutput == endOfInfo) $ do
+                dataSize <- writeString outWriteIdx toOutput
+                getNextCode startCodeSize >>=
+                  loop (outWriteIdx + dataSize)
+                       firstFreeIndex firstFreeIndex startCodeSize toOutput
+
+          | otherwise =  do
+              (written, dicAdd) <-
+                   if code >= writeIdx then do
+                     c <- firstVal oldCode
+                     wroteSize <- writeString outWriteIdx oldCode
+                     (outVec ..<-.. (outWriteIdx + wroteSize)) c
+                     addedSize <- addString writeIdx dicWriteIdx oldCode c
+                     return (wroteSize + 1, addedSize)
+                   else do
+                     wroteSize <- writeString outWriteIdx code
+                     c <- firstVal code
+                     addedSize <- addString writeIdx dicWriteIdx oldCode c
+                     return (wroteSize, addedSize)
+
+              let new_code_size = updateCodeSize codeSize $ writeIdx + 1
+              getNextCode new_code_size >>=
+                loop (outWriteIdx + written)
+                     (writeIdx + 1)
+                     (dicWriteIdx + dicAdd)
+                     new_code_size
+                     code
+
+    getNextCode startCodeSize >>=
+        loop initialWriteIdx firstFreeIndex firstFreeIndex startCodeSize 0
+
+  where tableEntryCount =  2 ^ min 12 nMaxBitKeySize
+        maxDataSize = tableEntryCount `div` 2 * (1 + tableEntryCount) + 1
+
+        isNewTiff = variant == TiffVariant
+        (switchOffset,  isTiffVariant) = case variant of
+            GifVariant -> (0, False)
+            TiffVariant -> (1, True)
+            OldTiffVariant -> (0, True)
+
+        initialElementCount = 2 ^ initialKeySize :: Int
+        clearCode | isTiffVariant = 256
+                  | otherwise = initialElementCount
+
+        endOfInfo | isTiffVariant = 257
+                  | otherwise = clearCode + 1
+
+        startCodeSize 
+                  | isTiffVariant = initialKeySize
+                  | otherwise = initialKeySize + 1
+
+        firstFreeIndex = endOfInfo + 1
+
+        resetArray a = lift $ rangeSetter initialElementCount a
+
+        updateCodeSize codeSize writeIdx
+            | writeIdx == 2 ^ codeSize - switchOffset = min 12 $ codeSize + 1
+            | otherwise = codeSize
+
+        getNextCode s 
+            | isNewTiff = fromIntegral <$> getNextBitsMSBFirst s
+            | otherwise = fromIntegral <$> getNextBitsLSBFirst s
+
+ src/Codec/Picture/Gif/Internal/LZWEncoding.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE BangPatterns, CPP #-}
+module Codec.Picture.Gif.Internal.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)
+
+    finalizeBoolWriterGif bitWriter
+  where
+    maxi = V.length vec
+
+    startCodeSize = initialKeySize + 1
+
+    clearCode = 2 ^ initialKeySize :: Int
+    endOfInfo = clearCode + 1
+    firstFreeIndex = endOfInfo + 1
+    
+    lookuper = lookupUpdate vec
+ src/Codec/Picture/HDR.hs view
@@ -0,0 +1,534 @@+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TupleSections   #-}
+-- | Module dedicated of Radiance file decompression (.hdr or .pic) file.
+-- Radiance file format is used for High dynamic range imaging.
+module Codec.Picture.HDR( decodeHDR
+                        , decodeHDRWithMetadata
+                        , encodeHDR
+                        , encodeRawHDR
+                        , encodeRLENewStyleHDR
+                        , writeHDR
+                        , writeRLENewStyleHDR
+                        ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( pure, (<*>), (<$>) )
+#endif
+
+import Data.Bits( Bits, (.&.), (.|.), unsafeShiftL, unsafeShiftR )
+import Data.Char( ord, chr, isDigit )
+import Data.Word( Word8 )
+
+#if !MIN_VERSION_base(4,11,0)
+import Data.Monoid( (<>) )
+#endif
+
+import Control.Monad( when, foldM, foldM_, forM, forM_, unless )
+import Control.Monad.Trans.Class( lift )
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Char8 as BC
+
+import Data.List( partition )
+import Data.Binary( Binary( .. ), encode )
+import Data.Binary.Get( Get, getByteString, getWord8 )
+import Data.Binary.Put( putByteString, putLazyByteString )
+
+import Control.Monad.ST( ST, runST )
+import Foreign.Storable ( Storable )
+import Control.Monad.Primitive ( PrimState, PrimMonad )
+import qualified Data.Vector.Storable as V
+import qualified Data.Vector.Storable.Mutable as M
+
+import Codec.Picture.Metadata( Metadatas
+                             , SourceFormat( SourceHDR )
+                             , basicMetadata )
+import Codec.Picture.InternalHelper
+import Codec.Picture.Types
+import Codec.Picture.VectorByteConversion
+
+#if MIN_VERSION_transformers(0, 4, 0)
+import Control.Monad.Trans.Except( ExceptT, throwE, runExceptT )
+#else
+-- Transfomers 0.3 compat
+import Control.Monad.Trans.Error( Error, ErrorT, throwError, runErrorT )
+
+type ExceptT = ErrorT
+
+throwE :: (Monad m, Error e) => e -> ErrorT e m a
+throwE = throwError
+
+runExceptT :: ErrorT e m a -> m (Either e a)
+runExceptT = runErrorT
+#endif
+
+{-# INLINE (.<<.) #-}
+(.<<.), (.>>.) :: (Bits a) => a -> Int -> a
+(.<<.) = unsafeShiftL
+(.>>.) = unsafeShiftR
+
+{-# INLINE (.<-.) #-}
+(.<-.) :: (PrimMonad m, Storable a)
+       => M.STVector (PrimState m) a -> Int -> a -> m ()
+(.<-.) = M.write 
+         {-M.unsafeWrite-}
+
+type HDRReader s a = ExceptT String (ST s) a
+
+data RGBE = RGBE !Word8 !Word8 !Word8 !Word8
+
+instance Binary RGBE where
+    put (RGBE r g b e) = put r >> put g >> put b >> put e
+    get = RGBE <$> get <*> get <*> get <*> get
+
+checkLineLength :: RGBE -> Int
+checkLineLength (RGBE _ _ a b) =
+    (fromIntegral a .<<. 8) .|. fromIntegral b
+
+isNewRunLengthMarker :: RGBE -> Bool
+isNewRunLengthMarker (RGBE 2 2 _ _) = True
+isNewRunLengthMarker _ = False
+
+data RadianceFormat =
+      FormatRGBE
+    | FormatXYZE
+
+radiance32bitRleRGBEFormat, radiance32bitRleXYZEFromat :: B.ByteString
+radiance32bitRleRGBEFormat = BC.pack "32-bit_rle_rgbe"
+radiance32bitRleXYZEFromat = BC.pack "32-bit_rle_xyze"
+
+instance Binary RadianceFormat where
+  put FormatRGBE = putByteString radiance32bitRleRGBEFormat
+  put FormatXYZE = putByteString radiance32bitRleXYZEFromat
+
+  get = getByteString (B.length radiance32bitRleRGBEFormat) >>= format
+    where format sig
+            | sig == radiance32bitRleRGBEFormat = pure FormatRGBE
+            | sig == radiance32bitRleXYZEFromat = pure FormatXYZE
+            | otherwise = fail "Unrecognized Radiance format"
+
+toRGBE :: PixelRGBF -> RGBE
+toRGBE (PixelRGBF r g b)
+    | d <= 1e-32 = RGBE 0 0 0 0
+    | otherwise = RGBE (fix r) (fix g) (fix b) (fromIntegral $ e + 128)
+  where d = maximum [r, g, b]
+        e = exponent d
+        coeff = significand d *  255.9999 / d
+        fix v = truncate $ v * coeff
+
+
+dropUntil :: Word8 -> Get ()
+dropUntil c = getWord8 >>= inner
+  where inner val | val == c = pure ()
+        inner _ = getWord8 >>= inner
+
+getUntil :: (Word8 -> Bool) -> B.ByteString -> Get B.ByteString
+getUntil f initialAcc = getWord8 >>= inner initialAcc
+  where inner acc c | f c = pure acc
+        inner acc c = getWord8 >>= inner (B.snoc acc c)
+
+data RadianceHeader = RadianceHeader
+  { radianceInfos :: [(B.ByteString, B.ByteString)]
+  , radianceFormat :: RadianceFormat
+  , radianceHeight :: !Int
+  , radianceWidth  :: !Int
+  , radianceData   :: L.ByteString
+  }
+
+radianceFileSignature :: B.ByteString
+radianceFileSignature = BC.pack "#?RADIANCE\n"
+
+unpackColor :: L.ByteString -> Int -> RGBE
+unpackColor str idx = RGBE (at 0) (at 1) (at 2) (at 3)
+  where at n = L.index str . fromIntegral $ idx + n
+
+storeColor :: M.STVector s Word8 -> Int -> RGBE -> ST s ()
+storeColor vec idx (RGBE r g b e) = do
+    (vec .<-. (idx + 0)) r
+    (vec .<-. (idx + 1)) g
+    (vec .<-. (idx + 2)) b
+    (vec .<-. (idx + 3)) e
+
+parsePair :: Char -> Get (B.ByteString, B.ByteString)
+parsePair firstChar = do
+    let eol c = c == fromIntegral (ord '\n')
+    line <- getUntil eol B.empty
+    case BC.split '=' line of
+      [] -> pure (BC.singleton firstChar, B.empty)
+      [val] -> pure (BC.singleton firstChar, val)
+      [key, val] -> pure (BC.singleton firstChar <> key, val)
+      (key : vals) -> pure (BC.singleton firstChar <> key, B.concat vals)
+
+decodeInfos :: Get [(B.ByteString, B.ByteString)]
+decodeInfos = do
+    char <- getChar8
+    case char of
+      -- comment
+      '#' -> dropUntil (fromIntegral $ ord '\n') >> decodeInfos
+      -- end of header, no more information
+      '\n' -> pure []
+      -- Classical parsing
+      c -> (:) <$> parsePair c <*> decodeInfos
+
+
+-- | Decode an HDR (radiance) image, the resulting image can be:
+--
+--  * 'ImageRGBF'
+--
+decodeHDR :: B.ByteString -> Either String DynamicImage
+decodeHDR = fmap fst . decodeHDRWithMetadata
+
+-- | Equivalent to decodeHDR but with aditional metadatas.
+decodeHDRWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
+decodeHDRWithMetadata str = runST $ runExceptT $
+  case runGet decodeHeader $ L.fromChunks [str] of
+    Left err -> throwE err
+    Right rez ->
+      let meta = basicMetadata SourceHDR (abs $ radianceWidth rez) (abs $ radianceHeight rez) in
+      (, meta) . ImageRGBF <$> (decodeRadiancePicture rez >>= lift . unsafeFreezeImage)
+
+getChar8 :: Get Char
+getChar8 = chr . fromIntegral <$> getWord8
+
+isSign :: Char -> Bool
+isSign c = c == '+' || c == '-'
+
+isAxisLetter :: Char -> Bool
+isAxisLetter c = c == 'X' || c == 'Y'
+
+decodeNum :: Get Int
+decodeNum = do
+    sign <- getChar8
+    letter <- getChar8
+    space <- getChar8
+
+    unless (isSign sign && isAxisLetter letter && space == ' ')
+           (fail "Invalid radiance size declaration")
+
+    let numDec acc c | isDigit c =
+            getChar8 >>= numDec (acc * 10 + ord c - ord '0')
+        numDec acc _
+            | sign == '-' = pure $ negate acc
+            | otherwise = pure acc
+
+    getChar8 >>= numDec 0
+
+copyPrevColor :: M.STVector s Word8 -> Int -> ST s ()
+copyPrevColor scanLine idx = do
+    r <- scanLine `M.unsafeRead` (idx - 4)
+    g <- scanLine `M.unsafeRead` (idx - 3)
+    b <- scanLine `M.unsafeRead` (idx - 2)
+    e <- scanLine `M.unsafeRead` (idx - 1)
+
+    (scanLine `M.unsafeWrite` (idx + 0)) r
+    (scanLine `M.unsafeWrite` (idx + 1)) g
+    (scanLine `M.unsafeWrite` (idx + 2)) b
+    (scanLine `M.unsafeWrite` (idx + 3)) e
+
+oldStyleRLE :: L.ByteString -> Int -> M.STVector s Word8
+            -> HDRReader s Int
+oldStyleRLE inputData initialIdx scanLine = inner initialIdx 0 0
+  where maxOutput = M.length scanLine
+        maxInput = fromIntegral $ L.length inputData
+
+        inner readIdx writeIdx _
+            | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx
+        inner readIdx writeIdx shift = do
+          let color@(RGBE r g b e) = unpackColor inputData readIdx
+              isRun = r == 1 && g == 1 && b == 1
+
+          if not isRun
+            then do
+              lift $ storeColor scanLine writeIdx color
+              inner (readIdx + 4) (writeIdx + 4) 0
+         
+            else do
+              let count = fromIntegral e .<<. shift
+              lift $ forM_ [0 .. count] $ \i -> copyPrevColor scanLine (writeIdx + 4 * i)
+              inner (readIdx + 4) (writeIdx + 4 * count) (shift + 8)
+
+newStyleRLE :: L.ByteString -> Int -> M.STVector s Word8
+            -> HDRReader s Int
+newStyleRLE inputData initialIdx scanline = foldM inner initialIdx [0 .. 3]
+  where dataAt idx
+            | fromIntegral idx >= maxInput = throwE $ "Read index out of bound (" ++ show idx ++ ")"
+            | otherwise = pure $ L.index inputData (fromIntegral idx)
+
+        maxOutput = M.length scanline
+        maxInput = fromIntegral $ L.length inputData
+        stride = 4
+
+
+        strideSet count destIndex _ | endIndex > maxOutput + stride =
+          throwE $ "Out of bound HDR scanline " ++ show endIndex ++ " (max " ++ show maxOutput ++ ")"
+            where endIndex = destIndex + count * stride
+        strideSet count destIndex val = aux destIndex count
+            where aux i 0 =  pure i
+                  aux i c = do
+                    lift $ (scanline .<-. i) val
+                    aux (i + stride) (c - 1)
+
+
+        strideCopy _ count destIndex
+            | writeEndBound > maxOutput + stride = throwE "Out of bound HDR scanline"
+                where writeEndBound = destIndex + count * stride
+        strideCopy sourceIndex count destIndex = aux sourceIndex destIndex count
+          where aux _ j 0 = pure j
+                aux i j c = do
+                    val <- dataAt i
+                    lift $ (scanline .<-. j) val
+                    aux (i + 1) (j + stride) (c - 1)
+
+        inner readIdx writeIdx
+            | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx
+        inner readIdx writeIdx = do
+          code <- dataAt readIdx
+          if code > 128
+            then do
+              let repeatCount = fromIntegral code .&. 0x7F
+              newVal <- dataAt $ readIdx + 1
+              endIndex <- strideSet repeatCount writeIdx newVal
+              inner (readIdx + 2) endIndex 
+
+            else do
+              let iCode = fromIntegral code
+              endIndex <- strideCopy (readIdx + 1) iCode writeIdx
+              inner (readIdx + iCode + 1) endIndex
+
+instance Binary RadianceHeader where
+    get = decodeHeader
+    put hdr = do
+        putByteString radianceFileSignature
+        putByteString $ BC.pack "FORMAT="
+        put $ radianceFormat hdr
+        let sizeString =
+              BC.pack $ "\n\n-Y " ++ show (radianceHeight hdr)
+                        ++ " +X " ++ show (radianceWidth hdr) ++ "\n"
+        putByteString sizeString
+        putLazyByteString $ radianceData hdr
+
+
+decodeHeader :: Get RadianceHeader
+decodeHeader = do
+    sig <- getByteString $ B.length radianceFileSignature
+    when (sig /= radianceFileSignature)
+         (fail "Invalid radiance file signature")
+
+    infos <- decodeInfos
+    let formatKey = BC.pack "FORMAT"
+    case partition (\(k,_) -> k /= formatKey) infos of
+      (_, []) -> fail "No radiance format specified"
+      (info, [(_, formatString)]) ->
+        case runGet get $ L.fromChunks [formatString] of
+          Left err -> fail err
+          Right format -> do
+              (n1, n2, b) <- (,,) <$> decodeNum
+                                  <*> decodeNum
+                                  <*> getRemainingBytes
+              return . RadianceHeader info format n1 n2 $ L.fromChunks [b]
+
+      _ -> fail "Multiple radiance format specified"
+
+toFloat :: RGBE -> PixelRGBF
+toFloat (RGBE r g b e) = PixelRGBF rf gf bf
+  where f = encodeFloat 1 $ fromIntegral e - (128 + 8)
+        rf = (fromIntegral r + 0.0) * f
+        gf = (fromIntegral g + 0.0) * f
+        bf = (fromIntegral b + 0.0) * f
+
+encodeScanlineColor :: M.STVector s Word8
+                    -> M.STVector s Word8
+                    -> Int
+                    -> ST s Int
+encodeScanlineColor vec outVec outIdx = do
+    val <- vec `M.unsafeRead` 0
+    runLength 1 0 val 1 outIdx
+  where maxIndex = M.length vec
+
+        pushRun len val at = do
+            (outVec `M.unsafeWrite` at) $ fromIntegral $ len .|. 0x80
+            (outVec `M.unsafeWrite` (at + 1)) val
+            return $ at + 2
+
+        pushData start len at = do
+            (outVec `M.unsafeWrite` at) $ fromIntegral len
+            let first = start - len
+                end = start - 1
+                offset = at - first + 1
+            forM_ [first .. end] $ \i -> do
+                v <- vec `M.unsafeRead` i
+                (outVec `M.unsafeWrite` (offset + i)) v
+
+            return $ at + len + 1
+
+        -- End of scanline, empty the thing
+        runLength run cpy prev idx at | idx >= maxIndex =
+            case (run, cpy) of
+                (0, 0) -> pure at
+                (0, n) -> pushData idx n at
+                (n, 0) -> pushRun n prev at
+                (_, _) -> error "HDR - Run length algorithm is wrong"
+
+        -- full runlength, we must write the packet
+        runLength r@127   _ prev idx at = do
+            val <- vec `M.unsafeRead` idx
+            pushRun r prev at >>=
+                runLength 1 0 val (idx + 1)
+
+        -- full copy, we must write the packet
+        runLength   _ c@127    _ idx at = do
+            val <- vec `M.unsafeRead` idx
+            pushData idx c at >>=
+                runLength 1 0 val (idx + 1)
+
+        runLength n 0 prev idx at = do
+            val <- vec `M.unsafeRead` idx
+            case val == prev of
+               True -> runLength (n + 1) 0 prev (idx + 1) at
+               False | n < 4 -> runLength 0 (n + 1) val (idx + 1) at
+               False ->
+                    pushRun n prev at >>=
+                        runLength 1 0 val (idx + 1)
+
+        runLength 0 n prev idx at = do
+            val <- vec `M.unsafeRead` idx
+            if val /= prev
+               then runLength 0 (n + 1) val (idx + 1) at
+               else
+                pushData (idx - 1) (n - 1) at >>=
+                    runLength (2 :: Int) 0 val (idx + 1)
+
+        runLength _ _ _ _ _ =
+            error "HDR RLE inconsistent state"
+
+-- | Write an High dynamic range image into a radiance
+-- image file on disk.
+writeHDR :: FilePath -> Image PixelRGBF -> IO ()
+writeHDR filename img = L.writeFile filename $ encodeHDR img
+
+-- | Write a RLE encoded High dynamic range image into a radiance
+-- image file on disk.
+writeRLENewStyleHDR :: FilePath -> Image PixelRGBF -> IO ()
+writeRLENewStyleHDR filename img =
+    L.writeFile filename $ encodeRLENewStyleHDR img
+
+-- | Encode an High dynamic range image into a radiance image
+-- file format.
+-- Alias for encodeRawHDR
+encodeHDR :: Image PixelRGBF -> L.ByteString
+encodeHDR = encodeRawHDR
+
+-- | Encode an High dynamic range image into a radiance image
+-- file format. without compression
+encodeRawHDR :: Image PixelRGBF -> L.ByteString
+encodeRawHDR pic = encode descriptor
+  where
+    newImage = pixelMap rgbeInRgba pic
+    -- we are cheating to death here, the layout we want
+    -- correspond to the layout of pixelRGBA8, so we
+    -- convert
+    rgbeInRgba pixel = PixelRGBA8 r g b e
+      where RGBE r g b e = toRGBE pixel
+
+    descriptor = RadianceHeader
+        { radianceInfos = []
+        , radianceFormat = FormatRGBE
+        , radianceHeight = imageHeight pic
+        , radianceWidth  = imageWidth pic
+        , radianceData = L.fromChunks [toByteString $ imageData newImage]
+        }
+
+
+-- | Encode an High dynamic range image into a radiance image
+-- file format using a light RLE compression. Some problems
+-- seem to arise with some image viewer.
+encodeRLENewStyleHDR :: Image PixelRGBF -> L.ByteString
+encodeRLENewStyleHDR pic = encode $ runST $ do
+    let w = imageWidth pic
+        h = imageHeight pic
+
+    scanLineR <- M.new w :: ST s (M.STVector s Word8)
+    scanLineG <- M.new w
+    scanLineB <- M.new w
+    scanLineE <- M.new w
+
+    encoded <-
+        forM [0 .. h - 1] $ \line -> do
+            buff <- M.new $ w * 4 + w `div` 127 + 2
+            let columner col | col >= w = return ()
+                columner col = do
+                      let RGBE r g b e = toRGBE $ pixelAt pic col line
+                      (scanLineR `M.unsafeWrite` col) r
+                      (scanLineG `M.unsafeWrite` col) g
+                      (scanLineB `M.unsafeWrite` col) b
+                      (scanLineE `M.unsafeWrite` col) e
+
+                      columner (col + 1)
+
+            columner 0
+
+            (buff `M.unsafeWrite` 0) 2
+            (buff `M.unsafeWrite` 1) 2
+            (buff `M.unsafeWrite` 2) $ fromIntegral ((w .>>. 8) .&. 0xFF)
+            (buff `M.unsafeWrite` 3) $ fromIntegral (w .&. 0xFF)
+
+            i1 <- encodeScanlineColor scanLineR buff 4        
+            i2 <- encodeScanlineColor scanLineG buff i1
+            i3 <- encodeScanlineColor scanLineB buff i2
+            endIndex <- encodeScanlineColor scanLineE buff i3
+
+            (\v -> blitVector v 0 endIndex) <$> V.unsafeFreeze buff
+
+    pure RadianceHeader
+        { radianceInfos = []
+        , radianceFormat = FormatRGBE
+        , radianceHeight = h
+        , radianceWidth  = w
+        , radianceData = L.fromChunks encoded 
+        }
+    
+
+decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s PixelRGBF)
+decodeRadiancePicture hdr = do
+    let width = abs $ radianceWidth hdr
+        height = abs $ radianceHeight hdr
+        packedData = radianceData hdr
+
+    scanLine <- lift $ M.new $ width * 4
+    resultBuffer <- lift $ M.new $ width * height * 3
+
+    let scanLineImage = MutableImage
+                      { mutableImageWidth = width
+                      , mutableImageHeight = 1
+                      , mutableImageData = scanLine
+                      }
+
+        finalImage = MutableImage
+                   { mutableImageWidth = width
+                   , mutableImageHeight = height
+                   , mutableImageData = resultBuffer
+                   }
+
+    let scanLineExtractor readIdx line = do
+          let color = unpackColor packedData readIdx
+              inner | isNewRunLengthMarker color = do
+                          let calcSize = checkLineLength color
+                          when (calcSize /= width)
+                               (throwE "Invalid sanline size")
+                          pure $ \idx -> newStyleRLE packedData (idx + 4)
+                    | otherwise = pure $ oldStyleRLE packedData
+          f <- inner
+          newRead <- f readIdx scanLine
+          forM_ [0 .. width - 1] $ \i -> do
+              -- mokay, it's a hack, but I don't want to define a
+              -- pixel instance of RGBE...
+              PixelRGBA8 r g b e <- lift $ readPixel scanLineImage i 0
+              lift $ writePixel finalImage i line . toFloat $ RGBE r g b e
+
+          return newRead
+
+    foldM_ scanLineExtractor 0 [0 .. height - 1]
+
+    return finalImage
+
+ src/Codec/Picture/InternalHelper.hs view
@@ -0,0 +1,32 @@+{-# 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
+
+decode :: (Binary a) => B.ByteString -> Either String a
+decode = runGetStrict get
+
+runGet :: Get a -> L.ByteString -> Either String a
+runGet act = unpack . G.runGetOrFail act
+    where unpack (Left (_, _, str)) = Left str
+          unpack (Right (_, _, element)) = Right element
+
+runGetStrict :: Get a -> B.ByteString -> Either String a
+runGetStrict act buffer = runGet act $ L.fromChunks [buffer]
+
+getRemainingBytes :: Get B.ByteString
+getRemainingBytes = L.toStrict <$> getRemainingLazyByteString
+
+getRemainingLazyBytes :: Get L.ByteString
+getRemainingLazyBytes = getRemainingLazyByteString
+
+ src/Codec/Picture/Jpg.hs view
@@ -0,0 +1,1074 @@+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fspec-constr-count=5 #-}
+-- | Module used for JPEG file loading and writing.
+module Codec.Picture.Jpg( decodeJpeg
+                        , decodeJpegWithMetadata
+                        , encodeJpegAtQuality
+                        , encodeJpegAtQualityWithMetadata
+                        , encodeDirectJpegAtQualityWithMetadata
+                        , encodeJpeg
+                        , JpgEncodable
+                        ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Foldable( foldMap )
+import Data.Monoid( mempty )
+import Control.Applicative( pure, (<$>) )
+#endif
+
+import Control.Applicative( (<|>) )
+
+import Control.Arrow( (>>>) )
+import Control.Monad( when, forM_ )
+import Control.Monad.ST( ST, runST )
+import Control.Monad.Trans( lift )
+import Control.Monad.Trans.RWS.Strict( RWS, modify, tell, gets, execRWS )
+
+import Data.Bits( (.|.), unsafeShiftL )
+#if !MIN_VERSION_base(4,11,0)
+import Data.Monoid( (<>) )
+#endif
+import Data.Int( Int16, Int32 )
+import Data.Word(Word8, Word32)
+import Data.Binary( Binary(..), encode )
+import Data.STRef( newSTRef, writeSTRef, readSTRef )
+
+import Data.Vector( (//) )
+import Data.Vector.Unboxed( (!) )
+import qualified Data.Vector as V
+import qualified Data.Vector.Unboxed as VU
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector.Storable.Mutable as M
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+
+import Codec.Picture.InternalHelper
+import Codec.Picture.BitWriter
+import Codec.Picture.Types
+import Codec.Picture.Metadata( Metadatas
+                             , SourceFormat( SourceJpeg )
+                             , basicMetadata )
+import Codec.Picture.Tiff.Internal.Types
+import Codec.Picture.Tiff.Internal.Metadata
+import Codec.Picture.Jpg.Internal.Types
+import Codec.Picture.Jpg.Internal.Common
+import Codec.Picture.Jpg.Internal.Progressive
+import Codec.Picture.Jpg.Internal.DefaultTable
+import Codec.Picture.Jpg.Internal.FastDct
+import Codec.Picture.Jpg.Internal.Metadata
+
+quantize :: MacroBlock Int16 -> MutableMacroBlock s Int32
+         -> ST s (MutableMacroBlock s Int32)
+quantize table block = update 0
+  where update 64 = return block
+        update idx = do
+            val <- block `M.unsafeRead` idx
+            let q = fromIntegral (table `VS.unsafeIndex` idx)
+                finalValue = (val + (q `div` 2)) `quot` q -- rounded integer division
+            (block `M.unsafeWrite` idx) finalValue
+            update $ idx + 1
+
+
+powerOf :: Int32 -> Word32
+powerOf 0 = 0
+powerOf n = limit 1 0
+    where val = abs n
+          limit range i | val < range = i
+          limit range i = limit (2 * range) (i + 1)
+
+encodeInt :: BoolWriteStateRef s -> Word32 -> Int32 -> ST s ()
+{-# INLINE encodeInt #-}
+encodeInt st ssss n | n > 0 = writeBits' st (fromIntegral n) (fromIntegral ssss)
+encodeInt st ssss n         = writeBits' st (fromIntegral $ n - 1) (fromIntegral ssss)
+
+-- | Assume the macro block is initialized with zeroes
+acCoefficientsDecode :: HuffmanPackedTree -> MutableMacroBlock s Int16
+                     -> BoolReader s (MutableMacroBlock s Int16)
+acCoefficientsDecode acTree mutableBlock = parseAcCoefficient 1 >> return mutableBlock
+  where parseAcCoefficient n | n >= 64 = return ()
+                             | otherwise = do
+            rrrrssss <- decodeRrrrSsss acTree
+            case rrrrssss of
+                (  0, 0) -> return ()
+                (0xF, 0) -> parseAcCoefficient (n + 16)
+                (rrrr, ssss) -> do
+                    decoded <- fromIntegral <$> decodeInt ssss
+                    lift $ (mutableBlock `M.unsafeWrite` (n + rrrr)) decoded
+                    parseAcCoefficient (n + rrrr + 1)
+
+-- | Decompress a macroblock from a bitstream given the current configuration
+-- from the frame.
+decompressMacroBlock :: HuffmanPackedTree   -- ^ Tree used for DC coefficient
+                     -> HuffmanPackedTree   -- ^ Tree used for Ac coefficient
+                     -> MacroBlock Int16    -- ^ Current quantization table
+                     -> MutableMacroBlock s Int16    -- ^ A zigzag table, to avoid allocation
+                     -> DcCoefficient       -- ^ Previous dc value
+                     -> BoolReader s (DcCoefficient, MutableMacroBlock s Int16)
+decompressMacroBlock dcTree acTree quantizationTable zigzagBlock previousDc = do
+    dcDeltaCoefficient <- dcCoefficientDecode dcTree
+    block <- lift createEmptyMutableMacroBlock
+    let neoDcCoefficient = previousDc + dcDeltaCoefficient
+    lift $ (block `M.unsafeWrite` 0) neoDcCoefficient
+    fullBlock <- acCoefficientsDecode acTree block
+    decodedBlock <- lift $ decodeMacroBlock quantizationTable zigzagBlock fullBlock
+    return (neoDcCoefficient, decodedBlock)
+
+pixelClamp :: Int16 -> Word8
+pixelClamp n = fromIntegral . min 255 $ max 0 n
+
+unpack444Y :: Int -- ^ component index
+           -> Int -- ^ x
+           -> Int -- ^ y
+           -> MutableImage s PixelYCbCr8
+           -> MutableMacroBlock s Int16
+           -> ST s ()
+unpack444Y _ x y (MutableImage { mutableImageWidth = imgWidth, mutableImageData = img })
+                 block = blockVert baseIdx 0 zero
+  where zero = 0 :: Int
+        baseIdx = x * dctBlockSize + y * dctBlockSize * imgWidth
+
+        blockVert        _       _ j | j >= dctBlockSize = return ()
+        blockVert writeIdx readingIdx j = blockHoriz writeIdx readingIdx zero
+          where blockHoriz   _ readIdx i | i >= dctBlockSize = blockVert (writeIdx + imgWidth) readIdx $ j + 1
+                blockHoriz idx readIdx i = do
+                    val <- pixelClamp <$> (block `M.unsafeRead` readIdx)
+                    (img `M.unsafeWrite` idx) val
+                    blockHoriz (idx + 1) (readIdx + 1) $ i + 1
+
+unpack444Ycbcr :: Int -- ^ Component index
+              -> Int -- ^ x
+              -> Int -- ^ y
+              -> MutableImage s PixelYCbCr8
+              -> MutableMacroBlock s Int16
+              -> ST s ()
+unpack444Ycbcr compIdx x y
+                 (MutableImage { mutableImageWidth = imgWidth, mutableImageData = img })
+                 block = blockVert baseIdx 0 zero
+  where zero = 0 :: Int
+        baseIdx = (x * dctBlockSize + y * dctBlockSize * imgWidth) * 3 + compIdx
+
+        blockVert   _       _ j | j >= dctBlockSize = return ()
+        blockVert idx readIdx j = do
+            val0 <- pixelClamp <$> (block `M.unsafeRead` readIdx)
+            val1 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 1))
+            val2 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 2))
+            val3 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 3))
+            val4 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 4))
+            val5 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 5))
+            val6 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 6))
+            val7 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 7))
+
+            (img `M.unsafeWrite` idx) val0
+            (img `M.unsafeWrite` (idx +  3     )) val1
+            (img `M.unsafeWrite` (idx + (3 * 2))) val2
+            (img `M.unsafeWrite` (idx + (3 * 3))) val3
+            (img `M.unsafeWrite` (idx + (3 * 4))) val4
+            (img `M.unsafeWrite` (idx + (3 * 5))) val5
+            (img `M.unsafeWrite` (idx + (3 * 6))) val6
+            (img `M.unsafeWrite` (idx + (3 * 7))) val7
+
+            blockVert (idx + 3 * imgWidth) (readIdx + dctBlockSize) $ j + 1
+
+
+          {-where blockHoriz   _ readIdx i | i >= 8 = blockVert (writeIdx + imgWidth * 3) readIdx $ j + 1-}
+                {-blockHoriz idx readIdx i = do-}
+                    {-val <- pixelClamp <$> (block `M.unsafeRead` readIdx) -}
+                    {-(img `M.unsafeWrite` idx) val-}
+                    {-blockHoriz (idx + 3) (readIdx + 1) $ i + 1-}
+
+unpack421Ycbcr :: Int -- ^ Component index
+               -> Int -- ^ x
+               -> Int -- ^ y
+               -> MutableImage s PixelYCbCr8
+               -> MutableMacroBlock s Int16
+               -> ST s ()
+unpack421Ycbcr compIdx x y
+                 (MutableImage { mutableImageWidth = imgWidth,
+                                 mutableImageHeight = _, mutableImageData = img })
+                 block = blockVert baseIdx 0 zero
+  where zero = 0 :: Int
+        baseIdx = (x * dctBlockSize + y * dctBlockSize * imgWidth) * 3 + compIdx
+        lineOffset = imgWidth * 3
+
+        blockVert        _       _ j | j >= dctBlockSize = return ()
+        blockVert idx readIdx j = do
+            v0 <- pixelClamp <$> (block `M.unsafeRead` readIdx)
+            v1 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 1))
+            v2 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 2))
+            v3 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 3))
+            v4 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 4))
+            v5 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 5))
+            v6 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 6))
+            v7 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 7))
+
+            (img `M.unsafeWrite` idx)       v0
+            (img `M.unsafeWrite` (idx + 3)) v0
+
+            (img `M.unsafeWrite` (idx + 6    ))      v1
+            (img `M.unsafeWrite` (idx + 6     + 3))  v1
+
+            (img `M.unsafeWrite` (idx + 6 * 2))      v2
+            (img `M.unsafeWrite` (idx + 6 * 2 + 3))  v2
+
+            (img `M.unsafeWrite` (idx + 6 * 3))      v3
+            (img `M.unsafeWrite` (idx + 6 * 3 + 3))  v3
+
+            (img `M.unsafeWrite` (idx + 6 * 4))      v4
+            (img `M.unsafeWrite` (idx + 6 * 4 + 3))  v4
+
+            (img `M.unsafeWrite` (idx + 6 * 5))      v5
+            (img `M.unsafeWrite` (idx + 6 * 5 + 3))  v5
+
+            (img `M.unsafeWrite` (idx + 6 * 6))      v6
+            (img `M.unsafeWrite` (idx + 6 * 6 + 3))  v6
+
+            (img `M.unsafeWrite` (idx + 6 * 7))      v7
+            (img `M.unsafeWrite` (idx + 6 * 7 + 3))  v7
+
+            blockVert (idx + lineOffset) (readIdx + dctBlockSize) $ j + 1
+
+type Unpacker s = Int -- ^ component index
+               -> Int -- ^ x
+               -> Int -- ^ y
+               -> MutableImage s PixelYCbCr8
+               -> MutableMacroBlock s Int16
+               -> ST s ()
+
+type JpgScripter s a =
+    RWS () [([(JpgUnpackerParameter, Unpacker s)], L.ByteString)] JpgDecoderState a
+
+data JpgDecoderState = JpgDecoderState
+    { dcDecoderTables       :: !(V.Vector HuffmanPackedTree)
+    , acDecoderTables       :: !(V.Vector HuffmanPackedTree)
+    , quantizationMatrices  :: !(V.Vector (MacroBlock Int16))
+    , currentRestartInterv  :: !Int
+    , currentFrame          :: Maybe JpgFrameHeader
+    , app14Marker           :: !(Maybe JpgAdobeApp14)
+    , app0JFifMarker        :: !(Maybe JpgJFIFApp0)
+    , app1ExifMarker        :: !(Maybe [ImageFileDirectory])
+    , componentIndexMapping :: ![(Word8, Int)]
+    , isProgressive         :: !Bool
+    , maximumHorizontalResolution :: !Int
+    , maximumVerticalResolution   :: !Int
+    , seenBlobs                   :: !Int
+    }
+
+emptyDecoderState :: JpgDecoderState
+emptyDecoderState = JpgDecoderState
+    { dcDecoderTables =
+        let (_, dcLuma) = prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
+            (_, dcChroma) = prepareHuffmanTable DcComponent 1 defaultDcChromaHuffmanTable
+        in
+        V.fromList [ dcLuma, dcChroma, dcLuma, dcChroma ]
+
+    , acDecoderTables =
+        let (_, acLuma) = prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
+            (_, acChroma) = prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable
+        in
+        V.fromList [acLuma, acChroma, acLuma, acChroma]
+
+    , quantizationMatrices = V.replicate 4 (VS.replicate (8 * 8) 1)
+    , currentRestartInterv = -1
+    , currentFrame         = Nothing
+    , componentIndexMapping = []
+    , app14Marker = Nothing
+    , app0JFifMarker = Nothing
+    , app1ExifMarker = Nothing
+    , isProgressive        = False
+    , maximumHorizontalResolution = 0
+    , maximumVerticalResolution   = 0
+    , seenBlobs = 0
+    }
+
+-- | This pseudo interpreter interpret the Jpg frame for the huffman,
+-- quant table and restart interval parameters.
+jpgMachineStep :: JpgFrame -> JpgScripter s ()
+jpgMachineStep (JpgAdobeAPP14 app14) = modify $ \s ->
+    s { app14Marker = Just app14 }
+jpgMachineStep (JpgExif exif) = modify $ \s ->
+    s { app1ExifMarker = Just exif }
+jpgMachineStep (JpgJFIF app0) = modify $ \s ->
+    s { app0JFifMarker = Just app0 }
+jpgMachineStep (JpgAppFrame _ _) = pure ()
+jpgMachineStep (JpgExtension _ _) = pure ()
+jpgMachineStep (JpgScanBlob hdr raw_data) = do
+    let scanCount = length $ scans hdr
+    params <- concat <$> mapM (scanSpecifier scanCount) (scans hdr)
+
+    modify $ \st -> st { seenBlobs = seenBlobs st + 1 }
+    tell [(params, raw_data)  ]
+  where (selectionLow, selectionHigh) = spectralSelection hdr
+        approxHigh = fromIntegral $ successiveApproxHigh hdr
+        approxLow = fromIntegral $ successiveApproxLow hdr
+
+        
+        scanSpecifier scanCount scanSpec = do
+            compMapping <- gets componentIndexMapping
+            comp <- case lookup (componentSelector scanSpec) compMapping of
+                Nothing -> error "Jpg decoding error - bad component selector in blob."
+                Just v -> return v
+            let maximumHuffmanTable = 4
+                dcIndex = min (maximumHuffmanTable - 1) 
+                            . fromIntegral $ dcEntropyCodingTable scanSpec
+                acIndex = min (maximumHuffmanTable - 1)
+                            . fromIntegral $ acEntropyCodingTable scanSpec
+
+            dcTree <- gets $ (V.! dcIndex) . dcDecoderTables
+            acTree <- gets $ (V.! acIndex) . acDecoderTables
+            isProgressiveImage <- gets isProgressive
+            maxiW <- gets maximumHorizontalResolution 
+            maxiH <- gets maximumVerticalResolution
+            restart <- gets currentRestartInterv
+            frameInfo <- gets currentFrame
+            blobId <- gets seenBlobs                   
+            case frameInfo of
+              Nothing -> error "Jpg decoding error - no previous frame"
+              Just v -> do
+                 let compDesc = jpgComponents v !! comp
+                     compCount = length $ jpgComponents v
+                     xSampling = fromIntegral $ horizontalSamplingFactor compDesc
+                     ySampling = fromIntegral $ verticalSamplingFactor compDesc
+                     componentSubSampling =
+                        (maxiW - xSampling + 1, maxiH - ySampling + 1)
+                     (xCount, yCount)
+                        | scanCount > 1 || isProgressiveImage = (xSampling, ySampling)
+                        | otherwise = (1, 1)
+
+                 pure [ (JpgUnpackerParameter
+                         { dcHuffmanTree = dcTree
+                         , acHuffmanTree = acTree
+                         , componentIndex = comp
+                         , restartInterval = fromIntegral restart
+                         , componentWidth = xSampling
+                         , componentHeight = ySampling
+                         , subSampling = componentSubSampling
+                         , successiveApprox = (approxLow, approxHigh)
+                         , readerIndex = blobId
+                         , indiceVector =
+                             if scanCount == 1 then 0 else 1
+                         , coefficientRange =
+                             ( fromIntegral selectionLow
+                             , fromIntegral selectionHigh )
+                         , blockIndex = y * xSampling + x
+                         , blockMcuX = x
+                         , blockMcuY = y
+                         }, unpackerDecision compCount componentSubSampling)
+                             | y <- [0 .. yCount - 1]
+                             , x <- [0 .. xCount - 1] ]
+
+jpgMachineStep (JpgScans kind hdr) = modify $ \s ->
+   s { currentFrame = Just hdr
+     , componentIndexMapping =
+          [(componentIdentifier comp, ix) | (ix, comp) <- zip [0..] $ jpgComponents hdr]
+     , isProgressive = case kind of
+            JpgProgressiveDCTHuffman -> True
+            _ -> False
+     , maximumHorizontalResolution =
+         fromIntegral $ maximum horizontalResolutions
+     , maximumVerticalResolution =
+         fromIntegral $ maximum verticalResolutions
+     }
+    where components = jpgComponents hdr
+          horizontalResolutions = map horizontalSamplingFactor components
+          verticalResolutions = map verticalSamplingFactor components
+jpgMachineStep (JpgIntervalRestart restart) =
+    modify $ \s -> s { currentRestartInterv = fromIntegral restart }
+jpgMachineStep (JpgHuffmanTable tables) = mapM_ placeHuffmanTrees tables
+  where placeHuffmanTrees (spec, tree) = case huffmanTableClass spec of
+            DcComponent -> modify $ \s ->
+              if idx >= V.length (dcDecoderTables s) then s
+              else
+                let neu = dcDecoderTables s // [(idx, tree)] in 
+                s { dcDecoderTables = neu }
+                    where idx = fromIntegral $ huffmanTableDest spec
+                          
+            AcComponent -> modify $ \s ->
+              if idx >= V.length (acDecoderTables s) then s
+              else
+                s { acDecoderTables = acDecoderTables s // [(idx, tree)] }
+                    where idx = fromIntegral $ huffmanTableDest spec
+
+jpgMachineStep (JpgQuantTable tables) = mapM_ placeQuantizationTables tables
+  where placeQuantizationTables table = do
+            let idx = fromIntegral $ quantDestination table
+                tableData = quantTable table
+            modify $ \s ->
+                s { quantizationMatrices =  quantizationMatrices s // [(idx, tableData)] }
+
+unpackerDecision :: Int -> (Int, Int) -> Unpacker s
+unpackerDecision 1 (1, 1) = unpack444Y
+unpackerDecision 3 (1, 1) = unpack444Ycbcr
+unpackerDecision _ (2, 1) = unpack421Ycbcr
+unpackerDecision compCount (xScalingFactor, yScalingFactor) =
+    unpackMacroBlock compCount xScalingFactor yScalingFactor
+
+decodeImage :: JpgFrameHeader
+            -> V.Vector (MacroBlock Int16)
+            -> [([(JpgUnpackerParameter, Unpacker s)], L.ByteString)]
+            -> MutableImage s PixelYCbCr8 -- ^ Result image to write into
+            -> ST s (MutableImage s PixelYCbCr8)
+decodeImage frame quants lst outImage = do
+  let compCount = length $ jpgComponents frame
+  zigZagArray <- createEmptyMutableMacroBlock
+  dcArray <- M.replicate compCount 0  :: ST s (M.STVector s DcCoefficient)
+  resetCounter <- newSTRef restartIntervalValue
+
+  forM_ lst $ \(params, str) -> do
+    let componentsInfo = V.fromList params
+        compReader = initBoolStateJpg . B.concat $ L.toChunks str
+        maxiSubSampW = maximum [fst $ subSampling c | (c,_) <- params]
+        maxiSubSampH = maximum [snd $ subSampling c | (c,_) <- params]
+
+        (maxiW, maxiH) = 
+            if length params > 1 then
+                (maximum [componentWidth c | (c,_) <- params], 
+                    maximum [componentHeight c | (c,_) <- params])
+            else
+                (maxiSubSampW, maxiSubSampH)
+
+        imageBlockWidth = toBlockSize imgWidth
+        imageBlockHeight = toBlockSize imgHeight
+
+        imageMcuWidth = (imageBlockWidth + (maxiW - 1)) `div` maxiW
+        imageMcuHeight = (imageBlockHeight + (maxiH - 1)) `div` maxiH
+
+    execBoolReader compReader $ rasterMap imageMcuWidth imageMcuHeight $ \x y -> do
+      resetLeft <- lift $ readSTRef resetCounter
+      if resetLeft == 0 then do
+        lift $ M.set dcArray 0
+        byteAlignJpg
+        _restartCode <- decodeRestartInterval
+        lift $ resetCounter `writeSTRef` (restartIntervalValue - 1)
+      else
+        lift $ resetCounter `writeSTRef` (resetLeft - 1)
+
+      V.forM_ componentsInfo $ \(comp, unpack) -> do
+        let compIdx = componentIndex comp
+            dcTree = dcHuffmanTree comp
+            acTree = acHuffmanTree comp
+            quantId = fromIntegral .  quantizationTableDest
+                    $ jpgComponents frame !! compIdx
+            qTable = quants V.! min 3 quantId
+            xd = blockMcuX comp
+            yd = blockMcuY comp
+            (subX, subY) = subSampling comp
+        dc <- lift $ dcArray `M.unsafeRead` compIdx
+        (dcCoeff, block) <-
+              decompressMacroBlock dcTree acTree qTable zigZagArray $ fromIntegral dc
+        lift $ (dcArray `M.unsafeWrite` compIdx) dcCoeff
+        let verticalLimited = y == imageMcuHeight - 1
+        if (x == imageMcuWidth - 1) || verticalLimited then
+          lift $ unpackMacroBlock imgComponentCount
+                                  subX subY compIdx
+                                  (x * maxiW + xd) (y * maxiH + yd) outImage block
+        else
+          lift $ unpack compIdx (x * maxiW + xd) (y * maxiH + yd) outImage block
+
+  return outImage
+
+  where imgComponentCount = length $ jpgComponents frame
+
+        imgWidth = fromIntegral $ jpgWidth frame
+        imgHeight = fromIntegral $ jpgHeight frame
+        restartIntervalValue = case lst of
+                ((p,_):_,_): _ -> restartInterval p
+                _ -> -1
+
+gatherImageKind :: [JpgFrame] -> Maybe JpgImageKind
+gatherImageKind lst = case [k | JpgScans k _ <- lst, isDctSpecifier k] of
+    [JpgBaselineDCTHuffman] -> Just BaseLineDCT
+    [JpgProgressiveDCTHuffman] -> Just ProgressiveDCT
+    [JpgExtendedSequentialDCTHuffman] -> Just BaseLineDCT
+    _ -> Nothing
+  where isDctSpecifier JpgProgressiveDCTHuffman = True
+        isDctSpecifier JpgBaselineDCTHuffman = True
+        isDctSpecifier JpgExtendedSequentialDCTHuffman = True
+        isDctSpecifier _ = False
+
+gatherScanInfo :: JpgImage -> (JpgFrameKind, JpgFrameHeader)
+gatherScanInfo img = head [(a, b) | JpgScans a b <- jpgFrame img]
+
+dynamicOfColorSpace :: Maybe JpgColorSpace -> Int -> Int -> VS.Vector Word8
+                    -> Either String DynamicImage
+dynamicOfColorSpace Nothing _ _ _ = Left "Unknown color space"
+dynamicOfColorSpace (Just color) w h imgData = case color of
+  JpgColorSpaceCMYK -> return . ImageCMYK8 $ Image w h imgData
+  JpgColorSpaceYCCK ->
+     let ymg = Image w h $ VS.map (255-) imgData :: Image PixelYCbCrK8 in
+     return . ImageCMYK8 $ convertImage ymg
+  JpgColorSpaceYCbCr -> return . ImageYCbCr8 $ Image w h imgData
+  JpgColorSpaceRGB -> return . ImageRGB8 $ Image w h imgData
+  JpgColorSpaceYA -> return . ImageYA8 $ Image w h imgData
+  JpgColorSpaceY -> return . ImageY8 $ Image w h imgData
+  colorSpace -> Left $ "Wrong color space : " ++ show colorSpace
+
+colorSpaceOfAdobe :: Int -> JpgAdobeApp14 -> Maybe JpgColorSpace
+colorSpaceOfAdobe compCount app = case (compCount, _adobeTransform app) of
+  (3, AdobeYCbCr) -> pure JpgColorSpaceYCbCr
+  (1, AdobeUnknown) -> pure JpgColorSpaceY
+  (3, AdobeUnknown) -> pure JpgColorSpaceRGB
+  (4, AdobeYCck) -> pure JpgColorSpaceYCCK
+  {-(4, AdobeUnknown) -> pure JpgColorSpaceCMYKInverted-}
+  _ -> Nothing
+
+colorSpaceOfState :: JpgDecoderState -> Maybe JpgColorSpace
+colorSpaceOfState st = do
+  hdr <- currentFrame st
+  let compStr = [toEnum . fromEnum $ componentIdentifier comp
+                        | comp <- jpgComponents hdr]
+      app14 = do
+        marker <- app14Marker st
+        colorSpaceOfAdobe (length compStr) marker
+  app14 <|> colorSpaceOfComponentStr compStr
+
+
+colorSpaceOfComponentStr :: String -> Maybe JpgColorSpace
+colorSpaceOfComponentStr s = case s of
+  [_] -> pure  JpgColorSpaceY
+  [_,_] -> pure  JpgColorSpaceYA
+  "\0\1\2" -> pure  JpgColorSpaceYCbCr
+  "\1\2\3" -> pure  JpgColorSpaceYCbCr
+  "RGB" -> pure  JpgColorSpaceRGB
+  "YCc" -> pure  JpgColorSpaceYCC
+  [_,_,_] -> pure  JpgColorSpaceYCbCr
+
+  "RGBA" -> pure  JpgColorSpaceRGBA
+  "YCcA" -> pure  JpgColorSpaceYCCA
+  "CMYK" -> pure  JpgColorSpaceCMYK
+  "YCcK" -> pure  JpgColorSpaceYCCK
+  [_,_,_,_] -> pure  JpgColorSpaceCMYK
+  _ -> Nothing
+
+-- | Try to decompress and decode a jpeg file. The colorspace is still
+-- YCbCr if you want to perform computation on the luma part. You can convert it
+-- to RGB using 'convertImage' from the 'ColorSpaceConvertible' typeclass.
+--
+-- This function can output the following images:
+--
+--  * 'ImageY8'
+--
+--  * 'ImageYA8'
+--
+--  * 'ImageRGB8'
+--
+--  * 'ImageCMYK8'
+--
+--  * 'ImageYCbCr8'
+--
+decodeJpeg :: B.ByteString -> Either String DynamicImage
+decodeJpeg = fmap fst . decodeJpegWithMetadata
+
+-- | Equivalent to 'decodeJpeg' but also extracts metadatas.
+--
+-- Extract the following metadatas from the JFIF block:
+--
+--  * 'Codec.Picture.Metadata.DpiX'
+--  * 'Codec.Picture.Metadata.DpiY' 
+--
+-- Exif metadata are also extracted if present.
+--
+decodeJpegWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
+decodeJpegWithMetadata file = case runGetStrict get file of
+  Left err -> Left err
+  Right img -> case imgKind of
+     Just BaseLineDCT ->
+       let (st, arr) = decodeBaseline
+           jfifMeta = foldMap extractMetadatas $ app0JFifMarker st
+           exifMeta = foldMap extractTiffMetadata $ app1ExifMarker st
+           meta = jfifMeta <> exifMeta <> sizeMeta
+       in
+       (, meta) <$>
+           dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr
+     Just ProgressiveDCT ->
+       let (st, arr) = decodeProgressive
+           jfifMeta = foldMap extractMetadatas $ app0JFifMarker st
+           exifMeta = foldMap extractTiffMetadata $ app1ExifMarker st
+           meta = jfifMeta <> exifMeta <> sizeMeta
+       in
+       (, meta) <$>
+           dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr
+     _ -> Left "Unknown JPG kind"
+    where
+      compCount = length $ jpgComponents scanInfo
+      (_,scanInfo) = gatherScanInfo img
+
+      imgKind = gatherImageKind $ jpgFrame img
+      imgWidth = fromIntegral $ jpgWidth scanInfo
+      imgHeight = fromIntegral $ jpgHeight scanInfo
+
+      sizeMeta = basicMetadata SourceJpeg imgWidth imgHeight
+
+      imageSize = imgWidth * imgHeight * compCount
+
+
+      decodeProgressive = runST $ do
+        let (st, wrotten) =
+               execRWS (mapM_ jpgMachineStep (jpgFrame img)) () emptyDecoderState
+            Just fHdr = currentFrame st
+        fimg <-
+            progressiveUnpack
+                (maximumHorizontalResolution st, maximumVerticalResolution st)
+                fHdr
+                (quantizationMatrices st)
+                wrotten
+        frozen <- unsafeFreezeImage fimg
+        return (st, imageData frozen)
+
+
+      decodeBaseline = runST $ do
+        let (st, wrotten) =
+              execRWS (mapM_ jpgMachineStep (jpgFrame img)) () emptyDecoderState
+            Just fHdr = currentFrame st
+        resultImage <- M.new imageSize
+        let wrapped = MutableImage imgWidth imgHeight resultImage
+        fImg <- decodeImage 
+            fHdr
+            (quantizationMatrices st)
+            wrotten
+            wrapped
+        frozen <- unsafeFreezeImage fImg
+        return (st, imageData frozen)
+
+extractBlock :: forall s px. (PixelBaseComponent px ~ Word8)
+             => Image px       -- ^ Source image
+             -> MutableMacroBlock s Int16      -- ^ Mutable block where to put extracted block
+             -> Int                     -- ^ Plane
+             -> Int                     -- ^ X sampling factor
+             -> Int                     -- ^ Y sampling factor
+             -> Int                     -- ^ Sample per pixel
+             -> Int                     -- ^ Block x
+             -> Int                     -- ^ Block y
+             -> ST s (MutableMacroBlock s Int16)
+extractBlock (Image { imageWidth = w, imageHeight = h, imageData = src })
+             block 1 1 sampCount plane bx by | (bx * dctBlockSize) + 7 < w && (by * 8) + 7 < h = do
+    let baseReadIdx = (by * dctBlockSize * w) + bx * dctBlockSize
+    sequence_ [(block `M.unsafeWrite` (y * dctBlockSize + x)) val
+                        | y <- [0 .. dctBlockSize - 1]
+                        , let blockReadIdx = baseReadIdx + y * w
+                        , x <- [0 .. dctBlockSize - 1]
+                        , let val = fromIntegral $ src `VS.unsafeIndex` ((blockReadIdx + x) * sampCount + plane)
+                        ]
+    return block
+extractBlock (Image { imageWidth = w, imageHeight = h, imageData = src })
+             block sampWidth sampHeight sampCount plane bx by = do
+    let accessPixel x y | x < w && y < h = let idx = (y * w + x) * sampCount + plane in src `VS.unsafeIndex` idx
+                        | x >= w = accessPixel (w - 1) y
+                        | otherwise = accessPixel x (h - 1)
+
+        pixelPerCoeff = fromIntegral $ sampWidth * sampHeight
+
+        blockVal x y = sum [fromIntegral $ accessPixel (xBase + dx) (yBase + dy)
+                                | dy <- [0 .. sampHeight - 1]
+                                , dx <- [0 .. sampWidth - 1] ] `div` pixelPerCoeff
+            where xBase = blockXBegin + x * sampWidth
+                  yBase = blockYBegin + y * sampHeight
+
+        blockXBegin = bx * dctBlockSize * sampWidth
+        blockYBegin = by * dctBlockSize * sampHeight
+
+    sequence_ [(block `M.unsafeWrite` (y * dctBlockSize + x)) $ blockVal x y | y <- [0 .. 7], x <- [0 .. 7] ]
+    return block
+
+serializeMacroBlock :: BoolWriteStateRef s
+                    -> HuffmanWriterCode -> HuffmanWriterCode
+                    -> MutableMacroBlock s Int32
+                    -> ST s ()
+serializeMacroBlock !st !dcCode !acCode !blk =
+ (blk `M.unsafeRead` 0) >>= (fromIntegral >>> encodeDc) >> writeAcs (0, 1) >> return ()
+  where writeAcs acc@(_, 63) =
+            (blk `M.unsafeRead` 63) >>= (fromIntegral >>> encodeAcCoefs acc) >> return ()
+        writeAcs acc@(_, i ) =
+            (blk `M.unsafeRead`  i) >>= (fromIntegral >>> encodeAcCoefs acc) >>= writeAcs
+
+        encodeDc n = writeBits' st (fromIntegral code) (fromIntegral bitCount)
+                        >> when (ssss /= 0) (encodeInt st ssss n)
+            where ssss = powerOf $ fromIntegral n
+                  (bitCount, code) = dcCode `V.unsafeIndex` fromIntegral ssss
+
+        encodeAc 0         0 = writeBits' st (fromIntegral code) $ fromIntegral bitCount
+            where (bitCount, code) = acCode `V.unsafeIndex` 0
+
+        encodeAc zeroCount n | zeroCount >= 16 =
+          writeBits' st (fromIntegral code) (fromIntegral bitCount) >>  encodeAc (zeroCount - 16) n
+            where (bitCount, code) = acCode `V.unsafeIndex` 0xF0
+        encodeAc zeroCount n =
+          writeBits' st (fromIntegral code) (fromIntegral bitCount) >> encodeInt st ssss n
+            where rrrr = zeroCount `unsafeShiftL` 4
+                  ssss = powerOf $ fromIntegral n
+                  rrrrssss = rrrr .|. ssss
+                  (bitCount, code) = acCode `V.unsafeIndex` fromIntegral rrrrssss
+
+        encodeAcCoefs (            _, 63) 0 = encodeAc 0 0 >> return (0, 64)
+        encodeAcCoefs (zeroRunLength,  i) 0 = return (zeroRunLength + 1, i + 1)
+        encodeAcCoefs (zeroRunLength,  i) n =
+            encodeAc zeroRunLength n >> return (0, i + 1)
+
+encodeMacroBlock :: QuantificationTable
+                 -> MutableMacroBlock s Int32
+                 -> MutableMacroBlock s Int32
+                 -> Int16
+                 -> MutableMacroBlock s Int16
+                 -> ST s (Int32, MutableMacroBlock s Int32)
+encodeMacroBlock quantTableOfComponent workData finalData prev_dc block = do
+ -- the inverse level shift is performed internally by the fastDCT routine
+ blk <- fastDctLibJpeg workData block
+        >>= zigZagReorderForward finalData
+        >>= quantize quantTableOfComponent
+ dc <- blk `M.unsafeRead` 0
+ (blk `M.unsafeWrite` 0) $ dc - fromIntegral prev_dc
+ return (dc, blk)
+
+divUpward :: (Integral a) => a -> a -> a
+divUpward n dividor = val + (if rest /= 0 then 1 else 0)
+    where (val, rest) = n `divMod` dividor
+
+prepareHuffmanTable :: DctComponent -> Word8 -> HuffmanTable
+                    -> (JpgHuffmanTableSpec, HuffmanPackedTree)
+prepareHuffmanTable classVal dest tableDef =
+   (JpgHuffmanTableSpec { huffmanTableClass = classVal
+                        , huffmanTableDest  = dest
+                        , huffSizes = sizes
+                        , huffCodes = V.fromListN 16
+                            [VU.fromListN (fromIntegral $ sizes ! i) lst
+                                                | (i, lst) <- zip [0..] tableDef ]
+                        }, VS.singleton 0)
+      where sizes = VU.fromListN 16 $ map (fromIntegral . length) tableDef
+
+-- | Encode an image in jpeg at a reasonnable quality level.
+-- If you want better quality or reduced file size, you should
+-- use `encodeJpegAtQuality`
+encodeJpeg :: Image PixelYCbCr8 -> L.ByteString
+encodeJpeg = encodeJpegAtQuality 50
+
+defaultHuffmanTables :: [(JpgHuffmanTableSpec, HuffmanPackedTree)]
+defaultHuffmanTables =
+    [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
+    , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
+    , prepareHuffmanTable DcComponent 1 defaultDcChromaHuffmanTable
+    , prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable
+    ]
+
+lumaQuantTableAtQuality :: Int -> QuantificationTable 
+lumaQuantTableAtQuality qual = scaleQuantisationMatrix qual defaultLumaQuantizationTable
+
+chromaQuantTableAtQuality :: Int -> QuantificationTable
+chromaQuantTableAtQuality qual =
+  scaleQuantisationMatrix qual defaultChromaQuantizationTable
+
+zigzaggedQuantificationSpec :: Int -> [JpgQuantTableSpec]
+zigzaggedQuantificationSpec qual =
+  [ JpgQuantTableSpec { quantPrecision = 0, quantDestination = 0, quantTable = luma }
+  , JpgQuantTableSpec { quantPrecision = 0, quantDestination = 1, quantTable = chroma }
+  ]
+  where
+    luma = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
+    chroma = zigZagReorderForwardv $ chromaQuantTableAtQuality qual
+
+-- | Function to call to encode an image to jpeg.
+-- The quality factor should be between 0 and 100 (100 being
+-- the best quality).
+encodeJpegAtQuality :: Word8                -- ^ Quality factor
+                    -> Image PixelYCbCr8    -- ^ Image to encode
+                    -> L.ByteString         -- ^ Encoded JPEG
+encodeJpegAtQuality quality = encodeJpegAtQualityWithMetadata quality mempty
+
+-- | Record gathering all information to encode a component
+-- from the source image. Previously was a huge tuple
+-- burried in the code
+data EncoderState = EncoderState
+  { _encComponentIndex :: !Int
+  , _encBlockWidth     :: !Int
+  , _encBlockHeight    :: !Int
+  , _encQuantTable     :: !QuantificationTable
+  , _encDcHuffman      :: !HuffmanWriterCode
+  , _encAcHuffman      :: !HuffmanWriterCode
+  }
+
+
+-- | Helper type class describing all JPG-encodable pixel types
+class (Pixel px, PixelBaseComponent px ~ Word8) => JpgEncodable px where
+  additionalBlocks :: Image px -> [JpgFrame]
+  additionalBlocks _ = []
+
+  componentsOfColorSpace :: Image px -> [JpgComponent]
+
+  encodingState :: Int -> Image px -> V.Vector EncoderState
+
+  imageHuffmanTables :: Image px -> [(JpgHuffmanTableSpec, HuffmanPackedTree)]
+  imageHuffmanTables _ = defaultHuffmanTables 
+
+  scanSpecificationOfColorSpace :: Image px -> [JpgScanSpecification]
+
+  quantTableSpec :: Image px -> Int -> [JpgQuantTableSpec]
+  quantTableSpec _ qual = take 1 $ zigzaggedQuantificationSpec qual
+
+  maximumSubSamplingOf :: Image px -> Int
+  maximumSubSamplingOf _ = 1
+
+instance JpgEncodable Pixel8 where
+  scanSpecificationOfColorSpace _ =
+    [ JpgScanSpecification { componentSelector = 1
+                           , dcEntropyCodingTable = 0
+                           , acEntropyCodingTable = 0
+                           }
+    ]
+
+  componentsOfColorSpace _ =
+    [ JpgComponent { componentIdentifier      = 1
+                   , horizontalSamplingFactor = 1
+                   , verticalSamplingFactor   = 1
+                   , quantizationTableDest    = 0
+                   }
+    ]
+
+  imageHuffmanTables _ =
+    [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
+    , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
+    ]
+
+  encodingState qual _ = V.singleton EncoderState
+     { _encComponentIndex = 0
+     , _encBlockWidth     = 1
+     , _encBlockHeight    = 1
+     , _encQuantTable     = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
+     , _encDcHuffman      = makeInverseTable defaultDcLumaHuffmanTree
+     , _encAcHuffman      = makeInverseTable defaultAcLumaHuffmanTree
+     }
+
+
+instance JpgEncodable PixelYCbCr8 where
+  maximumSubSamplingOf _ = 2
+  quantTableSpec _ qual = zigzaggedQuantificationSpec qual
+  scanSpecificationOfColorSpace _ =
+    [ JpgScanSpecification { componentSelector = 1
+                           , dcEntropyCodingTable = 0
+                           , acEntropyCodingTable = 0
+                           }
+    , JpgScanSpecification { componentSelector = 2
+                           , dcEntropyCodingTable = 1
+                           , acEntropyCodingTable = 1
+                           }
+    , JpgScanSpecification { componentSelector = 3
+                           , dcEntropyCodingTable = 1
+                           , acEntropyCodingTable = 1
+                           }
+    ]
+
+  componentsOfColorSpace _ =
+    [ JpgComponent { componentIdentifier      = 1
+                   , horizontalSamplingFactor = 2
+                   , verticalSamplingFactor   = 2
+                   , quantizationTableDest    = 0
+                   }
+    , JpgComponent { componentIdentifier      = 2
+                   , horizontalSamplingFactor = 1
+                   , verticalSamplingFactor   = 1
+                   , quantizationTableDest    = 1
+                   }
+    , JpgComponent { componentIdentifier      = 3
+                   , horizontalSamplingFactor = 1
+                   , verticalSamplingFactor   = 1
+                   , quantizationTableDest    = 1
+                   }
+    ]
+  
+  encodingState qual _ = V.fromListN 3 [lumaState, chromaState, chromaState { _encComponentIndex = 2 }]
+    where
+      lumaState = EncoderState
+        { _encComponentIndex = 0
+        , _encBlockWidth     = 2
+        , _encBlockHeight    = 2
+        , _encQuantTable     = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
+        , _encDcHuffman      = makeInverseTable defaultDcLumaHuffmanTree
+        , _encAcHuffman      = makeInverseTable defaultAcLumaHuffmanTree
+        }
+      chromaState = EncoderState
+        { _encComponentIndex = 1
+        , _encBlockWidth     = 1
+        , _encBlockHeight    = 1
+        , _encQuantTable     = zigZagReorderForwardv $ chromaQuantTableAtQuality qual
+        , _encDcHuffman      = makeInverseTable defaultDcChromaHuffmanTree
+        , _encAcHuffman      = makeInverseTable defaultAcChromaHuffmanTree
+        }
+
+instance JpgEncodable PixelRGB8 where
+  additionalBlocks _ = [JpgAdobeAPP14 adobe14] where
+    adobe14 = JpgAdobeApp14
+        { _adobeDctVersion = 100
+        , _adobeFlag0      = 0
+        , _adobeFlag1      = 0
+        , _adobeTransform  = AdobeUnknown
+        }
+
+  imageHuffmanTables _ =
+    [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
+    , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
+    ]
+
+  scanSpecificationOfColorSpace _ = fmap build "RGB" where
+    build c = JpgScanSpecification
+      { componentSelector = fromIntegral $ fromEnum c
+      , dcEntropyCodingTable = 0
+      , acEntropyCodingTable = 0
+      }
+
+  componentsOfColorSpace _ = fmap build "RGB" where
+    build c = JpgComponent
+      { componentIdentifier      = fromIntegral $ fromEnum c
+      , horizontalSamplingFactor = 1
+      , verticalSamplingFactor   = 1
+      , quantizationTableDest    = 0
+      }
+
+  encodingState qual _ = V.fromListN 3 $ fmap build [0 .. 2] where
+    build ix = EncoderState
+      { _encComponentIndex = ix
+      , _encBlockWidth     = 1
+      , _encBlockHeight    = 1
+      , _encQuantTable     = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
+      , _encDcHuffman      = makeInverseTable defaultDcLumaHuffmanTree
+      , _encAcHuffman      = makeInverseTable defaultAcLumaHuffmanTree
+      }
+
+instance JpgEncodable PixelCMYK8 where
+  additionalBlocks _ = [] where
+    _adobe14 = JpgAdobeApp14
+        { _adobeDctVersion = 100
+        , _adobeFlag0      = 32768
+        , _adobeFlag1      = 0
+        , _adobeTransform  = AdobeYCck
+        }
+    
+  imageHuffmanTables _ =
+    [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
+    , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
+    ]
+
+  scanSpecificationOfColorSpace _ = fmap build "CMYK" where
+    build c = JpgScanSpecification
+      { componentSelector = fromIntegral $ fromEnum c
+      , dcEntropyCodingTable = 0
+      , acEntropyCodingTable = 0
+      }
+
+  componentsOfColorSpace _ = fmap build "CMYK" where
+    build c = JpgComponent
+      { componentIdentifier      = fromIntegral $ fromEnum c
+      , horizontalSamplingFactor = 1
+      , verticalSamplingFactor   = 1
+      , quantizationTableDest    = 0
+      }
+
+  encodingState qual _ = V.fromListN 4 $ fmap build [0 .. 3] where
+    build ix = EncoderState
+      { _encComponentIndex = ix
+      , _encBlockWidth     = 1
+      , _encBlockHeight    = 1
+      , _encQuantTable     = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
+      , _encDcHuffman      = makeInverseTable defaultDcLumaHuffmanTree
+      , _encAcHuffman      = makeInverseTable defaultAcLumaHuffmanTree
+      }
+
+-- | Equivalent to 'encodeJpegAtQuality', but will store the following
+-- metadatas in the file using a JFIF block:
+--
+--  * 'Codec.Picture.Metadata.DpiX'
+--  * 'Codec.Picture.Metadata.DpiY' 
+--
+encodeJpegAtQualityWithMetadata :: Word8                -- ^ Quality factor
+                                -> Metadatas
+                                -> Image PixelYCbCr8    -- ^ Image to encode
+                                -> L.ByteString         -- ^ Encoded JPEG
+encodeJpegAtQualityWithMetadata = encodeDirectJpegAtQualityWithMetadata
+
+-- | Equivalent to 'encodeJpegAtQuality', but will store the following
+-- metadatas in the file using a JFIF block:
+--
+--  * 'Codec.Picture.Metadata.DpiX'
+--  * 'Codec.Picture.Metadata.DpiY' 
+--
+-- This function also allow to create JPEG files with the following color
+-- space:
+--
+--  * Y ('Pixel8') for greyscale.
+--  * RGB ('PixelRGB8') with no color downsampling on any plane
+--  * CMYK ('PixelCMYK8') with no color downsampling on any plane
+--
+encodeDirectJpegAtQualityWithMetadata :: forall px. (JpgEncodable px)
+                                      => Word8                -- ^ Quality factor
+                                      -> Metadatas
+                                      -> Image px             -- ^ Image to encode
+                                      -> L.ByteString         -- ^ Encoded JPEG
+encodeDirectJpegAtQualityWithMetadata quality metas img = encode finalImage where
+  !w = imageWidth img
+  !h = imageHeight img
+  !exifMeta = case encodeTiffStringMetadata metas of
+     [] -> []
+     lst -> [JpgExif lst]
+  finalImage = JpgImage $
+      encodeMetadatas metas ++
+      exifMeta ++
+      additionalBlocks img ++
+      [ JpgQuantTable $ quantTableSpec img (fromIntegral quality)
+      , JpgScans JpgBaselineDCTHuffman hdr
+      , JpgHuffmanTable $ imageHuffmanTables img
+      , JpgScanBlob scanHeader encodedImage
+      ]
+
+  !outputComponentCount = componentCount (undefined :: px)
+
+  scanHeader = scanHeader'{ scanLength = fromIntegral $ calculateSize scanHeader' }
+  scanHeader' = JpgScanHeader
+      { scanLength = 0
+      , scanComponentCount = fromIntegral outputComponentCount
+      , scans = scanSpecificationOfColorSpace img
+      , spectralSelection = (0, 63)
+      , successiveApproxHigh = 0
+      , successiveApproxLow  = 0
+      }
+
+  hdr = hdr' { jpgFrameHeaderLength   = fromIntegral $ calculateSize hdr' }
+  hdr' = JpgFrameHeader
+    { jpgFrameHeaderLength   = 0
+    , jpgSamplePrecision     = 8
+    , jpgHeight              = fromIntegral h
+    , jpgWidth               = fromIntegral w
+    , jpgImageComponentCount = fromIntegral outputComponentCount
+    , jpgComponents          = componentsOfColorSpace img
+    }
+
+  !maxSampling = maximumSubSamplingOf img
+  !horizontalMetaBlockCount = w `divUpward` (dctBlockSize * maxSampling)
+  !verticalMetaBlockCount = h `divUpward` (dctBlockSize * maxSampling)
+  !componentDef = encodingState (fromIntegral quality) img
+
+  encodedImage = runST $ do
+    dc_table <- M.replicate outputComponentCount 0
+    block <- createEmptyMutableMacroBlock
+    workData <- createEmptyMutableMacroBlock
+    zigzaged <- createEmptyMutableMacroBlock
+    writeState <- newWriteStateRef
+
+    rasterMap horizontalMetaBlockCount verticalMetaBlockCount $ \mx my ->
+      V.forM_ componentDef $ \(EncoderState comp sizeX sizeY table dc ac) -> 
+        let !xSamplingFactor = maxSampling - sizeX + 1
+            !ySamplingFactor = maxSampling - sizeY + 1
+            !extractor = extractBlock img block xSamplingFactor ySamplingFactor outputComponentCount
+        in
+        rasterMap sizeX sizeY $ \subX subY -> do
+          let !blockY = my * sizeY + subY
+              !blockX = mx * sizeX + subX
+          prev_dc <- dc_table `M.unsafeRead` comp
+          extracted <- extractor comp blockX blockY
+          (dc_coeff, neo_block) <- encodeMacroBlock table workData zigzaged prev_dc extracted
+          (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff
+          serializeMacroBlock writeState dc ac neo_block
+
+    finalizeBoolWriter writeState
+
+ src/Codec/Picture/Jpg/Internal/Common.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE CPP #-}
+module Codec.Picture.Jpg.Internal.Common
+    ( DctCoefficients
+    , JpgUnpackerParameter( .. )
+    , decodeInt
+    , dcCoefficientDecode
+    , deQuantize
+    , decodeRrrrSsss
+    , zigZagReorderForward 
+    , zigZagReorderForwardv
+    , zigZagReorder
+    , inverseDirectCosineTransform
+    , unpackInt
+    , unpackMacroBlock
+    , rasterMap
+    , decodeMacroBlock
+    , decodeRestartInterval
+    , toBlockSize
+    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( pure, (<$>) )
+#endif
+
+import Control.Monad( when )
+import Control.Monad.ST( ST, runST )
+import Data.Bits( unsafeShiftL, unsafeShiftR, (.&.) )
+import Data.Int( Int16, Int32 )
+import Data.Maybe( fromMaybe )
+import Data.Word( Word8 )
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector.Storable.Mutable as M
+import Foreign.Storable ( Storable )
+
+import Codec.Picture.Types
+import Codec.Picture.BitWriter
+import Codec.Picture.Jpg.Internal.Types
+import Codec.Picture.Jpg.Internal.FastIdct
+import Codec.Picture.Jpg.Internal.DefaultTable
+
+-- | Same as for DcCoefficient, to provide nicer type signatures
+type DctCoefficients = DcCoefficient
+
+data JpgUnpackerParameter = JpgUnpackerParameter
+    { dcHuffmanTree        :: !HuffmanPackedTree
+    , acHuffmanTree        :: !HuffmanPackedTree
+    , componentIndex       :: {-# UNPACK #-} !Int
+    , restartInterval      :: {-# UNPACK #-} !Int
+    , componentWidth       :: {-# UNPACK #-} !Int
+    , componentHeight      :: {-# UNPACK #-} !Int
+    , subSampling          :: !(Int, Int)
+    , coefficientRange     :: !(Int, Int)
+    , successiveApprox     :: !(Int, Int)
+    , readerIndex          :: {-# UNPACK #-} !Int
+      -- | When in progressive mode, we can have many
+      -- color in a scan or 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
+    , blockMcuY            :: {-# UNPACK #-} !Int
+    }
+    deriving Show
+
+toBlockSize :: Int -> Int
+toBlockSize v = (v + 7) `div` 8
+
+decodeRestartInterval :: BoolReader s Int32
+decodeRestartInterval = return (-1) {-  do
+  bits <- replicateM 8 getNextBitJpg
+  if bits == replicate 8 True
+     then do
+         marker <- replicateM 8 getNextBitJpg
+         return $ packInt marker
+     else return (-1)
+        -}
+
+{-# INLINE decodeInt #-}
+decodeInt :: Int -> BoolReader s Int32
+decodeInt ssss = do
+    signBit <- getNextBitJpg
+    let dataRange = 1 `unsafeShiftL` fromIntegral (ssss - 1)
+        leftBitCount = ssss - 1
+    -- First following bits store the sign of the coefficient, and counted in
+    -- SSSS, so the bit count for the int, is ssss - 1
+    if signBit
+       then (\w -> dataRange + fromIntegral w) <$> unpackInt leftBitCount
+       else (\w -> 1 - dataRange * 2 + fromIntegral w) <$> unpackInt leftBitCount
+
+decodeRrrrSsss :: HuffmanPackedTree -> BoolReader s (Int, Int)
+decodeRrrrSsss tree = do
+    rrrrssss <- huffmanPackedDecode tree
+    let rrrr = (rrrrssss `unsafeShiftR` 4) .&. 0xF
+        ssss =  rrrrssss .&. 0xF
+    pure (fromIntegral rrrr, fromIntegral ssss)
+
+dcCoefficientDecode :: HuffmanPackedTree -> BoolReader s DcCoefficient
+dcCoefficientDecode dcTree = do
+    ssss <- huffmanPackedDecode dcTree
+    if ssss == 0
+       then return 0
+       else fromIntegral <$> decodeInt (fromIntegral ssss)
+
+-- | Apply a quantization matrix to a macroblock
+{-# INLINE deQuantize #-}
+deQuantize :: MacroBlock Int16 -> MutableMacroBlock s Int16
+           -> ST s (MutableMacroBlock s Int16)
+deQuantize table block = update 0
+    where update 64 = return block
+          update i = do
+              val <- block `M.unsafeRead` i
+              let finalValue = val * (table `VS.unsafeIndex` i)
+              (block `M.unsafeWrite` i) finalValue
+              update $ i + 1
+
+inverseDirectCosineTransform :: MutableMacroBlock s Int16
+                             -> ST s (MutableMacroBlock s Int16)
+inverseDirectCosineTransform mBlock =
+    fastIdct mBlock >>= mutableLevelShift
+
+zigZagOrder :: MacroBlock Int
+zigZagOrder = makeMacroBlock $ concat
+    [[ 0, 1, 5, 6,14,15,27,28]
+    ,[ 2, 4, 7,13,16,26,29,42]
+    ,[ 3, 8,12,17,25,30,41,43]
+    ,[ 9,11,18,24,31,40,44,53]
+    ,[10,19,23,32,39,45,52,54]
+    ,[20,22,33,38,46,51,55,60]
+    ,[21,34,37,47,50,56,59,61]
+    ,[35,36,48,49,57,58,62,63]
+    ]
+
+zigZagReorderForwardv :: (Storable a, Num a) => VS.Vector a -> VS.Vector a
+zigZagReorderForwardv vec = runST $ do
+    v <- M.new 64
+    mv <- VS.thaw vec
+    zigZagReorderForward v mv >>= VS.freeze
+
+zigZagOrderForward :: MacroBlock Int
+zigZagOrderForward = VS.generate 64 inv
+  where inv i = fromMaybe 0 $ VS.findIndex (i ==) zigZagOrder
+
+zigZagReorderForward :: (Storable a)
+                     => MutableMacroBlock s a
+                     -> MutableMacroBlock s a
+                     -> ST s (MutableMacroBlock s a)
+{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int32
+                                           -> MutableMacroBlock s Int32
+                                           -> ST s (MutableMacroBlock s Int32) #-}
+{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int16
+                                           -> MutableMacroBlock s Int16
+                                           -> ST s (MutableMacroBlock s Int16) #-}
+{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Word8
+                                           -> MutableMacroBlock s Word8
+                                           -> ST s (MutableMacroBlock s Word8) #-}
+zigZagReorderForward zigzaged block = ordering zigZagOrderForward >> return zigzaged
+  where ordering !table = reorder (0 :: Int)
+          where reorder !i | i >= 64 = return ()
+                reorder i  = do
+                     let idx = table `VS.unsafeIndex` i
+                     v <- block `M.unsafeRead` idx
+                     (zigzaged `M.unsafeWrite` i) v
+                     reorder (i + 1)
+
+zigZagReorder :: MutableMacroBlock s Int16 -> MutableMacroBlock s Int16
+              -> ST s (MutableMacroBlock s Int16)
+zigZagReorder zigzaged block = do
+    let update i =  do
+            let idx = zigZagOrder `VS.unsafeIndex` i
+            v <- block `M.unsafeRead` idx
+            (zigzaged `M.unsafeWrite` i) v
+
+        reorder 63 = update 63
+        reorder i  = update i >> reorder (i + 1)
+
+    reorder (0 :: Int)
+    return zigzaged
+
+-- | Unpack an int of the given size encoded from MSB to LSB.
+unpackInt :: Int -> BoolReader s Int32
+unpackInt = getNextIntJpg
+
+{-# INLINE rasterMap #-}
+rasterMap :: (Monad m)
+          => Int -> Int -> (Int -> Int -> m ())
+          -> m ()
+rasterMap width height f = liner 0
+  where liner y | y >= height = return ()
+        liner y = columner 0
+          where columner x | x >= width = liner (y + 1)
+                columner x = f x y >> columner (x + 1)
+
+pixelClamp :: Int16 -> Word8
+pixelClamp n = fromIntegral . min 255 $ max 0 n
+
+-- | Given a size coefficient (how much a pixel span horizontally
+-- and vertically), the position of the macroblock, return a list
+-- of indices and value to be stored in an array (like the final
+-- image)
+unpackMacroBlock :: Int    -- ^ Component count
+                 -> Int -- ^ Width coefficient
+                 -> Int -- ^ Height coefficient
+                 -> Int -- ^ Component index
+                 -> Int -- ^ x
+                 -> Int -- ^ y
+                 -> MutableImage s PixelYCbCr8
+                 -> MutableMacroBlock s Int16
+                 -> ST s ()
+unpackMacroBlock compCount wCoeff hCoeff compIdx x y
+                 (MutableImage { mutableImageWidth = imgWidth,
+                                 mutableImageHeight = imgHeight, mutableImageData = img })
+                 block = rasterMap dctBlockSize dctBlockSize unpacker
+  where unpacker i j = do
+          let yBase = y * dctBlockSize + j * hCoeff
+          compVal <- pixelClamp <$> (block `M.unsafeRead` (i + j * dctBlockSize))
+          rasterMap wCoeff hCoeff $ \wDup hDup -> do
+             let xBase = x * dctBlockSize + i * wCoeff
+                 xPos = xBase + wDup
+                 yPos = yBase + hDup
+
+             when (xPos < imgWidth && yPos < imgHeight)
+                  (do let mutableIdx = (xPos + yPos * imgWidth) * compCount + compIdx
+                      (img `M.unsafeWrite` mutableIdx) compVal)
+
+-- | This is one of the most important function of the decoding,
+-- it form the barebone decoding pipeline for macroblock. It's all
+-- there is to know for macro block transformation
+decodeMacroBlock :: MacroBlock DctCoefficients
+                 -> MutableMacroBlock s Int16
+                 -> MutableMacroBlock s Int16
+                 -> ST s (MutableMacroBlock s Int16)
+decodeMacroBlock quantizationTable zigZagBlock block =
+    deQuantize quantizationTable block >>= zigZagReorder zigZagBlock
+                                       >>= inverseDirectCosineTransform
+
+ src/Codec/Picture/Jpg/Internal/DefaultTable.hs view
@@ -0,0 +1,298 @@+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
+-- | Module used by the jpeg decoder internally, shouldn't be used
+-- in user code.
+module Codec.Picture.Jpg.Internal.DefaultTable( DctComponent( .. )
+                                     , HuffmanTree( .. )
+                                     , HuffmanTable
+                                     , HuffmanPackedTree
+                                     , MacroBlock
+                                     , QuantificationTable
+                                     , HuffmanWriterCode 
+                                     , scaleQuantisationMatrix
+                                     , makeMacroBlock
+                                     , makeInverseTable
+                                     , buildHuffmanTree
+                                     , packHuffmanTree
+                                     , huffmanPackedDecode
+
+                                     , defaultChromaQuantizationTable
+
+                                     , defaultLumaQuantizationTable
+
+                                     , defaultAcChromaHuffmanTree
+                                     , defaultAcChromaHuffmanTable
+
+                                     , defaultAcLumaHuffmanTree 
+                                     , defaultAcLumaHuffmanTable 
+
+                                     , defaultDcChromaHuffmanTree 
+                                     , defaultDcChromaHuffmanTable
+
+                                     , defaultDcLumaHuffmanTree
+                                     , defaultDcLumaHuffmanTable
+                                     ) where
+
+import Control.DeepSeq( NFData(..) )
+import Data.Int( Int16 )
+import Foreign.Storable ( Storable )
+import Control.Monad.ST( runST )
+import qualified Data.Vector.Storable as SV
+import qualified Data.Vector as V
+import Data.Bits( unsafeShiftL, (.|.), (.&.) )
+import Data.Word( Word8, Word16 )
+import Data.List( foldl' )
+import qualified Data.Vector.Storable.Mutable as M
+import GHC.Generics( Generic )
+
+import Codec.Picture.BitWriter
+
+-- | Tree storing the code used for huffman encoding.
+data HuffmanTree = Branch HuffmanTree HuffmanTree -- ^ If bit is 0 take the first subtree, if 1, the right.
+                 | Leaf Word8       -- ^ We should output the value
+                 | Empty            -- ^ no value present
+                 deriving (Eq, Show)
+
+type HuffmanPackedTree = SV.Vector Word16
+
+type HuffmanWriterCode = V.Vector (Word8, Word16)
+
+packHuffmanTree :: HuffmanTree -> HuffmanPackedTree
+packHuffmanTree tree = runST $ do
+    table <- M.replicate 512 0x8000
+    let aux (Empty) idx = return $ idx + 1
+        aux (Leaf v) idx = do
+            (table `M.unsafeWrite` idx) $ fromIntegral v .|. 0x4000
+            return $ idx + 1
+
+        aux (Branch i1@(Leaf _) i2@(Leaf _)) idx =
+            aux i1 idx >>= aux i2
+
+        aux (Branch i1@(Leaf _) i2) idx = do
+            _ <- aux i1 idx
+            ix2 <- aux i2 $ idx + 2
+            (table `M.unsafeWrite` (idx + 1)) $ fromIntegral $ idx + 2
+            return ix2
+
+        aux (Branch i1 i2@(Leaf _)) idx = do
+            ix1 <- aux i1 (idx + 2)
+            _ <- aux i2 (idx + 1)
+            (table `M.unsafeWrite` idx) . fromIntegral $ idx + 2
+            return ix1
+
+        aux (Branch i1 i2) idx = do
+            ix1 <- aux i1 (idx + 2)
+            ix2 <- aux i2 ix1
+            (table `M.unsafeWrite` idx) (fromIntegral $ idx + 2)
+            (table `M.unsafeWrite` (idx + 1)) (fromIntegral ix1)
+            return ix2
+    _ <- aux tree 0
+    SV.unsafeFreeze table
+
+makeInverseTable :: HuffmanTree -> HuffmanWriterCode
+makeInverseTable t = V.replicate 255 (0,0) V.// inner 0 0 t
+  where inner _     _     Empty   = []
+        inner depth code (Leaf v) = [(fromIntegral v, (depth, code))]
+        inner depth code (Branch l r) =
+          inner (depth + 1) shifted l ++ inner (depth + 1) (shifted .|. 1) r
+            where shifted = code `unsafeShiftL` 1
+
+-- | Represent a compact array of 8 * 8 values. The size
+-- is not guarenteed by type system, but if makeMacroBlock is
+-- used, everything should be fine size-wise
+type MacroBlock a = SV.Vector a
+
+type QuantificationTable = MacroBlock Int16
+
+-- | Helper function to create pure macro block of the good size.
+makeMacroBlock :: (Storable a) => [a] -> MacroBlock a
+makeMacroBlock = SV.fromListN 64
+
+-- | Enumeration used to search in the tables for different components.
+data DctComponent = DcComponent | AcComponent
+    deriving (Eq, Show, Generic)
+instance NFData DctComponent
+
+-- | Transform parsed coefficients from the jpeg header to a
+-- tree which can be used to decode data.
+buildHuffmanTree :: [[Word8]] -> HuffmanTree
+buildHuffmanTree table = foldl' insertHuffmanVal Empty
+                       . concatMap (\(i, t) -> map (i + 1,) t)
+                       $ zip ([0..] :: [Int]) table
+  where isTreeFullyDefined Empty = False
+        isTreeFullyDefined (Leaf _) = True
+        isTreeFullyDefined (Branch l r) = isTreeFullyDefined l && isTreeFullyDefined r
+
+        insertHuffmanVal Empty (0, val) = Leaf val
+        insertHuffmanVal Empty (d, val) = Branch (insertHuffmanVal Empty (d - 1, val)) Empty
+        insertHuffmanVal (Branch l r) (d, val)
+            | isTreeFullyDefined l = Branch l (insertHuffmanVal r (d - 1, val))
+            | otherwise            = Branch (insertHuffmanVal l (d - 1, val)) r
+        insertHuffmanVal (Leaf _) _ = error "Inserting in value, shouldn't happen"
+
+scaleQuantisationMatrix :: Int -> QuantificationTable -> QuantificationTable 
+scaleQuantisationMatrix quality
+    | quality < 0 = scaleQuantisationMatrix 0
+        -- shouldn't show much difference than with 1,
+        -- but hey, at least we're complete
+    | quality == 0 = SV.map (scale (10000 :: Int))
+    | quality < 50 = let qq = 5000 `div` quality
+                     in SV.map (scale qq)
+    | otherwise    = SV.map (scale q)
+          where q = 200 - quality * 2
+                scale coeff i = fromIntegral . min 255 
+                                             . max 1 
+                                             $ fromIntegral i * coeff `div` 100
+
+huffmanPackedDecode :: HuffmanPackedTree -> BoolReader s Word8
+huffmanPackedDecode table = getNextBitJpg >>= aux 0
+  where aux idx b
+            | (v .&. 0x8000) /= 0 = return  0
+            | (v .&. 0x4000) /= 0 = return . fromIntegral $ v .&. 0xFF
+            | otherwise = getNextBitJpg >>= aux v
+          where tableIndex | b = idx + 1
+                           | otherwise = idx
+                v = table `SV.unsafeIndex` fromIntegral tableIndex
+
+defaultLumaQuantizationTable :: QuantificationTable
+defaultLumaQuantizationTable = makeMacroBlock
+    [16, 11, 10, 16,  24,  40,  51,  61
+    ,12, 12, 14, 19,  26,  58,  60,  55
+    ,14, 13, 16, 24,  40,  57,  69,  56
+    ,14, 17, 22, 29,  51,  87,  80,  62
+    ,18, 22, 37, 56,  68, 109, 103,  77
+    ,24, 35, 55, 64,  81, 104, 113,  92
+    ,49, 64, 78, 87, 103, 121, 120, 101
+    ,72, 92, 95, 98, 112, 100, 103,  99
+    ]
+
+defaultChromaQuantizationTable :: QuantificationTable
+defaultChromaQuantizationTable = makeMacroBlock
+    [17, 18, 24, 47, 99, 99, 99, 99
+    ,18, 21, 26, 66, 99, 99, 99, 99
+    ,24, 26, 56, 99, 99, 99, 99, 99
+    ,47, 66, 99, 99, 99, 99, 99, 99
+    ,99, 99, 99, 99, 99, 99, 99, 99
+    ,99, 99, 99, 99, 99, 99, 99, 99
+    ,99, 99, 99, 99, 99, 99, 99, 99
+    ,99, 99, 99, 99, 99, 99, 99, 99
+    ]
+
+defaultDcLumaHuffmanTree :: HuffmanTree
+defaultDcLumaHuffmanTree = buildHuffmanTree defaultDcLumaHuffmanTable
+
+-- | From the Table K.3 of ITU-81 (p153)
+defaultDcLumaHuffmanTable :: HuffmanTable
+defaultDcLumaHuffmanTable =
+    [ []
+    , [0]
+    , [1, 2, 3, 4, 5]
+    , [6]
+    , [7]
+    , [8]
+    , [9]
+    , [10]
+    , [11]
+    , []
+    , []
+    , []
+    , []
+    , []
+    , []
+    , []
+    ]
+
+defaultDcChromaHuffmanTree :: HuffmanTree
+defaultDcChromaHuffmanTree = buildHuffmanTree defaultDcChromaHuffmanTable
+
+-- | From the Table K.4 of ITU-81 (p153)
+defaultDcChromaHuffmanTable :: HuffmanTable
+defaultDcChromaHuffmanTable = 
+    [ []
+    , [0, 1, 2]
+    , [3]
+    , [4]
+    , [5]
+    , [6]
+    , [7]
+    , [8]
+    , [9]
+    , [10]
+    , [11]
+    , []
+    , []
+    , []
+    , []
+    , []
+    ]
+
+defaultAcLumaHuffmanTree :: HuffmanTree
+defaultAcLumaHuffmanTree = buildHuffmanTree defaultAcLumaHuffmanTable
+
+-- | From the Table K.5 of ITU-81 (p154)
+defaultAcLumaHuffmanTable :: HuffmanTable
+defaultAcLumaHuffmanTable =
+    [ []
+    , [0x01, 0x02]
+    , [0x03]
+    , [0x00, 0x04, 0x11]
+    , [0x05, 0x12, 0x21]
+    , [0x31, 0x41]
+    , [0x06, 0x13, 0x51, 0x61]
+    , [0x07, 0x22, 0x71]
+    , [0x14, 0x32, 0x81, 0x91, 0xA1]
+    , [0x08, 0x23, 0x42, 0xB1, 0xC1]
+    , [0x15, 0x52, 0xD1, 0xF0]
+    , [0x24, 0x33, 0x62, 0x72]
+    , []
+    , []
+    , [0x82]
+    , [0x09, 0x0A, 0x16, 0x17, 0x18, 0x19, 0x1A, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x34, 0x35
+      ,0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4A, 0x53, 0x54
+      ,0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73
+      ,0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A
+      ,0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7
+      ,0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7, 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4
+      ,0xC5, 0xC6, 0xC7, 0xC8, 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9, 0xDA
+      ,0xE1, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5
+      ,0xF6, 0xF7, 0xF8, 0xF9, 0xFA]
+    ]
+
+type HuffmanTable = [[Word8]]
+
+defaultAcChromaHuffmanTree :: HuffmanTree
+defaultAcChromaHuffmanTree = buildHuffmanTree defaultAcChromaHuffmanTable 
+
+defaultAcChromaHuffmanTable :: HuffmanTable
+defaultAcChromaHuffmanTable = 
+    [ []
+    , [0x00, 0x01]
+    , [0x02]
+    , [0x03, 0x11]
+    , [0x04, 0x05, 0x21, 0x31]
+    , [0x06, 0x12, 0x41, 0x51]
+    , [0x07, 0x61, 0x71]
+    , [0x13, 0x22, 0x32, 0x81]
+    , [0x08, 0x14, 0x42, 0x91, 0xA1, 0xB1, 0xC1]
+    , [0x09, 0x23, 0x33, 0x52, 0xF0]
+    , [0x15, 0x62, 0x72, 0xD1]
+    , [0x0A, 0x16, 0x24, 0x34]
+    , []
+    , [0xE1]
+    , [0x25, 0xF1]
+    , [ 0x17, 0x18, 0x19, 0x1A, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x35
+      , 0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47
+      , 0x48, 0x49, 0x4A, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59
+      , 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73
+      , 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x82, 0x83, 0x84
+      , 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A, 0x92, 0x93, 0x94, 0x95
+      , 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6
+      , 0xA7, 0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7
+      , 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, 0xC8
+      , 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9
+      , 0xDA, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA
+      , 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0xFA
+      ]
+    ]
+
+ src/Codec/Picture/Jpg/Internal/FastDct.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+module Codec.Picture.Jpg.Internal.FastDct( referenceDct, fastDctLibJpeg ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<$>) )
+#endif
+
+import Data.Int( Int16, Int32 )
+import Data.Bits( unsafeShiftR, unsafeShiftL )
+import Control.Monad.ST( ST )
+
+import qualified Data.Vector.Storable.Mutable as M
+
+import Codec.Picture.Jpg.Internal.Types
+import Control.Monad( forM, forM_ )
+
+-- | Reference implementation of the DCT, directly implementing the formula
+-- of ITU-81. It's slow as hell, perform to many operations, but is accurate
+-- and a good reference point.
+referenceDct :: MutableMacroBlock s Int32
+             -> MutableMacroBlock s Int16
+             -> ST s (MutableMacroBlock s Int32)
+referenceDct workData block = do
+  forM_ [(u, v) | u <- [0 :: Int .. dctBlockSize - 1], v <- [0..dctBlockSize - 1]] $ \(u,v) -> do
+    val <- at (u,v)
+    (workData `M.unsafeWrite` (v * dctBlockSize + u)) . truncate $ (1 / 4) * c u * c v * val
+
+  return workData
+ where -- at :: (Int, Int) -> ST s Float
+   at (u,v) = do
+     toSum <-
+        forM [(x,y) | x <- [0..dctBlockSize - 1], y <- [0..dctBlockSize - 1 :: Int]] $ \(x,y) -> do
+            sample <- fromIntegral <$> (block `M.unsafeRead` (y * dctBlockSize + x))
+            return $ sample * cos ((2 * fromIntegral x + 1) * fromIntegral u * (pi :: Float)/ 16) 
+                            * cos ((2 * fromIntegral y + 1) * fromIntegral v * pi / 16)
+     return $ sum toSum
+
+   c 0 = 1 / sqrt 2
+   c _ = 1
+
+pASS1_BITS, cONST_BITS :: Int
+cONST_BITS = 13
+pASS1_BITS =  2
+
+
+fIX_0_298631336, fIX_0_390180644, fIX_0_541196100,
+    fIX_0_765366865, fIX_0_899976223, fIX_1_175875602,
+    fIX_1_501321110, fIX_1_847759065, fIX_1_961570560,
+    fIX_2_053119869, fIX_2_562915447, fIX_3_072711026 :: Int32
+fIX_0_298631336 = 2446    -- FIX(0.298631336) */
+fIX_0_390180644 = 3196    -- FIX(0.390180644) */
+fIX_0_541196100 = 4433    -- FIX(0.541196100) */
+fIX_0_765366865 = 6270    -- FIX(0.765366865) */
+fIX_0_899976223 = 7373    -- FIX(0.899976223) */
+fIX_1_175875602 = 9633    -- FIX(1.175875602) */
+fIX_1_501321110 = 12299    -- FIX(1.501321110) */
+fIX_1_847759065 = 15137    -- FIX(1.847759065) */
+fIX_1_961570560 = 16069    -- FIX(1.961570560) */
+fIX_2_053119869 = 16819    -- FIX(2.053119869) */
+fIX_2_562915447 = 20995    -- FIX(2.562915447) */
+fIX_3_072711026 = 25172    -- FIX(3.072711026) */
+
+cENTERJSAMPLE :: Int32
+cENTERJSAMPLE = 128
+
+-- | Fast DCT extracted from libjpeg
+fastDctLibJpeg :: MutableMacroBlock s Int32
+        -> MutableMacroBlock s Int16
+        -> ST s (MutableMacroBlock s Int32)
+fastDctLibJpeg workData sample_block = do
+ firstPass workData  0
+ secondPass workData 7
+ {-_ <- mutate (\_ a -> a `quot` 8) workData-}
+ return workData
+  where -- Pass 1: process rows.
+        -- Note results are scaled up by sqrt(8) compared to a true DCT;
+        -- furthermore, we scale the results by 2**PASS1_BITS.
+        firstPass         _ i | i == dctBlockSize = return ()
+        firstPass dataBlock i = do
+            let baseIdx = i * dctBlockSize
+                readAt idx = fromIntegral <$> sample_block `M.unsafeRead` (baseIdx + idx)
+                mult = (*)
+                writeAt idx = dataBlock `M.unsafeWrite` (baseIdx + idx)
+                writeAtPos idx n = (dataBlock `M.unsafeWrite` (baseIdx + idx))
+                                    (n `unsafeShiftR` (cONST_BITS - pASS1_BITS))
+
+            blk0 <- readAt 0
+            blk1 <- readAt 1
+            blk2 <- readAt 2
+            blk3 <- readAt 3
+            blk4 <- readAt 4
+            blk5 <- readAt 5
+            blk6 <- readAt 6
+            blk7 <- readAt 7
+
+            let tmp0 = blk0 + blk7
+                tmp1 = blk1 + blk6
+                tmp2 = blk2 + blk5
+                tmp3 = blk3 + blk4
+
+                tmp10 = tmp0 + tmp3
+                tmp12 = tmp0 - tmp3
+                tmp11 = tmp1 + tmp2
+                tmp13 = tmp1 - tmp2
+
+                tmp0' = blk0 - blk7
+                tmp1' = blk1 - blk6
+                tmp2' = blk2 - blk5
+                tmp3' = blk3 - blk4
+
+            -- Stage 4 and output
+            writeAt 0 $ (tmp10 + tmp11 - dctBlockSize * cENTERJSAMPLE) `unsafeShiftL` pASS1_BITS
+            writeAt 4 $ (tmp10 - tmp11) `unsafeShiftL` pASS1_BITS
+
+            let z1 = mult (tmp12 + tmp13) fIX_0_541196100
+                     + (1 `unsafeShiftL` (cONST_BITS - pASS1_BITS - 1))
+
+            writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865
+            writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065
+
+            let tmp10' = tmp0' + tmp3'
+                tmp11' = tmp1' + tmp2'
+                tmp12' = tmp0' + tmp2'
+                tmp13' = tmp1' + tmp3'
+                z1' = mult (tmp12' + tmp13') fIX_1_175875602 --  c3 */
+                        -- Add fudge factor here for final descale. */
+                        + (1 `unsafeShiftL` (cONST_BITS - pASS1_BITS-1))
+                tmp0'' = mult tmp0' fIX_1_501321110
+                tmp1'' = mult tmp1' fIX_3_072711026
+                tmp2'' = mult tmp2' fIX_2_053119869
+                tmp3'' = mult tmp3' fIX_0_298631336
+
+                tmp10'' = mult tmp10' (- fIX_0_899976223)
+                tmp11'' = mult tmp11' (- fIX_2_562915447)
+                tmp12'' = mult tmp12' (- fIX_0_390180644) + z1'
+                tmp13'' = mult tmp13' (- fIX_1_961570560) + z1'
+
+            writeAtPos 1 $ tmp0'' + tmp10'' + tmp12''
+            writeAtPos 3 $ tmp1'' + tmp11'' + tmp13''
+            writeAtPos 5 $ tmp2'' + tmp11'' + tmp12''
+            writeAtPos 7 $ tmp3'' + tmp10'' + tmp13''
+
+            firstPass dataBlock $ i + 1
+
+        -- Pass 2: process columns.
+        -- We remove the PASS1_BITS scaling, but leave the results scaled up
+        -- by an overall factor of 8.
+        secondPass :: M.STVector s Int32 -> Int -> ST s ()
+        secondPass _     (-1) = return ()
+        secondPass block i = do
+            let readAt idx = block `M.unsafeRead` ((7 - i) + idx * dctBlockSize)
+                mult = (*)
+                writeAt idx = block `M.unsafeWrite` (dctBlockSize * idx + (7 - i))
+                writeAtPos idx n = (block `M.unsafeWrite` (dctBlockSize * idx + (7 - i))) $ n `unsafeShiftR` (cONST_BITS + pASS1_BITS + 3)
+            blk0 <- readAt 0
+            blk1 <- readAt 1
+            blk2 <- readAt 2
+            blk3 <- readAt 3
+            blk4 <- readAt 4
+            blk5 <- readAt 5
+            blk6 <- readAt 6
+            blk7 <- readAt 7
+
+            let tmp0 = blk0 + blk7
+                tmp1 = blk1 + blk6
+                tmp2 = blk2 + blk5
+                tmp3 = blk3 + blk4
+
+                -- Add fudge factor here for final descale. */
+                tmp10 = tmp0 + tmp3 + (1 `unsafeShiftL` (pASS1_BITS-1))
+                tmp12 = tmp0 - tmp3
+                tmp11 = tmp1 + tmp2
+                tmp13 = tmp1 - tmp2
+
+                tmp0' = blk0 - blk7
+                tmp1' = blk1 - blk6
+                tmp2' = blk2 - blk5
+                tmp3' = blk3 - blk4
+
+            writeAt 0 $ (tmp10 + tmp11) `unsafeShiftR` (pASS1_BITS + 3)
+            writeAt 4 $ (tmp10 - tmp11) `unsafeShiftR` (pASS1_BITS + 3)
+
+            let z1 = mult (tmp12 + tmp13) fIX_0_541196100
+                    + (1 `unsafeShiftL` (cONST_BITS + pASS1_BITS - 1))
+
+            writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865
+            writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065
+
+            let tmp10' = tmp0' + tmp3'
+                tmp11' = tmp1' + tmp2'
+                tmp12' = tmp0' + tmp2'
+                tmp13' = tmp1' + tmp3'
+
+                z1' = mult (tmp12' + tmp13') fIX_1_175875602
+                    -- Add fudge factor here for final descale. */
+                   + 1 `unsafeShiftL` (cONST_BITS+pASS1_BITS-1);
+
+                tmp0''  = mult tmp0'    fIX_1_501321110
+                tmp1''  = mult tmp1'    fIX_3_072711026
+                tmp2''  = mult tmp2'    fIX_2_053119869
+                tmp3''  = mult tmp3'    fIX_0_298631336
+                tmp10'' = mult tmp10' (- fIX_0_899976223)
+                tmp11'' = mult tmp11' (- fIX_2_562915447)
+                tmp12'' = mult tmp12' (- fIX_0_390180644)
+                            + z1'
+                tmp13'' = mult tmp13' (- fIX_1_961570560)
+                            + z1'
+            writeAtPos 1 $ tmp0'' + tmp10'' + tmp12''
+            writeAtPos 3 $ tmp1'' + tmp11'' + tmp13''
+            writeAtPos 5 $ tmp2'' + tmp11'' + tmp12''
+            writeAtPos 7 $ tmp3'' + tmp10'' + tmp13''
+
+            secondPass block (i - 1)
+
+{-# ANN module "HLint: ignore Use camelCase" #-}
+{-# ANN module "HLint: ignore Reduce duplication" #-}
+
+ src/Codec/Picture/Jpg/Internal/FastIdct.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+-- | Module providing a 'fast' implementation of IDCT
+--
+-- inverse two dimensional DCT, Chen-Wang algorithm       
+-- (cf. IEEE ASSP-32, pp. 803-816, Aug. 1984)             
+-- 32-bit integer arithmetic (8 bit coefficients)         
+-- 11 mults, 29 adds per DCT                              
+--                                      sE, 18.8.91       
+--
+-- coefficients extended to 12 bit for IEEE1180-1990      
+-- compliance                           sE,  2.1.94       
+--
+-- this code assumes >> to be a two's-complement arithmetic
+-- right shift: (-2)>>1 == -1 , (-3)>>1 == -2               
+module Codec.Picture.Jpg.Internal.FastIdct( MutableMacroBlock
+                                 , fastIdct
+                                 , mutableLevelShift
+                                 , createEmptyMutableMacroBlock
+                                 ) where
+
+import qualified Data.Vector.Storable as V
+import Control.Monad.ST( ST )
+import Data.Bits( unsafeShiftL, unsafeShiftR )
+import Data.Int( Int16 )
+import qualified Data.Vector.Storable.Mutable as M
+
+import Codec.Picture.Jpg.Internal.Types
+
+iclip :: V.Vector Int16
+iclip = V.fromListN 1024 [ val i| i <- [(-512) .. 511] ]
+    where val i | i < (-256) = -256
+                | i > 255    =  255
+                | otherwise  =  i
+
+data IDctStage = IDctStage { 
+        x0 :: {-# UNPACK #-} !Int,
+        x1 :: {-# UNPACK #-} !Int,
+        x2 :: {-# UNPACK #-} !Int,
+        x3 :: {-# UNPACK #-} !Int,
+        x4 :: {-# UNPACK #-} !Int,
+        x5 :: {-# UNPACK #-} !Int,
+        x6 :: {-# UNPACK #-} !Int,
+        x7 :: {-# UNPACK #-} !Int,
+        x8 :: {-# UNPACK #-} !Int
+    }
+
+w1, w2, w3, w5, w6, w7 :: Int
+w1 = 2841 -- 2048*sqrt(2)*cos(1*pi/16)
+w2 = 2676 -- 2048*sqrt(2)*cos(2*pi/16)
+w3 = 2408 -- 2048*sqrt(2)*cos(3*pi/16)
+w5 = 1609 -- 2048*sqrt(2)*cos(5*pi/16)
+w6 = 1108 -- 2048*sqrt(2)*cos(6*pi/16)
+w7 = 565  -- 2048*sqrt(2)*cos(7*pi/16)
+
+-- row (horizontal) IDCT
+--
+--           7                       pi         1
+-- dst[k] = sum c[l] * src[l] * cos( -- * ( k + - ) * l )
+--          l=0                      8          2
+--
+-- where: c[0]    = 128
+--        c[1..7] = 128*sqrt(2)
+idctRow :: MutableMacroBlock s Int16 -> Int ->  ST s ()
+idctRow blk idx = do
+  xx0 <- blk `M.unsafeRead` (0 + idx)
+  xx1 <- blk `M.unsafeRead` (4 + idx) 
+  xx2 <- blk `M.unsafeRead` (6 + idx)
+  xx3 <- blk `M.unsafeRead` (2 + idx)
+  xx4 <- blk `M.unsafeRead` (1 + idx)
+  xx5 <- blk `M.unsafeRead` (7 + idx)
+  xx6 <- blk `M.unsafeRead` (5 + idx)
+  xx7 <- blk `M.unsafeRead` (3 + idx)
+  let initialState = IDctStage { x0 = (fromIntegral xx0 `unsafeShiftL` 11) + 128
+                               , x1 =  fromIntegral xx1 `unsafeShiftL` 11
+                               , x2 =  fromIntegral xx2
+                               , x3 =  fromIntegral xx3
+                               , x4 =  fromIntegral xx4
+                               , x5 =  fromIntegral xx5
+                               , x6 =  fromIntegral xx6
+                               , x7 =  fromIntegral xx7
+                               , x8 = 0
+                               } 
+
+      firstStage c = c { x4 = x8'  + (w1 - w7) * x4 c
+                       , x5 = x8'  - (w1 + w7) * x5 c
+                       , x6 = x8'' - (w3 - w5) * x6 c
+                       , x7 = x8'' - (w3 + w5) * x7 c
+                       , x8 = x8''
+                       }
+          where x8' = w7 * (x4 c + x5 c)
+                x8'' = w3 * (x6 c + x7 c)
+
+      secondStage c = c { x0 = x0 c - x1 c
+                        , x8 = x0 c + x1 c 
+                        , x1 = x1''
+                        , x2 = x1' - (w2 + w6) * x2 c
+                        , x3 = x1' + (w2 - w6) * x3 c
+                        , x4 = x4 c - x6 c
+                        , x6 = x5 c + x7 c
+                        , x5 = x5 c - x7 c
+                        }
+            where x1'  = w6 * (x3 c + x2 c)
+                  x1'' = x4 c + x6 c
+
+      thirdStage c = c { x7 = x8 c + x3 c
+                       , x8 = x8 c - x3 c
+                       , x3 = x0 c + x2 c
+                       , x0 = x0 c - x2 c
+                       , x2 = (181 * (x4 c + x5 c) + 128) `unsafeShiftR` 8
+                       , x4 = (181 * (x4 c - x5 c) + 128) `unsafeShiftR` 8
+                       }
+      scaled c = c { x0 = (x7 c + x1 c) `unsafeShiftR` 8
+                   , x1 = (x3 c + x2 c) `unsafeShiftR` 8
+                   , x2 = (x0 c + x4 c) `unsafeShiftR` 8
+                   , x3 = (x8 c + x6 c) `unsafeShiftR` 8
+                   , x4 = (x8 c - x6 c) `unsafeShiftR` 8
+                   , x5 = (x0 c - x4 c) `unsafeShiftR` 8
+                   , x6 = (x3 c - x2 c) `unsafeShiftR` 8
+                   , x7 = (x7 c - x1 c) `unsafeShiftR` 8
+                   }
+      transformed = scaled . thirdStage . secondStage $ firstStage initialState
+
+  (blk `M.unsafeWrite` (0 + idx)) . fromIntegral $ x0 transformed
+  (blk `M.unsafeWrite` (1 + idx)) . fromIntegral $ x1 transformed
+  (blk `M.unsafeWrite` (2 + idx)) . fromIntegral $ x2 transformed
+  (blk `M.unsafeWrite` (3 + idx)) . fromIntegral $ x3 transformed
+  (blk `M.unsafeWrite` (4 + idx)) . fromIntegral $ x4 transformed
+  (blk `M.unsafeWrite` (5 + idx)) . fromIntegral $ x5 transformed
+  (blk `M.unsafeWrite` (6 + idx)) . fromIntegral $ x6 transformed
+  (blk `M.unsafeWrite` (7 + idx)) . fromIntegral $ x7 transformed
+
+-- column (vertical) IDCT
+--
+--             7                         pi         1
+-- dst[8*k] = sum c[l] * src[8*l] * cos( -- * ( k + - ) * l )
+--            l=0                        8          2
+--
+-- where: c[0]    = 1/1024
+--        c[1..7] = (1/1024)*sqrt(2)
+--
+idctCol :: MutableMacroBlock s Int16 -> Int -> ST s ()
+idctCol blk idx = do
+  xx0 <- blk `M.unsafeRead` (    0 + idx)
+  xx1 <- blk `M.unsafeRead` (8 * 4 + idx)
+  xx2 <- blk `M.unsafeRead` (8 * 6 + idx)
+  xx3 <- blk `M.unsafeRead` (8 * 2 + idx)
+  xx4 <- blk `M.unsafeRead` (8     + idx)
+  xx5 <- blk `M.unsafeRead` (8 * 7 + idx)
+  xx6 <- blk `M.unsafeRead` (8 * 5 + idx)
+  xx7 <- blk `M.unsafeRead` (8 * 3 + idx)
+  let initialState = IDctStage { x0 = (fromIntegral xx0 `unsafeShiftL` 8) + 8192
+                               , x1 =  fromIntegral xx1 `unsafeShiftL` 8
+                               , x2 =  fromIntegral xx2
+                               , x3 =  fromIntegral xx3
+                               , x4 =  fromIntegral xx4
+                               , x5 =  fromIntegral xx5
+                               , x6 =  fromIntegral xx6
+                               , x7 =  fromIntegral xx7
+                               , x8 = 0
+                               } 
+      firstStage c = c { x4 = (x8'  + (w1 - w7) * x4 c) `unsafeShiftR` 3
+                       , x5 = (x8'  - (w1 + w7) * x5 c) `unsafeShiftR` 3
+                       , x6 = (x8'' - (w3 - w5) * x6 c) `unsafeShiftR` 3
+                       , x7 = (x8'' - (w3 + w5) * x7 c) `unsafeShiftR` 3
+                       , x8 = x8''
+                       }
+          where x8'  = w7 * (x4 c + x5 c) + 4
+                x8'' = w3 * (x6 c + x7 c) + 4
+
+      secondStage c = c { x8 = x0 c + x1 c
+                        , x0 = x0 c - x1 c
+                        , x2 = (x1' - (w2 + w6) * x2 c) `unsafeShiftR` 3
+                        , x3 = (x1' + (w2 - w6) * x3 c) `unsafeShiftR` 3
+                        , x4 = x4 c - x6 c
+                        , x1 = x1''
+                        , x6 = x5 c + x7 c
+                        , x5 = x5 c - x7 c
+                        }
+          where x1'  = w6 * (x3 c + x2 c) + 4
+                x1'' = x4 c + x6 c
+  
+      thirdStage c = c { x7 = x8 c + x3 c
+                       , x8 = x8 c - x3 c
+                       , x3 = x0 c + x2 c
+                       , x0 = x0 c - x2 c
+                       , x2 = (181 * (x4 c + x5 c) + 128) `unsafeShiftR` 8
+                       , x4 = (181 * (x4 c - x5 c) + 128) `unsafeShiftR` 8
+                       }
+
+      clip i | i < 511 = if i > -512 then iclip `V.unsafeIndex` (i + 512)
+                                    else iclip `V.unsafeIndex` 0
+            
+             | otherwise = iclip `V.unsafeIndex` 1023
+
+      f = thirdStage . secondStage $ firstStage initialState
+  (blk `M.unsafeWrite` (idx + 8*0)) . clip $ (x7 f + x1 f) `unsafeShiftR` 14
+  (blk `M.unsafeWrite` (idx + 8  )) . clip $ (x3 f + x2 f) `unsafeShiftR` 14
+  (blk `M.unsafeWrite` (idx + 8*2)) . clip $ (x0 f + x4 f) `unsafeShiftR` 14
+  (blk `M.unsafeWrite` (idx + 8*3)) . clip $ (x8 f + x6 f) `unsafeShiftR` 14
+  (blk `M.unsafeWrite` (idx + 8*4)) . clip $ (x8 f - x6 f) `unsafeShiftR` 14
+  (blk `M.unsafeWrite` (idx + 8*5)) . clip $ (x0 f - x4 f) `unsafeShiftR` 14
+  (blk `M.unsafeWrite` (idx + 8*6)) . clip $ (x3 f - x2 f) `unsafeShiftR` 14
+  (blk `M.unsafeWrite` (idx + 8*7)) . clip $ (x7 f - x1 f) `unsafeShiftR` 14
+
+
+{-# INLINE fastIdct #-}
+-- | Algorithm to call to perform an IDCT, return the same
+-- block that the one given as input.
+fastIdct :: MutableMacroBlock s Int16
+         -> ST s (MutableMacroBlock s Int16)
+fastIdct block = rows 0
+  where rows 8 = cols 0
+        rows i = idctRow block (8 * i) >> rows (i + 1)
+
+        cols 8 = return block
+        cols i = idctCol block i >> cols (i + 1)
+
+{-# INLINE mutableLevelShift #-}
+-- | Perform a Jpeg level shift in a mutable fashion.
+mutableLevelShift :: MutableMacroBlock s Int16
+                  -> ST s (MutableMacroBlock s Int16)
+mutableLevelShift block = update 0
+  where update 64 = return block
+        update idx = do
+            val <- block `M.unsafeRead` idx
+            (block `M.unsafeWrite` idx) $ val + 128
+            update $ idx + 1
+
+ src/Codec/Picture/Jpg/Internal/Metadata.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}
+module Codec.Picture.Jpg.Internal.Metadata ( extractMetadatas, encodeMetadatas ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( pure )
+import Data.Monoid( mempty )
+import Data.Word( Word )
+#endif
+
+import Data.Word( Word16 )
+import Data.Maybe( fromMaybe )
+import qualified Codec.Picture.Metadata as Met
+import Codec.Picture.Metadata( Metadatas )
+import Codec.Picture.Jpg.Internal.Types
+
+scalerOfUnit :: JFifUnit -> Met.Keys Word -> Word16 -> Metadatas -> Metadatas
+scalerOfUnit unit k v = case unit of
+  JFifUnitUnknown -> id
+  JFifPixelsPerInch -> Met.insert k (fromIntegral v)
+  JFifPixelsPerCentimeter ->
+    Met.insert k (Met.dotsPerCentiMeterToDotPerInch $ fromIntegral v)
+
+extractMetadatas :: JpgJFIFApp0 -> Metadatas
+extractMetadatas jfif = 
+    inserter Met.DpiX (_jfifDpiX jfif)
+        $ inserter Met.DpiY (_jfifDpiY jfif) mempty
+  where
+    inserter = scalerOfUnit $ _jfifUnit jfif
+
+
+encodeMetadatas :: Metadatas -> [JpgFrame]
+encodeMetadatas metas = fromMaybe [] $ do
+  dpiX <- Met.lookup Met.DpiX metas
+  dpiY <- Met.lookup Met.DpiY metas
+  pure . pure . JpgJFIF $ JpgJFIFApp0
+    { _jfifUnit      = JFifPixelsPerInch
+    , _jfifDpiX      = fromIntegral dpiX
+    , _jfifDpiY      = fromIntegral dpiY
+    , _jfifThumbnail = Nothing
+    }
+
+ src/Codec/Picture/Jpg/Internal/Progressive.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
+module Codec.Picture.Jpg.Internal.Progressive
+    ( JpgUnpackerParameter( .. )
+    , progressiveUnpack
+    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( pure, (<$>) )
+#endif
+
+import Control.Monad( when, unless, forM_ )
+import Control.Monad.ST( ST )
+import Control.Monad.Trans( lift )
+import Data.Bits( (.&.), (.|.), unsafeShiftL )
+import Data.Int( Int16, Int32 )
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Vector as V
+import qualified Data.Vector.Storable as VS
+import Data.Vector( (!) )
+import qualified Data.Vector.Mutable as M
+import qualified Data.Vector.Storable.Mutable as MS
+
+import Codec.Picture.Types
+import Codec.Picture.BitWriter
+import Codec.Picture.Jpg.Internal.Common
+import Codec.Picture.Jpg.Internal.Types
+import Codec.Picture.Jpg.Internal.DefaultTable
+
+createMcuLineIndices :: JpgComponent -> Int -> Int -> V.Vector (VS.Vector Int)
+createMcuLineIndices param imgWidth mcuWidth =
+ V.fromList $ VS.fromList <$> [indexSolo, indexMulti]
+  where compW = fromIntegral $ horizontalSamplingFactor param
+        compH = fromIntegral $ verticalSamplingFactor param
+        imageBlockSize = toBlockSize imgWidth
+
+        -- if the displayed MCU block is only displayed in half (like with
+        -- width 500 then we loose one macroblock of the MCU at the end of
+        -- the line. Previous implementation which naively used full mcu
+        -- was wrong. Only taking into account visible macroblocks
+        indexSolo = [base + x
+            | y <- [0 .. compH - 1]
+            , let base = y * mcuWidth * compW
+            , x <- [0 .. imageBlockSize - 1]]
+
+        indexMulti =
+            [(mcu + y * mcuWidth) * compW + x
+                | mcu <- [0 .. mcuWidth - 1]
+                , y <- [0 .. compH - 1]
+                , x <- [0 .. compW - 1] ]
+
+decodeFirstDC :: JpgUnpackerParameter
+              -> MS.STVector s Int16
+              -> MutableMacroBlock s Int16
+              -> Int32
+              -> BoolReader s Int32
+decodeFirstDC params dcCoeffs block eobrun = unpack >> pure eobrun
+  where unpack = do
+          (dcDeltaCoefficient) <- dcCoefficientDecode $ dcHuffmanTree params
+          previousDc <- lift $ dcCoeffs `MS.unsafeRead` componentIndex params
+          let neoDcCoefficient = previousDc + dcDeltaCoefficient
+              approxLow = fst $ successiveApprox params
+              scaledDc = neoDcCoefficient `unsafeShiftL` approxLow
+          lift $ (block `MS.unsafeWrite` 0) scaledDc 
+          lift $ (dcCoeffs `MS.unsafeWrite` componentIndex params) neoDcCoefficient
+
+decodeRefineDc :: JpgUnpackerParameter
+               -> a
+               -> MutableMacroBlock s Int16
+               -> Int32
+               -> BoolReader s Int32
+decodeRefineDc params _ block eobrun = unpack >> pure eobrun
+  where approxLow = fst $ successiveApprox params
+        plusOne = 1 `unsafeShiftL` approxLow
+        unpack = do
+            bit <- getNextBitJpg
+            when bit . lift $ do
+                v <- block `MS.unsafeRead` 0
+                (block `MS.unsafeWrite` 0) $ v .|. plusOne
+
+decodeFirstAc :: JpgUnpackerParameter
+              -> a
+              -> MutableMacroBlock s Int16
+              -> Int32
+              -> BoolReader s Int32
+decodeFirstAc _params _ _block eobrun | eobrun > 0 = pure $ eobrun - 1
+decodeFirstAc params _ block _ = unpack startIndex
+  where (startIndex, maxIndex) = coefficientRange params
+        (low, _) = successiveApprox params
+        unpack n | n > maxIndex = pure 0
+        unpack n = do
+            rrrrssss <- decodeRrrrSsss $ acHuffmanTree params
+            case rrrrssss of
+                (0xF, 0) -> unpack $ n + 16
+                (  0, 0) -> return 0
+                (  r, 0) -> eobrun <$> unpackInt r
+                    where eobrun lowBits = (1 `unsafeShiftL` r) - 1 + lowBits
+                (  r, s) -> do
+                    let n' = n + r
+                    val <- (`unsafeShiftL` low) <$> decodeInt s
+                    lift . (block `MS.unsafeWrite` n') $ fromIntegral val
+                    unpack $ n' + 1
+
+decodeRefineAc :: forall a s. JpgUnpackerParameter
+               -> a
+               -> MutableMacroBlock s Int16
+               -> Int32
+               -> BoolReader s Int32
+decodeRefineAc params _ block eobrun
+        | eobrun == 0 = unpack startIndex
+        | otherwise   = performEobRun startIndex >> return (eobrun - 1)
+  where (startIndex, maxIndex) = coefficientRange params
+        (low, _) = successiveApprox params
+        plusOne = 1 `unsafeShiftL` low
+        minusOne = (-1) `unsafeShiftL` low
+
+        getBitVal = do
+            v <- getNextBitJpg
+            pure $ if v then plusOne else minusOne
+
+        performEobRun idx | idx > maxIndex = pure ()
+        performEobRun idx = do
+          coeff <- lift $ block `MS.unsafeRead` idx
+          if coeff /= 0 then do
+            bit <- getNextBitJpg
+            case (bit, (coeff .&. plusOne) == 0) of
+               (False, _)    -> performEobRun $ idx + 1
+               (True, False) -> performEobRun $ idx + 1
+               (True, True) -> do
+                   let newVal | coeff >= 0 = coeff + plusOne
+                              | otherwise = coeff + minusOne
+                   lift $ (block `MS.unsafeWrite` idx) newVal
+                   performEobRun $ idx + 1
+          else
+            performEobRun $ idx + 1
+
+        unpack idx | idx > maxIndex = pure 0
+        unpack idx = do
+            rrrrssss <- decodeRrrrSsss $ acHuffmanTree params
+            case rrrrssss of
+              (0xF, 0) -> do
+                idx' <- updateCoeffs 0xF idx
+                unpack $ idx' + 1
+
+              (  r, 0) -> do
+                  lowBits <- unpackInt r
+                  let newEobRun = (1 `unsafeShiftL` r) + lowBits - 1
+                  performEobRun idx
+                  pure newEobRun
+
+              (  r, _) -> do
+                  val <- getBitVal
+                  idx' <- updateCoeffs (fromIntegral r) idx
+                  when (idx' <= maxIndex) $
+                       lift $ (block `MS.unsafeWrite` idx') val
+                  unpack $ idx' + 1
+
+        updateCoeffs :: Int -> Int -> BoolReader s Int
+        updateCoeffs r idx
+            | r   < 0        = pure $ idx - 1
+            | idx > maxIndex = pure idx
+        updateCoeffs r idx = do
+          coeff <- lift $ block `MS.unsafeRead` idx
+          if coeff /= 0 then do
+            bit <- getNextBitJpg
+            when (bit && coeff .&. plusOne == 0) $ do
+              let writeCoeff | coeff >= 0 = coeff + plusOne
+                             | otherwise = coeff + minusOne
+              lift $ (block `MS.unsafeWrite` idx) writeCoeff
+            updateCoeffs r $ idx + 1
+          else
+            updateCoeffs (r - 1) $ idx + 1
+
+type Unpacker s =
+    JpgUnpackerParameter -> MS.STVector s Int16 -> MutableMacroBlock s Int16 -> Int32
+        -> BoolReader s Int32
+
+
+prepareUnpacker :: [([(JpgUnpackerParameter, a)], L.ByteString)]
+                -> ST s ( V.Vector (V.Vector (JpgUnpackerParameter, Unpacker s))
+                        , M.STVector s BoolState)
+prepareUnpacker lst = do
+    let boolStates = V.fromList $ map snd infos
+    vec <- V.unsafeThaw boolStates
+    return (V.fromList $ map fst infos, vec)
+  where infos = map prepare lst
+        prepare ([], _) = error "progressiveUnpack, no component"
+        prepare (whole@((param, _) : _) , byteString) =
+         (V.fromList $ map (\(p,_) -> (p, unpacker)) whole, boolReader)
+           where unpacker = selection (successiveApprox param) (coefficientRange param)
+                 boolReader = initBoolStateJpg . B.concat $ L.toChunks byteString
+
+                 selection (_, 0) (0, _) = decodeFirstDC
+                 selection (_, 0) _      = decodeFirstAc
+                 selection _      (0, _) = decodeRefineDc
+                 selection _      _      = decodeRefineAc
+
+data ComponentData s = ComponentData
+  { componentIndices    :: V.Vector (VS.Vector Int)
+  , componentBlocks     :: V.Vector (MutableMacroBlock s Int16)
+  , componentId         :: !Int
+  , componentBlockCount :: !Int
+  }
+
+-- | Iteration from 0 to n in monadic context, without data
+-- keeping.
+lineMap :: (Monad m) => Int -> (Int -> m ()) -> m ()
+{-# INLINE lineMap #-}
+lineMap count f = go 0
+  where go n | n >= count = return ()
+        go n = f n >> go (n + 1)
+
+progressiveUnpack :: (Int, Int)
+                  -> JpgFrameHeader
+                  -> V.Vector (MacroBlock Int16)
+                  -> [([(JpgUnpackerParameter, a)], L.ByteString)]
+                  -> ST s (MutableImage s PixelYCbCr8)
+progressiveUnpack (maxiW, maxiH) frame quants lst = do
+    (unpackers, readers) <- prepareUnpacker lst
+    allBlocks <- mapM allocateWorkingBlocks . zip [0..] $ jpgComponents frame
+                    :: ST s [ComponentData s]
+    let scanCount = length lst
+        restartIntervalValue = case lst of
+                ((p,_):_,_): _ -> restartInterval p
+                _ -> -1
+    dcCoeffs <- MS.replicate imgComponentCount 0
+    eobRuns <- MS.replicate (length lst) 0
+    workBlock <- createEmptyMutableMacroBlock
+    writeIndices <- MS.replicate imgComponentCount (0 :: Int)
+    restartIntervals <- MS.replicate scanCount restartIntervalValue
+    let elementCount = imgWidth * imgHeight * fromIntegral imgComponentCount
+    img <- MutableImage imgWidth imgHeight <$> MS.replicate elementCount 128
+
+    let processRestartInterval =
+          forM_ [0 .. scanCount - 1] $ \ix -> do
+            v <- restartIntervals `MS.read` ix
+            if v == 0 then do
+              -- reset DC prediction
+              when (ix == 0) (MS.set dcCoeffs 0)
+              reader <- readers `M.read` ix
+              (_, updated) <- runBoolReaderWith reader $
+                  byteAlignJpg >> decodeRestartInterval
+              (readers `M.write` ix) updated 
+              (eobRuns `MS.unsafeWrite` ix) 0
+              (restartIntervals `MS.unsafeWrite` ix) $ restartIntervalValue - 1
+            else
+              (restartIntervals `MS.unsafeWrite` ix) $ v - 1
+
+
+    lineMap imageMcuHeight $ \mmY -> do
+      -- Reset all blocks to 0
+      forM_ allBlocks $ V.mapM_ (`MS.set` 0) .  componentBlocks
+      MS.set writeIndices 0
+
+      lineMap imageMcuWidth $ \_mmx -> do
+        processRestartInterval 
+        V.forM_ unpackers $ V.mapM_ $ \(unpackParam, unpacker) -> do
+            boolState <- readers `M.read` readerIndex unpackParam
+            eobrun <- eobRuns `MS.read` readerIndex unpackParam
+            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
+            unless (writeIndex + blockIndex unpackParam >= maxIndexLength) $ do
+               let realIndex = indexVector VS.! (writeIndex + blockIndex unpackParam)
+                   writeBlock = componentBlocks componentData ! realIndex
+               (eobrun', state) <-
+                   runBoolReaderWith boolState $
+                       unpacker unpackParam dcCoeffs writeBlock eobrun
+
+               (readers `M.write` readerIndex unpackParam) state
+               (eobRuns `MS.write` readerIndex unpackParam) eobrun'
+
+        -- Update the write indices
+        forM_ allBlocks $ \comp -> do
+          writeIndex <- writeIndices `MS.read` componentId comp
+          let newIndex = writeIndex + componentBlockCount comp
+          (writeIndices `MS.write` componentId comp) newIndex
+
+      forM_ allBlocks $ \compData -> do
+        let compBlocks = componentBlocks compData
+            cId = componentId compData
+            comp = jpgComponents frame !! cId
+            quantId =
+                fromIntegral $ quantizationTableDest comp
+            table = quants ! min 3 quantId
+            compW = fromIntegral $ horizontalSamplingFactor comp
+            compH = fromIntegral $ verticalSamplingFactor comp
+            cw8 = maxiW - fromIntegral (horizontalSamplingFactor comp) + 1
+            ch8 = maxiH - fromIntegral (verticalSamplingFactor comp) + 1
+
+        rasterMap (imageMcuWidth * compW) compH $ \rx y -> do
+            let ry = mmY * maxiH + y
+                block = compBlocks ! (y * imageMcuWidth * compW + rx)
+            transformed <- decodeMacroBlock table workBlock block
+            unpackMacroBlock imgComponentCount
+                    cw8 ch8 cId (rx * cw8) ry
+                    img transformed
+
+    return img
+
+  where imgComponentCount = length $ jpgComponents frame
+
+        imgWidth = fromIntegral $ jpgWidth frame
+        imgHeight = fromIntegral $ jpgHeight frame
+
+        imageBlockWidth = toBlockSize imgWidth
+        imageBlockHeight = toBlockSize imgHeight
+
+        imageMcuWidth =  (imageBlockWidth + (maxiW - 1)) `div` maxiW
+        imageMcuHeight = (imageBlockHeight + (maxiH - 1)) `div` maxiH
+
+        allocateWorkingBlocks (ix, comp) = do
+            let blockCount = hSample * vSample * imageMcuWidth * 2
+            blocks <- V.replicateM blockCount createEmptyMutableMacroBlock
+            return ComponentData 
+                { componentBlocks = blocks
+                , componentIndices = createMcuLineIndices comp imgWidth imageMcuWidth
+                , componentBlockCount = hSample * vSample
+                , componentId = ix
+                }
+            where hSample = fromIntegral $ horizontalSamplingFactor comp
+                  vSample = fromIntegral $ verticalSamplingFactor comp
+
+ src/Codec/Picture/Jpg/Internal/Types.hs view
@@ -0,0 +1,1073 @@+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE CPP #-}
+
+-- | A good explanation of the JPEG format, including diagrams, is given at:
+-- <https://github.com/corkami/formats/blob/master/image/jpeg.md>
+--
+-- The full spec (excluding EXIF): https://www.w3.org/Graphics/JPEG/itu-t81.pdf
+module Codec.Picture.Jpg.Internal.Types( MutableMacroBlock
+                              , createEmptyMutableMacroBlock
+                              , printMacroBlock
+                              , printPureMacroBlock
+                              , DcCoefficient
+                              , JpgImage( .. )
+                              , JpgComponent( .. )
+                              , JpgFrameHeader( .. )
+                              , JpgFrame( .. )
+                              , JpgFrameKind( .. )
+                              , JpgScanHeader( .. )
+                              , JpgQuantTableSpec( .. )
+                              , JpgHuffmanTableSpec( .. )
+                              , JpgImageKind( .. )
+                              , JpgScanSpecification( .. )
+                              , JpgColorSpace( .. )
+                              , AdobeTransform( .. )
+                              , JpgAdobeApp14( .. )
+                              , JpgJFIFApp0( .. )
+                              , JFifUnit( .. )
+                              , TableList( .. )
+                              , RestartInterval( .. )
+                              , getJpgImage
+                              , calculateSize
+                              , dctBlockSize
+                              , parseECS
+                              , parseECS_simple
+                              , skipUntilFrames
+                              , skipFrameMarker
+                              , parseFrameOfKind
+                              , parseFrames
+                              , parseFrameKinds
+                              , parseToFirstFrameHeader
+                              ) where
+
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( pure, (<*>), (<$>) )
+#endif
+
+import Control.DeepSeq( NFData(..) )
+import Control.Monad( when, replicateM, forM, forM_, unless )
+import Control.Monad.ST( ST )
+import Data.Bits( (.|.), (.&.), unsafeShiftL, unsafeShiftR )
+import Data.List( partition )
+import Data.Maybe( maybeToList )
+import GHC.Generics( Generic )
+
+#if !MIN_VERSION_base(4,11,0)
+import Data.Monoid( (<>) )
+#endif
+
+import Foreign.Storable ( Storable )
+import Data.Vector.Unboxed( (!) )
+import qualified Data.Vector as V
+import qualified Data.Vector.Unboxed as VU
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector.Storable.Mutable as M
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Unsafe as BU
+
+import Data.Int( Int16, Int64 )
+import Data.Word(Word8, Word16 )
+import Data.Binary( Binary(..) )
+
+import Data.Binary.Get( Get
+                      , getWord8
+                      , getWord16be
+                      , getByteString
+                      , skip
+                      , bytesRead
+                      , lookAhead
+                      , ByteOffset
+                      , getLazyByteString
+                      )
+import qualified Data.Binary.Get.Internal as GetInternal
+
+import Data.Binary.Put( Put
+                      , putWord8
+                      , putWord16be
+                      , putLazyByteString
+                      , putByteString
+                      , runPut
+                      )
+
+import Codec.Picture.InternalHelper
+import Codec.Picture.Jpg.Internal.DefaultTable
+import Codec.Picture.Tiff.Internal.Types
+import Codec.Picture.Tiff.Internal.Metadata( exifOffsetIfd )
+import Codec.Picture.Metadata.Exif
+
+import Text.Printf
+
+-- | Type only used to make clear what kind of integer we are carrying
+-- Might be transformed into newtype in the future
+type DcCoefficient = Int16
+
+-- | Macroblock that can be transformed.
+type MutableMacroBlock s a = M.STVector s a
+
+data JpgFrameKind =
+      JpgBaselineDCTHuffman
+    | JpgExtendedSequentialDCTHuffman
+    | JpgProgressiveDCTHuffman
+    | JpgLosslessHuffman
+    | JpgDifferentialSequentialDCTHuffman
+    | JpgDifferentialProgressiveDCTHuffman
+    | JpgDifferentialLosslessHuffman
+    | JpgExtendedSequentialArithmetic
+    | JpgProgressiveDCTArithmetic
+    | JpgLosslessArithmetic
+    | JpgDifferentialSequentialDCTArithmetic
+    | JpgDifferentialProgressiveDCTArithmetic
+    | JpgDifferentialLosslessArithmetic
+    | JpgQuantizationTable
+    | JpgHuffmanTableMarker
+    | JpgStartOfScan
+    | JpgEndOfImage
+    | JpgAppSegment Word8
+    | JpgExtensionSegment Word8
+
+    | JpgRestartInterval
+    | JpgRestartIntervalEnd Word8
+    deriving (Eq, Show, Generic)
+instance NFData JpgFrameKind
+
+data JpgFrame =
+      JpgAppFrame        !Word8 B.ByteString
+    | JpgAdobeAPP14      !JpgAdobeApp14
+    | JpgJFIF            !JpgJFIFApp0
+    | JpgExif            ![ImageFileDirectory]
+    | JpgExtension       !Word8 B.ByteString
+    | JpgQuantTable      ![JpgQuantTableSpec]
+    | JpgHuffmanTable    ![(JpgHuffmanTableSpec, HuffmanPackedTree)]
+    | JpgScanBlob        !JpgScanHeader !L.ByteString -- ^ The @ByteString@ is the ECS (Entropy-Coded Segment), typically the largest part of compressed image data.
+    | JpgScans           !JpgFrameKind !JpgFrameHeader
+    | JpgIntervalRestart !Word16
+    deriving (Eq, Show, Generic)
+instance NFData JpgFrame
+
+data JpgColorSpace
+  = JpgColorSpaceYCbCr
+  | JpgColorSpaceYCC
+  | JpgColorSpaceY
+  | JpgColorSpaceYA
+  | JpgColorSpaceYCCA
+  | JpgColorSpaceYCCK
+  | JpgColorSpaceCMYK
+  | JpgColorSpaceRGB
+  | JpgColorSpaceRGBA
+  deriving (Eq, Show, Generic)
+instance NFData JpgColorSpace
+
+data AdobeTransform
+  = AdobeUnknown    -- ^ Value 0
+  | AdobeYCbCr      -- ^ value 1
+  | AdobeYCck       -- ^ value 2
+  deriving (Eq, Show, Generic)
+instance NFData AdobeTransform
+
+data JpgAdobeApp14 = JpgAdobeApp14
+  { _adobeDctVersion :: !Word16
+  , _adobeFlag0      :: !Word16
+  , _adobeFlag1      :: !Word16
+  , _adobeTransform  :: !AdobeTransform
+  }
+  deriving (Eq, Show, Generic)
+instance NFData JpgAdobeApp14
+
+-- | Size: 1
+data JFifUnit
+  = JFifUnitUnknown   -- ^ 0
+  | JFifPixelsPerInch -- ^ 1
+  | JFifPixelsPerCentimeter -- ^ 2
+  deriving (Eq, Show, Generic)
+instance NFData JFifUnit
+
+instance Binary JFifUnit where
+  put v = putWord8 $ case v of
+    JFifUnitUnknown -> 0
+    JFifPixelsPerInch -> 1
+    JFifPixelsPerCentimeter -> 2
+  get = do
+    v <- getWord8
+    pure $ case v of
+      0 -> JFifUnitUnknown
+      1 -> JFifPixelsPerInch
+      2 -> JFifPixelsPerCentimeter
+      _ -> JFifUnitUnknown
+
+data JpgJFIFApp0 = JpgJFIFApp0
+  { _jfifUnit      :: !JFifUnit
+  , _jfifDpiX      :: !Word16
+  , _jfifDpiY      :: !Word16
+  , _jfifThumbnail :: !(Maybe {- (Image PixelRGB8) -} Int)
+  }
+  deriving (Eq, Show, Generic)
+instance NFData JpgJFIFApp0
+
+instance Binary JpgJFIFApp0 where
+  get = do
+    sig <- getByteString 5
+    when (sig /= BC.pack "JFIF\0") $
+        fail "Invalid JFIF signature"
+    major <- getWord8
+    minor <- getWord8
+    when (major /= 1 && minor > 2) $
+        fail "Unrecognize JFIF version"
+    unit <- get
+    dpiX <- getWord16be
+    dpiY <- getWord16be
+    w <- getWord8
+    h <- getWord8
+    let pxCount = 3 * w * h
+    img <- case pxCount of
+      0 -> return Nothing
+      _ -> return Nothing
+    return $ JpgJFIFApp0
+        { _jfifUnit      = unit
+        , _jfifDpiX      = dpiX
+        , _jfifDpiY      = dpiY
+        , _jfifThumbnail = img
+        }
+
+
+  put jfif = do
+    putByteString $ BC.pack "JFIF\0" -- 5
+    putWord8 1                       -- 1 6
+    putWord8 2                       -- 1 7
+    put $ _jfifUnit jfif             -- 1 8
+    putWord16be $ _jfifDpiX jfif     -- 2 10
+    putWord16be $ _jfifDpiY jfif     -- 2 12
+    putWord8 0                       -- 1 13
+    putWord8 0                       -- 1 14
+
+{-Thumbnail width (tw) 	1 	Horizontal size of embedded JFIF thumbnail in pixels-}
+{-Thumbnail height (th) 	1 	Vertical size of embedded JFIF thumbnail in pixels-}
+{-Thumbnail data 	3 × tw × th 	Uncompressed 24 bit RGB raster thumbnail-}
+
+instance Binary AdobeTransform where
+  put v = case v of
+    AdobeUnknown -> putWord8 0
+    AdobeYCbCr -> putWord8 1
+    AdobeYCck -> putWord8 2
+
+  get = do
+    v <- getWord8
+    pure $ case v of
+      0 -> AdobeUnknown
+      1 -> AdobeYCbCr
+      2 -> AdobeYCck
+      _ -> AdobeUnknown
+
+instance Binary JpgAdobeApp14 where
+  get = do
+    let sig = BC.pack "Adobe"
+    fileSig <- getByteString 5
+    when (fileSig /= sig) $
+       fail "Invalid Adobe APP14 marker"
+    version <- getWord16be
+    when (version /= 100) $
+       fail $ "Invalid Adobe APP14 version " ++ show version
+    JpgAdobeApp14 version
+                  <$> getWord16be
+                  <*> getWord16be <*> get
+
+  put (JpgAdobeApp14 v f0 f1 t) = do
+    putByteString $ BC.pack "Adobe"
+    putWord16be v
+    putWord16be f0
+    putWord16be f1
+    put t
+
+
+data JpgFrameHeader = JpgFrameHeader
+    { jpgFrameHeaderLength   :: !Word16
+    , jpgSamplePrecision     :: !Word8
+    , jpgHeight              :: !Word16
+    , jpgWidth               :: !Word16
+    , jpgImageComponentCount :: !Word8
+    , jpgComponents          :: ![JpgComponent]
+    }
+    deriving (Eq, Show, Generic)
+instance NFData JpgFrameHeader
+
+
+instance SizeCalculable JpgFrameHeader where
+    calculateSize hdr = 2 + 1 + 2 + 2 + 1
+                      + sum [calculateSize c | c <- jpgComponents hdr]
+
+data JpgComponent = JpgComponent
+    { componentIdentifier       :: !Word8
+      -- | Stored with 4 bits
+    , horizontalSamplingFactor  :: !Word8
+      -- | Stored with 4 bits
+    , verticalSamplingFactor    :: !Word8
+    , quantizationTableDest     :: !Word8
+    }
+    deriving (Eq, Show, Generic)
+instance NFData JpgComponent
+
+instance SizeCalculable JpgComponent where
+    calculateSize _ = 3
+
+data JpgImage = JpgImage { jpgFrame :: [JpgFrame] }
+    deriving (Eq, Show, Generic)
+instance NFData JpgImage
+
+data JpgScanSpecification = JpgScanSpecification
+    { componentSelector :: !Word8
+      -- | Encoded as 4 bits
+    , dcEntropyCodingTable :: !Word8
+      -- | Encoded as 4 bits
+    , acEntropyCodingTable :: !Word8
+
+    }
+    deriving (Eq, Show, Generic)
+instance NFData JpgScanSpecification
+
+instance SizeCalculable JpgScanSpecification where
+    calculateSize _ = 2
+
+data JpgScanHeader = JpgScanHeader
+    { scanLength :: !Word16
+    , scanComponentCount :: !Word8
+    , scans :: [JpgScanSpecification]
+
+      -- | (begin, end)
+    , spectralSelection    :: (Word8, Word8)
+
+      -- | Encoded as 4 bits
+    , successiveApproxHigh :: !Word8
+
+      -- | Encoded as 4 bits
+    , successiveApproxLow :: !Word8
+    }
+    deriving (Eq, Show, Generic)
+instance NFData JpgScanHeader
+
+instance SizeCalculable JpgScanHeader where
+    calculateSize hdr = 2 + 1
+                      + sum [calculateSize c | c <- scans hdr]
+                      + 2
+                      + 1
+
+data JpgQuantTableSpec = JpgQuantTableSpec
+    { -- | Stored on 4 bits
+      quantPrecision     :: !Word8
+
+      -- | Stored on 4 bits
+    , quantDestination   :: !Word8
+
+    , quantTable         :: MacroBlock Int16
+    }
+    deriving (Eq, Show, Generic)
+instance NFData JpgQuantTableSpec
+
+class SizeCalculable a where
+    calculateSize :: a -> Int
+
+-- | Type introduced only to avoid some typeclass overlapping
+-- problem
+newtype TableList a = TableList [a]
+
+instance (SizeCalculable a, Binary a) => Binary (TableList a) where
+    put (TableList lst) = do
+        putWord16be . fromIntegral $ sum [calculateSize table | table <- lst] + 2
+        mapM_ put lst
+
+    get = TableList <$> (getWord16be >>= \s -> innerParse (fromIntegral s - 2))
+      where innerParse :: Int -> Get [a]
+            innerParse 0    = return []
+            innerParse size = do
+                onStart <- fromIntegral <$> bytesRead
+                table <- get
+                onEnd <- fromIntegral <$> bytesRead
+                (table :) <$> innerParse (size - (onEnd - onStart))
+
+instance SizeCalculable JpgQuantTableSpec where
+    calculateSize table =
+        1 + (fromIntegral (quantPrecision table) + 1) * 64
+
+instance Binary JpgQuantTableSpec where
+    put table = do
+        let precision = quantPrecision table
+        put4BitsOfEach precision (quantDestination table)
+        forM_ (VS.toList $ quantTable table) $ \coeff ->
+            if precision == 0 then putWord8 $ fromIntegral coeff
+                             else putWord16be $ fromIntegral coeff
+
+    get = do
+        (precision, dest) <- get4BitOfEach
+        coeffs <- replicateM 64 $ if precision == 0
+                then fromIntegral <$> getWord8
+                else fromIntegral <$> getWord16be
+        return JpgQuantTableSpec
+            { quantPrecision = precision
+            , quantDestination = dest
+            , quantTable = VS.fromListN 64 coeffs
+            }
+
+data JpgHuffmanTableSpec = JpgHuffmanTableSpec
+    { -- | 0 : DC, 1 : AC, stored on 4 bits
+      huffmanTableClass       :: !DctComponent
+      -- | Stored on 4 bits
+    , huffmanTableDest        :: !Word8
+
+    , huffSizes :: !(VU.Vector Word8)
+    , huffCodes :: !(V.Vector (VU.Vector Word8))
+    }
+    deriving (Eq, Show, Generic)
+instance NFData JpgHuffmanTableSpec
+
+instance SizeCalculable JpgHuffmanTableSpec where
+    calculateSize table = 1 + 16 + sum [fromIntegral e | e <- VU.toList $ huffSizes table]
+
+instance Binary JpgHuffmanTableSpec where
+    put table = do
+        let classVal = if huffmanTableClass table == DcComponent
+                          then 0 else 1
+        put4BitsOfEach classVal $ huffmanTableDest table
+        mapM_ put . VU.toList $ huffSizes table
+        forM_ [0 .. 15] $ \i ->
+            when (huffSizes table ! i /= 0)
+                 (let elements = VU.toList $ huffCodes table V.! i
+                  in mapM_ put elements)
+
+    get = do
+        (huffClass, huffDest) <- get4BitOfEach
+        sizes <- replicateM 16 getWord8
+        codes <- forM sizes $ \s ->
+            VU.replicateM (fromIntegral s) getWord8
+        return JpgHuffmanTableSpec
+            { huffmanTableClass =
+                if huffClass == 0 then DcComponent else AcComponent
+            , huffmanTableDest = huffDest
+            , huffSizes = VU.fromListN 16 sizes
+            , huffCodes = V.fromListN 16 codes
+            }
+
+instance Binary JpgImage where
+    put (JpgImage { jpgFrame = frames }) =
+        putWord8 0xFF >> putWord8 0xD8 >> mapM_ putFrame frames
+            >> putWord8 0xFF >> putWord8 0xD9
+
+    -- | Consider using `getJpgImage` instead for a non-semi-lazy implementation.
+    get = do
+        skipUntilFrames
+        frames <- parseFramesSemiLazy
+        -- let endOfImageMarker = 0xD9
+        {-checkMarker commonMarkerFirstByte endOfImageMarker-}
+        return JpgImage { jpgFrame = frames }
+
+-- | Like `get` from `instance Binary JpgImage`, but without the legacy
+-- semi-lazy implementation.
+getJpgImage :: Get JpgImage
+getJpgImage = do
+    skipUntilFrames
+    frames <- parseFrames
+    return JpgImage { jpgFrame = frames }
+
+skipUntilFrames :: Get ()
+skipUntilFrames = do
+    let startOfImageMarker = 0xD8
+    checkMarker commonMarkerFirstByte startOfImageMarker
+    eatUntilCode
+
+eatUntilCode :: Get ()
+eatUntilCode = do
+    code <- getWord8
+    unless (code == 0xFF) eatUntilCode
+
+takeCurrentFrame :: Get B.ByteString
+takeCurrentFrame = do
+    size <- getWord16be
+    getByteString (fromIntegral size - 2)
+
+putFrame :: JpgFrame -> Put
+putFrame (JpgAdobeAPP14 adobe) =
+    put (JpgAppSegment 14) >> putWord16be 14 >> put adobe
+putFrame (JpgJFIF jfif) =
+    put (JpgAppSegment 0) >> putWord16be (14+2) >> put jfif
+putFrame (JpgExif exif) = putExif exif
+putFrame (JpgAppFrame appCode str) =
+    put (JpgAppSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str
+putFrame (JpgExtension appCode str) =
+    put (JpgExtensionSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str
+putFrame (JpgQuantTable tables) =
+    put JpgQuantizationTable >> put (TableList tables)
+putFrame (JpgHuffmanTable tables) =
+    put JpgHuffmanTableMarker >> put (TableList $ map fst tables)
+putFrame (JpgIntervalRestart size) =
+    put JpgRestartInterval >> put (RestartInterval size)
+putFrame (JpgScanBlob hdr blob) =
+    put JpgStartOfScan >> put hdr >> putLazyByteString blob
+putFrame (JpgScans kind hdr) =
+    put kind >> put hdr
+
+--------------------------------------------------
+----            Serialization instances
+--------------------------------------------------
+commonMarkerFirstByte :: Word8
+commonMarkerFirstByte = 0xFF
+
+checkMarker :: Word8 -> Word8 -> Get ()
+checkMarker b1 b2 = do
+    rb1 <- getWord8
+    rb2 <- getWord8
+    when (rb1 /= b1 || rb2 /= b2)
+         (fail "Invalid marker used")
+
+-- | Simpler implementation of `parseECS` to allow an easier understanding
+-- of the logic, and to provide a comparison for correctness.
+parseECS_simple :: Get L.ByteString
+parseECS_simple = do
+    -- There's no efficient way in `binary` to parse byte-by-byte while assembling a
+    -- resulting ByteString (without using `.Internal` modules, which is what
+    --  `parseECS` does), so instead first compute the length of the content
+    -- byte-by-byte inside a `lookAhead` (not advancing the parser offset), and
+    -- then efficiently take that long a ByteString (advancing the parser offset).
+    --
+    -- This is still slow compared to `parseECS` because parser functions
+    -- (`getWord8`) are used repeatedly, instead of plain loops over ByteString contents.
+    -- The slowdown is ~2x on GHC 8.10.7 on an Intel Core i7-7500U.
+    n <- lookAhead getContentLength
+    getLazyByteString n
+  where
+    getContentLength :: Get ByteOffset
+    getContentLength = do
+        bytesReadBeforeContent <- bytesRead
+        let loop :: Word8 -> Get ByteOffset
+            loop !v = do
+                vNext <- getWord8
+                let isReset = 0xD0 <= vNext && vNext <= 0xD7
+                let vIsSegmentMarker = v == 0xFF && vNext /= 0 && not isReset
+                if not vIsSegmentMarker
+                    then loop vNext
+                    else do
+                        bytesReadAfterContentPlus2 <- bytesRead -- "plus 2" because we've also read the segment marker (0xFF and `vNext`)
+                        let !contentLength = (bytesReadAfterContentPlus2 - 2) - bytesReadBeforeContent
+                        return contentLength
+
+        v_first <- getWord8
+        loop v_first
+
+-- Replace by `Data.ByteString.dropEnd` once we require `bytestring >= 0.11.1.0`.
+bsDropEnd :: Int -> B.ByteString -> B.ByteString
+bsDropEnd n bs
+    | n <= 0    = bs
+    | n >= len  = B.empty
+    | otherwise = B.take (len - 1) bs
+  where
+    len = B.length bs
+{-# INLINE bsDropEnd #-}
+
+-- | Parses a Scan's ECS (Entropy-Coded Segment, the largest part of compressed image data)
+-- from the `Get` stream.
+--
+-- When this function is called, the parser's offset should be
+-- immediately behind the SOS tag.
+--
+-- As described on e.g. https://www.ccoderun.ca/programming/2017-01-31_jpeg/,
+--
+-- > To find the next segment after the SOS, you must keep reading until you
+-- > find a 0xFF bytes which is not immediately followed by 0x00 (see "byte stuffing")
+-- > [or a reset marker's byte: 0xD0 through 0xD7].
+-- > Normally, this will be the EOI segment that comes at the end of the file.
+--
+-- where the 0xFF is the next segment's marker.
+-- See https://github.com/corkami/formats/blob/master/image/jpeg.md#entropy-coded-segment
+-- for more details.
+--
+-- This function returns the ECS, not including the next segment's
+-- marker on its trailing end.
+parseECS :: Get L.ByteString
+parseECS = do
+    -- For a simpler but slower implementation of this function, see
+    -- `parseECS_simple`.
+
+    v_first <- getWord8
+    -- TODO: Compare with what `scan` from `binary-parsers` does.
+    --       Probably we cannot use it because it does not allow us to set the parser state
+    --       to be _before_ the segment marker which would be convenient to not have to
+    --       make a special case the function that calls this function.
+    --       But `scan` works on pointers into the bytestring chunks. Why, for performance?
+    --       I've asked on https://github.com/winterland1989/binary-parsers/issues/7
+    --       If that is for performance, we may want to replicate the same thing here.
+    --
+    --       An orthogonal idea is to use `Data.ByteString.elemIndex` to fast-forward
+    --       to the next 0xFF using `memchr`, but the `unsafe` call to `memchr` might
+    --       have too much overhead, since 0xFF bytes appear statistically every 256 bytes.
+    --       See https://stackoverflow.com/questions/14519905/how-much-does-it-cost-for-haskell-ffi-to-go-into-c-and-back
+
+    -- `withInputChunks` allows us to work on chunks of ByteStrings,
+    -- reducing the number of higher-overhead `Get` functions called.
+    -- It also allows to easily assemble the ByteString to return,
+    -- which may be cross-chunk.
+    -- `withInputChunks` terminates when we return a
+    --     Right (consumed :: ByteString, unconsumed :: ByteString)
+    -- from `consumeChunk`, setting the `Get` parser's offset to just before `unconsumed`.
+    -- Because the segment marker we seek may be the 2 bytes across chunk boundaries,
+    -- we need to keep a reference to the previous chunk (initialised as `B.empty`),
+    -- so that we can set `consumed` properly, because this function is supposed
+    -- to not consume the start of the segment marker (see code dropping the last
+    -- byte of the previous chunk below).
+    GetInternal.withInputChunks
+        (v_first, B.empty)
+        consumeChunk
+        (         L.fromChunks . (B.singleton v_first :)) -- `v_first` also belongs to the returned BS
+        (return . L.fromChunks . (B.singleton v_first :)) -- `v_first` also belongs to the returned BS
+  where
+    consumeChunk :: GetInternal.Consume (Word8, B.ByteString) -- which is: (Word8, B.ByteString) -> B.ByteString -> Either (Word8, B.ByteString) (B.ByteString, B.ByteString)
+    consumeChunk (!v_chunk_start, !prev_chunk) !chunk
+        -- If `withInputChunks` hands us an empty chunk (which `binary` probably
+        -- won't do, but since that's not documented, handle it anyway) then skip over it,
+        -- so that we always remember the last `prev_chunk` that actually has data in it,
+        -- since we `bsDropEnd 1 prev_chunk` in the `case` below.
+        | B.null chunk = Left (v_chunk_start, prev_chunk)
+        | otherwise = loop v_chunk_start 0
+          where
+            loop :: Word8 -> Int -> Either (Word8, B.ByteString) (B.ByteString, B.ByteString)
+            loop !v !offset_in_chunk
+                | offset_in_chunk >= B.length chunk = Left (v, chunk)
+                | otherwise =
+                    let !vNext = BU.unsafeIndex chunk offset_in_chunk -- bounds check is done above
+                        !isReset = 0xD0 <= vNext && vNext <= 0xD7
+                        !vIsSegmentMarker = v == 0xFF && vNext /= 0 && not isReset
+                    in
+                        if not vIsSegmentMarker
+                            then loop vNext (offset_in_chunk+1)
+                            else
+                                -- Set the parser state to _before_ the segment marker.
+                                -- The first case, where the segment marker's 2 bytes are exactly
+                                -- at the chunk boundary, requires us to allocate a new BS with
+                                -- `B.cons`; luckily this case should be rare.
+                                let (!consumed, !unconsumed) = case () of
+                                     () | offset_in_chunk == 0 -> (bsDropEnd 1 prev_chunk, v `B.cons` chunk) -- segment marker starts at `v`, which is the last byte of the previous chunk
+                                        | offset_in_chunk == 1 -> (B.empty, chunk) -- segment marker starts exactly at `chunk`
+                                        | otherwise            -> B.splitAt (offset_in_chunk - 1) chunk -- segment marker starts at `v`, which is 1 before `vNext` (which is at `offset_in_chunk`)
+                                in Right $! (consumed, unconsumed)
+
+
+
+parseAdobe14 :: B.ByteString -> Maybe JpgFrame
+parseAdobe14 str = case runGetStrict get str of
+    Left _err -> Nothing
+    Right app14 -> Just $! JpgAdobeAPP14 app14
+
+-- | Parse JFIF or JFXX information. Right now only JFIF.
+parseJF__ :: B.ByteString -> Maybe JpgFrame
+parseJF__ str = case runGetStrict get str of
+    Left _err -> Nothing
+    Right jfif -> Just $! JpgJFIF jfif
+
+parseExif :: B.ByteString -> Maybe JpgFrame
+parseExif str
+  | exifHeader `B.isPrefixOf` str =
+      let
+        tiff = B.drop (B.length exifHeader) str
+      in
+        case runGetStrict (getP tiff) tiff of
+            Left _err -> Nothing
+            Right (_hdr :: TiffHeader, []) -> Nothing
+            Right (_hdr :: TiffHeader, ifds : _) -> Just $! JpgExif ifds
+  | otherwise = Nothing
+  where
+    exifHeader = BC.pack "Exif\0\0"
+
+putExif :: [ImageFileDirectory] -> Put
+putExif ifds = putAll where
+  hdr = TiffHeader
+    { hdrEndianness = EndianBig
+    , hdrOffset = 8
+    }
+
+  ifdList = case partition (isInIFD0 . ifdIdentifier) ifds of
+    (ifd0, []) -> [ifd0]
+    (ifd0, ifdExif) -> [ifd0 <> pure exifOffsetIfd, ifdExif]
+
+  exifBlob = runPut $ do
+    putByteString $ BC.pack "Exif\0\0"
+    putP BC.empty (hdr, ifdList)
+
+  putAll = do
+    put (JpgAppSegment 1)
+    putWord16be . fromIntegral $ L.length exifBlob + 2
+    putLazyByteString exifBlob
+
+skipFrameMarker :: Get ()
+skipFrameMarker = do
+    word <- getWord8
+    when (word /= 0xFF) $ do
+        readedData <- bytesRead
+        fail $ "Invalid Frame marker (" ++ show word
+                ++ ", bytes read : " ++ show readedData ++ ")"
+
+-- | Parses a single frame.
+--
+-- Returns `Nothing` when we encounter a frame we want to skip.
+parseFrameOfKind :: JpgFrameKind -> Get (Maybe JpgFrame)
+parseFrameOfKind kind = do
+    case kind of
+        JpgEndOfImage -> return Nothing
+        JpgAppSegment 0 -> parseJF__ <$> takeCurrentFrame
+        JpgAppSegment 1 -> parseExif <$> takeCurrentFrame
+        JpgAppSegment 14 -> parseAdobe14 <$> takeCurrentFrame
+        JpgAppSegment c -> Just . JpgAppFrame c <$> takeCurrentFrame
+        JpgExtensionSegment c -> Just . JpgExtension c <$> takeCurrentFrame
+        JpgQuantizationTable ->
+            (\(TableList quants) -> Just $! JpgQuantTable quants) <$> get
+        JpgRestartInterval ->
+            (\(RestartInterval i) -> Just $! JpgIntervalRestart i) <$> get
+        JpgHuffmanTableMarker ->
+            (\(TableList huffTables) -> Just $!
+                    JpgHuffmanTable [(t, packHuffmanTree . buildPackedHuffmanTree $ huffCodes t) | t <- huffTables])
+                    <$> get
+        JpgStartOfScan -> do
+            scanHeader <- get
+            ecs <- parseECS
+            return $! Just $! JpgScanBlob scanHeader ecs
+        _ -> Just . JpgScans kind <$> get
+
+
+-- | Parse a list of `JpgFrame`s.
+--
+-- This function has various quirks; consider the below with great caution
+-- when using this function.
+--
+-- While @data JpgFrame = ... | JpgScanBlob !...` itself has strict fields,
+--
+-- This function is written in such a way that that it can construct
+-- the @[JpgFrame]@ "lazily" such that the expensive byte-by-byte traversal
+-- in `parseECS` to create a `JpgScanBlob` can be avoided if only
+-- list elements before that `JpgScanBlob` are evaluated.
+--
+-- That means the user can write code such as
+--
+-- > let mbFirstScan =
+-- >       case runGetOrFail (get @JPG.JpgImage) hugeImageByteString of -- (`get @JPG.JpgImage` uses `parseFramesSemiLazy`)
+-- >         Right (_restBs, _offset, res) ->
+-- >           find (\frame -> case frame of { JPG.JpgScans{} -> True; _ -> False }) (JPG.jpgFrame res)
+--
+-- with the guarantee that only the bytes before the ECS (large compressed image data)
+-- will be inspected, assuming that indeed there is at least 1 `JpgScan` in front
+-- of the `JpgScanBlob` that contains the ECS.
+--
+-- This guarantee can be useful to e.g. quickly read just the image
+-- dimensions (width, height) without traversing the large data.
+--
+-- Also note that this `Get` parser does not correctly maintain the parser byte offset
+-- (`Data.Binary.Get.bytesRead`), because as soon as a `JpgStartOfScan` is returned,
+-- it uses `Data.Binary.Get.getRemainingLazyBytes` to provide:
+--
+-- 1. the laziness described above, and
+-- 2. the ability to ignore any parser failure after the first successfully-parsed
+--    `JpgScanBlob` (it is debatable whether this behaviour is a desirable behaviour of this
+--    library, but it is historically so and existing exposed functions do not break
+--    this for backwards compatibility with existing uses of this library).
+--    This fact also means that even `parseNextFrameStrict` cannot maintain
+--    correct parser byte offsets.
+--
+-- Further note that if you are reading a huge JPEG image from disk strictly,
+-- this will already incur a full traversal (namely creation) of the `hugeImageByteString`.
+-- Thus, `parseNextFrameLazy` only provides any benefit if you:
+--
+-- - read the image from disk using lazy IO (not recommended!) such as via
+--   `Data.ByteString.Lazy.readFile`,
+-- - or do something similar, such as creating the `hugeImageByteString` via @mmap()@
+--
+-- This function is called "semi lazy" because only the first `JpgScanBlob` returned
+-- in the `[JpgFrame]` is returned lazily; frames of other types, or multiple
+-- `JpgScanBlob`s, are confusingly not dealt with lazily.
+--
+-- If as a caller you do not want to deal with any of these quirks,
+-- and use proper strict IO and/or via `Data.Binary.Get`'s incremental input interface:
+--
+-- - If you want the whole `[JpgFrame]`: use `parseFrames`.
+-- - If you want parsing to terminate early as in the example shown above,
+--   use in combination with just the right amount of `get :: Get JpgFrameKind`,
+--   `parseFrameOfKind`, and `skipFrameMarker`.
+parseFramesSemiLazy :: Get [JpgFrame]
+parseFramesSemiLazy = do
+    kind <- get
+    case kind of
+        -- The end-of-image case needs to be here because `_ ->` default case below
+        -- unconditionally uses `skipFrameMarker` which does not exist after `JpgEndOfImage`.
+        JpgEndOfImage -> pure []
+        JpgStartOfScan -> do
+            scanHeader <- get
+            remainingBytes <- getRemainingLazyBytes
+            -- It is after the above `getRemainingLazyBytes` that the `Get` parser lazily succeeds,
+            -- allowing consumers of `parseFramesSemiLazy` evaluate all `[JpgFrame]` list elements
+            -- until (excluding) the cons-cell around the `JpgScanBlob ...` we construct below.
+
+            return $ case runGet parseECS remainingBytes of
+                Left _ ->
+                    -- Construct invalid `JpgScanBlob` even when the compressed JPEG
+                    -- data is truncated or otherwise invalid, because that's what JuicyPixels's
+                    -- `parseFramesSemiLazy` function did in the past, for backwards compat.
+                    [JpgScanBlob scanHeader remainingBytes]
+                Right ecs ->
+                    JpgScanBlob scanHeader ecs
+                    :
+                    -- TODO Why `drop 1` instead of `runGet (skipFrameMarker *> parseFramesSemiLazy) remainingBytes` that would check that the dropped 1 Byte is really a frame marker?
+                    case runGet parseFramesSemiLazy (L.drop (L.length ecs + 1) remainingBytes) of
+                        -- After we've encountered the first scan blob containing encoded image data,
+                        -- we accept anything else after to fail parsing, ignoring that failure,
+                        -- end emitting no further frames.
+                        -- TODO: Explain why JuicyPixel chose to use this logic, insteaed of failing.
+                        Left _ -> []
+                        Right remainingFrames -> remainingFrames
+        _ -> do
+            mbFrame <- parseFrameOfKind kind
+            skipFrameMarker
+            remainingFrames <- parseFramesSemiLazy
+            return $ maybeToList mbFrame ++ remainingFrames
+
+-- | Parse a list of `JpgFrame`s.
+parseFrames :: Get [JpgFrame]
+parseFrames = do
+    kind <- get
+    case kind of
+        JpgEndOfImage -> pure []
+        _ -> do
+            mbFrame <- parseFrameOfKind kind
+            skipFrameMarker
+            remainingFrames <- parseFrames
+            return $ maybeToList mbFrame ++ remainingFrames
+
+-- | Parse a list of `JpgFrameKind`s with their corresponding offsets and lengths
+-- (not counting the segment and frame markers into the lengths).
+--
+-- Useful for debugging.
+parseFrameKinds :: Get [(JpgFrameKind, Int64, Int64)]
+parseFrameKinds = do
+    kindMarkerOffset :: Int64 <- bytesRead
+    kind <- get
+    case kind of
+        JpgEndOfImage -> pure [(JpgEndOfImage, kindMarkerOffset, 0)]
+        _ -> do
+            parserOffsetBefore <- bytesRead
+            _ <- parseFrameOfKind kind
+            parserOffsetAfter <- bytesRead
+            let !segmentLengthWithoutMarker = parserOffsetAfter - parserOffsetBefore
+            skipFrameMarker
+            remainingKinds <- parseFrameKinds
+            return $ (kind, kindMarkerOffset, segmentLengthWithoutMarker):remainingKinds
+
+-- | Parses forward, returning the first scan header encountered.
+--
+-- Should be used after `skipUntilFrames`.
+--
+-- Fails parsing when an SOS segment marker (`JpgStartOfScan`, resulting
+-- in `JpgScanBlob`) is encountered before an SOF segment marker (that
+-- results in `JpgScans` carrying the `JpgFrameHeader`).
+parseToFirstFrameHeader :: Get (Maybe JpgFrameHeader)
+parseToFirstFrameHeader = do
+    kind <- get
+    case kind of
+        JpgEndOfImage -> return Nothing
+        JpgStartOfScan -> fail "parseToFirstFrameHeader: Encountered SOS frame marker before frame header that tells its dimensions"
+        _ -> do
+            mbFrame <- parseFrameOfKind kind
+            case mbFrame of
+                Nothing -> continueSearching
+                Just frame -> case frame of
+                    JpgScans _ frameHeader -> return $ Just $! frameHeader
+                    _ -> continueSearching
+  where
+    continueSearching = do
+        skipFrameMarker
+        parseToFirstFrameHeader
+
+buildPackedHuffmanTree :: V.Vector (VU.Vector Word8) -> HuffmanTree
+buildPackedHuffmanTree = buildHuffmanTree . map VU.toList . V.toList
+
+secondStartOfFrameByteOfKind :: JpgFrameKind -> Word8
+secondStartOfFrameByteOfKind = aux
+  where
+    aux JpgBaselineDCTHuffman = 0xC0
+    aux JpgExtendedSequentialDCTHuffman = 0xC1
+    aux JpgProgressiveDCTHuffman = 0xC2
+    aux JpgLosslessHuffman = 0xC3
+    aux JpgDifferentialSequentialDCTHuffman = 0xC5
+    aux JpgDifferentialProgressiveDCTHuffman = 0xC6
+    aux JpgDifferentialLosslessHuffman = 0xC7
+    aux JpgExtendedSequentialArithmetic = 0xC9
+    aux JpgProgressiveDCTArithmetic = 0xCA
+    aux JpgLosslessArithmetic = 0xCB
+    aux JpgHuffmanTableMarker = 0xC4
+    aux JpgDifferentialSequentialDCTArithmetic = 0xCD
+    aux JpgDifferentialProgressiveDCTArithmetic = 0xCE
+    aux JpgDifferentialLosslessArithmetic = 0xCF
+    aux JpgEndOfImage = 0xD9
+    aux JpgQuantizationTable = 0xDB
+    aux JpgStartOfScan = 0xDA
+    aux JpgRestartInterval = 0xDD
+    aux (JpgRestartIntervalEnd v) = v
+    aux (JpgAppSegment a) = (a + 0xE0)
+    aux (JpgExtensionSegment a) = a
+
+data JpgImageKind = BaseLineDCT | ProgressiveDCT
+
+instance Binary JpgFrameKind where
+    put v = putWord8 0xFF >> put (secondStartOfFrameByteOfKind v)
+    get = do
+        -- no lookahead :(
+        {-word <- getWord8-}
+        word2 <- getWord8
+        case word2 of
+            0xC0 -> return JpgBaselineDCTHuffman
+            0xC1 -> return JpgExtendedSequentialDCTHuffman
+            0xC2 -> return JpgProgressiveDCTHuffman
+            0xC3 -> return JpgLosslessHuffman
+            0xC4 -> return JpgHuffmanTableMarker
+            0xC5 -> return JpgDifferentialSequentialDCTHuffman
+            0xC6 -> return JpgDifferentialProgressiveDCTHuffman
+            0xC7 -> return JpgDifferentialLosslessHuffman
+            0xC9 -> return JpgExtendedSequentialArithmetic
+            0xCA -> return JpgProgressiveDCTArithmetic
+            0xCB -> return JpgLosslessArithmetic
+            0xCD -> return JpgDifferentialSequentialDCTArithmetic
+            0xCE -> return JpgDifferentialProgressiveDCTArithmetic
+            0xCF -> return JpgDifferentialLosslessArithmetic
+            0xD9 -> return JpgEndOfImage
+            0xDA -> return JpgStartOfScan
+            0xDB -> return JpgQuantizationTable
+            0xDD -> return JpgRestartInterval
+            a | a >= 0xF0 -> return $! JpgExtensionSegment a
+              | a >= 0xE0 -> return $! JpgAppSegment (a - 0xE0)
+              | a >= 0xD0 && a <= 0xD7 -> return $! JpgRestartIntervalEnd a
+              | otherwise -> fail ("Invalid frame marker (" ++ show a ++ ")")
+
+put4BitsOfEach :: Word8 -> Word8 -> Put
+put4BitsOfEach a b = put $ (a `unsafeShiftL` 4) .|. b
+
+get4BitOfEach :: Get (Word8, Word8)
+get4BitOfEach = do
+    val <- get
+    return ((val `unsafeShiftR` 4) .&. 0xF, val .&. 0xF)
+
+newtype RestartInterval = RestartInterval Word16
+
+instance Binary RestartInterval where
+    put (RestartInterval i) = putWord16be 4 >> putWord16be i
+    get = do
+        size <- getWord16be
+        when (size /= 4) (fail "Invalid jpeg restart interval size")
+        RestartInterval <$> getWord16be
+
+instance Binary JpgComponent where
+    get = do
+        ident <- getWord8
+        (horiz, vert) <- get4BitOfEach
+        quantTableIndex <- getWord8
+        return JpgComponent
+            { componentIdentifier = ident
+            , horizontalSamplingFactor = horiz
+            , verticalSamplingFactor = vert
+            , quantizationTableDest = quantTableIndex
+            }
+    put v = do
+        put $ componentIdentifier v
+        put4BitsOfEach (horizontalSamplingFactor v) $ verticalSamplingFactor v
+        put $ quantizationTableDest v
+
+instance Binary JpgFrameHeader where
+    get = do
+        beginOffset <- fromIntegral <$> bytesRead
+        frmHLength <- getWord16be
+        samplePrec <- getWord8
+        h <- getWord16be
+        w <- getWord16be
+        compCount <- getWord8
+        components <- replicateM (fromIntegral compCount) get
+        endOffset <- fromIntegral <$> bytesRead
+        when (beginOffset - endOffset < fromIntegral frmHLength)
+             (skip $ fromIntegral frmHLength - (endOffset - beginOffset))
+        return JpgFrameHeader
+            { jpgFrameHeaderLength = frmHLength
+            , jpgSamplePrecision = samplePrec
+            , jpgHeight = h
+            , jpgWidth = w
+            , jpgImageComponentCount = compCount
+            , jpgComponents = components
+            }
+
+    put v = do
+        putWord16be $ jpgFrameHeaderLength v
+        putWord8    $ jpgSamplePrecision v
+        putWord16be $ jpgHeight v
+        putWord16be $ jpgWidth v
+        putWord8    $ jpgImageComponentCount v
+        mapM_ put   $ jpgComponents v
+
+instance Binary JpgScanSpecification where
+    put v = do
+        put $ componentSelector v
+        put4BitsOfEach (dcEntropyCodingTable v) $ acEntropyCodingTable v
+
+    get = do
+        compSel <- get
+        (dc, ac) <- get4BitOfEach
+        return JpgScanSpecification {
+            componentSelector = compSel
+          , dcEntropyCodingTable = dc
+          , acEntropyCodingTable = ac
+          }
+
+instance Binary JpgScanHeader where
+    get = do
+        thisScanLength <- getWord16be
+        compCount <- getWord8
+        comp <- replicateM (fromIntegral compCount) get
+        specBeg <- get
+        specEnd <- get
+        (approxHigh, approxLow) <- get4BitOfEach
+
+        return JpgScanHeader {
+            scanLength = thisScanLength,
+            scanComponentCount = compCount,
+            scans = comp,
+            spectralSelection = (specBeg, specEnd),
+            successiveApproxHigh = approxHigh,
+            successiveApproxLow = approxLow
+        }
+
+    put v = do
+        putWord16be $ scanLength v
+        putWord8 $ scanComponentCount v
+        mapM_ put $ scans v
+        putWord8 . fst $ spectralSelection v
+        putWord8 . snd $ spectralSelection v
+        put4BitsOfEach (successiveApproxHigh v) $ successiveApproxLow v
+
+{-# INLINE createEmptyMutableMacroBlock #-}
+-- | Create a new macroblock with the good array size
+createEmptyMutableMacroBlock :: (Storable a, Num a) => ST s (MutableMacroBlock s a)
+createEmptyMutableMacroBlock = M.replicate 64 0
+
+printMacroBlock :: (Storable a, PrintfArg a)
+                => MutableMacroBlock s a -> ST s String
+printMacroBlock block = pLn 0
+    where pLn 64 = return "===============================\n"
+          pLn i = do
+              v <- block `M.unsafeRead` i
+              vn <- pLn (i+1)
+              return $ printf (if i `mod` 8 == 0 then "\n%5d " else "%5d ") v ++ vn
+
+printPureMacroBlock :: (Storable a, PrintfArg a) => MacroBlock a -> String
+printPureMacroBlock block = pLn 0
+    where pLn 64 = "===============================\n"
+          pLn i = str ++ pLn (i + 1)
+            where str | i `mod` 8 == 0 = printf "\n%5d " v
+                      | otherwise = printf "%5d" v
+                  v = block VS.! i
+
+
+{-# INLINE dctBlockSize #-}
+dctBlockSize :: Num a => a
+dctBlockSize = 8
+ src/Codec/Picture/Metadata.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+-- | This module expose a common "metadata" storage for various image
+-- type. Different format can generate different metadatas, and write
+-- only a part of them.
+--
+-- Since version 3.2.5
+--
+module Codec.Picture.Metadata( -- * Types
+                               Metadatas
+                             , Keys( .. )
+                             , Value( .. )
+                             , Elem( .. )
+                             , SourceFormat( .. )
+                             , ColorSpace( .. )
+
+                               -- * Functions
+                             , Codec.Picture.Metadata.lookup
+                             , empty
+                             , insert
+                             , delete
+                             , singleton
+
+                               -- * Folding
+                             , foldl'
+                             , Codec.Picture.Metadata.foldMap
+
+                              -- * Helper functions
+                             , mkDpiMetadata
+                             , mkSizeMetadata
+                             , basicMetadata
+                             , simpleMetadata
+                             , extractExifMetas
+
+                               -- * Conversion functions
+                             , dotsPerMeterToDotPerInch
+                             , dotPerInchToDotsPerMeter 
+                             , dotsPerCentiMeterToDotPerInch
+                             ) where
+
+import Prelude hiding (Foldable(..))
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid( Monoid, mempty, mappend )
+import Data.Word( Word )
+#endif
+
+
+import Control.DeepSeq( NFData( .. ) )
+import qualified Data.ByteString as B
+import qualified Data.Foldable as F
+
+import Codec.Picture.Metadata.Exif
+
+#if MIN_VERSION_base(4,7,0)
+import Data.Typeable( (:~:)( Refl ) )
+type Equiv = (:~:)
+#else
+data Equiv a b where
+    Refl :: Equiv a a
+#endif
+
+-- | Type describing the original file format of the file.
+data SourceFormat
+  = SourceJpeg
+  | SourceGif
+  | SourceBitmap
+  | SourceTiff
+  | SourcePng
+  | SourceHDR
+  | SourceTGA
+  deriving (Eq, Show)
+
+instance NFData SourceFormat where
+  rnf a = a `seq` ()
+
+-- | The same color values may result in slightly different colors on different
+-- devices. To get consistent colors accross multiple devices we need a way of
+-- mapping color values from a source device into their equivalents on the
+-- target device.
+--
+-- The solution is essentially to define, for each device, a family of mappings
+-- that convert between device colors and standard CIEXYZ or CIELAB colors. The
+-- collection of mappings for a device is known as the 'color-profile' of that
+-- device, and each color-profile can be thought of as describing a
+-- 'color-space'.
+--
+-- If we know the color-space of the input pixels, and the color space of the
+-- output device, then we can convert the colors in the image to their
+-- equivalents on the output device.
+--
+-- JuicyPixels does not parse color-profiles or attempt to perform color
+-- correction.
+--
+-- The following color space types are recognised:
+--
+--   * sRGB: Standard RGB color space.
+--   * Windows BMP color space: Color space information embedded within a V4
+--         Windows BMP file.
+--   * ICC profile: An ICC color profile.
+data ColorSpace = SRGB
+                | WindowsBitmapColorSpace !B.ByteString
+                | ICCProfile !B.ByteString
+                deriving (Eq, Show)
+
+instance NFData ColorSpace where
+  rnf v = v `seq` ()
+
+-- | Store various additional information about an image. If
+-- something is not recognized, it can be stored in an unknown tag.
+--
+--   * 'DpiX' Dot per inch on this x axis.
+--
+--   * 'DpiY' Dot per inch on this y axis.
+--
+--   * 'Width' Image width in pixel. Relying on the metadata for this
+--          information can avoid the full decompression of the image.
+--          Ignored for image writing.
+--
+--   * 'Height' Image height in pixels. Relying on the metadata for this
+--          information can void the full decompression of the image.
+--          Ignored for image writing.
+--
+--   * 'ColorProfile' An unparsed ICC color profile. Currently only supported by
+--          the Bitmap format.
+--
+--   * 'Unknown' unlikely to be decoded, but usefull for metadata writing
+--
+--   * 'Exif' Exif tag and associated data.
+--
+data Keys a where
+  Gamma       :: Keys Double
+  ColorSpace  :: Keys ColorSpace
+  Format      :: Keys SourceFormat
+  DpiX        :: Keys Word
+  DpiY        :: Keys Word
+  Width       :: Keys Word
+  Height      :: Keys Word
+  Title       :: Keys String
+  Description :: Keys String
+  Author      :: Keys String
+  Copyright   :: Keys String
+  Software    :: Keys String
+  Comment     :: Keys String
+  Disclaimer  :: Keys String
+  Source      :: Keys String
+  Warning     :: Keys String
+  Exif        :: !ExifTag -> Keys ExifData
+  Unknown     :: !String -> Keys Value
+
+deriving instance Show (Keys a)
+deriving instance Eq (Keys a)
+{-deriving instance Ord (Keys a)-}
+
+-- | Encode values for unknown information
+data Value
+  = Int    !Int
+  | Double !Double
+  | String !String
+  deriving (Eq, Show)
+
+instance NFData Value where
+  rnf v = v `seq` () -- everything is strict, so it's OK
+
+-- | Element describing a metadata and it's (typed) associated
+-- value.
+data Elem k =
+  forall a. (Show a, NFData a) => !(k a) :=> a
+
+deriving instance Show (Elem Keys)
+
+instance NFData (Elem Keys) where
+  rnf (_ :=> v) = rnf v `seq` ()
+
+keyEq :: Keys a -> Keys b -> Maybe (Equiv a b)
+keyEq a b = case (a, b) of
+  (Gamma, Gamma) -> Just Refl
+  (ColorSpace, ColorSpace) -> Just Refl
+  (DpiX, DpiX) -> Just Refl
+  (DpiY, DpiY) -> Just Refl
+  (Width, Width) -> Just Refl
+  (Height, Height) -> Just Refl
+  (Title, Title) -> Just Refl
+  (Description, Description) -> Just Refl
+  (Author, Author) -> Just Refl
+  (Copyright, Copyright) -> Just Refl
+  (Software, Software) -> Just Refl
+  (Comment, Comment) -> Just Refl
+  (Disclaimer, Disclaimer) -> Just Refl
+  (Source, Source) -> Just Refl
+  (Warning, Warning) -> Just Refl
+  (Format, Format) -> Just Refl
+  (Unknown v1, Unknown v2) | v1 == v2 -> Just Refl
+  (Exif t1, Exif t2) | t1 == t2 -> Just Refl
+  _ -> Nothing
+
+-- | Dependent storage used for metadatas.
+-- All metadatas of a given kind are unique within
+-- this container.
+    --
+-- The current data structure is based on list,
+-- so bad performances can be expected.
+newtype Metadatas = Metadatas
+  { getMetadatas :: [Elem Keys]
+  }
+  deriving (Show, NFData)
+
+instance Monoid Metadatas where
+  mempty = empty
+#if !MIN_VERSION_base(4,11,0)
+  mappend = union
+#else
+instance Semigroup Metadatas where
+  (<>) = union
+#endif
+
+-- | Right based union
+union :: Metadatas -> Metadatas -> Metadatas
+union m1 = F.foldl' go m1 . getMetadatas where
+  go acc el@(k :=> _) = Metadatas $ el : getMetadatas (delete k acc)
+
+-- | Strict left fold of the metadatas
+foldl' :: (acc -> Elem Keys -> acc) -> acc -> Metadatas -> acc
+foldl' f initAcc = F.foldl' f initAcc . getMetadatas
+
+-- | foldMap equivalent for metadatas.
+foldMap :: Monoid m => (Elem Keys -> m) -> Metadatas -> m
+foldMap f = foldl' (\acc v -> acc `mappend` f v) mempty
+
+-- | Remove an element of the given keys from the metadatas.
+-- If not present does nothing.
+delete :: Keys a -> Metadatas -> Metadatas
+delete k = Metadatas . go . getMetadatas where
+  go [] = []
+  go (el@(k2 :=> _) : rest) = case keyEq k k2 of
+    Nothing -> el : go rest
+    Just Refl -> rest
+
+-- | Extract all Exif specific metadatas
+extractExifMetas :: Metadatas -> [(ExifTag, ExifData)]
+extractExifMetas = go . getMetadatas where
+  go :: [Elem Keys] -> [(ExifTag, ExifData)]
+  go [] = []
+  go ((k :=> v) : rest) =
+    case k of
+      Exif t -> (t, v) : go rest
+      _ -> go rest
+
+-- | Search a metadata with the given key.
+lookup :: Keys a -> Metadatas -> Maybe a
+lookup k = go . getMetadatas where
+  go [] = Nothing
+  go ((k2 :=> v) : rest) = case keyEq k k2 of
+    Nothing -> go rest
+    Just Refl -> Just v
+
+-- | Insert an element in the metadatas, if an element with
+-- the same key is present, it is overwritten.
+insert :: (Show a, NFData a) => Keys a -> a -> Metadatas -> Metadatas
+insert k val metas =
+  Metadatas $ (k :=> val) : getMetadatas (delete k metas)
+
+-- | Create metadatas with a single element.
+singleton :: (Show a, NFData a) => Keys a -> a -> Metadatas
+singleton k val = Metadatas [k :=> val]
+
+-- | Empty metadatas. Favor 'mempty'
+empty :: Metadatas
+empty = Metadatas mempty
+
+-- | Conversion from dpm to dpi
+dotsPerMeterToDotPerInch :: Word -> Word
+dotsPerMeterToDotPerInch z = z * 254 `div` 10000
+
+-- | Conversion from dpi to dpm
+dotPerInchToDotsPerMeter :: Word -> Word
+dotPerInchToDotsPerMeter z = (z * 10000) `div` 254
+
+-- | Conversion dpcm -> dpi
+dotsPerCentiMeterToDotPerInch :: Word -> Word
+dotsPerCentiMeterToDotPerInch z = z * 254 `div` 100
+
+-- | Create metadatas indicating the resolution, with DpiX == DpiY
+mkDpiMetadata :: Word -> Metadatas
+mkDpiMetadata w =
+  Metadatas [DpiY :=> w, DpiX :=> w]
+
+-- | Create metadatas holding width and height information.
+mkSizeMetadata :: Integral n => n -> n -> Metadatas
+mkSizeMetadata w h = 
+  Metadatas [ Width :=> fromIntegral w, Height :=> fromIntegral h ]
+
+-- | Create simple metadatas with Format, Width & Height
+basicMetadata :: Integral nSize => SourceFormat -> nSize -> nSize -> Metadatas
+basicMetadata f w h =
+  Metadatas [ Format :=> f
+            , Width :=> fromIntegral w
+            , Height :=> fromIntegral h
+            ]
+
+-- | Create simple metadatas with Format, Width, Height, DpiX & DpiY
+simpleMetadata :: (Integral nSize, Integral nDpi)
+               => SourceFormat -> nSize -> nSize -> nDpi -> nDpi -> Metadatas
+simpleMetadata f w h dpiX dpiY =
+  Metadatas [ Format :=> f
+            , Width :=> fromIntegral w
+            , Height :=> fromIntegral h
+            , DpiX :=> fromIntegral dpiX
+            , DpiY :=> fromIntegral dpiY
+            ]
+
+ src/Codec/Picture/Metadata/Exif.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE DeriveGeneric #-}
+
+-- | This module provide a totally partial and incomplete maping
+-- of Exif values. Used for Tiff parsing and reused for Exif extraction.
+module Codec.Picture.Metadata.Exif ( ExifTag( .. )
+                                   , ExifData( .. )
+
+                                   , tagOfWord16
+                                   , word16OfTag
+
+                                   , isInIFD0
+                                   ) where
+
+import Control.DeepSeq( NFData( .. ) )
+import Data.Int( Int32 )
+import Data.Word( Word16, Word32 )
+import qualified Data.Vector as V
+import qualified Data.ByteString as B
+import GHC.Generics( Generic )
+
+-- | Tag values used for exif fields. Completly incomplete
+data ExifTag
+  = TagPhotometricInterpretation
+  | TagCompression -- ^ Short type
+  | TagImageWidth  -- ^ Short or long type
+  | TagImageLength -- ^ Short or long type
+  | TagXResolution -- ^ Rational type
+  | TagYResolution -- ^ Rational type
+  | TagResolutionUnit --  ^ Short type
+  | TagRowPerStrip -- ^ Short or long type
+  | TagStripByteCounts -- ^ Short or long
+  | TagStripOffsets -- ^ Short or long
+  | TagBitsPerSample --  ^ Short
+  | TagColorMap -- ^ Short
+  | TagTileWidth
+  | TagTileLength
+  | TagTileOffset
+  | TagTileByteCount
+  | TagSamplesPerPixel -- ^ Short
+  | TagArtist
+  | TagDocumentName
+  | TagSoftware
+  | TagPlanarConfiguration -- ^ Short
+  | TagOrientation
+  | TagSampleFormat -- ^ Short
+  | TagInkSet
+  | TagSubfileType
+  | TagFillOrder
+  | TagYCbCrCoeff
+  | TagYCbCrSubsampling
+  | TagYCbCrPositioning
+  | TagReferenceBlackWhite
+  | TagXPosition
+  | TagYPosition
+  | TagExtraSample
+  | TagImageDescription
+  | TagPredictor
+  | TagCopyright
+  | TagMake
+  | TagModel
+  | TagDateTime
+  | TagGPSInfo
+  | TagLightSource -- ^ Short
+  | TagFlash -- ^ Short
+
+  | TagJpegProc
+  | TagJPEGInterchangeFormat
+  | TagJPEGInterchangeFormatLength
+  | TagJPEGRestartInterval
+  | TagJPEGLosslessPredictors
+  | TagJPEGPointTransforms
+  | TagJPEGQTables
+  | TagJPEGDCTables
+  | TagJPEGACTables
+
+  | TagExifOffset
+  | TagUnknown !Word16
+  deriving (Eq, Ord, Show, Generic)
+instance NFData ExifTag
+
+-- | Convert a value to it's corresponding Exif tag.
+-- Will often be written as 'TagUnknown'
+tagOfWord16 :: Word16 -> ExifTag
+tagOfWord16 v = case v of
+  255 -> TagSubfileType
+  256 -> TagImageWidth
+  257 -> TagImageLength
+  258 -> TagBitsPerSample
+  259 -> TagCompression
+  262 -> TagPhotometricInterpretation
+  266 -> TagFillOrder
+  269 -> TagDocumentName
+  270 -> TagImageDescription
+  271 -> TagMake
+  272 -> TagModel
+  273 -> TagStripOffsets
+  274 -> TagOrientation
+  277 -> TagSamplesPerPixel
+  278 -> TagRowPerStrip
+  279 -> TagStripByteCounts
+  282 -> TagXResolution
+  283 -> TagYResolution
+  284 -> TagPlanarConfiguration
+  286 -> TagXPosition
+  287 -> TagYPosition
+  296 -> TagResolutionUnit
+  305 -> TagSoftware
+  306 -> TagDateTime
+  315 -> TagArtist
+  317 -> TagPredictor
+  320 -> TagColorMap
+  322 -> TagTileWidth
+  323 -> TagTileLength
+  324 -> TagTileOffset
+  325 -> TagTileByteCount
+  332 -> TagInkSet
+  338 -> TagExtraSample
+  339 -> TagSampleFormat
+  529 -> TagYCbCrCoeff
+  512 -> TagJpegProc
+  513 -> TagJPEGInterchangeFormat
+  514 -> TagJPEGInterchangeFormatLength
+  515 -> TagJPEGRestartInterval
+  517 -> TagJPEGLosslessPredictors
+  518 -> TagJPEGPointTransforms
+  519 -> TagJPEGQTables
+  520 -> TagJPEGDCTables
+  521 -> TagJPEGACTables
+  530 -> TagYCbCrSubsampling
+  531 -> TagYCbCrPositioning
+  532 -> TagReferenceBlackWhite
+  33432 -> TagCopyright
+  34665 -> TagExifOffset
+  34853 -> TagGPSInfo
+  37384 -> TagLightSource
+  37385 -> TagFlash
+  vv -> TagUnknown vv
+
+-- | Convert a tag to it's corresponding value.
+word16OfTag :: ExifTag -> Word16
+word16OfTag t = case t of
+  TagSubfileType -> 255
+  TagImageWidth -> 256
+  TagImageLength -> 257
+  TagBitsPerSample -> 258
+  TagCompression -> 259
+  TagPhotometricInterpretation -> 262
+  TagFillOrder -> 266
+  TagDocumentName -> 269
+  TagImageDescription -> 270
+  TagMake -> 271
+  TagModel -> 272
+  TagStripOffsets -> 273
+  TagOrientation -> 274
+  TagSamplesPerPixel -> 277
+  TagRowPerStrip -> 278
+  TagStripByteCounts -> 279
+  TagXResolution -> 282
+  TagYResolution -> 283
+  TagPlanarConfiguration -> 284
+  TagXPosition -> 286
+  TagYPosition -> 287
+  TagResolutionUnit -> 296
+  TagSoftware -> 305
+  TagDateTime -> 306
+  TagArtist -> 315
+  TagPredictor -> 317
+  TagColorMap -> 320
+  TagTileWidth -> 322
+  TagTileLength -> 323
+  TagTileOffset -> 324
+  TagTileByteCount -> 325
+  TagInkSet -> 332
+  TagExtraSample -> 338
+  TagSampleFormat -> 339
+  TagYCbCrCoeff -> 529
+  TagJpegProc -> 512
+  TagJPEGInterchangeFormat -> 513
+  TagJPEGInterchangeFormatLength -> 514
+  TagJPEGRestartInterval -> 515
+  TagJPEGLosslessPredictors -> 517
+  TagJPEGPointTransforms -> 518
+  TagJPEGQTables -> 519
+  TagJPEGDCTables -> 520
+  TagJPEGACTables -> 521
+  TagYCbCrSubsampling -> 530
+  TagYCbCrPositioning -> 531
+  TagReferenceBlackWhite -> 532
+  TagCopyright -> 33432
+  TagExifOffset -> 34665
+  TagGPSInfo -> 34853
+  TagLightSource -> 37384
+  TagFlash -> 37385
+  (TagUnknown v) -> v
+
+isInIFD0 :: ExifTag -> Bool
+isInIFD0 t = word16OfTag t <= lastTag || isRedirectTag where
+  lastTag = word16OfTag TagCopyright
+  isRedirectTag = t `elem` [TagExifOffset, TagGPSInfo]
+
+-- | Possible data held by an Exif tag
+data ExifData
+  = ExifNone
+  | ExifLong      !Word32
+  | ExifShort     !Word16
+  | ExifString    !B.ByteString
+  | ExifUndefined !B.ByteString
+  | ExifShorts    !(V.Vector Word16)
+  | ExifLongs     !(V.Vector Word32)
+  | ExifRational  !Word32 !Word32
+  | ExifSignedRational  !Int32 !Int32
+  | ExifIFD       ![(ExifTag, ExifData)]
+  deriving (Eq, Show, Generic)
+instance NFData ExifData
+ src/Codec/Picture/Png.hs view
@@ -0,0 +1,536 @@+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+-- | Module used for loading & writing \'Portable Network Graphics\' (PNG)
+-- files.
+--
+-- A high level API is provided. It loads and saves images for you
+-- while hiding all the details about PNG chunks.
+--
+-- Basic functions for PNG handling are 'decodePng', 'encodePng'
+-- and 'encodePalettedPng'. Convenience functions are provided
+-- for direct file handling and using 'DynamicImage's.
+--
+-- The loader has been validated against the pngsuite (http://www.libpng.org/pub/png/pngsuite.html)
+module Codec.Picture.Png( -- * High level functions
+                          PngSavable( .. ),
+                          PngPaletteSaveable( .. )
+
+                        , decodePng
+                        , decodePngWithMetadata
+                        , decodePngWithPaletteAndMetadata
+
+                        , writePng
+                        , encodeDynamicPng
+                        , writeDynamicPng
+                        ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<$>) )
+#endif
+
+import Control.Arrow( first )
+import Control.Monad( forM_, foldM_, when, void )
+import Control.Monad.ST( ST, runST )
+
+#if !MIN_VERSION_base(4,11,0)
+import Data.Monoid( (<>) )
+#endif
+
+import Data.Binary( Binary( get) )
+
+import qualified Data.Vector.Storable as V
+import qualified Data.Vector.Storable.Mutable as M
+import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR )
+import Data.List( find, zip4 )
+import Data.Word( Word8, Word16, Word32 )
+import qualified Codec.Compression.Zlib as Z
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Unsafe as BU
+import qualified Data.ByteString.Lazy as Lb
+import Foreign.Storable ( Storable )
+
+import Codec.Picture.Types
+import Codec.Picture.Metadata
+import Codec.Picture.Png.Internal.Type
+import Codec.Picture.Png.Internal.Export
+import Codec.Picture.Png.Internal.Metadata
+import Codec.Picture.InternalHelper
+
+-- | Simple structure used to hold information about Adam7 deinterlacing.
+-- A structure is used to avoid pollution of the module namespace.
+data Adam7MatrixInfo = Adam7MatrixInfo
+    { adam7StartingRow  :: [Int]
+    , adam7StartingCol  :: [Int]
+    , adam7RowIncrement :: [Int]
+    , adam7ColIncrement :: [Int]
+    , adam7BlockHeight  :: [Int]
+    , adam7BlockWidth   :: [Int]
+    }
+
+-- | The real info about the matrix.
+adam7MatrixInfo :: Adam7MatrixInfo
+adam7MatrixInfo = Adam7MatrixInfo
+    { adam7StartingRow  = [0, 0, 4, 0, 2, 0, 1]
+    , adam7StartingCol  = [0, 4, 0, 2, 0, 1, 0]
+    , adam7RowIncrement = [8, 8, 8, 4, 4, 2, 2]
+    , adam7ColIncrement = [8, 8, 4, 4, 2, 2, 1]
+    , adam7BlockHeight  = [8, 8, 4, 4, 2, 2, 1]
+    , adam7BlockWidth   = [8, 4, 4, 2, 2, 1, 1]
+    }
+
+unparsePngFilter :: Word8 -> Either String PngFilter
+{-# INLINE unparsePngFilter #-}
+unparsePngFilter 0 = Right FilterNone
+unparsePngFilter 1 = Right FilterSub
+unparsePngFilter 2 = Right FilterUp
+unparsePngFilter 3 = Right FilterAverage
+unparsePngFilter 4 = Right FilterPaeth
+unparsePngFilter _ = Left "Invalid scanline filter"
+
+getBounds :: (Monad m, Storable a) => M.STVector s a -> m (Int, Int)
+{-# INLINE getBounds #-}
+getBounds v = return (0, M.length v - 1)
+
+-- | Apply a filtering method on a reduced image. Apply the filter
+-- on each line, using the previous line (the one above it) to perform
+-- some prediction on the value.
+pngFiltering :: LineUnpacker s -> Int -> (Int, Int)    -- ^ Image size
+             -> B.ByteString -> Int
+             -> ST s Int
+pngFiltering _ _ (imgWidth, imgHeight) _str initialIdx
+        | imgWidth <= 0 || imgHeight <= 0 = return initialIdx
+pngFiltering unpacker beginZeroes (imgWidth, imgHeight) str initialIdx = do
+    thisLine <- M.replicate (beginZeroes + imgWidth) 0
+    otherLine <- M.replicate (beginZeroes + imgWidth) 0
+    let folder            _          _  lineIndex !idx | lineIndex >= imgHeight = return idx
+        folder previousLine currentLine lineIndex !idx = do
+               let byte = str `BU.unsafeIndex` idx
+               let lineFilter = case unparsePngFilter byte of
+                       Right FilterNone    -> filterNone
+                       Right FilterSub     -> filterSub
+                       Right FilterAverage -> filterAverage
+                       Right FilterUp      -> filterUp
+                       Right FilterPaeth   -> filterPaeth
+                       _ -> filterNone
+               idx' <- lineFilter previousLine currentLine $ idx + 1
+               unpacker lineIndex (stride, currentLine)
+               folder currentLine previousLine (lineIndex + 1) idx'
+
+    folder thisLine otherLine (0 :: Int) initialIdx
+
+    where stride = fromIntegral beginZeroes
+          lastIdx = beginZeroes + imgWidth - 1
+
+          -- The filter implementation are... well non-idiomatic
+          -- to say the least, but my benchmarks proved me one thing,
+          -- they are faster than mapM_, gained something like 5% with
+          -- a rewrite from mapM_ to this direct version
+          filterNone, filterSub, filterUp, filterPaeth,
+                filterAverage :: PngLine s -> PngLine s -> Int -> ST s Int
+          filterNone !_previousLine !thisLine = inner beginZeroes
+            where inner idx !readIdx
+                            | idx > lastIdx = return readIdx
+                            | otherwise = do let byte = str `BU.unsafeIndex` readIdx
+                                             (thisLine `M.unsafeWrite` idx) byte
+                                             inner (idx + 1) $ readIdx + 1
+
+          filterSub !_previousLine !thisLine = inner beginZeroes
+            where inner idx !readIdx
+                            | idx > lastIdx = return readIdx
+                            | otherwise = do let byte = str `BU.unsafeIndex` readIdx
+                                             val <- thisLine `M.unsafeRead` (idx - stride)
+                                             (thisLine `M.unsafeWrite` idx) $ byte + val
+                                             inner (idx + 1) $ readIdx + 1
+
+          filterUp !previousLine !thisLine = inner beginZeroes
+            where inner idx !readIdx
+                            | idx > lastIdx = return readIdx
+                            | otherwise = do let byte = str `BU.unsafeIndex` readIdx
+                                             val <- previousLine `M.unsafeRead` idx
+                                             (thisLine `M.unsafeWrite` idx) $ val + byte
+                                             inner (idx + 1) $ readIdx + 1
+
+          filterAverage !previousLine !thisLine = inner beginZeroes
+            where inner idx !readIdx
+                            | idx > lastIdx = return readIdx
+                            | otherwise = do let byte = str `BU.unsafeIndex` readIdx
+                                             valA <- thisLine `M.unsafeRead` (idx - stride)
+                                             valB <- previousLine `M.unsafeRead` idx
+                                             let a' = fromIntegral valA
+                                                 b' = fromIntegral valB
+                                                 average = fromIntegral ((a' + b') `div` (2 :: Word16)) 
+                                                 writeVal = byte + average 
+                                             (thisLine `M.unsafeWrite` idx) writeVal
+                                             inner (idx + 1) $ readIdx + 1
+
+          filterPaeth !previousLine !thisLine = inner beginZeroes
+            where inner idx !readIdx
+                            | idx > lastIdx = return readIdx
+                            | otherwise = do let byte = str `BU.unsafeIndex` readIdx
+                                             valA <- thisLine `M.unsafeRead` (idx - stride)
+                                             valC <- previousLine `M.unsafeRead` (idx - stride)
+                                             valB <- previousLine `M.unsafeRead` idx
+                                             (thisLine `M.unsafeWrite` idx) $ byte + paeth valA valB valC
+                                             inner (idx + 1) $ readIdx + 1
+
+                  paeth a b c
+                    | pa <= pb && pa <= pc = a
+                    | pb <= pc             = b
+                    | otherwise            = c
+                      where a' = fromIntegral a :: Int
+                            b' = fromIntegral b
+                            c' = fromIntegral c
+                            p = a' + b' - c'
+                            pa = abs $ p - a'
+                            pb = abs $ p - b'
+                            pc = abs $ p - c'
+                  
+-- | Directly stolen from the definition in the standard (on W3C page),
+-- pixel predictor.
+
+type PngLine s = M.STVector s Word8
+type LineUnpacker s = Int -> (Int, PngLine s) -> ST s ()
+
+type StrideInfo  = (Int, Int)
+
+type BeginOffset = (Int, Int)
+
+
+-- | Unpack lines where bit depth is 8
+byteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
+byteUnpacker sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
+             (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do
+    (_, maxIdx) <- getBounds line
+    let realTop = beginTop + h * strideHeight
+        lineIndex = realTop * imgWidth
+        pixelToRead = min (imgWidth - 1) $ (maxIdx - beginIdx) `div` sampleCount
+        inner pixelIndex | pixelIndex > pixelToRead = return ()
+                         | otherwise = do
+            let destPixelIndex = lineIndex + pixelIndex * strideWidth + beginLeft 
+                destSampleIndex = destPixelIndex * sampleCount
+                srcPixelIndex = pixelIndex * sampleCount + beginIdx
+                perPixel sample | sample >= sampleCount = return ()
+                                | otherwise = do
+                    val <- line `M.unsafeRead` (srcPixelIndex + sample)
+                    let writeIdx = destSampleIndex + sample
+                    (arr `M.unsafeWrite` writeIdx) val
+                    perPixel (sample + 1)
+            perPixel 0
+            inner (pixelIndex + 1)
+    inner 0
+             
+
+-- | Unpack lines where bit depth is 1
+bitUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
+bitUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
+              (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do
+    (_, endLine) <- getBounds line
+    let realTop = beginTop + h * strideHeight
+        lineIndex = realTop * imgWidth
+        (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth
+        subPadd | subImageRest > 0 = 1
+                | otherwise = 0
+        (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 8
+    forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do
+        val <- line `M.unsafeRead` (pixelIndex  + beginIdx)
+        let writeIdx n = lineIndex + (pixelIndex * 8 + n) * strideWidth + beginLeft 
+        forM_ [0 .. 7] $ \bit -> (arr `M.unsafeWrite` writeIdx (7 - bit)) ((val `unsafeShiftR` bit) .&. 1)
+
+    when (lineRest /= 0)
+         (do val <- line `M.unsafeRead` endLine
+             let writeIdx n = lineIndex + (pixelToRead * 8 + n) * strideWidth + beginLeft
+             forM_ [0 .. lineRest - 1] $ \bit ->
+                (arr `M.unsafeWrite` writeIdx bit) ((val `unsafeShiftR` (7 - bit)) .&. 0x1))
+
+
+-- | Unpack lines when bit depth is 2
+twoBitsUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
+twoBitsUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
+                  (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do
+    (_, endLine) <- getBounds line
+    let realTop = beginTop + h * strideHeight
+        lineIndex = realTop * imgWidth
+        (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth
+        subPadd | subImageRest > 0 = 1
+                | otherwise = 0
+        (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 4
+
+    forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do
+        val <- line `M.unsafeRead` (pixelIndex  + beginIdx)
+        let writeIdx n = lineIndex + (pixelIndex * 4 + n) * strideWidth + beginLeft 
+        (arr `M.unsafeWrite` writeIdx 0) $ (val `unsafeShiftR` 6) .&. 0x3
+        (arr `M.unsafeWrite` writeIdx 1) $ (val `unsafeShiftR` 4) .&. 0x3
+        (arr `M.unsafeWrite` writeIdx 2) $ (val `unsafeShiftR` 2) .&. 0x3
+        (arr `M.unsafeWrite` writeIdx 3) $ val .&. 0x3
+
+    when (lineRest /= 0)
+         (do val <- line `M.unsafeRead` endLine
+             let writeIdx n = lineIndex + (pixelToRead * 4 + n) * strideWidth + beginLeft
+             forM_ [0 .. lineRest - 1] $ \bit ->
+                (arr `M.unsafeWrite` writeIdx bit) ((val `unsafeShiftR` (6 - 2 * bit)) .&. 0x3))
+
+halfByteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
+halfByteUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
+                   (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do
+    (_, endLine) <- getBounds line
+    let realTop = beginTop + h * strideHeight
+        lineIndex = realTop * imgWidth
+        (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth
+        subPadd | subImageRest > 0 = 1
+                | otherwise = 0
+        (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 2
+    forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do
+        val <- line `M.unsafeRead` (pixelIndex  + beginIdx)
+        let writeIdx n = lineIndex + (pixelIndex * 2 + n) * strideWidth + beginLeft 
+        (arr `M.unsafeWrite` writeIdx 0) $ (val `unsafeShiftR` 4) .&. 0xF
+        (arr `M.unsafeWrite` writeIdx 1) $ val .&. 0xF
+    
+    when (lineRest /= 0)
+         (do val <- line `M.unsafeRead` endLine
+             let writeIdx = lineIndex + (pixelToRead * 2) * strideWidth + beginLeft 
+             (arr `M.unsafeWrite` writeIdx) $ (val `unsafeShiftR` 4) .&. 0xF)
+
+shortUnpacker :: Int -> MutableImage s Word16 -> StrideInfo -> BeginOffset -> LineUnpacker s
+shortUnpacker sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
+             (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do
+    (_, maxIdx) <- getBounds line
+    let realTop = beginTop + h * strideHeight
+        lineIndex = realTop * imgWidth
+        pixelToRead = min (imgWidth - 1) $ (maxIdx - beginIdx) `div` (sampleCount * 2)
+    forM_ [0 .. pixelToRead] $ \pixelIndex -> do
+        let destPixelIndex = lineIndex + pixelIndex * strideWidth + beginLeft 
+            destSampleIndex = destPixelIndex * sampleCount
+            srcPixelIndex = pixelIndex * sampleCount * 2 + beginIdx
+        forM_ [0 .. sampleCount - 1] $ \sample -> do
+            highBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 0)
+            lowBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 1)
+            let fullValue = fromIntegral lowBits .|. (fromIntegral highBits `unsafeShiftL` 8)
+                writeIdx = destSampleIndex + sample
+            (arr `M.unsafeWrite` writeIdx) fullValue
+
+-- | Transform a scanline to a bunch of bytes. Bytes are then packed
+-- into pixels at a further step.
+scanlineUnpacker8 :: Int -> Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset
+                 -> LineUnpacker s
+scanlineUnpacker8 1 = bitUnpacker
+scanlineUnpacker8 2 = twoBitsUnpacker
+scanlineUnpacker8 4 = halfByteUnpacker
+scanlineUnpacker8 8 = byteUnpacker
+scanlineUnpacker8 _ = error "Impossible bit depth"
+
+byteSizeOfBitLength :: Int -> Int -> Int -> Int
+byteSizeOfBitLength pixelBitDepth sampleCount dimension = size + (if rest /= 0 then 1 else 0)
+   where (size, rest) = (pixelBitDepth * dimension * sampleCount) `quotRem` 8
+
+scanLineInterleaving :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s)
+                     -> B.ByteString
+                     -> ST s ()
+scanLineInterleaving depth sampleCount (imgWidth, imgHeight) unpacker str =
+    void $ pngFiltering (unpacker (1,1) (0, 0)) strideInfo (byteWidth, imgHeight) str 0
+        where byteWidth = byteSizeOfBitLength depth sampleCount imgWidth
+              strideInfo | depth < 8 = 1
+                         | otherwise = sampleCount * (depth `div` 8)
+
+-- | Given data and image size, recreate an image with deinterlaced
+-- data for PNG's adam 7 method.
+adam7Unpack :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s)
+            -> B.ByteString -> ST s ()
+adam7Unpack depth sampleCount (imgWidth, imgHeight) unpacker str =
+  void $ foldM_ (\i f -> f i) 0 subImages
+    where Adam7MatrixInfo { adam7StartingRow  = startRows
+                          , adam7RowIncrement = rowIncrement
+                          , adam7StartingCol  = startCols
+                          , adam7ColIncrement = colIncrement } = adam7MatrixInfo
+
+          subImages = 
+              [pngFiltering (unpacker (incrW, incrH) (beginW, beginH)) strideInfo (byteWidth, passHeight) str
+                            | (beginW, incrW, beginH, incrH) <- zip4 startCols colIncrement startRows rowIncrement
+                            , let passWidth = sizer imgWidth beginW incrW
+                                  passHeight = sizer imgHeight beginH incrH
+                                  byteWidth = byteSizeOfBitLength depth sampleCount passWidth
+                            ]
+          strideInfo | depth < 8 = 1
+                     | otherwise = sampleCount * (depth `div` 8)
+          sizer dimension begin increment
+            | dimension <= begin = 0
+            | otherwise = outDim + (if restDim /= 0 then 1 else 0)
+                where (outDim, restDim) = (dimension - begin) `quotRem` increment
+
+-- | deinterlace picture in function of the method indicated
+-- in the iHDR
+deinterlacer :: PngIHdr -> B.ByteString -> ST s (Either (V.Vector Word8) (V.Vector Word16))
+deinterlacer (PngIHdr { width = w, height = h, colourType  = imgKind
+                      , interlaceMethod = method, bitDepth = depth  }) str = do
+    let compCount = fromIntegral $ sampleCountOfImageType imgKind 
+        arraySize = (fromIntegral w) * (fromIntegral h) * compCount
+        deinterlaceFunction = case method of
+            PngNoInterlace -> scanLineInterleaving
+            PngInterlaceAdam7 -> adam7Unpack
+        iBitDepth = fromIntegral depth
+    if iBitDepth <= 8
+      then do
+        imgArray <- M.new arraySize
+        let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray
+        deinterlaceFunction iBitDepth 
+                            compCount
+                            (fromIntegral w, fromIntegral h)
+                            (scanlineUnpacker8 iBitDepth compCount mutableImage)
+                            str
+        Left <$> V.unsafeFreeze imgArray
+
+      else do
+        imgArray <- M.new arraySize
+        let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray
+        deinterlaceFunction iBitDepth 
+                            compCount
+                            (fromIntegral w, fromIntegral h)
+                            (shortUnpacker compCount mutableImage)
+                            str
+        Right <$> V.unsafeFreeze imgArray
+
+generateGreyscalePalette :: Word8 -> PngPalette
+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]
+                              , let i = fromIntegral $ n * (255 `div` maxValue)]
+
+sampleCountOfImageType :: PngImageType -> Word32
+sampleCountOfImageType PngGreyscale = 1
+sampleCountOfImageType PngTrueColour = 3
+sampleCountOfImageType PngIndexedColor = 1
+sampleCountOfImageType PngGreyscaleWithAlpha = 2
+sampleCountOfImageType PngTrueColourWithAlpha = 4
+
+paletteRGB1, paletteRGB2, paletteRGB4 :: PngPalette
+paletteRGB1 = generateGreyscalePalette 1
+paletteRGB2 = generateGreyscalePalette 2
+paletteRGB4 = generateGreyscalePalette 4
+
+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 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 =
+      fmap TrueColorImage . toImage ihdr ImageY8 ImageY16 $ runST $ deinterlacer ihdr bytes
+
+unparse _ Nothing _ PngIndexedColor  _ = Left "no valid palette found"
+unparse ihdr _ _ PngTrueColour          bytes =
+  fmap TrueColorImage . toImage ihdr ImageRGB8 ImageRGB16 $ runST $ deinterlacer ihdr bytes
+unparse ihdr _ _ PngGreyscaleWithAlpha  bytes =
+  fmap TrueColorImage . toImage ihdr ImageYA8 ImageYA16 $ runST $ deinterlacer ihdr bytes
+unparse ihdr _ _ PngTrueColourWithAlpha 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
+
+toImage :: forall a pxWord8 pxWord16
+         . PngIHdr
+        -> (Image pxWord8 -> DynamicImage) -> (Image pxWord16 -> DynamicImage)
+        -> Either (V.Vector (PixelBaseComponent pxWord8))
+                  (V.Vector (PixelBaseComponent pxWord16))
+        -> Either a DynamicImage
+toImage hdr const1 const2 lr = Right $ case lr of
+    Left a -> const1 $ Image w h a
+    Right a -> const2 $ Image w h a
+  where
+    w = fromIntegral $ width hdr
+    h = fromIntegral $ height hdr
+
+palette8 :: PngIHdr -> PngPalette -> [Lb.ByteString] -> Either (V.Vector Word8) t
+         -> Either String PalettedImage
+palette8 hdr palette transparency eimg = case (transparency, eimg) of
+  ([c], Left img) ->
+    Right . PalettedRGBA8 (Image w h img) $ addTransparencyToPalette palette c
+  (_, Left img) ->
+    return $ PalettedRGB8 (Image w h img) palette
+  (_, Right _) ->
+    Left "Invalid bit depth for paleted image"
+  where
+    w = fromIntegral $ width hdr
+    h = fromIntegral $ height hdr
+
+
+-- | Transform a raw png image to an image, without modifying the
+-- underlying pixel type. If the image is greyscale and < 8 bits,
+-- a transformation to RGBA8 is performed. This should change
+-- in the future.
+-- The resulting image let you manage the pixel types.
+--
+-- This function can output the following images:
+--
+--  * 'ImageY8'
+--
+--  * 'ImageY16'
+--
+--  * 'ImageYA8'
+--
+--  * 'ImageYA16'
+--
+--  * 'ImageRGB8'
+--
+--  * 'ImageRGB16'
+--
+--  * 'ImageRGBA8'
+--
+--  * 'ImageRGBA16'
+--
+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.
+decodePngWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)
+decodePngWithPaletteAndMetadata byte =  do
+  rawImg <- runGetStrict get byte
+  let ihdr = header rawImg
+      metadatas =
+         basicMetadata SourcePng (width ihdr) (height ihdr) <> extractMetadatas rawImg
+      compressedImageData =
+            Lb.concat [chunkData chunk | chunk <- chunks rawImg
+                                       , chunkType chunk == iDATSignature]
+      zlibHeaderSize = 1 {- compression method/flags code -}
+                     + 1 {- Additional flags/check bits -}
+                     + 4 {-CRC-}
+
+      transparencyColor =
+          [ chunkData chunk | chunk <- chunks rawImg
+                            , chunkType chunk == tRNSSignature ]
+
+
+  if Lb.length compressedImageData <= zlibHeaderSize then
+    Left "Invalid data size"
+  else
+    let imgData = Z.decompress compressedImageData
+        parseableData = B.concat $ Lb.toChunks imgData
+        palette = do 
+          p <- find (\c -> pLTESignature == chunkType c) $ chunks rawImg
+          case parsePalette p of
+            Left _ -> Nothing
+            Right plte -> return plte
+    in
+    (, metadatas) <$>
+        unparse ihdr palette transparencyColor (colourType ihdr) parseableData
+
+{-# ANN module "HLint: ignore Reduce duplication" #-}
+
+ src/Codec/Picture/Png/Internal/Export.hs view
@@ -0,0 +1,270 @@+{-# 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 = encodePalettedPngWithMetadata 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 metas pal img
+      | w <= 0 || w > 256 || h /= 1 = Left "Invalid palette"
+      | VS.any isTooBig $ imageData img =
+          Left "Image contains indexes absent from the palette"
+      | otherwise = Right $ genericEncodePng (Just pal) Nothing PngIndexedColor metas img
+        where w = imageWidth pal
+              h = imageHeight pal
+              isTooBig v = fromIntegral v >= w
+
+instance PngPaletteSaveable PixelRGBA8 where
+  encodePalettedPngWithMetadata metas pal img
+      | w <= 0 || w > 256 || h /= 1 = Left "Invalid palette"
+      | VS.any isTooBig $ imageData img =
+          Left "Image contains indexes absent from the palette"
+      | otherwise = Right $ genericEncodePng (Just opaquePalette) (Just alphaPal) PngIndexedColor metas img
+    where
+      w = imageWidth pal
+      h = imageHeight pal
+      opaquePalette = dropAlphaLayer pal
+      alphaPal = imageData $ extractComponent PlaneAlpha pal
+      isTooBig v = fromIntegral v >= 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 = encodePngWithMetadata 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 be stored 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 { imageWidth = w, imageHeight = h }) imgType depth = PngIHdr
+  { width             = fromIntegral w
+  , height            = fromIntegral h
+  , bitDepth          = depth
+  , colourType        = imgType
+  , compressionMethod = 0
+  , filterMethod      = 0
+  , interlaceMethod   = PngNoInterlace
+  }
+
+-- | Helper function to directly write an image as a png on disk.
+writePng :: (PngSavable pixel) => FilePath -> Image pixel -> IO ()
+writePng path img = Lb.writeFile path $ encodePng img
+
+endChunk :: PngRawChunk
+endChunk = mkRawChunk iENDSignature mempty
+
+prepareIDatChunk :: Lb.ByteString -> PngRawChunk
+prepareIDatChunk = mkRawChunk iDATSignature
+
+genericEncode16BitsPng :: forall px. (Pixel px, PixelBaseComponent px ~ Word16)
+                       => PngImageType -> Metadatas -> Image px -> Lb.ByteString
+genericEncode16BitsPng imgKind metas
+                 image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) =
+  encode PngRawImage { header = hdr
+                     , chunks = encodeMetadatas metas 
+                              <> [ prepareIDatChunk imgEncodedData
+                                 , endChunk
+                                 ]
+                     }
+    where hdr = preparePngHeader image imgKind 16
+          zero = B.singleton 0
+          compCount = componentCount (undefined :: px)
+
+          lineSize = compCount * w
+          blitToByteString vec = blitVector vec 0 (lineSize * 2)
+          encodeLine line = blitToByteString $ runST $ do
+              finalVec <- M.new $ lineSize * 2 :: ST s (M.STVector s Word8)
+              let baseIndex = line * lineSize
+              forM_ [0 ..  lineSize - 1] $ \ix -> do
+                  let v = arr `VS.unsafeIndex` (baseIndex + ix)
+                      high = fromIntegral $ (v `unsafeShiftR` 8) .&. 0xFF
+                      low = fromIntegral $ v .&. 0xFF
+
+                  (finalVec `M.unsafeWrite` (ix * 2 + 0)) high
+                  (finalVec `M.unsafeWrite` (ix * 2 + 1)) low
+
+              VS.unsafeFreeze finalVec
+
+          imgEncodedData = Z.compress . Lb.fromChunks
+                        $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]]
+
+preparePalette :: Palette -> PngRawChunk
+preparePalette pal = PngRawChunk
+  { chunkLength = fromIntegral $ imageWidth pal * 3
+  , chunkType   = pLTESignature
+  , chunkCRC    = pngComputeCrc [pLTESignature, binaryData]
+  , chunkData   = binaryData
+  }
+  where binaryData = Lb.fromChunks [toByteString $ imageData pal]
+
+preparePaletteAlpha :: VS.Vector Pixel8 -> PngRawChunk
+preparePaletteAlpha alphaPal = PngRawChunk
+  { chunkLength = fromIntegral $ VS.length alphaPal
+  , chunkType   = tRNSSignature
+  , chunkCRC    = pngComputeCrc [tRNSSignature, binaryData]
+  , chunkData   = binaryData
+  }
+  where binaryData = Lb.fromChunks [toByteString 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 palette palAlpha imgKind metas
+                 image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) =
+  encode PngRawImage { header = hdr
+                     , chunks = encodeMetadatas metas
+                              <> paletteChunk
+                              <> transpChunk
+                              <> [ prepareIDatChunk imgEncodedData
+                                 , endChunk
+                                 ]}
+  where
+    hdr = preparePngHeader image imgKind 8
+    zero = B.singleton 0
+    compCount = componentCount (undefined :: px)
+
+    paletteChunk = case palette of
+      Nothing -> []
+      Just p -> [preparePalette p]
+
+    transpChunk = case palAlpha of
+      Nothing -> []
+      Just p -> [preparePaletteAlpha p]
+
+    lineSize = compCount * w
+    encodeLine line = blitVector arr (line * lineSize) lineSize
+    imgEncodedData = Z.compress
+        . Lb.fromChunks
+        $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]]
+
+instance PngSavable PixelRGBA8 where
+  encodePngWithMetadata = genericEncodePng Nothing Nothing PngTrueColourWithAlpha
+
+instance PngSavable PixelRGB8 where
+  encodePngWithMetadata = genericEncodePng Nothing Nothing PngTrueColour
+
+instance PngSavable Pixel8 where
+  encodePngWithMetadata = genericEncodePng Nothing Nothing PngGreyscale
+
+instance PngSavable PixelYA8 where
+  encodePngWithMetadata = genericEncodePng Nothing Nothing PngGreyscaleWithAlpha
+
+instance PngSavable PixelYA16 where
+  encodePngWithMetadata = genericEncode16BitsPng PngGreyscaleWithAlpha
+
+instance PngSavable Pixel16 where
+  encodePngWithMetadata = genericEncode16BitsPng PngGreyscale
+
+instance PngSavable PixelRGB16 where
+  encodePngWithMetadata = genericEncode16BitsPng PngTrueColour
+
+instance PngSavable PixelRGBA16 where
+  encodePngWithMetadata = genericEncode16BitsPng 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 path img = case encodeDynamicPng img of
+        Left err -> return $ Left err
+        Right b  -> Lb.writeFile path b >> return (Right 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 (ImageRGB8 img) = Right $ encodePng img
+encodeDynamicPng (ImageRGBA8 img) = Right $ encodePng img
+encodeDynamicPng (ImageY8 img) = Right $ encodePng img
+encodeDynamicPng (ImageY16 img) = Right $ encodePng img
+encodeDynamicPng (ImageYA8 img) = Right $ encodePng img
+encodeDynamicPng (ImageYA16 img) = Right $ encodePng img
+encodeDynamicPng (ImageRGB16 img) = Right $ encodePng img
+encodeDynamicPng (ImageRGBA16 img) = Right $ encodePng img
+encodeDynamicPng _ = Left "Unsupported image format for PNG export"
+ src/Codec/Picture/Png/Internal/Metadata.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Codec.Picture.Png.Internal.Metadata( extractMetadatas
+                                 , encodeMetadatas
+                                 ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<$>), (<*>), pure )
+import Data.Monoid( Monoid, mempty )
+import Data.Foldable( foldMap )
+#endif
+
+import Data.Maybe( fromMaybe )
+import Data.Binary( Binary( get, put ), encode )
+import Data.Binary.Get( getLazyByteStringNul, getWord8 )
+import Data.Binary.Put( putLazyByteString, putWord8 )
+import qualified Data.ByteString.Lazy.Char8 as L
+#if !MIN_VERSION_base(4,11,0)
+import Data.Monoid( (<>) )
+#endif
+
+import qualified Codec.Compression.Zlib as Z
+
+import Codec.Picture.InternalHelper
+import qualified Codec.Picture.Metadata as Met
+import Codec.Picture.Metadata ( Metadatas
+                              , dotsPerMeterToDotPerInch
+                              , Elem( (:=>) ) )
+import Codec.Picture.Png.Internal.Type
+
+#if !MIN_VERSION_base(4,7,0)
+eitherFoldMap :: Monoid m => (a -> m) -> Either e a -> m
+eitherFoldMap f v = case v of
+  Left _ -> mempty
+  Right a -> f a
+#else
+eitherFoldMap :: Monoid m => (a -> m) -> Either e a -> m
+eitherFoldMap = foldMap
+#endif
+
+getGamma :: [L.ByteString] -> Metadatas
+getGamma [] = mempty
+getGamma (g:_) = eitherFoldMap unpackGamma $ runGet get g
+  where
+    unpackGamma gamma = Met.singleton Met.Gamma (getPngGamma gamma)
+
+getDpis :: [L.ByteString] -> Metadatas
+getDpis [] = mempty
+getDpis (b:_) = eitherFoldMap unpackPhys $ runGet get b
+  where
+    unpackPhys PngPhysicalDimension { pngUnit = PngUnitUnknown } =
+      Met.insert Met.DpiX 72 $ Met.singleton Met.DpiY 72
+    unpackPhys phy@PngPhysicalDimension { pngUnit = PngUnitMeter } =
+      Met.insert Met.DpiX dpx $ Met.singleton Met.DpiY dpy
+        where
+          dpx = dotsPerMeterToDotPerInch . fromIntegral $ pngDpiX phy
+          dpy = dotsPerMeterToDotPerInch . fromIntegral $ pngDpiY phy
+
+data PngText = PngText
+  { pngKeyword :: !L.ByteString
+  , pngData    :: !L.ByteString
+  }
+  deriving Show
+
+instance Binary PngText where
+  get = PngText <$> getLazyByteStringNul <*> getRemainingLazyBytes
+  put (PngText kw pdata) = do
+    putLazyByteString kw
+    putWord8 0
+    putLazyByteString pdata
+
+data PngZText = PngZText
+  { pngZKeyword :: !L.ByteString
+  , pngZData    :: !L.ByteString
+  }
+  deriving Show
+
+instance Binary PngZText where
+  get = PngZText <$> getLazyByteStringNul <* getCompressionType <*> (Z.decompress <$> getRemainingLazyBytes)
+    where
+      getCompressionType = do
+        0 <- getWord8
+        return ()
+  put (PngZText kw pdata) = do
+    putLazyByteString kw
+    putWord8 0
+    putWord8 0 -- compression type
+    putLazyByteString (Z.compress pdata)
+
+aToMetadata :: (a -> L.ByteString) -> (a -> L.ByteString) -> a -> Metadatas
+aToMetadata pkeyword pdata ptext = case pkeyword ptext of
+  "Title" -> strValue Met.Title
+  "Author" -> strValue Met.Author
+  "Description" -> strValue Met.Description
+  "Copyright" -> strValue Met.Copyright
+  {-"Creation Time" -> strValue Creation-}
+  "Software" -> strValue Met.Software
+  "Disclaimer" -> strValue Met.Disclaimer
+  "Warning" -> strValue Met.Warning
+  "Source" -> strValue Met.Source
+  "Comment" -> strValue Met.Comment
+  other -> 
+    Met.singleton
+      (Met.Unknown $ L.unpack other)
+      (Met.String . L.unpack $ pdata ptext)
+  where
+    strValue k = Met.singleton k . L.unpack $ pdata ptext
+
+textToMetadata :: PngText -> Metadatas
+textToMetadata = aToMetadata pngKeyword pngData
+
+ztxtToMetadata :: PngZText -> Metadatas
+ztxtToMetadata = aToMetadata pngZKeyword pngZData
+
+getTexts :: [L.ByteString] -> Metadatas
+getTexts = foldMap (eitherFoldMap textToMetadata . runGet get)
+
+getZTexts :: [L.ByteString] -> Metadatas
+getZTexts = foldMap (eitherFoldMap ztxtToMetadata . runGet get)
+
+extractMetadatas :: PngRawImage -> Metadatas
+extractMetadatas img = getDpis (chunksOf pHYsSignature)
+                    <> getGamma (chunksOf gammaSignature)
+                    <> getTexts (chunksOf tEXtSignature)
+                    <> getZTexts (chunksOf zTXtSignature)
+  where
+    chunksOf = chunksWithSig img
+
+encodePhysicalMetadata :: Metadatas -> [PngRawChunk]
+encodePhysicalMetadata metas = fromMaybe [] $ do
+  dx <- Met.lookup Met.DpiX metas
+  dy <- Met.lookup Met.DpiY metas
+  let to = fromIntegral . Met.dotPerInchToDotsPerMeter
+      dim = PngPhysicalDimension (to dx) (to dy) PngUnitMeter
+  pure [mkRawChunk pHYsSignature $ encode dim]
+
+encodeSingleMetadata :: Metadatas -> [PngRawChunk]
+encodeSingleMetadata = Met.foldMap go where
+  go :: Elem Met.Keys -> [PngRawChunk]
+  go v = case v of
+    Met.Exif _ :=> _ -> mempty
+    Met.DpiX :=> _ -> mempty
+    Met.DpiY :=> _ -> mempty
+    Met.Width :=> _ -> mempty
+    Met.Height :=> _ -> mempty
+    Met.Format :=> _ -> mempty
+    Met.Gamma       :=> g ->
+      pure $ mkRawChunk gammaSignature . encode $ PngGamma g
+    Met.ColorSpace  :=> _ -> mempty
+    Met.Title       :=> tx -> txt "Title" (L.pack tx)
+    Met.Description :=> tx -> txt "Description" (L.pack tx)
+    Met.Author      :=> tx -> txt "Author" (L.pack tx)
+    Met.Copyright   :=> tx -> txt "Copyright" (L.pack tx)
+    Met.Software    :=> tx -> txt "Software" (L.pack tx)
+    Met.Comment     :=> tx -> txt "Comment" (L.pack tx)
+    Met.Disclaimer  :=> tx -> txt "Disclaimer" (L.pack tx)
+    Met.Source      :=> tx -> txt "Source" (L.pack tx)
+    Met.Warning     :=> tx -> txt "Warning" (L.pack tx)
+    Met.Unknown k   :=> Met.String tx -> txt (L.pack k) (L.pack tx)
+    Met.Unknown _   :=> _ -> mempty
+
+  txt k c = pure . mkRawChunk tEXtSignature . encode $ PngText k c
+
+encodeMetadatas :: Metadatas -> [PngRawChunk]
+encodeMetadatas m = encodePhysicalMetadata m <> encodeSingleMetadata m
+
+ src/Codec/Picture/Png/Internal/Type.hs view
@@ -0,0 +1,452 @@+{-# LANGUAGE CPP #-}
+-- | Low level png module, you should import 'Codec.Picture.Png.Internal' instead.
+module Codec.Picture.Png.Internal.Type( PngIHdr( .. )
+                             , PngFilter( .. )
+                             , PngInterlaceMethod( .. )
+                             , PngPalette
+                             , PngImageType( .. )
+                             , PngPhysicalDimension( .. )
+                             , PngGamma( .. )
+                             , PngUnit( .. )
+                             , APngAnimationControl( .. )
+                             , APngFrameDisposal( .. )
+                             , APngBlendOp( .. )
+                             , APngFrameControl( .. )
+                             , parsePalette 
+                             , pngComputeCrc
+                             , pngSignature
+                             , iHDRSignature
+                             , pLTESignature
+                             , iDATSignature
+                             , iENDSignature
+                             , tRNSSignature
+                             , tEXtSignature
+                             , zTXtSignature
+                             , gammaSignature
+                             , pHYsSignature
+                             , animationControlSignature
+                             -- * Low level types
+                             , ChunkSignature
+                             , PngRawImage( .. )
+                             , PngChunk( .. )
+                             , PngRawChunk( .. )
+                             , PngLowLevel( .. )
+                             , chunksWithSig
+                             , mkRawChunk
+                             ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<$>), (<*>), pure )
+#endif
+
+import Control.Monad( when, replicateM )
+import Data.Bits( xor, (.&.), unsafeShiftR )
+import Data.Binary( Binary(..), Get, get )
+import Data.Binary.Get( getWord8
+                      , getWord32be
+                      , getLazyByteString
+                      )
+import Data.Binary.Put( runPut
+                      , putWord8
+                      , putWord32be
+                      , putLazyByteString
+                      )
+import Data.Vector.Unboxed( Vector, fromListN, (!) )
+import qualified Data.Vector.Storable as V
+import Data.List( foldl' )
+import Data.Word( Word32, Word16, Word8 )
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Lazy.Char8 as LS
+
+import Codec.Picture.Types
+import Codec.Picture.InternalHelper
+
+--------------------------------------------------
+----            Types
+--------------------------------------------------
+
+-- | Value used to identify a png chunk, must be 4 bytes long.
+type ChunkSignature = L.ByteString
+
+-- | Generic header used in PNG images.
+data PngIHdr = PngIHdr
+    { width             :: !Word32       -- ^ Image width in number of pixel
+    , height            :: !Word32       -- ^ Image height in number of pixel
+    , bitDepth          :: !Word8        -- ^ Number of bit per sample
+    , colourType        :: !PngImageType -- ^ Kind of png image (greyscale, true color, indexed...)
+    , compressionMethod :: !Word8        -- ^ Compression method used
+    , filterMethod      :: !Word8        -- ^ Must be 0
+    , interlaceMethod   :: !PngInterlaceMethod   -- ^ If the image is interlaced (for progressive rendering)
+    }
+    deriving Show
+
+data PngUnit
+    = PngUnitUnknown -- ^ 0 value
+    | PngUnitMeter   -- ^ 1 value
+
+instance Binary PngUnit where
+  get = do
+    v <- getWord8
+    pure $ case v of
+      0 -> PngUnitUnknown
+      1 -> PngUnitMeter
+      _ -> PngUnitUnknown
+  
+  put v = case v of
+    PngUnitUnknown -> putWord8 0
+    PngUnitMeter -> putWord8 1
+
+data PngPhysicalDimension = PngPhysicalDimension
+    { pngDpiX     :: !Word32
+    , pngDpiY     :: !Word32
+    , pngUnit     :: !PngUnit
+    }
+
+instance Binary PngPhysicalDimension where
+  get = PngPhysicalDimension <$> getWord32be <*> getWord32be <*> get
+  put (PngPhysicalDimension dpx dpy unit) =
+    putWord32be dpx >> putWord32be dpy >> put unit
+
+newtype PngGamma = PngGamma { getPngGamma :: Double }
+
+instance Binary PngGamma where
+  get = PngGamma . (/ 100000) . fromIntegral <$> getWord32be
+  put = putWord32be . ceiling . (100000 *) . getPngGamma 
+
+data APngAnimationControl = APngAnimationControl
+    { animationFrameCount :: !Word32
+    , animationPlayCount  :: !Word32
+    }
+    deriving Show
+
+-- | Encoded in a Word8
+data APngFrameDisposal
+      -- | No disposal is done on this frame before rendering the
+      -- next; the contents of the output buffer are left as is. 
+      -- Has Value 0
+    = APngDisposeNone
+      -- | The frame's region of the output buffer is to be cleared
+      -- to fully transparent black before rendering the next frame. 
+      -- Has Value 1
+    | APngDisposeBackground
+      -- | the frame's region of the output buffer is to be reverted
+      -- to the previous contents before rendering the next frame.
+      -- Has Value 2
+    | APngDisposePrevious 
+    deriving Show
+
+-- | Encoded in a Word8
+data APngBlendOp
+      -- | Overwrite output buffer. has value '0'
+    = APngBlendSource
+      -- | Alpha blend to the output buffer. Has value '1'
+    | APngBlendOver
+    deriving Show
+
+data APngFrameControl = APngFrameControl
+    { frameSequenceNum      :: !Word32 -- ^ Starting from 0
+    , frameWidth            :: !Word32 -- ^ Width of the following frame
+    , frameHeight           :: !Word32 -- ^ Height of the following frame
+    , frameLeft             :: !Word32 -- X position where to render the frame.
+    , frameTop              :: !Word32 -- Y position where to render the frame.
+    , frameDelayNumerator   :: !Word16
+    , frameDelayDenuminator :: !Word16
+    , frameDisposal         :: !APngFrameDisposal
+    , frameBlending         :: !APngBlendOp
+    }
+    deriving Show
+
+-- | What kind of information is encoded in the IDAT section
+-- of the PngFile
+data PngImageType =
+      PngGreyscale
+    | PngTrueColour
+    | PngIndexedColor
+    | PngGreyscaleWithAlpha
+    | PngTrueColourWithAlpha
+    deriving Show
+
+-- | Raw parsed image which need to be decoded.
+data PngRawImage = PngRawImage
+    { header       :: PngIHdr
+    , chunks       :: [PngRawChunk]
+    }
+
+-- | Palette with indices beginning at 0 to elemcount - 1
+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 = 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)
+
+-- | Data structure during real png loading/parsing
+data PngRawChunk = PngRawChunk
+    { chunkLength :: Word32
+    , chunkType   :: ChunkSignature
+    , chunkCRC    :: Word32
+    , chunkData   :: L.ByteString
+    }
+
+mkRawChunk :: ChunkSignature -> L.ByteString -> PngRawChunk
+mkRawChunk sig binaryData = PngRawChunk
+  { chunkLength = fromIntegral $ L.length binaryData
+  , chunkType   = sig
+  , chunkCRC    = pngComputeCrc [sig, binaryData]
+  , chunkData   = binaryData
+  }
+
+-- | PNG chunk representing some extra information found in the parsed file.
+data PngChunk = PngChunk
+    { pngChunkData        :: L.ByteString  -- ^ The raw data inside the chunk
+    , pngChunkSignature   :: ChunkSignature -- ^ The name of the chunk.
+    }
+
+-- | Low level access to PNG information
+data PngLowLevel a = PngLowLevel
+    { pngImage  :: Image a      -- ^ The real uncompressed image
+    , pngChunks :: [PngChunk]   -- ^ List of raw chunk where some user data might be present.
+    }
+
+-- | The pixels value should be :
+-- +---+---+
+-- | c | b |
+-- +---+---+
+-- | a | x |
+-- +---+---+
+-- x being the current filtered pixel
+data PngFilter =
+    -- | Filt(x) = Orig(x), Recon(x) = Filt(x)
+      FilterNone
+    -- | Filt(x) = Orig(x) - Orig(a),     Recon(x) = Filt(x) + Recon(a)
+    | FilterSub
+    -- | Filt(x) = Orig(x) - Orig(b),     Recon(x) = Filt(x) + Recon(b)
+    | FilterUp
+    -- | Filt(x) = Orig(x) - floor((Orig(a) + Orig(b)) / 2),
+    -- Recon(x) = Filt(x) + floor((Recon(a) + Recon(b)) / 2)
+    | FilterAverage
+    -- | Filt(x) = Orig(x) - PaethPredictor(Orig(a), Orig(b), Orig(c)),
+    -- Recon(x) = Filt(x) + PaethPredictor(Recon(a), Recon(b), Recon(c))
+    | FilterPaeth
+    deriving (Enum, Show)
+
+-- | Different known interlace methods for PNG image
+data PngInterlaceMethod =
+      -- | No interlacing, basic data ordering, line by line
+      -- from left to right.
+      PngNoInterlace
+
+      -- | Use the Adam7 ordering, see `adam7Reordering`
+    | PngInterlaceAdam7
+    deriving (Enum, Show)
+
+--------------------------------------------------
+----            Instances
+--------------------------------------------------
+instance Binary PngFilter where
+    put = putWord8 . toEnum . fromEnum
+    get = getWord8 >>= \w -> case w of
+        0 -> return FilterNone
+        1 -> return FilterSub
+        2 -> return FilterUp
+        3 -> return FilterAverage
+        4 -> return FilterPaeth
+        _ -> fail "Invalid scanline filter"
+
+instance Binary PngRawImage where
+    put img = do
+        putLazyByteString pngSignature
+        put $ header img
+        mapM_ put $ chunks img
+
+    get = parseRawPngImage
+
+instance Binary PngRawChunk where
+    put chunk = do
+        putWord32be $ chunkLength chunk
+        putLazyByteString $ chunkType chunk
+        when (chunkLength chunk /= 0)
+             (putLazyByteString $ chunkData chunk)
+        putWord32be $ chunkCRC chunk
+
+    get = do
+        size <- getWord32be
+        chunkSig <- getLazyByteString (fromIntegral $ L.length iHDRSignature)
+        imgData <- if size == 0
+            then return L.empty
+            else getLazyByteString (fromIntegral size)
+        crc <- getWord32be
+
+        let computedCrc = pngComputeCrc [chunkSig, imgData]
+        when (computedCrc `xor` crc /= 0)
+             (fail $ "Invalid CRC : " ++ show computedCrc ++ ", "
+                                      ++ show crc)
+        return PngRawChunk {
+            chunkLength = size,
+            chunkData = imgData,
+            chunkCRC = crc,
+            chunkType = chunkSig
+        }
+
+instance Binary PngIHdr where
+    put hdr = do
+        putWord32be 13
+        let inner = runPut $ do
+                putLazyByteString iHDRSignature
+                putWord32be $ width hdr
+                putWord32be $ height hdr
+                putWord8    $ bitDepth hdr
+                put $ colourType hdr
+                put $ compressionMethod hdr
+                put $ filterMethod hdr
+                put $ interlaceMethod hdr
+            crc = pngComputeCrc [inner]
+        putLazyByteString inner
+        putWord32be crc
+
+    get = do
+        _size <- getWord32be
+        ihdrSig <- getLazyByteString (L.length iHDRSignature)
+        when (ihdrSig /= iHDRSignature)
+             (fail "Invalid PNG file, wrong ihdr")
+        w <- getWord32be
+        h <- getWord32be
+        depth <- get
+        colorType <- get
+        compression <- get
+        filtermethod <- get
+        interlace <- get
+        _crc <- getWord32be
+        return PngIHdr {
+            width = w,
+            height = h,
+            bitDepth = depth,
+            colourType = colorType,
+            compressionMethod = compression,
+            filterMethod = filtermethod,
+            interlaceMethod = interlace
+        }
+
+-- | Parse method for a png chunk, without decompression.
+parseChunks :: Get [PngRawChunk]
+parseChunks = do
+    chunk <- get
+
+    if chunkType chunk == iENDSignature
+       then return [chunk]
+       else (chunk:) <$> parseChunks
+
+
+instance Binary PngInterlaceMethod where
+    get = getWord8 >>= \w -> case w of
+        0 -> return PngNoInterlace
+        1 -> return PngInterlaceAdam7
+        _ -> fail "Invalid interlace method"
+
+    put PngNoInterlace    = putWord8 0
+    put PngInterlaceAdam7 = putWord8 1
+
+-- | Implementation of the get method for the PngRawImage,
+-- unpack raw data, without decompressing it.
+parseRawPngImage :: Get PngRawImage
+parseRawPngImage = do
+    sig <- getLazyByteString (L.length pngSignature)
+    when (sig /= pngSignature)
+         (fail "Invalid PNG file, signature broken")
+
+    ihdr <- get
+
+    chunkList <- parseChunks
+    return PngRawImage { header = ihdr, chunks = chunkList }
+
+--------------------------------------------------
+----            functions
+--------------------------------------------------
+
+-- | Signature signalling that the following data will be a png image
+-- in the png bit stream
+pngSignature :: ChunkSignature
+pngSignature = L.pack [137, 80, 78, 71, 13, 10, 26, 10]
+
+-- | Helper function to help pack signatures.
+signature :: String -> ChunkSignature
+signature = LS.pack 
+
+-- | Signature for the header chunk of png (must be the first)
+iHDRSignature :: ChunkSignature 
+iHDRSignature = signature "IHDR"
+
+-- | Signature for a palette chunk in the pgn file. Must
+-- occure before iDAT.
+pLTESignature :: ChunkSignature
+pLTESignature = signature "PLTE"
+
+-- | Signature for a data chuck (with image parts in it)
+iDATSignature :: ChunkSignature
+iDATSignature = signature "IDAT"
+
+-- | Signature for the last chunk of a png image, telling
+-- the end.
+iENDSignature :: ChunkSignature
+iENDSignature = signature "IEND"
+
+tRNSSignature :: ChunkSignature
+tRNSSignature = signature "tRNS"
+
+gammaSignature :: ChunkSignature
+gammaSignature = signature "gAMA"
+
+pHYsSignature :: ChunkSignature
+pHYsSignature = signature "pHYs"
+
+tEXtSignature :: ChunkSignature
+tEXtSignature = signature "tEXt"
+
+zTXtSignature :: ChunkSignature
+zTXtSignature = signature "zTXt"
+
+animationControlSignature :: ChunkSignature
+animationControlSignature = signature "acTL"
+
+instance Binary PngImageType where
+    put PngGreyscale = putWord8 0
+    put PngTrueColour = putWord8 2
+    put PngIndexedColor = putWord8 3
+    put PngGreyscaleWithAlpha = putWord8 4
+    put PngTrueColourWithAlpha = putWord8 6
+
+    get = get >>= imageTypeOfCode
+
+imageTypeOfCode :: Word8 -> Get PngImageType
+imageTypeOfCode 0 = return PngGreyscale
+imageTypeOfCode 2 = return PngTrueColour
+imageTypeOfCode 3 = return PngIndexedColor
+imageTypeOfCode 4 = return PngGreyscaleWithAlpha
+imageTypeOfCode 6 = return PngTrueColourWithAlpha
+imageTypeOfCode _ = fail "Invalid png color code"
+
+-- | From the Annex D of the png specification.
+pngCrcTable :: Vector Word32
+pngCrcTable = fromListN 256 [ foldl' updateCrcConstant c [zero .. 7] | c <- [0 .. 255] ]
+    where zero = 0 :: Int -- To avoid defaulting to Integer
+          updateCrcConstant c _ | c .&. 1 /= 0 = magicConstant `xor` (c `unsafeShiftR` 1)
+                                | otherwise = c `unsafeShiftR` 1
+          magicConstant = 0xedb88320 :: Word32
+
+-- | Compute the CRC of a raw buffer, as described in annex D of the PNG
+-- specification.
+pngComputeCrc :: [L.ByteString] -> Word32
+pngComputeCrc = (0xFFFFFFFF `xor`) . L.foldl' updateCrc 0xFFFFFFFF . L.concat
+    where updateCrc crc val =
+              let u32Val = fromIntegral val
+                  lutVal = pngCrcTable ! (fromIntegral ((crc `xor` u32Val) .&. 0xFF))
+              in lutVal `xor` (crc `unsafeShiftR` 8)
+
+chunksWithSig :: PngRawImage -> ChunkSignature -> [LS.ByteString]
+chunksWithSig rawImg sig =
+  [chunkData chunk | chunk <- chunks rawImg, chunkType chunk == sig]
+
+ src/Codec/Picture/Saving.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE CPP #-}
+-- | Helper functions to save dynamic images to other file format
+-- with automatic color space/sample format conversion done automatically.
+module Codec.Picture.Saving( imageToJpg
+                           , imageToPng
+                           , imageToGif
+                           , imageToBitmap
+                           , imageToTiff
+                           , imageToRadiance
+                           , imageToTga
+                           ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid( mempty )
+#endif
+
+import Data.Bits( unsafeShiftR )
+import Data.Word( Word8, Word16, Word32 )
+import qualified Data.ByteString.Lazy as L
+import Codec.Picture.Bitmap
+import Codec.Picture.Jpg
+import Codec.Picture.Png
+import Codec.Picture.Gif
+import Codec.Picture.ColorQuant
+import Codec.Picture.HDR
+import Codec.Picture.Types
+import Codec.Picture.Tiff
+import Codec.Picture.Tga
+
+import qualified Data.Vector.Storable as V
+
+componentToLDR :: Float -> Word8
+componentToLDR = truncate . (255 *) . min 1.0 . max 0.0
+
+toStandardDef :: Image PixelRGBF -> Image PixelRGB8
+toStandardDef = pixelMap pixelConverter
+  where pixelConverter (PixelRGBF rf gf bf) = PixelRGB8 r g b
+          where r = componentToLDR rf
+                g = componentToLDR gf
+                b = componentToLDR bf
+
+greyScaleToStandardDef :: Image PixelF -> Image Pixel8
+greyScaleToStandardDef = pixelMap componentToLDR
+
+from16to8 :: ( PixelBaseComponent source ~ Word16
+             , PixelBaseComponent dest ~ Word8 )
+          => Image source -> Image dest
+from16to8 Image { imageWidth = w, imageHeight = h
+                , imageData = arr } = Image w h transformed
+   where transformed = V.map toWord8 arr
+         toWord8 v = fromIntegral (v `unsafeShiftR` 8)
+
+from32to8 :: ( PixelBaseComponent source ~ Word32
+             , PixelBaseComponent dest ~ Word8 )
+          => Image source -> Image dest
+from32to8 Image { imageWidth = w, imageHeight = h
+                , imageData = arr } = Image w h transformed
+   where transformed = V.map toWord8 arr
+         toWord8 v = fromIntegral (v `unsafeShiftR` 24)
+
+from32to16 :: ( PixelBaseComponent source ~ Word32
+             , PixelBaseComponent dest ~ Word16 )
+          => Image source -> Image dest
+from32to16 Image { imageWidth = w, imageHeight = h
+                , imageData = arr } = Image w h transformed
+   where transformed = V.map toWord16 arr
+         toWord16 v = fromIntegral (v `unsafeShiftR` 16)
+
+from16toFloat :: ( PixelBaseComponent source ~ Word16
+                 , PixelBaseComponent dest ~ Float )
+          => Image source -> Image dest
+from16toFloat Image { imageWidth = w, imageHeight = h
+                    , imageData = arr } = Image w h transformed
+   where transformed = V.map toWord8 arr
+         toWord8 v = fromIntegral v / 65536.0
+
+-- | This function will try to do anything to encode an image
+-- as RADIANCE, make all color conversion and such. Equivalent
+-- of 'decodeImage' for radiance encoding
+imageToRadiance :: DynamicImage -> L.ByteString
+imageToRadiance (ImageCMYK8 img) =
+    imageToRadiance . ImageRGB8 $ convertImage img
+imageToRadiance (ImageCMYK16 img) =
+    imageToRadiance . ImageRGB16 $ convertImage img
+imageToRadiance (ImageYCbCr8 img) =
+    imageToRadiance . ImageRGB8 $ convertImage img
+imageToRadiance (ImageRGB8   img) =
+    imageToRadiance . ImageRGBF $ promoteImage img
+imageToRadiance (ImageRGBF   img) = encodeHDR img
+imageToRadiance (ImageRGBA8  img) =
+    imageToRadiance . ImageRGBF . promoteImage $ dropAlphaLayer img
+imageToRadiance (ImageY8     img) =
+    imageToRadiance . ImageRGB8 $ promoteImage img
+imageToRadiance (ImageYF     img) =
+    imageToRadiance . ImageRGBF $ promoteImage img
+imageToRadiance (ImageYA8    img) =
+    imageToRadiance . ImageRGB8 . promoteImage $ dropAlphaLayer img
+imageToRadiance (ImageY16    img) =
+  imageToRadiance . ImageRGBF $ pixelMap toRgbf img
+    where toRgbf v = PixelRGBF val val val
+            where val = fromIntegral v / 65536.0
+imageToRadiance (ImageY32    img) =
+  imageToRadiance . ImageRGBF $ pixelMap toRgbf img
+    where toRgbf v = PixelRGBF val val val
+            where val = fromIntegral v / 4294967296.0
+imageToRadiance (ImageYA16   img) =
+  imageToRadiance . ImageRGBF $ pixelMap toRgbf img
+    where toRgbf (PixelYA16 v _) = PixelRGBF val val val
+            where val = fromIntegral v / 65536.0
+imageToRadiance (ImageRGB16  img) =
+    imageToRadiance . ImageRGBF $ from16toFloat img
+imageToRadiance (ImageRGBA16 img) =
+    imageToRadiance . ImageRGBF $ pixelMap toRgbf img
+    where toRgbf (PixelRGBA16 r g b _) = PixelRGBF (f r) (f g) (f b)
+            where f v = fromIntegral v / 65536.0
+
+-- | This function will try to do anything to encode an image
+-- as JPEG, make all color conversion and such. Equivalent
+-- of 'decodeImage' for jpeg encoding
+-- Save Y or YCbCr Jpeg only, all other colorspaces are converted.
+-- To save a RGB or CMYK JPEG file, use the
+-- 'Codec.Picture.Jpg.Internal.encodeDirectJpegAtQualityWithMetadata' function
+imageToJpg :: Int -> DynamicImage -> L.ByteString
+imageToJpg quality dynImage =
+    let encodeAtQuality = encodeJpegAtQuality (fromIntegral quality)
+        encodeWithMeta = encodeDirectJpegAtQualityWithMetadata (fromIntegral quality) mempty
+    in case dynImage of
+        ImageYCbCr8 img -> encodeAtQuality img
+        ImageCMYK8  img -> imageToJpg quality . ImageRGB8 $ convertImage img
+        ImageCMYK16 img -> imageToJpg quality . ImageRGB16 $ convertImage img
+        ImageRGB8   img -> encodeAtQuality (convertImage img)
+        ImageRGBF   img -> imageToJpg quality . ImageRGB8 $ toStandardDef img
+        ImageRGBA8  img -> encodeAtQuality (convertImage $ dropAlphaLayer img)
+        ImageYF     img -> imageToJpg quality . ImageY8 $ greyScaleToStandardDef img
+        ImageY8     img -> encodeWithMeta img
+        ImageYA8    img -> encodeWithMeta $ dropAlphaLayer img
+        ImageY16    img -> imageToJpg quality . ImageY8 $ from16to8 img
+        ImageYA16   img -> imageToJpg quality . ImageYA8 $ from16to8 img
+        ImageY32    img -> imageToJpg quality . ImageY8 $ from32to8 img
+        ImageRGB16  img -> imageToJpg quality . ImageRGB8 $ from16to8 img
+        ImageRGBA16 img -> imageToJpg quality . ImageRGBA8 $ from16to8 img
+
+-- | This function will try to do anything to encode an image
+-- as PNG, make all color conversion and such. Equivalent
+-- of 'decodeImage' for PNG encoding
+imageToPng :: DynamicImage -> L.ByteString
+imageToPng (ImageYCbCr8 img) = encodePng (convertImage img :: Image PixelRGB8)
+imageToPng (ImageCMYK8 img)  = encodePng (convertImage img :: Image PixelRGB8)
+imageToPng (ImageCMYK16 img) = encodePng (convertImage img :: Image PixelRGB16)
+imageToPng (ImageRGB8   img) = encodePng img
+imageToPng (ImageRGBF   img) = encodePng $ toStandardDef img
+imageToPng (ImageRGBA8  img) = encodePng img
+imageToPng (ImageY8     img) = encodePng img
+imageToPng (ImageYF     img) = encodePng $ greyScaleToStandardDef img
+imageToPng (ImageYA8    img) = encodePng img
+imageToPng (ImageY16    img) = encodePng img
+imageToPng (ImageY32    img) = imageToPng . ImageY16 $ from32to16 img
+imageToPng (ImageYA16   img) = encodePng img
+imageToPng (ImageRGB16  img) = encodePng img
+imageToPng (ImageRGBA16 img) = encodePng img
+
+-- | This function will try to do anything to encode an image
+-- as a Tiff, make all color conversion and such. Equivalent
+-- of 'decodeImage' for Tiff encoding
+imageToTiff :: DynamicImage -> L.ByteString
+imageToTiff (ImageYCbCr8 img) = encodeTiff img
+imageToTiff (ImageCMYK8 img)  = encodeTiff img
+imageToTiff (ImageCMYK16 img) = encodeTiff img
+imageToTiff (ImageRGB8   img) = encodeTiff img
+imageToTiff (ImageRGBF   img) = encodeTiff $ toStandardDef img
+imageToTiff (ImageRGBA8  img) = encodeTiff img
+imageToTiff (ImageY8     img) = encodeTiff img
+imageToTiff (ImageYF     img) = encodeTiff $ greyScaleToStandardDef img
+imageToTiff (ImageYA8    img) = encodeTiff $ dropAlphaLayer img
+imageToTiff (ImageY16    img) = encodeTiff img
+imageToTiff (ImageY32    img) = encodeTiff img
+imageToTiff (ImageYA16   img) = encodeTiff $ dropAlphaLayer img
+imageToTiff (ImageRGB16  img) = encodeTiff img
+imageToTiff (ImageRGBA16 img) = encodeTiff img
+
+-- | This function will try to do anything to encode an image
+-- as bitmap, make all color conversion and such. Equivalent
+-- of 'decodeImage' for Bitmap encoding
+imageToBitmap :: DynamicImage -> L.ByteString
+imageToBitmap (ImageYCbCr8 img) = encodeBitmap (convertImage img :: Image PixelRGB8)
+imageToBitmap (ImageCMYK8  img) = encodeBitmap (convertImage img :: Image PixelRGB8)
+imageToBitmap (ImageCMYK16 img) = imageToBitmap . ImageRGB16 $ convertImage img
+imageToBitmap (ImageRGBF   img) = encodeBitmap $ toStandardDef img
+imageToBitmap (ImageRGB8   img) = encodeBitmap img
+imageToBitmap (ImageRGBA8  img) = encodeBitmap img
+imageToBitmap (ImageY8     img) = encodeBitmap img
+imageToBitmap (ImageYF     img) = encodeBitmap $ greyScaleToStandardDef img
+imageToBitmap (ImageYA8    img) = encodeBitmap (promoteImage img :: Image PixelRGBA8)
+imageToBitmap (ImageY16    img) = imageToBitmap . ImageY8 $ from16to8 img
+imageToBitmap (ImageY32    img) = imageToBitmap . ImageY8 $ from32to8 img
+imageToBitmap (ImageYA16   img) = imageToBitmap . ImageYA8 $ from16to8 img
+imageToBitmap (ImageRGB16  img) = imageToBitmap . ImageRGB8 $ from16to8 img
+imageToBitmap (ImageRGBA16 img) = imageToBitmap . ImageRGBA8 $ from16to8 img
+
+
+-- | This function will try to do anything to encode an image
+-- as a gif, make all color conversion and quantization. Equivalent
+-- of 'decodeImage' for gif encoding
+imageToGif :: DynamicImage -> Either String L.ByteString
+imageToGif (ImageYCbCr8 img) = imageToGif . ImageRGB8 $ convertImage img
+imageToGif (ImageCMYK8  img) = imageToGif . ImageRGB8 $ convertImage img
+imageToGif (ImageCMYK16 img) = imageToGif . ImageRGB16 $ convertImage img
+imageToGif (ImageRGBF   img) = imageToGif . ImageRGB8 $ toStandardDef img
+imageToGif (ImageRGB8   img) = encodeGifImageWithPalette indexed pal
+  where (indexed, pal) = palettize defaultPaletteOptions img
+imageToGif (ImageRGBA8  img) = imageToGif . ImageRGB8 $ dropAlphaLayer img
+imageToGif (ImageY8     img) = Right $ encodeGifImage img
+imageToGif (ImageYF     img) = imageToGif . ImageY8 $ greyScaleToStandardDef img
+imageToGif (ImageYA8    img) = imageToGif . ImageY8 $ dropAlphaLayer img
+imageToGif (ImageY16    img) = imageToGif . ImageY8 $ from16to8 img
+imageToGif (ImageY32    img) = imageToGif . ImageY8 $ from32to8 img
+imageToGif (ImageYA16   img) = imageToGif . ImageYA8 $ from16to8 img
+imageToGif (ImageRGB16  img) = imageToGif . ImageRGB8 $ from16to8 img
+imageToGif (ImageRGBA16 img) = imageToGif . ImageRGBA8 $ from16to8 img
+
+-- | This function will try to do anything to encode an image
+-- as a tga, make all color conversion and quantization. Equivalent
+-- of 'decodeImage' for tga encoding
+imageToTga :: DynamicImage -> L.ByteString
+imageToTga (ImageYCbCr8 img) = encodeTga (convertImage img :: Image PixelRGB8)
+imageToTga (ImageCMYK8  img) = encodeTga (convertImage img :: Image PixelRGB8)
+imageToTga (ImageCMYK16 img) = encodeTga (from16to8 img :: Image PixelRGB8)
+imageToTga (ImageRGBF   img) = encodeTga $ toStandardDef img
+imageToTga (ImageRGB8   img) = encodeTga img
+imageToTga (ImageRGBA8  img) = encodeTga img
+imageToTga (ImageY8     img) = encodeTga img
+imageToTga (ImageYF     img) = encodeTga $ greyScaleToStandardDef img
+imageToTga (ImageYA8    img) = encodeTga (promoteImage img :: Image PixelRGBA8)
+imageToTga (ImageY16    img) = encodeTga (from16to8 img :: Image Pixel8)
+imageToTga (ImageY32    img) = encodeTga (from32to8 img :: Image Pixel8)
+imageToTga (ImageYA16   img) = encodeTga (from16to8 img :: Image PixelRGBA8)
+imageToTga (ImageRGB16  img) = encodeTga (from16to8 img :: Image PixelRGB8)
+imageToTga (ImageRGBA16 img) = encodeTga (from16to8 img :: Image PixelRGBA8)
+ src/Codec/Picture/Tga.hs view
@@ -0,0 +1,527 @@+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+-- | Module implementing function to read and write
+-- Targa (*.tga) files.
+module Codec.Picture.Tga( decodeTga
+                        , decodeTgaWithMetadata
+                        , decodeTgaWithPaletteAndMetadata
+                        , TgaSaveable
+                        , encodeTga
+                        , writeTga
+                        )  where
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid( mempty )
+import Control.Applicative( (<*>), pure, (<$>) )
+#endif
+
+import Control.Arrow( first )
+import Control.Monad.ST( ST, runST )
+import Data.Bits( (.&.)
+                , (.|.)
+                , bit
+                , testBit
+                , setBit
+                , unsafeShiftL
+                , unsafeShiftR )
+import Data.Word( Word8, Word16 )
+import Data.Binary( Binary( .. ), encode )
+import Data.Binary.Get( Get
+                      , getByteString 
+                      , getWord8
+                      , getWord16le
+                      )
+import Data.Binary.Put( putWord8
+                      , putWord16le
+                      , putByteString
+                      )
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as Lb
+import qualified Data.ByteString.Unsafe as U
+import qualified Data.Vector.Storable.Mutable as M
+
+import Codec.Picture.Types
+import Codec.Picture.InternalHelper
+import Codec.Picture.Metadata( Metadatas
+                             , SourceFormat( SourceTGA )
+                             , basicMetadata )
+import Codec.Picture.VectorByteConversion
+
+data TgaColorMapType
+  = ColorMapWithoutTable
+  | ColorMapWithTable
+  | ColorMapUnknown Word8
+
+instance Binary TgaColorMapType where
+  get = do
+    v <- getWord8
+    return $ case v of
+      0 -> ColorMapWithoutTable
+      1 -> ColorMapWithTable
+      n -> ColorMapUnknown n
+
+  put v = case v of
+    ColorMapWithoutTable -> putWord8 0
+    ColorMapWithTable -> putWord8 1
+    (ColorMapUnknown vv) -> putWord8 vv
+
+data TgaImageType
+  = ImageTypeNoData Bool
+  | ImageTypeColorMapped Bool
+  | ImageTypeTrueColor Bool
+  | ImageTypeMonochrome Bool
+
+isRleEncoded :: TgaImageType -> Bool
+isRleEncoded v = case v of
+  ImageTypeNoData      yn -> yn
+  ImageTypeColorMapped yn -> yn
+  ImageTypeTrueColor   yn -> yn
+  ImageTypeMonochrome  yn -> yn
+
+imageTypeOfCode :: Word8 -> Get TgaImageType
+imageTypeOfCode v = case v .&. 3 of
+    0 -> return $ ImageTypeNoData isEncoded
+    1 -> return $ ImageTypeColorMapped isEncoded
+    2 -> return $ ImageTypeTrueColor isEncoded
+    3 -> return $ ImageTypeMonochrome isEncoded
+    _ -> fail $ "Unknown TGA image type " ++ show v
+  where
+    isEncoded = testBit v 3
+
+codeOfImageType :: TgaImageType -> Word8
+codeOfImageType v = case v of
+    ImageTypeNoData encoded -> setVal 0 encoded
+    ImageTypeColorMapped encoded -> setVal 1 encoded
+    ImageTypeTrueColor encoded -> setVal 2 encoded
+    ImageTypeMonochrome encoded -> setVal 3 encoded
+    where
+      setVal vv True = setBit vv 3
+      setVal vv False = vv
+
+instance Binary TgaImageType where
+  get = getWord8 >>= imageTypeOfCode
+  put = putWord8 . codeOfImageType
+    
+data TgaImageDescription = TgaImageDescription
+  { _tgaIdXOrigin       :: Bool
+  , _tgaIdYOrigin       :: Bool
+  , _tgaIdAttributeBits :: Word8
+  }
+
+instance Binary TgaImageDescription where
+  put desc = putWord8 $ xOrig .|. yOrig .|. attr
+    where
+      xOrig | _tgaIdXOrigin desc = bit 4
+            | otherwise = 0
+
+      yOrig | not $ _tgaIdYOrigin desc = bit 5
+            | otherwise = 0
+      
+      attr = _tgaIdAttributeBits desc .&. 0xF
+
+  get = toDescr <$> getWord8 where
+    toDescr v = TgaImageDescription
+      { _tgaIdXOrigin       = testBit v 4
+      , _tgaIdYOrigin       = not $ testBit v 5
+      , _tgaIdAttributeBits = v .&. 0xF
+      }
+
+data TgaHeader = TgaHeader
+  { _tgaHdrIdLength         :: {-# UNPACK #-} !Word8
+  , _tgaHdrColorMapType     :: !TgaColorMapType
+  , _tgaHdrImageType        :: !TgaImageType
+  , _tgaHdrMapStart         :: {-# UNPACK #-} !Word16
+  , _tgaHdrMapLength        :: {-# UNPACK #-} !Word16
+  , _tgaHdrMapDepth         :: {-# UNPACK #-} !Word8
+  , _tgaHdrXOffset          :: {-# UNPACK #-} !Word16
+  , _tgaHdrYOffset          :: {-# UNPACK #-} !Word16
+  , _tgaHdrWidth            :: {-# UNPACK #-} !Word16
+  , _tgaHdrHeight           :: {-# UNPACK #-} !Word16
+  , _tgaHdrPixelDepth       :: {-# UNPACK #-} !Word8
+  , _tgaHdrImageDescription :: {-# UNPACK #-} !TgaImageDescription
+  }
+
+instance Binary TgaHeader where
+  get = TgaHeader
+     <$> g8 <*> get <*> get <*> g16 <*> g16 <*> g8
+     <*> g16 <*> g16 <*> g16 <*> g16 <*> g8 <*> get
+   where g16 = getWord16le
+         g8 = getWord8
+
+  put v = do
+    let p8 = putWord8
+        p16 = putWord16le
+    p8  $ _tgaHdrIdLength v
+    put $ _tgaHdrColorMapType v
+    put $ _tgaHdrImageType v
+
+    p16 $ _tgaHdrMapStart v
+    p16 $ _tgaHdrMapLength v
+    p8  $ _tgaHdrMapDepth v
+    p16 $ _tgaHdrXOffset v
+    p16 $ _tgaHdrYOffset v
+    p16 $ _tgaHdrWidth v
+    p16 $ _tgaHdrHeight v
+    p8  $ _tgaHdrPixelDepth v
+    put $ _tgaHdrImageDescription v
+
+
+data TgaFile = TgaFile
+  { _tgaFileHeader :: !TgaHeader
+  , _tgaFileId     :: !B.ByteString
+  , _tgaPalette    :: !B.ByteString
+  , _tgaFileRest   :: !B.ByteString
+  }
+
+getPalette :: TgaHeader -> Get B.ByteString
+getPalette hdr | _tgaHdrMapLength hdr <= 0 = return mempty
+getPalette hdr = getByteString $ bytePerPixel * pixelCount
+  where
+    bytePerPixel = fromIntegral $ _tgaHdrMapDepth hdr `div` 8
+    pixelCount = fromIntegral $ _tgaHdrMapLength hdr
+
+instance Binary TgaFile where
+  get = do
+    hdr <- get
+    validateTga hdr
+    fileId <- getByteString . fromIntegral $ _tgaHdrIdLength hdr
+    palette <- getPalette hdr
+    rest <- getRemainingBytes
+
+    return TgaFile {
+        _tgaFileHeader = hdr
+      , _tgaFileId = fileId
+      , _tgaPalette = palette
+      , _tgaFileRest = rest
+      }
+
+  put file = do
+    put $ _tgaFileHeader file
+    putByteString $ _tgaFileId file
+    putByteString $ _tgaPalette file
+    putByteString $ _tgaFileRest file
+
+data Depth8 = Depth8
+data Depth15 = Depth15
+data Depth24 = Depth24
+data Depth32 = Depth32
+
+class (Pixel (Unpacked a)) => TGAPixel a where
+   type Unpacked a
+   packedByteSize :: a -> Int
+   tgaUnpack      :: a -> B.ByteString -> Int -> Unpacked a
+
+instance TGAPixel Depth8 where
+   type Unpacked Depth8 = Pixel8
+   packedByteSize _ = 1
+   tgaUnpack _ = U.unsafeIndex
+
+instance TGAPixel Depth15 where
+   type Unpacked Depth15 = PixelRGBA8
+   packedByteSize _ = 2
+   tgaUnpack _ str ix = PixelRGBA8 r g b a
+      where
+        v0 = U.unsafeIndex str ix
+        v1 = U.unsafeIndex str $ ix + 1
+        r = (v1 .&. 0x7c) `unsafeShiftL` 1;
+        g = ((v1 .&. 0x03) `unsafeShiftL` 6) .|. ((v0 .&. 0xe0) `unsafeShiftR` 2);
+        b = (v0 .&. 0x1f) `unsafeShiftL` 3
+        a = 255 -- v1 .&. 0x80
+
+instance TGAPixel Depth24 where
+   type Unpacked Depth24 = PixelRGB8
+   packedByteSize _ = 3
+   tgaUnpack _ str ix = PixelRGB8 r g b
+     where
+       b = U.unsafeIndex str ix
+       g = U.unsafeIndex str (ix + 1)
+       r = U.unsafeIndex str (ix + 2)
+
+instance TGAPixel Depth32 where
+   type Unpacked Depth32 = PixelRGBA8
+   packedByteSize _ = 4
+   tgaUnpack _ str ix = PixelRGBA8 r g b a
+     where
+       b = U.unsafeIndex str ix
+       g = U.unsafeIndex str (ix + 1)
+       r = U.unsafeIndex str (ix + 2)
+       a = U.unsafeIndex str (ix + 3)
+
+prepareUnpacker :: TgaFile
+                -> (forall tgapx. (TGAPixel tgapx) => tgapx -> TgaFile -> Image (Unpacked tgapx))
+                -> Either String DynamicImage
+prepareUnpacker file f =
+  let hdr = _tgaFileHeader file
+      flipper :: (Pixel px) => Image px -> Image px
+      flipper = flipImage $ _tgaHdrImageDescription hdr
+  in
+  case _tgaHdrPixelDepth hdr of
+    8  -> pure . ImageY8 . flipper $ f Depth8 file
+    16 -> pure . ImageRGBA8 . flipper $ f Depth15 file
+    24 -> pure . ImageRGB8 . flipper $ f Depth24 file
+    32 -> pure . ImageRGBA8 . flipper $ f Depth32 file
+    n  -> Left $ "Invalid bit depth (" ++ show n ++ ")"
+
+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 _ _ _ = Left "Bad colorspace for image"
+
+unparse :: TgaFile -> Either String (PalettedImage, Metadatas)
+unparse file =
+  let hdr = _tgaFileHeader file
+      imageType = _tgaHdrImageType hdr
+
+      unpacker :: forall tgapx. (TGAPixel tgapx)
+               => tgapx -> TgaFile -> Image (Unpacked tgapx)
+      unpacker | isRleEncoded imageType = unpackRLETga
+               | otherwise = unpackUncompressedTga
+
+      metas = basicMetadata SourceTGA (_tgaHdrWidth hdr) (_tgaHdrHeight hdr)
+      decodedPalette = unparse file
+        { _tgaFileHeader = hdr
+            { _tgaHdrHeight = 1
+            , _tgaHdrWidth = _tgaHdrMapLength hdr
+            , _tgaHdrPixelDepth = _tgaHdrMapDepth hdr
+            , _tgaHdrImageType = ImageTypeTrueColor False
+            }
+        , _tgaFileRest = _tgaPalette file
+        }
+  in
+  case imageType of
+    ImageTypeNoData _ -> Left "No data detected in TGA file"
+    ImageTypeTrueColor _ ->
+      fmap ((, metas) . TrueColorImage) $ prepareUnpacker file unpacker
+    ImageTypeMonochrome _ ->
+      fmap ((, metas) . TrueColorImage) $ prepareUnpacker file unpacker
+    ImageTypeColorMapped _ ->
+      case decodedPalette of
+        Left str -> Left str
+        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 _ -> Left "Unknown pixel type"
+
+writeRun :: (Pixel px)
+         => M.STVector s (PixelBaseComponent px) -> Int -> px -> Int
+         -> ST s Int
+writeRun imgData localMaxi px = run
+  where
+    writeDelta = componentCount px
+    run writeIndex 
+      | writeIndex >= localMaxi = return writeIndex
+    run writeIndex = do
+      unsafeWritePixel imgData writeIndex px
+      run $ writeIndex + writeDelta
+
+copyData :: forall tgapx s
+          . (TGAPixel tgapx)
+         => tgapx
+         -> M.STVector s (PixelBaseComponent (Unpacked tgapx))
+         -> B.ByteString
+         -> Int -> Int
+         -> Int -> Int
+         -> ST s (Int, Int)
+copyData tgapx imgData readData maxi maxRead = go
+  where
+    readDelta = packedByteSize tgapx
+    writeDelta = componentCount (undefined :: Unpacked tgapx)
+
+    go writeIndex readIndex
+      | writeIndex >= maxi ||
+        readIndex >= maxRead = return (writeIndex, readIndex)
+    go writeIndex readIndex = do
+      let px = tgaUnpack tgapx readData readIndex :: Unpacked tgapx
+      unsafeWritePixel imgData writeIndex px
+      go (writeIndex + writeDelta) (readIndex + readDelta)
+
+unpackUncompressedTga :: forall tgapx
+                       . (TGAPixel tgapx)
+                      => tgapx -- ^ Type witness
+                      -> TgaFile
+                      -> Image (Unpacked tgapx)
+unpackUncompressedTga tga file = runST $ do
+    img <- MutableImage width height <$> M.new maxi
+    let imgData = mutableImageData img
+    _ <- copyData tga imgData readData maxi maxRead 0 0
+    unsafeFreezeImage img
+
+  where
+    hdr = _tgaFileHeader file
+    width = fromIntegral $ _tgaHdrWidth hdr
+    height = fromIntegral $ _tgaHdrHeight hdr
+    readData = _tgaFileRest file
+    compCount = componentCount (undefined :: Unpacked tgapx)
+    maxi = width * height * compCount
+    maxRead = B.length readData
+
+isRleChunk :: Word8 -> Bool
+isRleChunk v = testBit v 7
+
+runLength :: Word8 -> Int
+runLength v = fromIntegral (v .&. 0x7F) + 1
+
+unpackRLETga :: forall tgapx
+              . (TGAPixel tgapx)
+             => tgapx -- ^ Type witness
+             -> TgaFile
+             -> Image (Unpacked tgapx)
+unpackRLETga tga file = runST $ do
+    img <- MutableImage width height <$> M.new maxi
+    let imgData = mutableImageData img
+
+        go writeIndex readIndex
+            | writeIndex >= maxi = return () 
+            | readIndex >= maxRead = return ()
+        go writeIndex readIndex = do
+          let code = U.unsafeIndex readData readIndex
+              copyMax = min maxi $ writeIndex + runLength code * compCount
+          
+          if isRleChunk code then do
+            let px = tgaUnpack tga readData (readIndex + 1) :: Unpacked tgapx
+            lastWriteIndex <- writeRun imgData copyMax px writeIndex
+            go lastWriteIndex $ readIndex + 1 + readDelta
+
+          else do
+            (newWrite, newRead) <-
+                copyData tga imgData readData copyMax maxRead
+                    writeIndex (readIndex + 1)
+            go newWrite newRead
+
+    go 0 0
+    unsafeFreezeImage img
+
+  where
+    hdr = _tgaFileHeader file
+    width = fromIntegral $ _tgaHdrWidth hdr
+    height = fromIntegral $ _tgaHdrHeight hdr
+    readData = _tgaFileRest file
+    compCount = componentCount (undefined :: Unpacked tgapx)
+    maxi = width * height * compCount
+    maxRead = B.length readData
+    readDelta = packedByteSize tga
+
+flipImage :: (Pixel px)
+          => TgaImageDescription -> Image px -> Image px
+flipImage desc img
+    | xFlip && yFlip =
+        generateImage (\x y -> pixelAt img (wMax - x) (hMax - y)) w h
+    | xFlip =
+        generateImage (\x y -> pixelAt img (wMax - x) y) w h
+    | yFlip =
+        generateImage (\x y -> pixelAt img x (hMax - y)) w h
+    | otherwise = img
+  where
+    xFlip = _tgaIdXOrigin desc
+    yFlip = _tgaIdYOrigin desc
+    w = imageWidth img
+    h = imageHeight img
+
+    !wMax = w - 1
+    !hMax = h - 1
+
+validateTga :: TgaHeader -> Get ()
+validateTga hdr
+    | _tgaHdrWidth hdr <= 0 = fail "Width is null or negative"
+    | _tgaHdrHeight hdr <= 0 = fail "Height is null or negative"
+validateTga _ = return ()
+
+-- | Transform a raw tga image to an image, without modifying
+-- the underlying pixel type.
+--
+-- This function can output the following images:
+--
+--  * 'ImageY8'
+--
+--  * 'ImageRGB8'
+--
+--  * 'ImageRGBA8'
+--
+decodeTga :: B.ByteString -> Either String DynamicImage
+decodeTga byte = fst <$> decodeTgaWithMetadata byte
+
+-- | Equivalent to decodeTga but also provide metadata
+decodeTgaWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
+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.
+class TgaSaveable a where
+    tgaDataOfImage :: Image a -> B.ByteString
+    tgaPixelDepthOfImage :: Image a -> Word8
+    tgaTypeOfImage :: Image a -> TgaImageType
+
+instance TgaSaveable Pixel8 where
+    tgaDataOfImage = toByteString . imageData
+    tgaPixelDepthOfImage _ = 8
+    tgaTypeOfImage _ = ImageTypeMonochrome False
+
+instance TgaSaveable PixelRGB8 where
+    tgaPixelDepthOfImage _ = 24
+    tgaTypeOfImage _ = ImageTypeTrueColor False
+    tgaDataOfImage = toByteString . imageData . pixelMap flipRgb
+      where
+        flipRgb (PixelRGB8 r g b) = PixelRGB8 b g r
+
+instance TgaSaveable PixelRGBA8 where
+    tgaPixelDepthOfImage _ = 32
+    tgaTypeOfImage _ = ImageTypeTrueColor False
+    tgaDataOfImage = toByteString . imageData . pixelMap flipRgba
+      where
+        flipRgba (PixelRGBA8 r g b a) = PixelRGBA8 b g r a
+
+-- | Helper function to directly write an image a tga on disk.
+writeTga :: (TgaSaveable pixel) => FilePath -> Image pixel -> IO ()
+writeTga path img = Lb.writeFile path $ encodeTga img
+
+-- | Transform a compatible image to a raw bytestring
+-- representing a Targa file.
+encodeTga :: (TgaSaveable px) => Image px -> Lb.ByteString
+encodeTga img = encode file
+  where
+    file = TgaFile
+      { _tgaFileHeader = TgaHeader
+            { _tgaHdrIdLength         = 0
+            , _tgaHdrColorMapType     = ColorMapWithoutTable
+            , _tgaHdrImageType        = tgaTypeOfImage img
+            , _tgaHdrMapStart         = 0
+            , _tgaHdrMapLength        = 0
+            , _tgaHdrMapDepth         = 0
+            , _tgaHdrXOffset          = 0
+            , _tgaHdrYOffset          = 0
+            , _tgaHdrWidth            = fromIntegral $ imageWidth img
+            , _tgaHdrHeight           = fromIntegral $ imageHeight img
+            , _tgaHdrPixelDepth       = tgaPixelDepthOfImage img
+            , _tgaHdrImageDescription = TgaImageDescription
+                    { _tgaIdXOrigin       = False
+                    , _tgaIdYOrigin       = False
+                    , _tgaIdAttributeBits = 0
+                    }
+            }
+      , _tgaFileId     = mempty
+      , _tgaPalette    = mempty
+      , _tgaFileRest   = tgaDataOfImage img
+      }
+
+{-# ANN module "HLint: ignore Reduce duplication" #-}
+
+ src/Codec/Picture/Tiff.hs view
@@ -0,0 +1,941 @@+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE CPP #-}
+-- | Module implementing TIFF decoding.
+--
+-- Supported compression schemes:
+--
+--   * Uncompressed
+--
+--   * PackBits
+--
+--   * LZW
+--
+-- Supported bit depth:
+--
+--   * 2 bits
+--
+--   * 4 bits
+--
+--   * 8 bits
+--
+--   * 16 bits
+--
+module Codec.Picture.Tiff( decodeTiff
+                         , decodeTiffWithMetadata
+                         , decodeTiffWithPaletteAndMetadata
+                         , TiffSaveable
+                         , encodeTiff
+                         , writeTiff
+                         ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<$>), (<*>), pure )
+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 )
+import Data.Int( Int8 )
+import Data.Word( Word8, Word16, Word32 )
+import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR )
+import Data.Binary.Get( Get )
+import Data.Binary.Put( runPut )
+
+import qualified Data.Vector as V
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector.Storable.Mutable as M
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as Lb
+import qualified Data.ByteString.Unsafe as BU
+
+import Foreign.Storable( sizeOf )
+
+import Codec.Picture.Metadata.Exif
+import Codec.Picture.Metadata( Metadatas )
+import Codec.Picture.InternalHelper
+import Codec.Picture.BitWriter
+import Codec.Picture.Types
+import Codec.Picture.Gif.Internal.LZW
+import Codec.Picture.Tiff.Internal.Types
+import Codec.Picture.Tiff.Internal.Metadata
+import Codec.Picture.VectorByteConversion( toByteString )
+
+data TiffInfo = TiffInfo
+  { tiffHeader             :: TiffHeader
+  , tiffWidth              :: Word32
+  , tiffHeight             :: Word32
+  , tiffColorspace         :: TiffColorspace
+  , tiffSampleCount        :: Word32
+  , tiffRowPerStrip        :: Word32
+  , tiffPlaneConfiguration :: TiffPlanarConfiguration
+  , tiffSampleFormat       :: [TiffSampleFormat]
+  , tiffBitsPerSample      :: V.Vector Word32
+  , tiffCompression        :: TiffCompression
+  , tiffStripSize          :: V.Vector Word32
+  , tiffOffsets            :: V.Vector Word32
+  , tiffPalette            :: Maybe (Image PixelRGB16)
+  , tiffYCbCrSubsampling   :: V.Vector Word32
+  , tiffExtraSample        :: Maybe ExtraSample
+  , tiffPredictor          :: Predictor
+  , tiffMetadatas          :: Metadatas
+  }
+
+unLong :: String -> ExifData -> Get (V.Vector Word32)
+unLong _ (ExifLong v)   = pure $ V.singleton v
+unLong _ (ExifShort v)  = pure $ V.singleton (fromIntegral v)
+unLong _ (ExifShorts v) = pure $ V.map fromIntegral v
+unLong _ (ExifLongs v) = pure v
+unLong errMessage _ = fail errMessage
+
+findIFD :: String -> ExifTag -> [ImageFileDirectory]
+        -> Get ImageFileDirectory
+findIFD errorMessage tag lst =
+  case [v | v <- lst, ifdIdentifier v == tag] of
+    [] -> fail errorMessage
+    (x:_) -> pure x
+
+findPalette :: [ImageFileDirectory] -> Get (Maybe (Image PixelRGB16))
+findPalette ifds =
+    case [v | v <- ifds, ifdIdentifier v == TagColorMap] of
+        (ImageFileDirectory { ifdExtended = ExifShorts vec }:_) ->
+            pure . Just . Image pixelCount 1 $ VS.generate (V.length vec) axx
+                where pixelCount = V.length vec `div` 3
+                      axx v = vec `V.unsafeIndex` (idx + color * pixelCount)
+                          where (idx, color) = v `divMod` 3
+
+        _ -> pure Nothing
+
+findIFDData :: String -> ExifTag -> [ImageFileDirectory] -> Get Word32
+findIFDData msg tag lst = ifdOffset <$> findIFD msg tag lst
+
+findIFDDefaultData :: Word32 -> ExifTag -> [ImageFileDirectory] -> Get Word32
+findIFDDefaultData d tag lst =
+    case [v | v <- lst, ifdIdentifier v == tag] of
+        [] -> pure d
+        (x:_) -> pure $ ifdOffset x
+
+findIFDExt :: String -> ExifTag -> [ImageFileDirectory] -> Get ExifData
+findIFDExt msg tag lst = do
+    val <- findIFD msg tag lst
+    case val of
+      ImageFileDirectory
+        { ifdCount = 1, ifdOffset = ofs, ifdType = TypeShort } ->
+               pure . ExifShorts . V.singleton $ fromIntegral ofs
+      ImageFileDirectory
+        { ifdCount = 1, ifdOffset = ofs, ifdType = TypeLong } ->
+               pure . ExifLongs  . V.singleton $ fromIntegral ofs
+      ImageFileDirectory { ifdExtended = v } -> pure v
+
+
+findIFDExtDefaultData :: [Word32] -> ExifTag -> [ImageFileDirectory]
+                      -> Get [Word32]
+findIFDExtDefaultData d tag lst =
+    case [v | v <- lst, ifdIdentifier v == tag] of
+        [] -> pure d
+        (ImageFileDirectory { ifdExtended = ExifNone }:_) -> return d
+        (x:_) -> V.toList <$> unLong errorMessage (ifdExtended x)
+            where errorMessage =
+                    "Can't parse tag " ++ show tag ++ " " ++ show (ifdExtended x)
+
+-- It's temporary, remove once tiff decoding is better
+-- handled.
+{-  
+instance Show (Image PixelRGB16) where
+    show _ = "Image PixelRGB16"
+-}
+copyByteString :: B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32)
+               -> ST s Int
+copyByteString str vec stride startWrite (from, count) = inner startWrite fromi
+  where fromi = fromIntegral from
+        maxi = fromi + fromIntegral count
+
+        inner writeIdx i | i >= maxi = pure writeIdx
+        inner writeIdx i = do
+            let v = str `BU.unsafeIndex` i
+            (vec `M.unsafeWrite` writeIdx) v
+            inner (writeIdx + stride) $ i + 1
+
+unpackPackBit :: B.ByteString -> M.STVector s Word8 -> Int -> Int
+              -> (Word32, Word32)
+              -> ST s Int
+unpackPackBit str outVec stride writeIndex (offset, size) = loop fromi writeIndex
+  where fromi = fromIntegral offset
+        maxi = fromi + fromIntegral size
+
+        replicateByte writeIdx _     0 = pure writeIdx
+        replicateByte writeIdx v count = do
+            (outVec `M.unsafeWrite` writeIdx) v
+            replicateByte (writeIdx + stride) v $ count - 1
+
+        loop i writeIdx | i >= maxi = pure writeIdx
+        loop i writeIdx = choice
+          {-where v = fromIntegral (str `BU.unsafeIndex` i) :: Int8-}
+          where v = fromIntegral (str `B.index` i) :: Int8
+
+                choice
+                    -- data
+                    | 0    <= v =
+                        copyByteString str outVec stride writeIdx
+                                        (fromIntegral $ i + 1, fromIntegral v + 1)
+                            >>= loop (i + 2 + fromIntegral v)
+                    -- run
+                    | -127 <= v = do
+                        {-let nextByte = str `BU.unsafeIndex` (i + 1)-}
+                        let nextByte = str `B.index` (i + 1)
+                            count = negate (fromIntegral v) + 1 :: Int
+                        replicateByte writeIdx nextByte count
+                            >>= loop (i + 2)
+
+                    -- noop
+                    | otherwise = loop writeIdx $ i + 1
+
+uncompressAt :: TiffCompression
+             -> B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32)
+             -> ST s Int
+uncompressAt CompressionNone = copyByteString
+uncompressAt CompressionPackBit = unpackPackBit
+uncompressAt CompressionLZW =  \str outVec _stride writeIndex (offset, size) -> do
+    let toDecode = B.take (fromIntegral size) $ B.drop (fromIntegral offset) str
+    runBoolReader $ decodeLzwTiff toDecode outVec writeIndex
+    return 0
+uncompressAt _ = error "Unhandled compression"
+
+class Unpackable a where
+    type StorageType a :: *
+
+    outAlloc :: a -> Int -> ST s (M.STVector s (StorageType a))
+
+    -- | Final image and size, return offset and vector
+    allocTempBuffer :: a  -> M.STVector s (StorageType a) -> Int
+                    -> ST s (M.STVector s Word8)
+
+    offsetStride :: a -> Int -> Int -> (Int, Int)
+
+    mergeBackTempBuffer :: a    -- ^ Type witness, just for the type checker.
+                        -> Endianness
+                        -> M.STVector s Word8 -- ^ Temporary buffer handling decompression.
+                        -> Int  -- ^ Line size in pixels
+                        -> Int  -- ^ Write index, in bytes
+                        -> Word32  -- ^ size, in bytes
+                        -> Int  -- ^ Stride
+                        -> M.STVector s (StorageType a) -- ^ Final buffer
+                        -> ST s ()
+
+-- | The Word8 instance is just a passthrough, to avoid
+-- copying memory twice
+instance Unpackable Word8 where
+  type StorageType Word8 = Word8
+
+  offsetStride _ i stride = (i, stride)
+  allocTempBuffer _ buff _ = pure buff
+  mergeBackTempBuffer _ _ _ _ _ _ _ _ = pure ()
+  outAlloc _ count = M.replicate count 0 -- M.new
+
+instance Unpackable Word16 where
+  type StorageType Word16 = Word16
+
+  offsetStride _ _ _ = (0, 1)
+  outAlloc _ = M.new
+  allocTempBuffer _ _ s = M.new $ s * 2
+  mergeBackTempBuffer _ EndianLittle tempVec _ index size stride outVec =
+        looperLe index 0
+    where looperLe _ readIndex | readIndex >= fromIntegral size = pure ()
+          looperLe writeIndex readIndex = do
+              v1 <- tempVec `M.read` readIndex
+              v2 <- tempVec `M.read` (readIndex + 1)
+              let finalValue =
+                    (fromIntegral v2 `unsafeShiftL` 8) .|. fromIntegral v1
+              (outVec `M.write` writeIndex) finalValue
+
+              looperLe (writeIndex + stride) (readIndex + 2)
+  mergeBackTempBuffer _ EndianBig tempVec _ index size stride outVec =
+         looperBe index 0
+    where looperBe _ readIndex | readIndex >= fromIntegral size = pure ()
+          looperBe writeIndex readIndex = do
+              v1 <- tempVec `M.read` readIndex
+              v2 <- tempVec `M.read` (readIndex + 1)
+              let finalValue =
+                    (fromIntegral v1 `unsafeShiftL` 8) .|. fromIntegral v2
+              (outVec `M.write` writeIndex) finalValue
+
+              looperBe (writeIndex + stride) (readIndex + 2)
+
+instance Unpackable Word32 where
+  type StorageType Word32 = Word32
+
+  offsetStride _ _ _ = (0, 1)
+  outAlloc _ = M.new
+  allocTempBuffer _ _ s = M.new $ s * 4
+  mergeBackTempBuffer _ EndianLittle tempVec _ index size stride outVec =
+        looperLe index 0
+    where looperLe _ readIndex | readIndex >= fromIntegral size = pure ()
+          looperLe writeIndex readIndex = do
+              v1 <- tempVec `M.read` readIndex
+              v2 <- tempVec `M.read` (readIndex + 1)
+              v3 <- tempVec `M.read` (readIndex + 2)
+              v4 <- tempVec `M.read` (readIndex + 3)
+              let finalValue =
+                    (fromIntegral v4 `unsafeShiftL` 24) .|.
+                    (fromIntegral v3 `unsafeShiftL` 16) .|.
+                    (fromIntegral v2 `unsafeShiftL` 8) .|.
+                    fromIntegral v1
+              (outVec `M.write` writeIndex) finalValue
+
+              looperLe (writeIndex + stride) (readIndex + 4)
+  mergeBackTempBuffer _ EndianBig tempVec _ index size stride outVec =
+         looperBe index 0
+    where looperBe _ readIndex | readIndex >= fromIntegral size = pure ()
+          looperBe writeIndex readIndex = do
+              v1 <- tempVec `M.read` readIndex
+              v2 <- tempVec `M.read` (readIndex + 1)
+              v3 <- tempVec `M.read` (readIndex + 2)
+              v4 <- tempVec `M.read` (readIndex + 3)
+              let finalValue =
+                    (fromIntegral v1 `unsafeShiftL` 24) .|.
+                    (fromIntegral v2 `unsafeShiftL` 16) .|.
+                    (fromIntegral v3 `unsafeShiftL` 8) .|.
+                    fromIntegral v4
+              (outVec `M.write` writeIndex) finalValue
+
+              looperBe (writeIndex + stride) (readIndex + 4)
+
+instance Unpackable Float where
+  type StorageType Float = Float
+
+  offsetStride _ _ _ = (0, 1)
+  outAlloc _ = M.new
+  allocTempBuffer _ _ s = M.new $ s * 4
+  mergeBackTempBuffer :: forall s. Float
+                      -> Endianness
+                      -> M.STVector s Word8
+                      -> Int
+                      -> Int
+                      -> Word32
+                      -> Int
+                      -> M.STVector s (StorageType Float)
+                      -> ST s ()
+  mergeBackTempBuffer _ endianness tempVec lineSize index size stride outVec =
+        let outVecWord32 :: M.STVector s Word32
+            outVecWord32 = M.unsafeCast outVec
+        in mergeBackTempBuffer (0 :: Word32)
+                               endianness
+                               tempVec
+                               lineSize
+                               index
+                               size
+                               stride
+                               outVecWord32
+
+data Pack4 = Pack4
+
+instance Unpackable Pack4 where
+  type StorageType Pack4 = Word8
+  allocTempBuffer _ _ = M.new
+  offsetStride _ _ _ = (0, 1)
+  outAlloc _ = M.new
+  mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec =
+        inner 0 index pxCount
+    where pxCount = lineSize `div` stride
+
+          maxWrite = M.length outVec
+          inner readIdx writeIdx _
+                | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure ()
+          inner readIdx writeIdx line
+                | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount
+          inner readIdx writeIdx line = do
+            v <- tempVec `M.read` readIdx
+            let high = (v `unsafeShiftR` 4) .&. 0xF
+                low = v .&. 0xF
+            (outVec `M.write` writeIdx) high
+            when (writeIdx + stride < maxWrite) $
+                 (outVec `M.write` (writeIdx + stride)) low
+
+            inner (readIdx + 1) (writeIdx + 2 * stride) (line - 2)
+
+data Pack2 = Pack2
+
+instance Unpackable Pack2 where
+  type StorageType Pack2 = Word8
+  allocTempBuffer _ _ = M.new
+  offsetStride _ _ _ = (0, 1)
+  outAlloc _ = M.new
+  mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec =
+        inner 0 index pxCount
+    where pxCount = lineSize `div` stride
+
+          maxWrite = M.length outVec
+          inner readIdx writeIdx _
+                | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure ()
+          inner readIdx writeIdx line
+                | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount
+          inner readIdx writeIdx line = do
+            v <- tempVec `M.read` readIdx
+            let v0 = (v `unsafeShiftR` 6) .&. 0x3
+                v1 = (v `unsafeShiftR` 4) .&. 0x3
+                v2 = (v `unsafeShiftR` 2) .&. 0x3
+                v3 = v .&. 0x3
+
+            (outVec `M.write` writeIdx) v0
+            when (writeIdx + 1 * stride < maxWrite) $
+                 (outVec `M.write` (writeIdx + stride)) v1
+
+            when (writeIdx + 2 * stride < maxWrite) $
+                 (outVec `M.write` (writeIdx + stride * 2)) v2
+
+            when (writeIdx + 3 * stride < maxWrite) $
+                 (outVec `M.write` (writeIdx + stride * 3)) v3
+
+            inner (readIdx + 1) (writeIdx + 4 * stride) (line - 4)
+
+data Pack12 = Pack12
+
+instance Unpackable Pack12 where
+  type StorageType Pack12 = Word16
+  allocTempBuffer _ _ = M.new
+  offsetStride _ _ _ = (0, 1)
+  outAlloc _ = M.new
+  mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec =
+        inner 0 index pxCount
+    where pxCount = lineSize `div` stride
+
+          maxWrite = M.length outVec
+          inner readIdx writeIdx _
+                | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure ()
+          inner readIdx writeIdx line
+                | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount
+          inner readIdx writeIdx line = do
+            v0 <- tempVec `M.read` readIdx
+            v1 <- if readIdx + 1 < fromIntegral size
+                then tempVec `M.read` (readIdx + 1)
+                else pure 0
+            v2 <- if readIdx + 2 < fromIntegral size
+                then tempVec `M.read` (readIdx + 2)
+                else pure 0
+
+            let high0 = fromIntegral v0 `unsafeShiftL` 4
+                low0 = (fromIntegral v1 `unsafeShiftR` 4) .&. 0xF
+
+                p0 = high0 .|. low0
+
+                high1 = (fromIntegral v1 .&. 0xF) `unsafeShiftL` 8
+                low1 = fromIntegral v2
+                p1 = high1 .|. low1
+
+            (outVec `M.write` writeIdx) p0
+            when (writeIdx + 1 * stride < maxWrite) $
+                 (outVec `M.write` (writeIdx + stride)) p1
+
+            inner (readIdx + 3) (writeIdx + 2 * stride) (line - 2)
+
+data YCbCrSubsampling = YCbCrSubsampling
+    { ycbcrWidth        :: !Int
+    , ycbcrHeight       :: !Int
+    , ycbcrImageWidth   :: !Int
+    , ycbcrStripHeight  :: !Int
+    }
+
+instance Unpackable YCbCrSubsampling where
+  type StorageType YCbCrSubsampling = Word8
+
+  offsetStride _ _ _ = (0, 1)
+  outAlloc _ = M.new
+  allocTempBuffer _ _ = M.new
+  mergeBackTempBuffer subSampling _ tempVec _ index size _ outVec =
+      foldM_ unpacker 0 [(bx, by) | by <- [0, h .. lineCount - 1]
+                                  , bx <- [0, w .. imgWidth - 1]]
+    where w = ycbcrWidth subSampling
+          h = ycbcrHeight subSampling
+          imgWidth = ycbcrImageWidth subSampling
+          lineCount = ycbcrStripHeight subSampling
+
+          lumaCount = w * h
+          blockSize = lumaCount + 2
+
+          maxOut = M.length outVec
+
+          unpacker readIdx _ | readIdx >= fromIntegral size * 3 = pure readIdx
+          unpacker readIdx (bx, by) = do
+              cb <- tempVec `M.read` (readIdx + lumaCount)
+              cr <- tempVec `M.read` (readIdx + lumaCount + 1)
+
+              let pixelIndices =
+                        [index + ((by + y) * imgWidth + bx + x) * 3 | y <- [0 .. h - 1], x <- [0 .. w - 1]]
+
+                  writer readIndex writeIdx | writeIdx + 3 > maxOut = pure readIndex
+                  writer readIndex writeIdx = do
+                    y <- tempVec `M.read` readIndex
+                    (outVec `M.write` writeIdx) y
+                    (outVec `M.write` (writeIdx + 1)) cb
+                    (outVec `M.write` (writeIdx + 2)) cr
+                    return $ readIndex + 1
+
+              foldM_ writer readIdx pixelIndices
+
+              return $ readIdx + blockSize
+
+gatherStrips :: ( Unpackable comp
+                , Pixel pixel
+                , StorageType comp ~ PixelBaseComponent pixel
+                )
+             => comp -> B.ByteString -> TiffInfo -> Image pixel
+gatherStrips comp str nfo = runST $ do
+  let width = fromIntegral $ tiffWidth nfo
+      height = fromIntegral $ tiffHeight nfo
+      sampleCount = if tiffSampleCount nfo /= 0
+        then fromIntegral $ tiffSampleCount nfo
+        else V.length $ tiffBitsPerSample nfo
+
+      rowPerStrip = fromIntegral $ tiffRowPerStrip nfo
+      endianness = hdrEndianness $ tiffHeader nfo
+
+      stripCount = V.length $ tiffOffsets nfo
+      compression = tiffCompression nfo
+
+  outVec <- outAlloc comp $ width * height * sampleCount
+  tempVec <- allocTempBuffer comp outVec
+                        (rowPerStrip * width * sampleCount)
+
+  let mutableImage = MutableImage
+                   { mutableImageWidth = fromIntegral width
+                   , mutableImageHeight = fromIntegral height
+                   , mutableImageData = outVec
+                   }
+
+  case tiffPlaneConfiguration nfo of
+    PlanarConfigContig -> V.mapM_ unpacker sizes
+        where unpacker (idx, stripSampleCount, offset, packedSize) = do
+                  let (writeIdx, tempStride)  = offsetStride comp idx 1
+                  _ <- uncompressAt compression str tempVec tempStride
+                                    writeIdx (offset, packedSize)
+                  let typ :: M.MVector s a -> a
+                      typ = const undefined
+                      sampleSize = sizeOf (typ outVec)
+                  mergeBackTempBuffer comp endianness tempVec (width * sampleCount)
+                                      idx (fromIntegral $ stripSampleCount * sampleSize) 1 outVec
+
+
+              fullStripSampleCount = rowPerStrip * width * sampleCount
+              startWriteOffset = V.generate stripCount (fullStripSampleCount *)
+              stripSampleCounts = V.map strip startWriteOffset
+                  where
+                      strip start = min fullStripSampleCount (width * height * sampleCount - start)
+
+              sizes = V.zip4 startWriteOffset stripSampleCounts
+                             (tiffOffsets nfo) (tiffStripSize nfo)
+
+    PlanarConfigSeparate -> V.mapM_ unpacker sizes
+        where unpacker (idx, offset, size) = do
+                  let (writeIdx, tempStride) = offsetStride comp idx stride
+                  _ <- uncompressAt compression str tempVec tempStride
+                                    writeIdx (offset, size)
+                  mergeBackTempBuffer comp endianness tempVec (width * sampleCount)
+                                      idx size stride outVec
+
+              stride = V.length $ tiffOffsets nfo
+              idxVector = V.enumFromN 0 stride
+              sizes = V.zip3 idxVector (tiffOffsets nfo) (tiffStripSize nfo)
+
+  when (tiffPredictor nfo == PredictorHorizontalDifferencing) $ do
+    let f _ c1 c2 = c1 + c2
+    forM_ [0 .. height - 1] $ \y ->
+      forM_ [1 .. width - 1] $ \x -> do
+        p <- readPixel mutableImage (x - 1) y
+        q <- readPixel mutableImage x y
+        writePixel mutableImage x y $ mixWith f p q
+
+  unsafeFreezeImage mutableImage
+
+ifdSingleLong :: ExifTag -> Word32 -> Writer [ImageFileDirectory] ()
+ifdSingleLong tag = ifdMultiLong tag . V.singleton
+
+ifdSingleShort :: Endianness -> ExifTag -> Word16
+               -> Writer [ImageFileDirectory] ()
+ifdSingleShort endian tag = ifdMultiShort endian tag . V.singleton . fromIntegral
+
+ifdMultiLong :: ExifTag -> V.Vector Word32 -> Writer [ImageFileDirectory] ()
+ifdMultiLong tag v = tell . pure $ ImageFileDirectory
+        { ifdIdentifier = tag
+        , ifdType       = TypeLong
+        , ifdCount      = fromIntegral $ V.length v
+        , ifdOffset     = offset
+        , ifdExtended   = extended
+        }
+  where (offset, extended)
+                | V.length v > 1 = (0, ExifLongs v)
+                | otherwise = (V.head v, ExifNone)
+
+ifdMultiShort :: Endianness -> ExifTag -> V.Vector Word32
+              -> Writer [ImageFileDirectory] ()
+ifdMultiShort endian tag v = tell . pure $ ImageFileDirectory
+        { ifdIdentifier = tag
+        , ifdType       = TypeShort
+        , ifdCount      = size
+        , ifdOffset     = offset
+        , ifdExtended   = extended
+        }
+    where size = fromIntegral $ V.length v
+          (offset, extended)
+                | size > 2 = (0, ExifShorts $ V.map fromIntegral v)
+                | size == 2 =
+                    let v1 = fromIntegral $ V.head v
+                        v2 = fromIntegral $ v `V.unsafeIndex` 1
+                    in
+                    case endian of
+                      EndianLittle -> (v2 `unsafeShiftL` 16 .|. v1, ExifNone)
+                      EndianBig -> (v1 `unsafeShiftL` 16 .|. v2, ExifNone)
+
+                | otherwise = case endian of
+                    EndianLittle -> (V.head v, ExifNone)
+                    EndianBig -> (V.head v `unsafeShiftL` 16, ExifNone)
+
+instance BinaryParam B.ByteString TiffInfo where
+  putP rawData nfo = putP rawData (tiffHeader nfo, [list]) where
+    endianness = hdrEndianness $ tiffHeader nfo
+
+    ifdShort = ifdSingleShort endianness
+    ifdShorts = ifdMultiShort endianness
+
+    list = execWriter $ do
+      ifdSingleLong TagImageWidth $ tiffWidth nfo
+      ifdSingleLong TagImageLength $ tiffHeight nfo
+      ifdShorts TagBitsPerSample $ tiffBitsPerSample nfo
+      ifdSingleLong TagSamplesPerPixel $ tiffSampleCount nfo
+      ifdSingleLong TagRowPerStrip $ tiffRowPerStrip nfo
+      ifdShort TagPhotometricInterpretation
+                                  . packPhotometricInterpretation
+                                  $ tiffColorspace nfo
+      ifdShort TagPlanarConfiguration
+              . constantToPlaneConfiguration $ tiffPlaneConfiguration nfo
+      ifdMultiLong TagSampleFormat
+                                  . V.fromList
+                                  . map packSampleFormat
+                                  $ tiffSampleFormat nfo
+      ifdShort TagCompression . packCompression
+                                    $ tiffCompression nfo
+      ifdMultiLong TagStripOffsets $ tiffOffsets nfo
+
+      ifdMultiLong TagStripByteCounts $ tiffStripSize nfo
+
+      maybe (return ())
+            (ifdShort TagExtraSample . codeOfExtraSample)
+          $ tiffExtraSample nfo
+
+      let subSampling = tiffYCbCrSubsampling nfo
+      unless (V.null subSampling) $
+           ifdShorts TagYCbCrSubsampling subSampling
+
+  getP rawData = do
+    (hdr, cleanedFull :: [[ImageFileDirectory]]) <- getP rawData
+
+    let cleaned = concat cleanedFull
+        dataFind str tag = findIFDData str tag cleaned
+        dataDefault def tag = findIFDDefaultData def tag cleaned
+        extFind str tag = findIFDExt str tag cleaned
+        extDefault def tag = findIFDExtDefaultData def tag cleaned
+
+    TiffInfo hdr
+        <$> dataFind "Can't find width" TagImageWidth
+        <*> dataFind "Can't find height" TagImageLength
+        <*> (dataFind "Can't find color space" TagPhotometricInterpretation
+                     >>= unpackPhotometricInterpretation)
+        <*> dataFind "Can't find sample per pixel" TagSamplesPerPixel
+        <*> dataFind "Can't find row per strip" TagRowPerStrip
+        <*> (dataDefault 1 TagPlanarConfiguration
+                     >>= planarConfgOfConstant)
+        <*> (extDefault [1] TagSampleFormat
+                     >>= mapM unpackSampleFormat)
+        <*> (extFind "Can't find bit per sample" TagBitsPerSample
+                     >>= unLong "Can't find bit depth")
+        <*> (dataFind "Can't find Compression" TagCompression
+                     >>= unPackCompression)
+        <*> (extFind "Can't find byte counts" TagStripByteCounts
+                     >>= unLong "Can't find bit per sample")
+        <*> (extFind "Strip offsets missing" TagStripOffsets
+                     >>= unLong "Can't find strip offsets")
+        <*> findPalette cleaned
+        <*> (V.fromList <$> extDefault [2, 2] TagYCbCrSubsampling)
+        <*> pure Nothing
+        <*> (dataDefault 1 TagPredictor
+                     >>= predictorOfConstant)
+        <*> pure (extractTiffMetadata cleaned)
+
+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 } =
+    unpack file $ nfo { tiffRowPerStrip = tiffHeight nfo }
+unpack file nfo@TiffInfo { tiffColorspace = TiffPaleted
+                         , tiffBitsPerSample = lst
+                         , tiffSampleFormat = format
+                         , tiffPalette = Just p
+                         }
+  | lst == V.singleton 8 && format == [TiffSampleUint] =
+      pure . PalettedRGB16 (gatherStrips (0 :: Word8) file nfo) $ palette16Of p
+  | lst == V.singleton 4 && format == [TiffSampleUint] =
+      pure . PalettedRGB16 (gatherStrips Pack4 file nfo) $ palette16Of p
+  | lst == V.singleton 2 && format == [TiffSampleUint] =
+      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 . TrueColorImage . ImageCMYK8 $ gatherStrips (0 :: Word8) file nfo
+
+  | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format =
+        pure . TrueColorImage . ImageCMYK16 $ gatherStrips (0 :: Word16) file nfo
+
+unpack file nfo@TiffInfo { tiffColorspace = TiffMonochromeWhite0 } = do
+    img <- unpack file (nfo { tiffColorspace = TiffMonochrome })
+    case img of
+      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
+      _ -> Left "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 . TrueColorImage . ImageY8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo
+  | lst == V.singleton 4 && all (TiffSampleUint ==) format =
+        pure . TrueColorImage . ImageY8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo
+  | lst == V.singleton 8 && all (TiffSampleUint ==) format =
+        pure . TrueColorImage . ImageY8 $ gatherStrips (0 :: Word8) file nfo
+  | lst == V.singleton 12 && all (TiffSampleUint ==) format =
+        pure . TrueColorImage . ImageY16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo
+  | lst == V.singleton 16 && all (TiffSampleUint ==) format =
+        pure . TrueColorImage . ImageY16 $ gatherStrips (0 :: Word16) file nfo
+  | lst == V.singleton 32 && all (TiffSampleUint ==) format =
+        let img = gatherStrips (0 :: Word32) file nfo :: Image Pixel32
+        in pure $ TrueColorImage $ ImageY32 $ img
+  | lst == V.singleton 32 && all (TiffSampleFloat ==) format =
+        let img = gatherStrips (0 :: Float) file nfo :: Image PixelF
+        in pure $ TrueColorImage $ ImageYF $ img
+  | lst == V.singleton 64 = Left "Failure to unpack TIFF file, 64-bit samples unsupported."
+  | lst == V.fromList [2, 2] && all (TiffSampleUint ==) format =
+        pure . TrueColorImage . ImageYA8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo
+  | lst == V.fromList [4, 4] && all (TiffSampleUint ==) format =
+        pure . TrueColorImage . ImageYA8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo
+  | lst == V.fromList [8, 8] && all (TiffSampleUint ==) format =
+        pure . TrueColorImage . ImageYA8 $ gatherStrips (0 :: Word8) file nfo
+  | lst == V.fromList [12, 12] && all (TiffSampleUint ==) format =
+        pure . TrueColorImage . ImageYA16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo
+  | lst == V.fromList [16, 16] && all (TiffSampleUint ==) format =
+        pure . TrueColorImage . ImageYA16 $ gatherStrips (0 :: Word16) file nfo
+    where
+      expand12to16 x = x `unsafeShiftL` 4 + x `unsafeShiftR` (12 - 4)
+
+unpack file nfo@TiffInfo { tiffColorspace = TiffYCbCr
+                         , tiffBitsPerSample = lst
+                         , tiffPlaneConfiguration = PlanarConfigContig
+                         , tiffSampleFormat = format }
+  | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format =
+    pure . TrueColorImage . ImageYCbCr8 $ gatherStrips cbcrConf  file nfo
+      where defaulting 0 = 2
+            defaulting n = n
+
+            w = defaulting $ tiffYCbCrSubsampling nfo V.! 0
+            h = defaulting $ tiffYCbCrSubsampling nfo V.! 1
+            cbcrConf = YCbCrSubsampling
+                { ycbcrWidth        = fromIntegral w
+                , ycbcrHeight       = fromIntegral h
+                , ycbcrImageWidth   = fromIntegral $ tiffWidth nfo
+                , ycbcrStripHeight  = fromIntegral $ tiffRowPerStrip nfo
+                }
+
+unpack file nfo@TiffInfo { tiffColorspace = TiffRGB
+                         , tiffBitsPerSample = lst
+                         , tiffSampleFormat = format }
+  | lst == V.fromList [2, 2, 2] && all (TiffSampleUint ==) format =
+        pure . TrueColorImage . ImageRGB8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo
+  | lst == V.fromList [4, 4, 4] && all (TiffSampleUint ==) format =
+        pure . TrueColorImage . ImageRGB8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo
+  | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format =
+        pure . TrueColorImage . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo
+  | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format =
+        pure . TrueColorImage . ImageRGBA8 $ gatherStrips (0 :: Word8) file nfo
+  | lst == V.fromList [16, 16, 16] && all (TiffSampleUint ==) format =
+        pure . TrueColorImage . ImageRGB16 $ gatherStrips (0 :: Word16) file nfo
+  | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format =
+        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 . TrueColorImage . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo
+
+unpack _ _ = Left "Failure to unpack TIFF file"
+
+-- | Decode a tiff encoded image while preserving the underlying
+-- pixel type (except for Y32 which is truncated to 16 bits).
+--
+-- This function can output the following images:
+--
+--  * 'ImageY8'
+--
+--  * 'ImageY16'
+--
+--  * 'ImageY32'
+--
+--  * 'ImageYF'
+--
+--  * 'ImageYA8'
+--
+--  * 'ImageYA16'
+--
+--  * 'ImageRGB8'
+--
+--  * 'ImageRGB16'
+--
+--  * 'ImageRGBA8'
+--
+--  * 'ImageRGBA16'
+--
+--  * 'ImageCMYK8'
+--
+--  * 'ImageCMYK16'
+--
+decodeTiff :: B.ByteString -> Either String DynamicImage
+decodeTiff = fmap fst . decodeTiffWithMetadata 
+
+-- | Like 'decodeTiff' but also provides some metdata present
+-- in the Tiff file.
+--
+-- 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 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
+    
+
+-- | Class defining which pixel types can be serialized in a
+-- Tiff file.
+class (Pixel px) => TiffSaveable px where
+  colorSpaceOfPixel :: px -> TiffColorspace
+
+  extraSampleCodeOfPixel :: px -> Maybe ExtraSample
+  extraSampleCodeOfPixel _ = Nothing
+
+  subSamplingInfo   :: px -> V.Vector Word32
+  subSamplingInfo _ = V.empty
+
+  sampleFormat :: px -> [TiffSampleFormat]
+  sampleFormat _ = [TiffSampleUint]
+
+instance TiffSaveable Pixel8 where
+  colorSpaceOfPixel _ = TiffMonochrome
+
+instance TiffSaveable Pixel16 where
+  colorSpaceOfPixel _ = TiffMonochrome
+
+instance TiffSaveable Pixel32 where
+  colorSpaceOfPixel _ = TiffMonochrome
+
+instance TiffSaveable PixelF where
+  colorSpaceOfPixel _ = TiffMonochrome
+  sampleFormat _      = [TiffSampleFloat]
+
+instance TiffSaveable PixelYA8 where
+  colorSpaceOfPixel _ = TiffMonochrome
+  extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha
+
+instance TiffSaveable PixelYA16 where
+  colorSpaceOfPixel _ = TiffMonochrome
+  extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha
+
+instance TiffSaveable PixelCMYK8 where
+  colorSpaceOfPixel _ = TiffCMYK
+
+instance TiffSaveable PixelCMYK16 where
+  colorSpaceOfPixel _ = TiffCMYK
+
+instance TiffSaveable PixelRGB8 where
+  colorSpaceOfPixel  _ = TiffRGB
+
+instance TiffSaveable PixelRGB16 where
+  colorSpaceOfPixel  _ = TiffRGB
+
+instance TiffSaveable PixelRGBA8 where
+  colorSpaceOfPixel _ = TiffRGB
+  extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha
+
+instance TiffSaveable PixelRGBA16 where
+  colorSpaceOfPixel _ = TiffRGB
+  extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha
+
+instance TiffSaveable PixelYCbCr8 where
+  colorSpaceOfPixel _ = TiffYCbCr
+  subSamplingInfo _ = V.fromListN 2 [1, 1]
+
+-- | Transform an image into a Tiff encoded bytestring, ready to be
+-- written as a file.
+encodeTiff :: forall px. (TiffSaveable px) => Image px -> Lb.ByteString
+encodeTiff img = runPut $ putP rawPixelData hdr
+  where intSampleCount = componentCount (undefined :: px)
+        sampleCount = fromIntegral intSampleCount
+
+        sampleType = undefined :: PixelBaseComponent px
+        pixelData = imageData img
+
+        rawPixelData = toByteString pixelData
+        width = fromIntegral $ imageWidth img
+        height = fromIntegral $ imageHeight img
+        intSampleSize = sizeOf sampleType
+        sampleSize = fromIntegral intSampleSize
+        bitPerSample = sampleSize * 8
+        imageSize = width * height * sampleCount * sampleSize
+        headerSize = 8
+
+        hdr = TiffInfo
+            { tiffHeader             = TiffHeader
+                                            { hdrEndianness = EndianLittle
+                                            , hdrOffset = headerSize + imageSize
+                                            }
+            , tiffWidth              = width
+            , tiffHeight             = height
+            , tiffColorspace         = colorSpaceOfPixel (undefined :: px)
+            , tiffSampleCount        = fromIntegral sampleCount
+            , tiffRowPerStrip        = fromIntegral $ imageHeight img
+            , tiffPlaneConfiguration = PlanarConfigContig
+            , tiffSampleFormat       = sampleFormat (undefined :: px)
+            , tiffBitsPerSample      = V.replicate intSampleCount bitPerSample
+            , tiffCompression        = CompressionNone
+            , tiffStripSize          = V.singleton imageSize
+            , tiffOffsets            = V.singleton headerSize
+            , tiffPalette            = Nothing
+            , tiffYCbCrSubsampling   = subSamplingInfo (undefined :: px)
+            , tiffExtraSample        = extraSampleCodeOfPixel (undefined :: px)
+            , tiffPredictor          = PredictorNone -- not used when writing
+            , tiffMetadatas          = mempty
+            }
+
+-- | Helper function to directly write an image as a tiff on disk.
+writeTiff :: (TiffSaveable pixel) => FilePath -> Image pixel -> IO ()
+writeTiff path img = Lb.writeFile path $ encodeTiff img
+
+{-# ANN module "HLint: ignore Reduce duplication" #-}
+
+ src/Codec/Picture/Tiff/Internal/Metadata.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE CPP #-}
+module Codec.Picture.Tiff.Internal.Metadata
+    ( extractTiffMetadata
+    , encodeTiffStringMetadata
+    , exifOffsetIfd
+    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid( mempty )
+import Data.Foldable( foldMap )
+import Control.Applicative( (<$>) )
+#endif
+
+import Data.Bits( unsafeShiftL, (.|.) )
+import Data.Foldable( find )
+import Data.List( sortBy )
+import Data.Function( on )
+import qualified Data.Foldable as F
+#if !MIN_VERSION_base(4,11,0)
+import Data.Monoid( (<>) )
+#endif
+import Codec.Picture.Metadata( Metadatas )
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+import qualified Codec.Picture.Metadata as Met
+import qualified Data.Vector.Generic as V
+import Codec.Picture.Tiff.Internal.Types
+import Codec.Picture.Metadata( extractExifMetas )
+import Codec.Picture.Metadata.Exif
+
+exifOffsetIfd :: ImageFileDirectory
+exifOffsetIfd = ImageFileDirectory
+  { ifdIdentifier = TagExifOffset
+  , ifdCount = 1
+  , ifdType = TypeLong
+  , ifdOffset = 0
+  , ifdExtended = ExifNone
+  }
+
+typeOfData :: ExifData -> IfdType
+typeOfData d = case d of
+  ExifNone -> error "Impossible - typeOfData : ExifNone"
+  ExifIFD _exifs -> error "Impossible - typeOfData : ExifIFD"
+  ExifLong _l -> TypeLong
+  ExifLongs _l -> TypeLong
+  ExifShort _s -> TypeShort
+  ExifShorts _s -> TypeShort
+  ExifString _str -> TypeAscii
+  ExifUndefined _undef -> TypeUndefined
+  ExifRational _r1 _r2 -> TypeRational
+  ExifSignedRational _sr1 _sr2 -> TypeSignedRational
+
+makeIfd :: ExifTag -> ExifData -> ImageFileDirectory
+makeIfd t (ExifShort v) = ImageFileDirectory
+  { ifdIdentifier = t
+  , ifdType = TypeShort
+  , ifdCount = 1
+  , ifdOffset = fromIntegral v `unsafeShiftL` 16
+  , ifdExtended = ExifNone
+  }
+makeIfd t (ExifLong v) = ImageFileDirectory 
+  { ifdIdentifier = t
+  , ifdType = TypeLong
+  , ifdCount = 1
+  , ifdOffset = fromIntegral v
+  , ifdExtended = ExifNone
+  }
+makeIfd t d@(ExifShorts v)
+  | size == 2 = ImageFileDirectory
+    { ifdIdentifier = t
+    , ifdType = TypeShort
+    , ifdCount = 2
+    , ifdOffset = combined
+    , ifdExtended = ExifNone
+    }
+  | otherwise = ImageFileDirectory
+    { ifdIdentifier = t
+    , ifdType = TypeShort
+    , ifdCount = size
+    , ifdOffset = 0
+    , ifdExtended = d
+    }
+  where
+    size = fromIntegral $ F.length v
+    at i = fromIntegral $ v V.! i
+    combined = (at 0  `unsafeShiftL` 16) .|. at 1
+makeIfd t d@(ExifLongs v)
+  | size == 1 = ImageFileDirectory
+    { ifdIdentifier = t
+    , ifdType = TypeLong
+    , ifdCount = 1
+    , ifdOffset = v V.! 0
+    , ifdExtended = ExifNone
+    }
+  | otherwise = ImageFileDirectory
+    { ifdIdentifier = t
+    , ifdType = TypeLong
+    , ifdCount = size
+    , ifdOffset = 0
+    , ifdExtended = d
+    }
+  where size = fromIntegral $ F.length v
+makeIfd t s@(ExifString str) = ImageFileDirectory
+    { ifdIdentifier = t
+    , ifdType = TypeAscii
+    , ifdCount = fromIntegral $ BC.length str
+    , ifdOffset = 0
+    , ifdExtended = s
+    }
+makeIfd t s@(ExifUndefined str)
+  | size > 4 = ImageFileDirectory
+    { ifdIdentifier = t
+    , ifdType = TypeUndefined
+    , ifdCount = size
+    , ifdOffset = 0
+    , ifdExtended = s
+    }
+  | otherwise = ImageFileDirectory
+    { ifdIdentifier = t
+    , ifdType = TypeUndefined
+    , ifdCount = size
+    , ifdOffset = ofs
+    , ifdExtended = ExifNone
+    }
+  where
+    size = fromIntegral $ BC.length str
+    at ix
+      | fromIntegral ix < size = fromIntegral $ B.index str ix `unsafeShiftL` (4 - (8 * ix))
+      | otherwise = 0
+    ofs = at 0 .|. at 1 .|. at 2 .|. at 3
+makeIfd t d = ImageFileDirectory
+  { ifdIdentifier = t
+  , ifdType = typeOfData d
+  , ifdCount = 1
+  , ifdOffset = 0
+  , ifdExtended = d
+  }
+
+encodeTiffStringMetadata :: Metadatas -> [ImageFileDirectory]
+encodeTiffStringMetadata metas = sortBy (compare `on` word16OfTag . ifdIdentifier) $ allTags where
+  keyStr tag k = case Met.lookup k metas of
+    Nothing -> mempty
+    Just v -> pure . makeIfd tag . ExifString $ BC.pack v
+  allTags = copyright <> artist <> title <> description <> software <> allPureExif
+
+  allPureExif = fmap (uncurry makeIfd) $ extractExifMetas metas
+
+  copyright = keyStr TagCopyright Met.Copyright
+  artist = keyStr TagArtist Met.Author
+  title = keyStr TagDocumentName Met.Title
+  description = keyStr TagImageDescription Met.Description
+  software = keyStr TagSoftware Met.Software
+
+extractTiffStringMetadata :: [ImageFileDirectory] -> Metadatas
+extractTiffStringMetadata = Met.insert Met.Format Met.SourceTiff . foldMap go where
+  strMeta k = Met.singleton k . BC.unpack
+  exif ifd =
+    Met.singleton (Met.Exif $ ifdIdentifier ifd) $ ifdExtended ifd
+  inserter acc (k, v) = Met.insert (Met.Exif k) v acc
+  exifShort ifd =
+    Met.singleton (Met.Exif $ ifdIdentifier ifd) . (ExifShort . fromIntegral) $ ifdOffset ifd
+
+  go :: ImageFileDirectory -> Metadatas
+  go ifd = case (ifdIdentifier ifd, ifdExtended ifd) of
+    (TagArtist, ExifString v) -> strMeta Met.Author v
+    (TagBitsPerSample, _) -> mempty
+    (TagColorMap, _) -> mempty
+    (TagCompression, _) -> mempty
+    (TagCopyright, ExifString v) -> strMeta Met.Copyright v
+    (TagDocumentName, ExifString v) -> strMeta Met.Title v
+    (TagExifOffset, ExifIFD lst) -> F.foldl' inserter mempty lst
+    (TagImageDescription, ExifString v) -> strMeta Met.Description v
+    (TagImageLength, _) -> Met.singleton Met.Height . fromIntegral $ ifdOffset ifd
+    (TagImageWidth, _) -> Met.singleton Met.Width . fromIntegral $ ifdOffset ifd
+    (TagJPEGACTables, _) -> mempty
+    (TagJPEGDCTables, _) -> mempty
+    (TagJPEGInterchangeFormat, _) -> mempty
+    (TagJPEGInterchangeFormatLength, _) -> mempty
+    (TagJPEGLosslessPredictors, _) -> mempty
+    (TagJPEGPointTransforms, _) -> mempty
+    (TagJPEGQTables, _) -> mempty
+    (TagJPEGRestartInterval, _) -> mempty
+    (TagJpegProc, _) -> mempty
+    (TagModel, v) -> Met.singleton (Met.Exif TagModel) v
+    (TagMake, v) -> Met.singleton (Met.Exif TagMake) v
+    (TagOrientation, _) -> exifShort ifd
+    (TagResolutionUnit, _) -> mempty
+    (TagRowPerStrip, _) -> mempty
+    (TagSamplesPerPixel, _) -> mempty
+    (TagSoftware, ExifString v) -> strMeta Met.Software v
+    (TagStripByteCounts, _) -> mempty
+    (TagStripOffsets, _) -> mempty
+    (TagTileByteCount, _) -> mempty
+    (TagTileLength, _) -> mempty
+    (TagTileOffset, _) -> mempty
+    (TagTileWidth, _) -> mempty
+    (TagUnknown _, _) -> exif ifd
+    (TagXResolution, _) -> mempty
+    (TagYCbCrCoeff, _) -> mempty
+    (TagYCbCrPositioning, _) -> mempty
+    (TagYCbCrSubsampling, _) -> mempty
+    (TagYResolution, _) -> mempty
+    _ -> mempty
+
+byTag :: ExifTag -> ImageFileDirectory -> Bool
+byTag t ifd = ifdIdentifier ifd == t
+
+data TiffResolutionUnit
+  = ResolutionUnitUnknown
+  | ResolutionUnitInch
+  | ResolutionUnitCentimeter
+
+unitOfIfd :: ImageFileDirectory -> TiffResolutionUnit
+unitOfIfd ifd = case (ifdType ifd, ifdOffset ifd) of
+  (TypeShort, 1) -> ResolutionUnitUnknown
+  (TypeShort, 2) -> ResolutionUnitInch
+  (TypeShort, 3) -> ResolutionUnitCentimeter
+  _ -> ResolutionUnitUnknown
+
+extractTiffDpiMetadata :: [ImageFileDirectory] -> Metadatas
+extractTiffDpiMetadata lst = go where
+  go = case unitOfIfd <$> find (byTag TagResolutionUnit) lst of
+    Nothing -> mempty
+    Just ResolutionUnitUnknown -> mempty
+    Just ResolutionUnitCentimeter -> findDpis Met.dotsPerCentiMeterToDotPerInch mempty
+    Just ResolutionUnitInch -> findDpis id mempty
+
+  findDpis toDpi =
+     findDpi Met.DpiX TagXResolution toDpi . findDpi Met.DpiY TagYResolution toDpi
+
+  findDpi k tag toDpi metas = case find (byTag tag) lst of
+    Nothing -> metas
+    Just ImageFileDirectory { ifdExtended = ExifRational num den } ->
+      Met.insert k (toDpi . fromIntegral $ num `div` den) metas
+    Just _ -> metas
+
+extractTiffMetadata :: [ImageFileDirectory] -> Metadatas
+extractTiffMetadata lst = extractTiffDpiMetadata lst <> extractTiffStringMetadata lst
+
+ src/Codec/Picture/Tiff/Internal/Types.hs view
@@ -0,0 +1,504 @@+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Codec.Picture.Tiff.Internal.Types
+    ( BinaryParam( .. )
+    , Endianness( .. )
+    , TiffHeader( .. )
+    , TiffPlanarConfiguration( .. )
+    , TiffCompression( .. )
+    , IfdType( .. )
+    , TiffColorspace( .. )
+    , TiffSampleFormat( .. )
+    , ImageFileDirectory( .. )
+    , ExtraSample( .. )
+    , Predictor( .. )
+
+    , planarConfgOfConstant
+    , constantToPlaneConfiguration
+    , unpackSampleFormat
+    , packSampleFormat
+    , word16OfTag
+    , unpackPhotometricInterpretation
+    , packPhotometricInterpretation
+    , codeOfExtraSample
+    , unPackCompression
+    , packCompression 
+    , predictorOfConstant
+    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<$>), (<*>), pure )
+#endif
+
+import Control.DeepSeq( NFData(..) )
+import Control.Monad( forM_, when, replicateM, )
+import Data.Bits( (.&.), unsafeShiftR )
+import Data.Binary( Binary( .. ) )
+import Data.Binary.Get( Get
+                      , getWord16le, getWord16be
+                      , getWord32le, getWord32be
+                      , bytesRead
+                      , skip
+                      , getByteString
+                      )
+import Data.Binary.Put( Put
+                      , putWord16le, putWord16be
+                      , putWord32le, putWord32be
+                      , putByteString
+                      )
+import Data.Function( on )
+import Data.List( sortBy, mapAccumL )
+import qualified Data.Vector as V
+import qualified Data.ByteString as B
+import Data.Int( Int32 )
+import Data.Word( Word8, Word16, Word32 )
+import GHC.Generics( Generic )
+
+import Codec.Picture.Metadata.Exif
+{-import Debug.Trace-}
+
+data Endianness
+  = EndianLittle
+  | EndianBig
+  deriving (Eq, Show)
+
+instance Binary Endianness where
+  put EndianLittle = putWord16le 0x4949
+  put EndianBig = putWord16le 0x4D4D
+
+  get = do
+    tag <- getWord16le
+    case tag of
+      0x4949 -> return EndianLittle
+      0x4D4D -> return EndianBig
+      _ -> fail "Invalid endian tag value"
+
+-- | Because having a polymorphic get with endianness is to nice
+-- to pass on, introducing this helper type class, which is just
+-- a superset of Binary, but formalising a parameter passing
+-- into it.
+class BinaryParam a b where
+  getP :: a -> Get b
+  putP :: a -> b -> Put
+
+data TiffHeader = TiffHeader
+  { hdrEndianness :: !Endianness
+  , hdrOffset     :: {-# UNPACK #-} !Word32
+  }
+  deriving (Eq, Show)
+
+instance BinaryParam Endianness Word16 where
+  putP EndianLittle = putWord16le
+  putP EndianBig = putWord16be
+
+  getP EndianLittle = getWord16le
+  getP EndianBig = getWord16be
+
+instance BinaryParam Endianness Int32 where
+  putP en v = putP en $ (fromIntegral v :: Word32)
+  getP en = fromIntegral <$> (getP en :: Get Word32) 
+
+instance BinaryParam Endianness Word32 where
+  putP EndianLittle = putWord32le
+  putP EndianBig = putWord32be
+
+  getP EndianLittle = getWord32le
+  getP EndianBig = getWord32be
+
+instance Binary TiffHeader where
+  put hdr = do
+    let endian = hdrEndianness hdr
+    put endian
+    putP endian (42 :: Word16)
+    putP endian $ hdrOffset hdr
+
+  get = do
+    endian <- get
+    magic <- getP endian
+    let magicValue = 42 :: Word16
+    when (magic /= magicValue)
+         (fail "Invalid TIFF magic number")
+    TiffHeader endian <$> getP endian
+
+data TiffPlanarConfiguration
+  = PlanarConfigContig    -- = 1
+  | PlanarConfigSeparate  -- = 2
+
+planarConfgOfConstant :: Word32 -> Get TiffPlanarConfiguration
+planarConfgOfConstant 0 = pure PlanarConfigContig
+planarConfgOfConstant 1 = pure PlanarConfigContig
+planarConfgOfConstant 2 = pure PlanarConfigSeparate
+planarConfgOfConstant v = fail $ "Unknown planar constant (" ++ show v ++ ")"
+
+constantToPlaneConfiguration :: TiffPlanarConfiguration -> Word16
+constantToPlaneConfiguration PlanarConfigContig = 1
+constantToPlaneConfiguration PlanarConfigSeparate = 2
+
+data TiffCompression
+  = CompressionNone           -- 1
+  | CompressionModifiedRLE    -- 2
+  | CompressionLZW            -- 5
+  | CompressionJPEG           -- 6
+  | CompressionPackBit        -- 32273
+
+data IfdType
+  = TypeByte
+  | TypeAscii
+  | TypeShort
+  | TypeLong
+  | TypeRational
+  | TypeSByte
+  | TypeUndefined
+  | TypeSignedShort
+  | TypeSignedLong
+  | TypeSignedRational
+  | TypeFloat
+  | TypeDouble
+  deriving (Eq, Show, Generic)
+instance NFData IfdType
+
+instance BinaryParam Endianness IfdType where
+    getP endianness = getP endianness >>= conv where
+      conv :: Word16 -> Get IfdType
+      conv v = case v of
+        1  -> return TypeByte
+        2  -> return TypeAscii
+        3  -> return TypeShort
+        4  -> return TypeLong
+        5  -> return TypeRational
+        6  -> return TypeSByte
+        7  -> return TypeUndefined
+        8  -> return TypeSignedShort
+        9  -> return TypeSignedLong
+        10 -> return TypeSignedRational
+        11 -> return TypeFloat
+        12 -> return TypeDouble
+        _  -> fail "Invalid TIF directory type"
+
+    putP endianness = putP endianness . conv where
+      conv :: IfdType -> Word16
+      conv v = case v of
+        TypeByte -> 1
+        TypeAscii -> 2
+        TypeShort -> 3
+        TypeLong -> 4
+        TypeRational -> 5
+        TypeSByte -> 6
+        TypeUndefined -> 7
+        TypeSignedShort -> 8
+        TypeSignedLong -> 9
+        TypeSignedRational -> 10
+        TypeFloat -> 11
+        TypeDouble -> 12
+
+instance BinaryParam Endianness ExifTag where
+  getP endianness = tagOfWord16 <$> getP endianness
+  putP endianness = putP endianness . word16OfTag
+
+data Predictor
+  = PredictorNone                   -- 1
+  | PredictorHorizontalDifferencing -- 2
+  deriving Eq
+
+predictorOfConstant :: Word32 -> Get Predictor
+predictorOfConstant 1 = pure PredictorNone
+predictorOfConstant 2 = pure PredictorHorizontalDifferencing
+predictorOfConstant v = fail $ "Unknown predictor (" ++ show v ++ ")"
+
+paddWrite :: B.ByteString -> Put
+paddWrite str = putByteString str >> padding where
+  zero = 0 :: Word8
+  padding = when (odd (B.length str)) $ put zero
+
+instance BinaryParam (Endianness, Int, ImageFileDirectory) ExifData where
+  putP (endianness, _, _) = dump
+    where
+      dump ExifNone = pure ()
+      dump (ExifLong _) = pure ()
+      dump (ExifShort _) = pure ()
+      dump (ExifIFD _) = pure ()
+      dump (ExifString bstr) = paddWrite bstr
+      dump (ExifUndefined bstr) = paddWrite bstr
+      -- wrong if length == 2
+      dump (ExifShorts shorts) = V.mapM_ (putP endianness) shorts
+      dump (ExifLongs longs) = V.mapM_ (putP endianness) longs
+      dump (ExifRational a b) = putP endianness a >> putP endianness b
+      dump (ExifSignedRational a b) = putP endianness a >> putP endianness b
+
+  getP (endianness, maxi, ifd) = fetcher ifd
+    where
+      align ImageFileDirectory { ifdOffset = offset } act = do
+        readed <- bytesRead
+        let delta = fromIntegral offset - readed
+        if offset >= fromIntegral maxi || fromIntegral readed > offset then
+          pure ExifNone
+        else do
+          skip $ fromIntegral delta
+          act
+
+      getE :: (BinaryParam Endianness a) => Get a
+      getE = getP endianness
+
+      getVec count = V.replicateM (fromIntegral count)
+
+      immediateBytes ofs =
+        let bytes = [fromIntegral $ (ofs .&. 0xFF000000) `unsafeShiftR` (3 * 8)
+                    ,fromIntegral $ (ofs .&. 0x00FF0000) `unsafeShiftR` (2 * 8)
+                    ,fromIntegral $ (ofs .&. 0x0000FF00) `unsafeShiftR` (1 * 8)
+                    ,fromIntegral $  ofs .&. 0x000000FF
+                    ]
+        in case endianness of
+             EndianLittle -> reverse bytes
+             EndianBig    -> bytes
+
+      fetcher ImageFileDirectory { ifdIdentifier = TagExifOffset
+                                 , ifdType = TypeLong
+                                 , ifdCount = 1 } = do
+         align ifd $ do
+            let byOffset = sortBy (compare `on` ifdOffset)
+                cleansIfds = fmap (cleanImageFileDirectory endianness)
+            subIfds <- cleansIfds . byOffset <$> getP endianness
+            cleaned <- fetchExtended endianness maxi $ sortBy (compare `on` ifdOffset) subIfds
+            pure $ ExifIFD [(ifdIdentifier fd, ifdExtended fd) | fd <- cleaned]
+         {-  
+      fetcher ImageFileDirectory { ifdIdentifier = TagGPSInfo
+                                 , ifdType = TypeLong
+                                 , ifdCount = 1 } = do
+         align ifd 
+         subIfds <- fmap (cleanImageFileDirectory endianness) <$> getP endianness
+         cleaned <- fetchExtended endianness subIfds
+         pure $ ExifIFD [(ifdIdentifier fd, ifdExtended fd) | fd <- cleaned]
+        -}
+      fetcher ImageFileDirectory { ifdType = TypeUndefined, ifdCount = count } | count > 4 =
+         align ifd $ ExifUndefined <$> getByteString (fromIntegral count)
+      fetcher ImageFileDirectory { ifdType = TypeUndefined, ifdOffset = ofs } =
+          pure . ExifUndefined . B.pack $ take (fromIntegral $ ifdCount ifd)
+              (immediateBytes ofs)
+      fetcher ImageFileDirectory { ifdType = TypeAscii, ifdCount = count } | count > 4 =
+          align ifd $ ExifString <$> getByteString (fromIntegral count)
+      fetcher ImageFileDirectory { ifdType = TypeAscii, ifdOffset = ofs } =
+          pure . ExifString . B.pack $ take (fromIntegral $ ifdCount ifd)
+              (immediateBytes ofs)
+      fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 2, ifdOffset = ofs } =
+          pure . ExifShorts $ V.fromListN 2 valList
+            where high = fromIntegral $ ofs `unsafeShiftR` 16
+                  low = fromIntegral $ ofs .&. 0xFFFF
+                  valList = case endianness of
+                    EndianLittle -> [low, high]
+                    EndianBig -> [high, low]
+      fetcher ImageFileDirectory { ifdType = TypeRational, ifdCount = 1 } = do
+          align ifd $ ExifRational <$> getP EndianLittle <*> getP EndianLittle
+      fetcher ImageFileDirectory { ifdType = TypeSignedRational, ifdCount = 1 } = do
+          align ifd $ ExifSignedRational <$> getP EndianLittle <*> getP EndianLittle
+      fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 1 } =
+          pure . ExifShort . fromIntegral $ ifdOffset ifd
+      fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = count } | count > 2 =
+          align ifd $ ExifShorts <$> getVec count getE
+      fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = 1 } =
+          pure . ExifLong . fromIntegral $ ifdOffset ifd
+      fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = count } | count > 1 =
+          align ifd $ ExifLongs <$> getVec count getE
+      fetcher _ = pure ExifNone
+
+cleanImageFileDirectory :: Endianness -> ImageFileDirectory -> ImageFileDirectory
+cleanImageFileDirectory EndianBig ifd@(ImageFileDirectory { ifdCount = 1 }) = aux $ ifdType ifd
+  where
+    aux TypeShort = ifd { ifdOffset = ifdOffset ifd `unsafeShiftR` 16 }
+    aux _ = ifd
+cleanImageFileDirectory _ ifd = ifd
+
+fetchExtended :: Endianness -> Int -> [ImageFileDirectory] -> Get [ImageFileDirectory]
+fetchExtended endian maxi = mapM $ \ifd -> do
+  v <- getP (endian, maxi, ifd)
+  pure $ ifd { ifdExtended = v }
+
+-- | All the IFD must be written in order according to the tag
+-- value of the IFD. To avoid getting to much restriction in the
+-- serialization code, just sort it.
+orderIfdByTag :: [ImageFileDirectory] -> [ImageFileDirectory]
+orderIfdByTag = sortBy comparer where
+  comparer a b = compare t1 t2 where
+    t1 = word16OfTag $ ifdIdentifier a
+    t2 = word16OfTag $ ifdIdentifier b
+
+-- | Given an official offset and a list of IFD, update the offset information
+-- of the IFD with extended data.
+setupIfdOffsets :: Word32 -> [ImageFileDirectory] -> (Word32, [ImageFileDirectory])
+setupIfdOffsets initialOffset lst = mapAccumL updater startExtended lst
+  where ifdElementCount = fromIntegral $ length lst
+        ifdSize = 12
+        ifdCountSize = 2
+        nextOffsetSize = 4
+        startExtended = initialOffset
+                     + ifdElementCount * ifdSize
+                     + ifdCountSize + nextOffsetSize
+
+        paddedSize blob = fromIntegral $ blobLength + padding where
+          blobLength = B.length blob
+          padding = if odd blobLength then 1 else 0
+
+        updater ix ifd@(ImageFileDirectory { ifdIdentifier = TagExifOffset }) =
+            (ix, ifd { ifdOffset = ix } )
+        updater ix ifd@(ImageFileDirectory { ifdExtended = ExifUndefined b }) =
+            (ix + paddedSize b, ifd { ifdOffset = ix } )
+        updater ix ifd@(ImageFileDirectory { ifdExtended = ExifString b }) =
+            (ix + paddedSize b, ifd { ifdOffset = ix } )
+        updater ix ifd@(ImageFileDirectory { ifdExtended = ExifLongs v })
+            | V.length v > 1 = ( ix + fromIntegral (V.length v * 4)
+                               , ifd { ifdOffset = ix } )
+        updater ix ifd@(ImageFileDirectory { ifdExtended = ExifShorts v })
+            | V.length v > 2 = ( ix + fromIntegral (V.length v * 2)
+                             , ifd { ifdOffset = ix })
+        updater ix ifd = (ix, ifd)
+
+instance BinaryParam B.ByteString (TiffHeader, [[ImageFileDirectory]]) where
+  putP rawData (hdr, ifds) = do
+    put hdr
+    putByteString rawData
+    let endianness = hdrEndianness hdr
+        (_, offseted) = mapAccumL
+            (\ix ifd -> setupIfdOffsets ix $ orderIfdByTag ifd)
+            (hdrOffset hdr)
+            ifds
+    forM_ offseted $ \list -> do
+        putP endianness list
+        mapM_ (\field -> putP (endianness, (0::Int), field) $ ifdExtended field) list
+
+  getP raw = do
+    hdr <- get
+    readed <- bytesRead
+    skip . fromIntegral $ fromIntegral (hdrOffset hdr) - readed
+    let endian = hdrEndianness hdr
+        byOffset = sortBy (compare `on` ifdOffset)
+        cleanIfds = fmap (cleanImageFileDirectory endian)
+
+    ifd <-  cleanIfds . byOffset <$> getP endian
+    cleaned <- fetchExtended endian (B.length raw) ifd
+    return (hdr, [cleaned])
+
+data TiffSampleFormat
+  = TiffSampleUint
+  | TiffSampleInt
+  | TiffSampleFloat
+  | TiffSampleUnknown
+  deriving Eq
+
+unpackSampleFormat :: Word32 -> Get TiffSampleFormat
+unpackSampleFormat v = case v of
+  1 -> pure TiffSampleUint
+  2 -> pure TiffSampleInt
+  3 -> pure TiffSampleFloat
+  4 -> pure TiffSampleUnknown
+  vv -> fail $ "Undefined data format (" ++ show vv ++ ")"
+
+packSampleFormat :: TiffSampleFormat -> Word32
+packSampleFormat TiffSampleUint    = 1
+packSampleFormat TiffSampleInt     = 2
+packSampleFormat TiffSampleFloat   = 3
+packSampleFormat TiffSampleUnknown = 4
+
+data ImageFileDirectory = ImageFileDirectory
+  { ifdIdentifier :: !ExifTag -- Word16
+  , ifdType       :: !IfdType -- Word16
+  , ifdCount      :: !Word32
+  , ifdOffset     :: !Word32
+  , ifdExtended   :: !ExifData
+  }
+  deriving (Eq, Show, Generic)
+instance NFData ImageFileDirectory
+
+instance BinaryParam Endianness ImageFileDirectory where
+  getP endianness =
+    ImageFileDirectory <$> getE <*> getE <*> getE <*> getE
+                       <*> pure ExifNone
+        where getE :: (BinaryParam Endianness a) => Get a
+              getE = getP endianness
+
+  putP endianness ifd = do
+    let putE :: (BinaryParam Endianness a) => a -> Put
+        putE = putP endianness
+    putE $ ifdIdentifier ifd
+    putE $ ifdType ifd
+    putE $ ifdCount ifd
+    putE $ ifdOffset ifd
+
+instance BinaryParam Endianness [ImageFileDirectory] where
+  getP endianness = do
+    count <- getP endianness :: Get Word16
+    rez <- replicateM (fromIntegral count) $ getP endianness
+    _ <- getP endianness :: Get Word32
+    pure rez
+
+
+  putP endianness lst = do
+    let count = fromIntegral $ length lst :: Word16
+    putP endianness count
+    mapM_ (putP endianness) lst
+    putP endianness (0 :: Word32)
+
+data TiffColorspace
+  = TiffMonochromeWhite0 -- ^ 0
+  | TiffMonochrome       -- ^ 1
+  | TiffRGB              -- ^ 2
+  | TiffPaleted          -- ^ 3
+  | TiffTransparencyMask -- ^ 4
+  | TiffCMYK             -- ^ 5
+  | TiffYCbCr            -- ^ 6
+  | TiffCIELab           -- ^ 8
+
+
+packPhotometricInterpretation :: TiffColorspace -> Word16
+packPhotometricInterpretation v = case v of
+  TiffMonochromeWhite0 -> 0
+  TiffMonochrome       -> 1
+  TiffRGB              -> 2
+  TiffPaleted          -> 3
+  TiffTransparencyMask -> 4
+  TiffCMYK             -> 5
+  TiffYCbCr            -> 6
+  TiffCIELab           -> 8
+
+unpackPhotometricInterpretation :: Word32 -> Get TiffColorspace
+unpackPhotometricInterpretation v = case v of
+  0 -> pure TiffMonochromeWhite0
+  1 -> pure TiffMonochrome
+  2 -> pure TiffRGB
+  3 -> pure TiffPaleted
+  4 -> pure TiffTransparencyMask
+  5 -> pure TiffCMYK
+  6 -> pure TiffYCbCr
+  8 -> pure TiffCIELab
+  vv -> fail $ "Unrecognized color space " ++ show vv
+
+data ExtraSample
+  = ExtraSampleUnspecified       -- ^ 0
+  | ExtraSampleAssociatedAlpha   -- ^ 1
+  | ExtraSampleUnassociatedAlpha -- ^ 2
+
+codeOfExtraSample :: ExtraSample -> Word16
+codeOfExtraSample v = case v of
+  ExtraSampleUnspecified -> 0
+  ExtraSampleAssociatedAlpha -> 1
+  ExtraSampleUnassociatedAlpha -> 2
+
+unPackCompression :: Word32 -> Get TiffCompression
+unPackCompression v = case v of
+  0 -> pure CompressionNone
+  1 -> pure CompressionNone
+  2 -> pure CompressionModifiedRLE
+  5 -> pure CompressionLZW
+  6 -> pure CompressionJPEG
+  32773 -> pure CompressionPackBit
+  vv -> fail $ "Unknown compression scheme " ++ show vv
+
+packCompression :: TiffCompression -> Word16
+packCompression v = case v of
+  CompressionNone        -> 1
+  CompressionModifiedRLE -> 2
+  CompressionLZW         -> 5
+  CompressionJPEG        -> 6
+  CompressionPackBit     -> 32773
+
+ src/Codec/Picture/Types.hs view
@@ -0,0 +1,2640 @@+-- | Module provides basic types for image manipulation in the library.
+
+{-# LANGUAGE BangPatterns           #-}
+{-# LANGUAGE CPP                    #-}
+{-# LANGUAGE DeriveDataTypeable     #-}
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE Rank2Types             #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE TypeSynonymInstances   #-}
+{-# LANGUAGE UndecidableInstances   #-}
+-- Defined types are used to store all of those __Juicy Pixels__
+module Codec.Picture.Types( -- * Types
+                            -- ** Image types
+                            Image( .. )
+                          , MutableImage( .. )
+                          , DynamicImage( .. )
+                          , PalettedImage( .. )
+                          , Palette
+                          , Palette'( .. )
+
+                            -- ** Image functions
+                          , createMutableImage
+                          , newMutableImage
+                          , freezeImage
+                          , unsafeFreezeImage
+                          , thawImage
+                          , unsafeThawImage
+
+                            -- ** Image Lenses
+                          , Traversal
+                          , imagePixels
+                          , imageIPixels
+
+                            -- ** Pixel types
+                          , Pixel8
+                          , Pixel16
+                          , Pixel32
+                          , PixelF
+                          , PixelYA8( .. )
+                          , PixelYA16( .. )
+                          , PixelRGB8( .. )
+                          , PixelRGB16( .. )
+                          , PixelRGBF( .. )
+                          , PixelRGBA8( .. )
+                          , PixelRGBA16( .. )
+                          , PixelCMYK8( .. )
+                          , PixelCMYK16( .. )
+                          , PixelYCbCr8( .. )
+                          , PixelYCbCrK8( .. )
+
+                          -- * Type classes
+                          , ColorConvertible( .. )
+                          , Pixel(..)
+                          -- $graph
+                          , ColorSpaceConvertible( .. )
+                          , LumaPlaneExtractable( .. )
+                          , TransparentPixel( .. )
+
+                            -- * Helper functions
+                          , pixelMap
+                          , pixelMapXY
+                          , pixelFold
+                          , pixelFoldM
+                          , pixelFoldMap
+
+                          , dynamicMap
+                          , dynamicPixelMap
+                          , palettedToTrueColor
+                          , palettedAsImage
+                          , dropAlphaLayer
+                          , withImage
+                          , zipPixelComponent3
+                          , generateImage
+                          , generateFoldImage
+                          , gammaCorrection
+                          , toneMapping
+
+                            -- * Color plane extraction
+                          , ColorPlane ( )
+
+                          , PlaneRed( .. )
+                          , PlaneGreen( .. )
+                          , PlaneBlue( .. )
+                          , PlaneAlpha( .. )
+                          , PlaneLuma( .. )
+                          , PlaneCr( .. )
+                          , PlaneCb( .. )
+                          , PlaneCyan( .. )
+                          , PlaneMagenta( .. )
+                          , PlaneYellow( .. )
+                          , PlaneBlack( .. )
+
+                          , extractComponent
+                          , unsafeExtractComponent
+
+                            -- * Packeable writing (unsafe but faster)
+                          , PackeablePixel( .. )
+                          , fillImageWith
+                          , readPackedPixelAt
+                          , writePackedPixelAt
+                          , unsafeWritePixelBetweenAt
+                          ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid( Monoid, mempty )
+import Control.Applicative( Applicative, pure, (<*>), (<$>) )
+#endif
+#if !MIN_VERSION_base(4,11,0)
+import Data.Monoid( (<>) )
+#endif
+import Control.Monad( foldM, liftM, ap )
+import Control.DeepSeq( NFData( .. ) )
+import Control.Monad.ST( ST, runST )
+import Control.Monad.Primitive ( PrimMonad, PrimState )
+import Foreign.ForeignPtr( castForeignPtr )
+import Foreign.Storable ( Storable )
+import Data.Bits( unsafeShiftL, unsafeShiftR, (.|.), (.&.) )
+import Data.Typeable ( Typeable )
+import Data.Word( Word8, Word16, Word32, Word64 )
+import Data.Vector.Storable ( (!) )
+import qualified Data.Vector.Storable as V
+import qualified Data.Vector.Storable.Mutable as M
+
+#include "ConvGraph.hs"
+
+-- | The main type of this package, one that most
+-- functions work on, is Image.
+--
+-- Parameterized by the underlying pixel format it
+-- forms a rigid type. If you wish to store images
+-- of different or unknown pixel formats use 'DynamicImage'.
+--
+-- Image is essentially a rectangular pixel buffer
+-- of specified width and height. The coordinates are
+-- assumed to start from the upper-left corner
+-- of the image, with the horizontal position first
+-- and vertical second.
+data Image a = Image
+    { -- | Width of the image in pixels
+      imageWidth  :: {-# UNPACK #-} !Int
+      -- | Height of the image in pixels.
+    , imageHeight :: {-# UNPACK #-} !Int
+
+      -- | Image pixel data. To extract pixels at a given position
+      -- you should use the helper functions.
+      --
+      -- Internally pixel data is stored as consecutively packed
+      -- lines from top to bottom, scanned from left to right
+      -- within individual lines, from first to last color
+      -- component within each pixel.
+    , imageData   :: V.Vector (PixelBaseComponent a)
+    }
+    deriving (Typeable)
+
+instance (Eq (PixelBaseComponent a), Storable (PixelBaseComponent a))
+    => Eq (Image a) where
+  a == b = imageWidth  a == imageWidth  b &&
+           imageHeight a == imageHeight b &&
+           imageData   a == imageData   b
+
+-- | Type for the palette used in Gif & PNG files.
+type Palette = Image PixelRGB8
+
+-- | Class used to describle plane present in the pixel
+-- type. If a pixel has a plane description associated,
+-- you can use the plane name to extract planes independently.
+class ColorPlane pixel planeToken where
+    -- | Retrieve the index of the component in the
+    -- given pixel type.
+    toComponentIndex :: pixel -> planeToken -> Int
+
+-- | Define the plane for the red color component
+data PlaneRed = PlaneRed
+    deriving (Typeable)
+
+-- | Define the plane for the green color component
+data PlaneGreen = PlaneGreen
+    deriving (Typeable)
+
+-- | Define the plane for the blue color component
+data PlaneBlue = PlaneBlue
+    deriving (Typeable)
+
+-- | Define the plane for the alpha (transparency) component
+data PlaneAlpha = PlaneAlpha
+    deriving (Typeable)
+
+-- | Define the plane for the luma component
+data PlaneLuma = PlaneLuma
+    deriving (Typeable)
+
+-- | Define the plane for the Cr component
+data PlaneCr = PlaneCr
+    deriving (Typeable)
+
+-- | Define the plane for the Cb component
+data PlaneCb = PlaneCb
+    deriving (Typeable)
+
+-- | Define plane for the cyan component of the
+-- CMYK color space.
+data PlaneCyan = PlaneCyan
+    deriving (Typeable)
+
+-- | Define plane for the magenta component of the
+-- CMYK color space.
+data PlaneMagenta = PlaneMagenta
+    deriving (Typeable)
+
+-- | Define plane for the yellow component of the
+-- CMYK color space.
+data PlaneYellow = PlaneYellow
+    deriving (Typeable)
+
+-- | Define plane for the black component of
+-- the CMYK color space.
+data PlaneBlack = PlaneBlack
+    deriving (Typeable)
+
+-- | Extract a color plane from an image given a present plane in the image
+-- examples:
+--
+-- @
+--  extractRedPlane :: Image PixelRGB8 -> Image Pixel8
+--  extractRedPlane = extractComponent PlaneRed
+-- @
+--
+extractComponent :: forall px plane. ( Pixel px
+                                     , Pixel (PixelBaseComponent px)
+                                     , PixelBaseComponent (PixelBaseComponent px)
+                                                    ~ PixelBaseComponent px
+                                     , ColorPlane px plane )
+                 => plane -> Image px -> Image (PixelBaseComponent px)
+extractComponent plane = unsafeExtractComponent idx
+    where idx = toComponentIndex (undefined :: px) plane
+
+-- | Extract a plane of an image. Returns the requested color
+-- component as a greyscale image.
+--
+-- If you ask for a component out of bound, the `error` function will
+-- be called.
+unsafeExtractComponent :: forall a
+                        . ( Pixel a
+                          , Pixel (PixelBaseComponent a)
+                          , PixelBaseComponent (PixelBaseComponent a)
+                                              ~ PixelBaseComponent a)
+                       => Int     -- ^ The component index, beginning at 0 ending at (componentCount - 1)
+                       -> Image a -- ^ Source image
+                       -> Image (PixelBaseComponent a)
+unsafeExtractComponent comp img@(Image { imageWidth = w, imageHeight = h })
+  | comp >= padd = error $ "extractComponent : invalid component index ("
+                         ++ show comp ++ ", max:" ++ show padd ++ ")"
+  | otherwise = Image { imageWidth = w, imageHeight = h, imageData = plane }
+      where plane = stride img padd comp
+            padd = componentCount (undefined :: a)
+
+-- | For any image with an alpha component (transparency),
+-- drop it, returning a pure opaque image.
+dropAlphaLayer :: (TransparentPixel a b) => Image a -> Image b
+dropAlphaLayer = pixelMap dropTransparency
+
+-- | Class modeling transparent pixel, should provide a method
+-- to combine transparent pixels
+class (Pixel a, Pixel b) => TransparentPixel a b | a -> b where
+    -- | Just return the opaque pixel value
+    dropTransparency :: a -> b
+
+    -- | access the transparency (alpha layer) of a given
+    -- transparent pixel type.
+    getTransparency :: a -> PixelBaseComponent a
+{-# DEPRECATED getTransparency "please use 'pixelOpacity' instead" #-}
+
+instance TransparentPixel PixelRGBA8 PixelRGB8 where
+    {-# INLINE dropTransparency #-}
+    dropTransparency (PixelRGBA8 r g b _) = PixelRGB8 r g b
+    {-# INLINE getTransparency #-}
+    getTransparency (PixelRGBA8 _ _ _ a) = a
+
+lineFold :: (Monad m) => a -> Int -> (a -> Int -> m a) -> m a
+{-# INLINE lineFold #-}
+lineFold initial count f = go 0 initial
+  where go n acc | n >= count = return acc
+        go n acc = f acc n >>= go (n + 1)
+
+stride :: (Storable (PixelBaseComponent a))
+       => Image a -> Int -> Int -> V.Vector (PixelBaseComponent a)
+stride Image { imageWidth = w, imageHeight = h, imageData = array }
+        padd firstComponent = runST $ do
+    let cell_count = w * h
+    outArray <- M.new cell_count
+
+    let go writeIndex _ | writeIndex >= cell_count = return ()
+        go writeIndex readIndex = do
+          (outArray `M.unsafeWrite` writeIndex) $ array `V.unsafeIndex` readIndex
+          go (writeIndex + 1) $ readIndex + padd
+
+    go 0 firstComponent
+    V.unsafeFreeze outArray
+
+instance NFData (Image a) where
+    rnf (Image width height dat) = width  `seq`
+                                   height `seq`
+                                   dat    `seq`
+                                   ()
+
+-- | Image or pixel buffer, the coordinates are assumed to start
+-- from the upper-left corner of the image, with the horizontal
+-- position first, then the vertical one. The image can be transformed in place.
+data MutableImage s a = MutableImage
+    { -- | Width of the image in pixels
+      mutableImageWidth  :: {-# UNPACK #-} !Int
+
+      -- | Height of the image in pixels.
+    , mutableImageHeight :: {-# UNPACK #-} !Int
+
+      -- | The real image, to extract pixels at some position
+      -- you should use the helpers functions.
+    , mutableImageData   :: M.STVector s (PixelBaseComponent a)
+    }
+    deriving (Typeable)
+
+-- | `O(n)` Yield an immutable copy of an image by making a copy of it
+freezeImage :: (Storable (PixelBaseComponent px), PrimMonad m)
+            => MutableImage (PrimState m) px -> m (Image px)
+freezeImage (MutableImage w h d) = Image w h `liftM` V.freeze d
+
+-- | `O(n)` Yield a mutable copy of an image by making a copy of it.
+thawImage :: (Storable (PixelBaseComponent px), PrimMonad m)
+          => Image px -> m (MutableImage (PrimState m) px)
+thawImage (Image w h d) = MutableImage w h `liftM` V.thaw d
+
+-- | `O(1)` Unsafe convert an imutable image to an mutable one without copying.
+-- The source image shouldn't be used after this operation.
+unsafeThawImage :: (Storable (PixelBaseComponent px), PrimMonad m)
+                => Image px -> m (MutableImage (PrimState m) px)
+{-# NOINLINE unsafeThawImage #-}
+unsafeThawImage (Image w h d) = MutableImage w h `liftM` V.unsafeThaw d
+
+-- | `O(1)` Unsafe convert a mutable image to an immutable one without copying.
+-- The mutable image may not be used after this operation.
+unsafeFreezeImage ::  (Storable (PixelBaseComponent a), PrimMonad m)
+                  => MutableImage (PrimState m) a -> m (Image a)
+unsafeFreezeImage (MutableImage w h d) = Image w h `liftM` V.unsafeFreeze d
+
+-- | Create a mutable image, filled with the given background color.
+createMutableImage :: (Pixel px, PrimMonad m)
+                   => Int -- ^ Width
+                   -> Int -- ^ Height
+                   -> px  -- ^ Background color
+                   -> m (MutableImage (PrimState m) px)
+createMutableImage width height background =
+   generateMutableImage (\_ _ -> background) width height
+
+-- | Create a mutable image with garbage as content. All data
+-- is uninitialized.
+newMutableImage :: forall px m. (Pixel px, PrimMonad m)
+                => Int -- ^ Width
+                -> Int -- ^ Height
+                -> m (MutableImage (PrimState m) px)
+newMutableImage w h = MutableImage w h `liftM` M.new (w * h * compCount)
+  where compCount = componentCount (undefined :: px)
+
+instance NFData (MutableImage s a) where
+    rnf (MutableImage width height dat) = width  `seq`
+                                          height `seq`
+                                          dat    `seq`
+                                          ()
+
+-- | Image type enumerating all predefined pixel types.
+-- It enables loading and use of images of different
+-- pixel types.
+data DynamicImage =
+       -- | A greyscale image.
+       ImageY8    (Image Pixel8)
+       -- | A greyscale image with 16bit components
+     | ImageY16   (Image Pixel16)
+       -- | A greyscale image with 32bit components
+     | ImageY32   (Image Pixel32)
+       -- | A greyscale HDR image
+     | ImageYF    (Image PixelF)
+       -- | An image in greyscale with an alpha channel.
+     | ImageYA8   (Image PixelYA8)
+      -- | An image in greyscale with alpha channel on 16 bits.
+     | ImageYA16  (Image PixelYA16)
+       -- | An image in true color.
+     | ImageRGB8  (Image PixelRGB8)
+       -- | An image in true color with 16bit depth.
+     | ImageRGB16 (Image PixelRGB16)
+       -- | An image with HDR pixels
+     | ImageRGBF  (Image PixelRGBF)
+       -- | An image in true color and an alpha channel.
+     | ImageRGBA8 (Image PixelRGBA8)
+       -- | A true color image with alpha on 16 bits.
+     | ImageRGBA16 (Image PixelRGBA16)
+       -- | An image in the colorspace used by Jpeg images.
+     | ImageYCbCr8 (Image PixelYCbCr8)
+       -- | An image in the colorspace CMYK
+     | ImageCMYK8  (Image PixelCMYK8)
+       -- | An image in the colorspace CMYK and 16 bits precision
+     | ImageCMYK16 (Image PixelCMYK16)
+    deriving (Eq, 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
+-- the following snippet:
+--
+-- > dynWidth :: DynamicImage -> Int
+-- > dynWidth img = dynamicMap imageWidth img
+--
+dynamicMap :: (forall pixel . (Pixel pixel) => Image pixel -> a)
+           -> DynamicImage -> a
+dynamicMap f (ImageY8    i) = f i
+dynamicMap f (ImageY16   i) = f i
+dynamicMap f (ImageY32   i) = f i
+dynamicMap f (ImageYF    i) = f i
+dynamicMap f (ImageYA8   i) = f i
+dynamicMap f (ImageYA16  i) = f i
+dynamicMap f (ImageRGB8  i) = f i
+dynamicMap f (ImageRGB16 i) = f i
+dynamicMap f (ImageRGBF  i) = f i
+dynamicMap f (ImageRGBA8 i) = f i
+dynamicMap f (ImageRGBA16 i) = f i
+dynamicMap f (ImageYCbCr8 i) = f i
+dynamicMap f (ImageCMYK8 i) = f i
+dynamicMap f (ImageCMYK16 i) = f i
+
+-- | Equivalent of the `pixelMap` function for the dynamic images.
+-- You can perform pixel colorspace independant operations with this
+-- function.
+--
+-- For instance, if you want to extract a square crop of any image,
+-- without caring about colorspace, you can use the following snippet.
+--
+-- > dynSquare :: DynamicImage -> DynamicImage
+-- > dynSquare = dynamicPixelMap squareImage
+-- >
+-- > squareImage :: Pixel a => Image a -> Image a
+-- > squareImage img = generateImage (\x y -> pixelAt img x y) edge edge
+-- >    where edge = min (imageWidth img) (imageHeight img)
+--
+dynamicPixelMap :: (forall pixel . (Pixel pixel) => Image pixel -> Image pixel)
+                -> DynamicImage -> DynamicImage
+dynamicPixelMap f = aux
+  where
+    aux (ImageY8    i) = ImageY8 (f i)
+    aux (ImageY16   i) = ImageY16 (f i)
+    aux (ImageY32   i) = ImageY32 (f i)
+    aux (ImageYF    i) = ImageYF (f i)
+    aux (ImageYA8   i) = ImageYA8 (f i)
+    aux (ImageYA16  i) = ImageYA16 (f i)
+    aux (ImageRGB8  i) = ImageRGB8 (f i)
+    aux (ImageRGB16 i) = ImageRGB16 (f i)
+    aux (ImageRGBF  i) = ImageRGBF (f i)
+    aux (ImageRGBA8 i) = ImageRGBA8 (f i)
+    aux (ImageRGBA16 i) = ImageRGBA16 (f i)
+    aux (ImageYCbCr8 i) = ImageYCbCr8 (f i)
+    aux (ImageCMYK8 i) = ImageCMYK8 (f i)
+    aux (ImageCMYK16 i) = ImageCMYK16 (f i)
+
+instance NFData DynamicImage where
+    rnf (ImageY8 img)     = rnf img
+    rnf (ImageY16 img)    = rnf img
+    rnf (ImageY32 img)    = rnf img
+    rnf (ImageYF img)     = rnf img
+    rnf (ImageYA8 img)    = rnf img
+    rnf (ImageYA16 img)   = rnf img
+    rnf (ImageRGB8 img)   = rnf img
+    rnf (ImageRGB16 img)  = rnf img
+    rnf (ImageRGBF img)   = rnf img
+    rnf (ImageRGBA8 img)  = rnf img
+    rnf (ImageRGBA16 img) = rnf img
+    rnf (ImageYCbCr8 img) = rnf img
+    rnf (ImageCMYK8 img)  = rnf img
+    rnf (ImageCMYK16 img)  = rnf img
+
+-- | Type alias for 8bit greyscale pixels. For simplicity,
+-- greyscale pixels use plain numbers instead of a separate type.
+type Pixel8 = Word8
+
+-- | Type alias for 16bit greyscale pixels.
+type Pixel16 = Word16
+
+-- | Type alias for 32bit greyscale pixels.
+type Pixel32 = Word32
+
+-- | Type alias for 32bit floating point greyscale pixels. The standard
+-- bounded value range is mapped to the closed interval [0,1] i.e.
+--
+-- > map promotePixel [0, 1 .. 255 :: Pixel8] == [0/255, 1/255 .. 1.0 :: PixelF]
+type PixelF = Float
+
+-- | Pixel type storing 8bit Luminance (Y) and alpha (A) information.
+-- Values are stored in the following order:
+--
+--  * Luminance
+--
+--  * Alpha
+--
+data PixelYA8 = PixelYA8 {-# UNPACK #-} !Pixel8  -- Luminance
+                         {-# UNPACK #-} !Pixel8  -- Alpha value
+              deriving (Eq, Ord, Show, Typeable)
+
+-- | Pixel type storing 16bit Luminance (Y) and alpha (A) information.
+-- Values are stored in the following order:
+--
+--  * Luminance
+--
+--  * Alpha
+--
+data PixelYA16 = PixelYA16 {-# UNPACK #-} !Pixel16  -- Luminance
+                           {-# UNPACK #-} !Pixel16  -- Alpha value
+              deriving (Eq, Ord, Show, Typeable)
+
+-- | Classic pixel type storing 8bit red, green and blue (RGB) information.
+-- Values are stored in the following order:
+--
+--  * Red
+--
+--  * Green
+--
+--  * Blue
+--
+data PixelRGB8 = PixelRGB8 {-# UNPACK #-} !Pixel8 -- Red
+                           {-# UNPACK #-} !Pixel8 -- Green
+                           {-# UNPACK #-} !Pixel8 -- Blue
+               deriving (Eq, Ord, Show, Typeable)
+
+-- | Pixel type storing value for the YCCK color space:
+--
+-- * Y (Luminance)
+--
+-- * Cb
+--
+-- * Cr
+--
+-- * Black
+--
+data PixelYCbCrK8 = PixelYCbCrK8 {-# UNPACK #-} !Pixel8
+                                 {-# UNPACK #-} !Pixel8
+                                 {-# UNPACK #-} !Pixel8
+                                 {-# UNPACK #-} !Pixel8
+               deriving (Eq, Ord, Show, Typeable)
+
+-- | Pixel type storing 16bit red, green and blue (RGB) information.
+-- Values are stored in the following order:
+--
+--  * Red
+--
+--  * Green
+--
+--  * Blue
+--
+data PixelRGB16 = PixelRGB16 {-# UNPACK #-} !Pixel16 -- Red
+                             {-# UNPACK #-} !Pixel16 -- Green
+                             {-# UNPACK #-} !Pixel16 -- Blue
+               deriving (Eq, Ord, Show, Typeable)
+
+-- | HDR pixel type storing floating point 32bit red, green and blue (RGB) information.
+-- Same value range and comments apply as for 'PixelF'.
+-- Values are stored in the following order:
+--
+--  * Red
+--
+--  * Green
+--
+--  * Blue
+--
+data PixelRGBF = PixelRGBF {-# UNPACK #-} !PixelF -- Red
+                           {-# UNPACK #-} !PixelF -- Green
+                           {-# UNPACK #-} !PixelF -- Blue
+               deriving (Eq, Ord, Show, Typeable)
+
+-- | Pixel type storing 8bit luminance, blue difference and red difference (YCbCr) information.
+-- Values are stored in the following order:
+--
+--  * Y (luminance)
+--
+--  * Cb
+--
+--  * Cr
+--
+data PixelYCbCr8 = PixelYCbCr8 {-# UNPACK #-} !Pixel8 -- Y luminance
+                               {-# UNPACK #-} !Pixel8 -- Cb blue difference
+                               {-# UNPACK #-} !Pixel8 -- Cr red difference
+                 deriving (Eq, Ord, Show, Typeable)
+
+-- | Pixel type storing 8bit cyan, magenta, yellow and black (CMYK) information.
+-- Values are stored in the following order:
+--
+--   * Cyan
+--
+--   * Magenta
+--
+--   * Yellow
+--
+--   * Black
+--
+data PixelCMYK8 = PixelCMYK8 {-# UNPACK #-} !Pixel8 -- Cyan
+                             {-# UNPACK #-} !Pixel8 -- Magenta
+                             {-# UNPACK #-} !Pixel8 -- Yellow
+                             {-# UNPACK #-} !Pixel8 -- Black
+                 deriving (Eq, Ord, Show, Typeable)
+
+-- | Pixel type storing 16bit cyan, magenta, yellow and black (CMYK) information.
+-- Values are stored in the following order:
+--
+--   * Cyan
+--
+--   * Magenta
+--
+--   * Yellow
+--
+--   * Black
+--
+data PixelCMYK16 = PixelCMYK16 {-# UNPACK #-} !Pixel16 -- Cyan
+                               {-# UNPACK #-} !Pixel16 -- Magenta
+                               {-# UNPACK #-} !Pixel16 -- Yellow
+                               {-# UNPACK #-} !Pixel16 -- Black
+                 deriving (Eq, Ord, Show, Typeable)
+
+
+-- | Classical pixel type storing 8bit red, green, blue and alpha (RGBA) information.
+-- Values are stored in the following order:
+--
+--  * Red
+--
+--  * Green
+--
+--  * Blue
+--
+--  * Alpha
+--
+data PixelRGBA8 = PixelRGBA8 {-# UNPACK #-} !Pixel8 -- Red
+                             {-# UNPACK #-} !Pixel8 -- Green
+                             {-# UNPACK #-} !Pixel8 -- Blue
+                             {-# UNPACK #-} !Pixel8 -- Alpha
+                deriving (Eq, Ord, Show, Typeable)
+
+-- | Pixel type storing 16bit red, green, blue and alpha (RGBA) information.
+-- Values are stored in the following order:
+--
+--  * Red
+--
+--  * Green
+--
+--  * Blue
+--
+--  * Alpha
+--
+data PixelRGBA16 = PixelRGBA16 {-# UNPACK #-} !Pixel16 -- Red
+                               {-# UNPACK #-} !Pixel16 -- Green
+                               {-# UNPACK #-} !Pixel16 -- Blue
+                               {-# UNPACK #-} !Pixel16 -- Alpha
+                deriving (Eq, Ord, Show, Typeable)
+
+-- | Definition of pixels used in images. Each pixel has a color space, and a representative
+-- component (Word8 or Float).
+class ( Storable (PixelBaseComponent a)
+      , Num (PixelBaseComponent a), Eq a ) => Pixel a where
+    -- | Type of the pixel component, "classical" images
+    -- would have Word8 type as their PixelBaseComponent,
+    -- HDR image would have Float for instance
+    type PixelBaseComponent a :: *
+
+    -- | Call the function for every component of the pixels.
+    -- For example for RGB pixels mixWith is declared like this:
+    --
+    -- > mixWith f (PixelRGB8 ra ga ba) (PixelRGB8 rb gb bb) =
+    -- >    PixelRGB8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb)
+    --
+    mixWith :: (Int -> PixelBaseComponent a -> PixelBaseComponent a -> PixelBaseComponent a)
+            -> a -> a -> a
+
+    -- | Extension of the `mixWith` which separate the treatment
+    -- of the color components of the alpha value (transparency component).
+    -- For pixel without alpha components, it is equivalent to mixWith.
+    --
+    -- > mixWithAlpha f fa (PixelRGBA8 ra ga ba aa) (PixelRGB8 rb gb bb ab) =
+    -- >    PixelRGBA8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (fa aa ab)
+    --
+    mixWithAlpha :: (Int -> PixelBaseComponent a -> PixelBaseComponent a
+                         -> PixelBaseComponent a)  -- ^ Function for color component
+                 -> (PixelBaseComponent a -> PixelBaseComponent a
+                         -> PixelBaseComponent a) -- ^ Function for alpha component
+                 -> a -> a -> a
+    {-# INLINE mixWithAlpha #-}
+    mixWithAlpha f _ = mixWith f
+
+    -- | Return the opacity of a pixel, if the pixel has an
+    -- alpha layer, return the alpha value. If the pixel
+    -- doesn't have an alpha value, return a value
+    -- representing the opaqueness.
+    pixelOpacity :: a -> PixelBaseComponent a
+
+    -- | Return the number of components of the pixel
+    componentCount :: a -> Int
+
+    -- | Apply a function to each component of a pixel.
+    -- If the color type possess an alpha (transparency channel),
+    -- it is treated like the other color components.
+    colorMap :: (PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
+
+    -- | Calculate the index for the begining of the pixel
+    pixelBaseIndex :: Image a -> Int -> Int -> Int
+    pixelBaseIndex (Image { imageWidth = w }) x y =
+            (x + y * w) * componentCount (undefined :: a)
+
+    -- | Calculate theindex for the begining of the pixel at position x y
+    mutablePixelBaseIndex :: MutableImage s a -> Int -> Int -> Int
+    mutablePixelBaseIndex (MutableImage { mutableImageWidth = w }) x y =
+            (x + y * w) * componentCount (undefined :: a)
+
+    -- | Extract a pixel at a given position, (x, y), the origin
+    -- is assumed to be at the corner top left, positive y to the
+    -- bottom of the image
+    pixelAt :: Image a -> Int -> Int -> a
+
+    -- | Same as pixelAt but for mutable images.
+    readPixel :: PrimMonad m => MutableImage (PrimState m) a -> Int -> Int -> m a
+
+    -- | Write a pixel in a mutable image at position x y
+    writePixel :: PrimMonad m => MutableImage (PrimState m) a -> Int -> Int -> a -> m ()
+
+    -- | Unsafe version of pixelAt, read a pixel at the given
+    -- index without bound checking (if possible).
+    -- The index is expressed in number (PixelBaseComponent a)
+    unsafePixelAt :: V.Vector (PixelBaseComponent a) -> Int -> a
+
+    -- | Unsafe version of readPixel,  read a pixel at the given
+    -- position without bound checking (if possible). The index
+    -- is expressed in number (PixelBaseComponent a)
+    unsafeReadPixel :: PrimMonad m => M.STVector (PrimState m) (PixelBaseComponent a) -> Int -> m a
+
+    -- | Unsafe version of writePixel, write a pixel at the
+    -- given position without bound checking. This can be _really_ unsafe.
+    -- The index is expressed in number (PixelBaseComponent a)
+    unsafeWritePixel :: PrimMonad m => M.STVector (PrimState m) (PixelBaseComponent a) -> Int -> a -> m ()
+
+
+-- | Implement upcasting for pixel types.
+-- Minimal declaration of `promotePixel`.
+-- It is strongly recommended to overload promoteImage to keep
+-- performance acceptable
+class (Pixel a, Pixel b) => ColorConvertible a b where
+    -- | Convert a pixel type to another pixel type. This
+    -- operation should never lose any data.
+    promotePixel :: a -> b
+
+    -- | Change the underlying pixel type of an image by performing a full copy
+    -- of it.
+    promoteImage :: Image a -> Image b
+    promoteImage = pixelMap promotePixel
+
+-- | This class abstract colorspace conversion. This
+-- conversion can be lossy, which ColorConvertible cannot
+class (Pixel a, Pixel b) => ColorSpaceConvertible a b where
+    -- | Pass a pixel from a colorspace (say RGB) to the second one
+    -- (say YCbCr)
+    convertPixel :: a -> b
+
+    -- | Helper function to convert a whole image by taking a
+    -- copy it.
+    convertImage :: Image a -> Image b
+    convertImage = pixelMap convertPixel
+
+generateMutableImage :: forall m px. (Pixel px, PrimMonad m)
+                     => (Int -> Int -> px)  -- ^ Generating function, with `x` and `y` params.
+                     -> Int        -- ^ Width in pixels
+                     -> Int        -- ^ Height in pixels
+                     -> m (MutableImage (PrimState m) px)
+{-# INLINE generateMutableImage #-}
+generateMutableImage f w h = MutableImage w h `liftM` generated where
+  compCount = componentCount (undefined :: px)
+
+  generated = do
+    arr <- M.new (w * h * compCount)
+    let lineGenerator _ !y | y >= h = return ()
+        lineGenerator !lineIdx y = column lineIdx 0
+          where column !idx !x | x >= w = lineGenerator idx $ y + 1
+                column idx x = do
+                    unsafeWritePixel arr idx $ f x y
+                    column (idx + compCount) $ x + 1
+    lineGenerator 0 0
+    return arr
+
+-- | Create an image given a function to generate pixels.
+-- The function will receive values from 0 to width-1 for the x parameter
+-- and 0 to height-1 for the y parameter. The coordinates 0,0 are the upper
+-- left corner of the image, and (width-1, height-1) the lower right corner.
+--
+-- for example, to create a small gradient image:
+--
+-- > imageCreator :: String -> IO ()
+-- > imageCreator path = writePng path $ generateImage pixelRenderer 250 300
+-- >    where pixelRenderer x y = PixelRGB8 (fromIntegral x) (fromIntegral y) 128
+--
+generateImage :: forall px. (Pixel px)
+              => (Int -> Int -> px)  -- ^ Generating function, with `x` and `y` params.
+              -> Int        -- ^ Width in pixels
+              -> Int        -- ^ Height in pixels
+              -> Image px
+{-# INLINE generateImage #-}
+generateImage f w h = runST img where
+  img :: ST s (Image px)
+  img = generateMutableImage f w h >>= unsafeFreezeImage
+
+-- | Create an image using a monadic initializer function.
+-- The function will receive values from 0 to width-1 for the x parameter
+-- and 0 to height-1 for the y parameter. The coordinates 0,0 are the upper
+-- left corner of the image, and (width-1, height-1) the lower right corner.
+--
+-- The function is called for each pixel in the line from left to right (0 to width - 1)
+-- and for each line (0 to height - 1).
+withImage :: forall m pixel. (Pixel pixel, PrimMonad m)
+          => Int                     -- ^ Image width
+          -> Int                     -- ^ Image height
+          -> (Int -> Int -> m pixel) -- ^ Generating functions
+          -> m (Image pixel)
+withImage width height pixelGenerator = do
+  let pixelComponentCount = componentCount (undefined :: pixel)
+  arr <- M.new (width * height * pixelComponentCount)
+  let mutImage = MutableImage
+        { mutableImageWidth = width
+        , mutableImageHeight = height
+        , mutableImageData = arr
+        }
+
+  let pixelPositions = [(x, y) | y <- [0 .. height-1], x <- [0..width-1]]
+  sequence_ [pixelGenerator x y >>= unsafeWritePixel arr idx
+                        | ((x,y), idx) <- zip pixelPositions [0, pixelComponentCount ..]]
+  unsafeFreezeImage mutImage
+
+-- | Create an image given a function to generate pixels.
+-- The function will receive values from 0 to width-1 for the x parameter
+-- and 0 to height-1 for the y parameter. The coordinates 0,0 are the upper
+-- left corner of the image, and (width-1, height-1) the lower right corner.
+--
+-- the acc parameter is a user defined one.
+--
+-- The function is called for each pixel in the line from left to right (0 to width - 1)
+-- and for each line (0 to height - 1).
+generateFoldImage :: forall a acc. (Pixel a)
+                  => (acc -> Int -> Int -> (acc, a)) -- ^ Function taking the state, x and y
+                  -> acc        -- ^ Initial state
+                  -> Int        -- ^ Width in pixels
+                  -> Int        -- ^ Height in pixels
+                  -> (acc, Image a)
+generateFoldImage f intialAcc w h =
+ (finalState, Image { imageWidth = w, imageHeight = h, imageData = generated })
+  where compCount = componentCount (undefined :: a)
+        (finalState, generated) = runST $ do
+            arr <- M.new (w * h * compCount)
+            let mutImage = MutableImage {
+                                mutableImageWidth = w,
+                                mutableImageHeight = h,
+                                mutableImageData = arr }
+            foldResult <- foldM (\acc (x,y) -> do
+                    let (acc', px) = f acc x y
+                    writePixel mutImage x y px
+                    return acc') intialAcc [(x,y) | y <- [0 .. h-1], x <- [0 .. w-1]]
+
+            frozen <- V.unsafeFreeze arr
+            return (foldResult, frozen)
+
+-- | Fold over the pixel of an image with a raster scan order:
+-- from top to bottom, left to right
+{-# INLINE pixelFold #-}
+pixelFold :: forall acc pixel. (Pixel pixel)
+          => (acc -> Int -> Int -> pixel -> acc) -> acc -> Image pixel -> acc
+pixelFold f initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) =
+  columnFold 0 initialAccumulator 0
+    where
+      !compCount = componentCount (undefined :: pixel)
+      !vec = imageData img
+
+      lfold !y acc !x !idx
+        | x >= w = columnFold (y + 1) acc idx
+        | otherwise = 
+            lfold y (f acc x y $ unsafePixelAt vec idx) (x + 1) (idx + compCount)
+
+      columnFold !y lineAcc !readIdx
+        | y >= h = lineAcc
+        | otherwise = lfold y lineAcc 0 readIdx
+
+-- | Fold over the pixel of an image with a raster scan order:
+-- from top to bottom, left to right, carrying out a state
+pixelFoldM :: (Pixel pixel, Monad m)
+           => (acc -> Int -> Int -> pixel -> m acc) -- ^ monadic mapping function
+           -> acc                              -- ^ Initial state
+           -> Image pixel                       -- ^ Image to fold over
+           -> m acc
+{-# INLINE pixelFoldM  #-}
+pixelFoldM action initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) =
+  lineFold initialAccumulator h columnFold
+    where
+      pixelFolder y acc x = action acc x y $ pixelAt img x y
+      columnFold lineAcc y = lineFold lineAcc w (pixelFolder y)
+
+
+-- | Fold over the pixel of an image with a raster scan order:
+-- from top to bottom, left to right. This functions is analog
+-- to the foldMap from the 'Foldable' typeclass, but due to the
+-- Pixel constraint, Image cannot be made an instance of it.
+pixelFoldMap :: forall m px. (Pixel px, Monoid m) => (px -> m) -> Image px -> m
+pixelFoldMap f Image { imageWidth = w, imageHeight = h, imageData = vec } = folder 0
+  where
+    compCount = componentCount (undefined :: px)
+    maxi = w * h * compCount
+
+    folder idx | idx >= maxi = mempty
+    folder idx = f (unsafePixelAt vec idx) <> folder (idx + compCount)
+
+-- | `map` equivalent for an image, working at the pixel level.
+-- Little example : a brightness function for an rgb image
+--
+-- > brightnessRGB8 :: Int -> Image PixelRGB8 -> Image PixelRGB8
+-- > brightnessRGB8 add = pixelMap brightFunction
+-- >      where up v = fromIntegral (fromIntegral v + add)
+-- >            brightFunction (PixelRGB8 r g b) =
+-- >                    PixelRGB8 (up r) (up g) (up b)
+--
+pixelMap :: forall a b. (Pixel a, Pixel b)
+         => (a -> b) -> Image a -> Image b
+{-# SPECIALIZE INLINE pixelMap :: (PixelYCbCr8 -> PixelRGB8) -> Image PixelYCbCr8 -> Image PixelRGB8 #-}
+{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelYCbCr8) -> Image PixelRGB8 -> Image PixelYCbCr8 #-}
+{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGB8) -> Image PixelRGB8 -> Image PixelRGB8 #-}
+{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGBA8) -> Image PixelRGB8 -> Image PixelRGBA8 #-}
+{-# SPECIALIZE INLINE pixelMap :: (PixelRGBA8 -> PixelRGBA8) -> Image PixelRGBA8 -> Image PixelRGBA8 #-}
+{-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> PixelRGB8) -> Image Pixel8 -> Image PixelRGB8 #-}
+{-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> Pixel8) -> Image Pixel8 -> Image Pixel8 #-}
+pixelMap f Image { imageWidth = w, imageHeight = h, imageData = vec } =
+  Image w h pixels
+    where sourceComponentCount = componentCount (undefined :: a)
+          destComponentCount = componentCount (undefined :: b)
+
+          pixels = runST $ do
+            newArr <- M.new (w * h * destComponentCount)
+            let lineMapper _ _ y | y >= h = return ()
+                lineMapper readIdxLine writeIdxLine y = colMapper readIdxLine writeIdxLine 0
+                  where colMapper readIdx writeIdx x
+                            | x >= w = lineMapper readIdx writeIdx $ y + 1
+                            | otherwise = do
+                                unsafeWritePixel newArr writeIdx . f $ unsafePixelAt vec readIdx
+                                colMapper (readIdx + sourceComponentCount)
+                                          (writeIdx + destComponentCount)
+                                          (x + 1)
+            lineMapper 0 0 0
+
+            -- unsafeFreeze avoids making a second copy and it will be
+            -- safe because newArray can't be referenced as a mutable array
+            -- outside of this where block
+            V.unsafeFreeze newArr
+
+
+-- | Helpers to embed a rankNTypes inside an Applicative
+newtype GenST a = GenST { genAction :: forall s. ST s (M.STVector s a) }
+
+-- | Traversal type matching the definition in the Lens package.
+type Traversal s t a b =
+    forall f. Applicative f => (a -> f b) -> s -> f t 
+
+writePx :: Pixel px
+        => Int -> GenST (PixelBaseComponent px) -> px -> GenST (PixelBaseComponent px)
+{-# INLINE writePx #-}
+writePx idx act px = GenST $ do
+   vec <- genAction act
+   unsafeWritePixel vec idx px
+   return vec
+
+freezeGenST :: Pixel px
+            => Int -> Int -> GenST (PixelBaseComponent px) -> Image px
+freezeGenST w h act =
+  Image w h (runST (genAction act >>= V.unsafeFreeze))
+
+-- | Traversal in "raster" order, from left to right the top to bottom.
+-- This traversal is matching pixelMap in spirit.
+--
+-- Since 3.2.4
+imagePixels :: forall pxa pxb. (Pixel pxa, Pixel pxb)
+            => Traversal (Image pxa) (Image pxb) pxa pxb
+{-# INLINE imagePixels #-}
+imagePixels f Image { imageWidth = w, imageHeight = h, imageData = vec } =
+  freezeGenST w h <$> pixels
+  where
+    sourceComponentCount = componentCount (undefined :: pxa)
+    destComponentCount = componentCount (undefined :: pxb)
+
+    maxi = w * h * sourceComponentCount
+    pixels =
+      go (pure $ GenST $ M.new (w * h * destComponentCount)) 0 0
+
+    go act readIdx _ | readIdx >= maxi = act
+    go act readIdx writeIdx =
+      go newAct (readIdx + sourceComponentCount) (writeIdx + destComponentCount)
+      where
+        px = f (unsafePixelAt vec readIdx)
+        newAct = writePx writeIdx <$> act <*> px
+
+-- | Traversal providing the pixel position with it's value.
+-- The traversal in raster order, from lef to right, then top
+-- to bottom. The traversal match pixelMapXY in spirit.
+--
+-- Since 3.2.4
+imageIPixels :: forall pxa pxb. (Pixel pxa, Pixel pxb)
+             => Traversal (Image pxa) (Image pxb) (Int, Int, pxa) pxb
+{-# INLINE imageIPixels #-}
+imageIPixels f Image { imageWidth = w, imageHeight = h, imageData = vec } =
+  freezeGenST w h <$> pixels
+  where
+    sourceComponentCount = componentCount (undefined :: pxa)
+    destComponentCount = componentCount (undefined :: pxb)
+
+    pixels =
+      lineMapper (pure $ GenST $ M.new (w * h * destComponentCount)) 0 0 0
+
+    lineMapper act _ _ y | y >= h = act
+    lineMapper act readIdxLine writeIdxLine y =
+        go act readIdxLine writeIdxLine 0
+      where
+        go cact readIdx writeIdx x
+          | x >= w = lineMapper cact readIdx writeIdx $ y + 1
+          | otherwise = do
+             let px = f (x, y, unsafePixelAt vec readIdx)
+             go (writePx writeIdx <$> cact <*> px)
+                (readIdx + sourceComponentCount)
+                (writeIdx + destComponentCount)
+                (x + 1)
+
+-- | Just like `pixelMap` only the function takes the pixel coordinates as
+--   additional parameters.
+pixelMapXY :: forall a b. (Pixel a, Pixel b)
+           => (Int -> Int -> a -> b) -> Image a -> Image b
+{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelYCbCr8 -> PixelRGB8)
+                                 -> Image PixelYCbCr8 -> Image PixelRGB8 #-}
+{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGB8 -> PixelYCbCr8)
+                                 -> Image PixelRGB8 -> Image PixelYCbCr8 #-}
+{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGB8 -> PixelRGB8)
+                                 -> Image PixelRGB8 -> Image PixelRGB8 #-}
+{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGB8 -> PixelRGBA8)
+                                 -> Image PixelRGB8 -> Image PixelRGBA8 #-}
+{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGBA8 -> PixelRGBA8)
+                                 -> Image PixelRGBA8 -> Image PixelRGBA8 #-}
+{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> Pixel8 -> PixelRGB8)
+                                 -> Image Pixel8 -> Image PixelRGB8 #-}
+pixelMapXY f Image { imageWidth = w, imageHeight = h, imageData = vec } =
+  Image w h pixels
+    where sourceComponentCount = componentCount (undefined :: a)
+          destComponentCount = componentCount (undefined :: b)
+
+          pixels = runST $ do
+            newArr <- M.new (w * h * destComponentCount)
+            let lineMapper _ _ y | y >= h = return ()
+                lineMapper readIdxLine writeIdxLine y = colMapper readIdxLine writeIdxLine 0
+                  where colMapper readIdx writeIdx x
+                            | x >= w = lineMapper readIdx writeIdx $ y + 1
+                            | otherwise = do
+                                unsafeWritePixel newArr writeIdx . f x y $ unsafePixelAt vec readIdx
+                                colMapper (readIdx + sourceComponentCount)
+                                          (writeIdx + destComponentCount)
+                                          (x + 1)
+            lineMapper 0 0 0
+
+            -- unsafeFreeze avoids making a second copy and it will be
+            -- safe because newArray can't be referenced as a mutable array
+            -- outside of this where block
+            V.unsafeFreeze newArr
+
+-- | Combine, pixel by pixel and component by component
+-- the values of 3 different images. Usage example:
+--
+-- > averageBrightNess c1 c2 c3 = clamp $ toInt c1 + toInt c2 + toInt c3
+-- >   where clamp = fromIntegral . min 0 . max 255
+-- >         toInt :: a -> Int
+-- >         toInt = fromIntegral
+-- > ziPixelComponent3 averageBrightNess img1 img2 img3
+--
+zipPixelComponent3
+    :: forall px. ( V.Storable (PixelBaseComponent px))
+    => (PixelBaseComponent px -> PixelBaseComponent px -> PixelBaseComponent px
+            -> PixelBaseComponent px)
+    -> Image px -> Image px -> Image px -> Image px
+{-# INLINE zipPixelComponent3 #-}
+zipPixelComponent3 f i1@(Image { imageWidth = w, imageHeight = h }) i2 i3
+  | not isDimensionEqual = error "Different image size zipPairwisePixelComponent"
+  | otherwise = Image { imageWidth = w
+                      , imageHeight = h
+                      , imageData = V.zipWith3 f data1 data2 data3
+                      }
+       where data1 = imageData i1
+             data2 = imageData i2
+             data3 = imageData i3
+
+             isDimensionEqual =
+                 w == imageWidth i2 && w == imageWidth i3 &&
+                     h == imageHeight i2 && h == imageHeight i3
+
+-- | Helper class to help extract a luma plane out
+-- of an image or a pixel
+class (Pixel a, Pixel (PixelBaseComponent a)) => LumaPlaneExtractable a where
+    -- | Compute the luminance part of a pixel
+    computeLuma      :: a -> PixelBaseComponent a
+
+    -- | Extract a luma plane out of an image. This
+    -- method is in the typeclass to help performant
+    -- implementation.
+    --
+    -- > jpegToGrayScale :: FilePath -> FilePath -> IO ()
+    -- > jpegToGrayScale source dest
+    extractLumaPlane :: Image a -> Image (PixelBaseComponent a)
+    extractLumaPlane = pixelMap computeLuma
+
+instance LumaPlaneExtractable Pixel8 where
+    {-# INLINE computeLuma #-}
+    computeLuma = id
+    extractLumaPlane = id
+
+instance LumaPlaneExtractable Pixel16 where
+    {-# INLINE computeLuma #-}
+    computeLuma = id
+    extractLumaPlane = id
+
+instance LumaPlaneExtractable Pixel32 where
+    {-# INLINE computeLuma #-}
+    computeLuma = id
+    extractLumaPlane = id
+
+instance LumaPlaneExtractable PixelF where
+    {-# INLINE computeLuma #-}
+    computeLuma = id
+    extractLumaPlane = id
+
+instance LumaPlaneExtractable PixelRGBF where
+    {-# INLINE computeLuma #-}
+    computeLuma (PixelRGBF r g b) =
+        0.3 * r + 0.59 * g + 0.11 * b
+
+instance LumaPlaneExtractable PixelRGBA8 where
+    {-# INLINE computeLuma #-}
+    computeLuma (PixelRGBA8 r g b _) =
+       floor $ (0.3 :: Double) * fromIntegral r
+             + 0.59 * fromIntegral g
+             + 0.11 * fromIntegral b
+
+instance LumaPlaneExtractable PixelYCbCr8 where
+    {-# INLINE computeLuma #-}
+    computeLuma (PixelYCbCr8 y _ _) = y
+    extractLumaPlane = extractComponent PlaneLuma
+
+-- | Free promotion for identic pixel types
+instance (Pixel a) => ColorConvertible a a where
+    {-# INLINE promotePixel #-}
+    promotePixel = id
+
+    {-# INLINE promoteImage #-}
+    promoteImage = id
+
+--------------------------------------------------
+----            Pixel8 instances
+--------------------------------------------------
+instance Pixel Pixel8 where
+    type PixelBaseComponent Pixel8 = Word8
+
+    {-# INLINE pixelOpacity #-}
+    pixelOpacity = const maxBound
+
+    {-# INLINE mixWith #-}
+    mixWith f = f 0
+
+    {-# INLINE colorMap #-}
+    colorMap f = f
+
+    {-# INLINE componentCount #-}
+    componentCount _ = 1
+
+    {-# INLINE pixelAt #-}
+    pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w)
+
+    {-# INLINE readPixel #-}
+    readPixel image@(MutableImage { mutableImageData = arr }) x y =
+        arr `M.read` mutablePixelBaseIndex image x y
+
+    {-# INLINE writePixel #-}
+    writePixel image@(MutableImage { mutableImageData = arr }) x y =
+        arr `M.write` mutablePixelBaseIndex image x y
+
+    {-# INLINE unsafePixelAt #-}
+    unsafePixelAt = V.unsafeIndex
+    {-# INLINE unsafeReadPixel #-}
+    unsafeReadPixel = M.unsafeRead
+    {-# INLINE unsafeWritePixel #-}
+    unsafeWritePixel = M.unsafeWrite
+
+instance ColorConvertible Pixel8 PixelYA8 where
+    {-# INLINE promotePixel #-}
+    promotePixel c = PixelYA8 c 255
+
+instance ColorConvertible Pixel8 PixelF where
+    {-# INLINE promotePixel #-}
+    promotePixel c = fromIntegral c / 255.0
+
+instance ColorConvertible Pixel8 Pixel16 where
+    {-# INLINE promotePixel #-}
+    promotePixel c = fromIntegral c * 257
+
+instance ColorConvertible Pixel8 PixelRGB8 where
+    {-# INLINE promotePixel #-}
+    promotePixel c = PixelRGB8 c c c
+
+instance ColorConvertible Pixel8 PixelRGB16 where
+    {-# INLINE promotePixel #-}
+    promotePixel c = PixelRGB16 (fromIntegral c * 257) (fromIntegral c * 257) (fromIntegral c * 257)
+
+instance ColorConvertible Pixel8 PixelRGBA8 where
+    {-# INLINE promotePixel #-}
+    promotePixel c = PixelRGBA8 c c c 255
+
+--------------------------------------------------
+----            Pixel16 instances
+--------------------------------------------------
+instance Pixel Pixel16 where
+    type PixelBaseComponent Pixel16 = Word16
+
+    {-# INLINE pixelOpacity #-}
+    pixelOpacity = const maxBound
+
+    {-# INLINE mixWith #-}
+    mixWith f = f 0
+
+    {-# INLINE colorMap #-}
+    colorMap f = f
+
+    {-# INLINE componentCount #-}
+    componentCount _ = 1
+    {-# INLINE pixelAt #-}
+    pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w)
+
+    {-# INLINE readPixel #-}
+    readPixel image@(MutableImage { mutableImageData = arr }) x y =
+        arr `M.read` mutablePixelBaseIndex image x y
+
+    {-# INLINE writePixel #-}
+    writePixel image@(MutableImage { mutableImageData = arr }) x y =
+        arr `M.write` mutablePixelBaseIndex image x y
+
+    {-# INLINE unsafePixelAt #-}
+    unsafePixelAt = V.unsafeIndex
+    {-# INLINE unsafeReadPixel #-}
+    unsafeReadPixel = M.unsafeRead
+    {-# INLINE unsafeWritePixel #-}
+    unsafeWritePixel = M.unsafeWrite
+
+instance ColorConvertible Pixel16 PixelYA16 where
+    {-# INLINE promotePixel #-}
+    promotePixel c = PixelYA16 c maxBound
+
+instance ColorConvertible Pixel16 PixelRGB16 where
+    {-# INLINE promotePixel #-}
+    promotePixel c = PixelRGB16 c c c
+
+instance ColorConvertible Pixel16 PixelRGBA16 where
+    {-# INLINE promotePixel #-}
+    promotePixel c = PixelRGBA16 c c c maxBound
+
+--------------------------------------------------
+----            Pixel32 instances
+--------------------------------------------------
+instance Pixel Pixel32 where
+    type PixelBaseComponent Pixel32 = Word32
+
+    {-# INLINE pixelOpacity #-}
+    pixelOpacity = const maxBound
+
+    {-# INLINE mixWith #-}
+    mixWith f = f 0
+
+    {-# INLINE colorMap #-}
+    colorMap f = f
+
+    {-# INLINE componentCount #-}
+    componentCount _ = 1
+
+    {-# INLINE pixelAt #-}
+    pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w)
+
+    {-# INLINE readPixel #-}
+    readPixel image@(MutableImage { mutableImageData = arr }) x y =
+        arr `M.read` mutablePixelBaseIndex image x y
+
+    {-# INLINE writePixel #-}
+    writePixel image@(MutableImage { mutableImageData = arr }) x y =
+        arr `M.write` mutablePixelBaseIndex image x y
+
+    {-# INLINE unsafePixelAt #-}
+    unsafePixelAt = V.unsafeIndex
+    {-# INLINE unsafeReadPixel #-}
+    unsafeReadPixel = M.unsafeRead
+    {-# INLINE unsafeWritePixel #-}
+    unsafeWritePixel = M.unsafeWrite
+
+--------------------------------------------------
+----            PixelF instances
+--------------------------------------------------
+instance Pixel PixelF where
+    type PixelBaseComponent PixelF = Float
+
+    {-# INLINE pixelOpacity #-}
+    pixelOpacity = const 1.0
+
+    {-# INLINE mixWith #-}
+    mixWith f = f 0
+
+    {-# INLINE colorMap #-}
+    colorMap f = f
+    {-# INLINE componentCount #-}
+    componentCount _ = 1
+    {-# INLINE pixelAt #-}
+    pixelAt (Image { imageWidth = w, imageData = arr }) x y =
+        arr ! (x + y * w)
+
+    {-# INLINE readPixel #-}
+    readPixel image@(MutableImage { mutableImageData = arr }) x y =
+        arr `M.read` mutablePixelBaseIndex image x y
+
+    {-# INLINE writePixel #-}
+    writePixel image@(MutableImage { mutableImageData = arr }) x y =
+        arr `M.write` mutablePixelBaseIndex image x y
+
+    {-# INLINE unsafePixelAt #-}
+    unsafePixelAt = V.unsafeIndex
+    {-# INLINE unsafeReadPixel #-}
+    unsafeReadPixel = M.unsafeRead
+    {-# INLINE unsafeWritePixel #-}
+    unsafeWritePixel = M.unsafeWrite
+
+instance ColorConvertible PixelF PixelRGBF where
+    {-# INLINE promotePixel #-}
+    promotePixel c = PixelRGBF c c c-- (c / 0.3) (c / 0.59)  (c / 0.11)
+
+--------------------------------------------------
+----            PixelYA8 instances
+--------------------------------------------------
+instance Pixel PixelYA8 where
+    type PixelBaseComponent PixelYA8 = Word8
+
+    {-# INLINE pixelOpacity #-}
+    pixelOpacity (PixelYA8 _ a) = a
+
+    {-# INLINE mixWith #-}
+    mixWith f (PixelYA8 ya aa) (PixelYA8 yb ab) =
+        PixelYA8 (f 0 ya yb) (f 1 aa ab)
+
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelYA8 y a) = PixelYA8 (f y) (f a)
+    {-# INLINE componentCount #-}
+    componentCount _ = 2
+    {-# INLINE pixelAt #-}
+    pixelAt image@(Image { imageData = arr }) x y =
+        PixelYA8 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1))
+        where baseIdx = pixelBaseIndex image x y
+
+    {-# INLINE readPixel #-}
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        yv <- arr `M.read` baseIdx
+        av <- arr `M.read` (baseIdx + 1)
+        return $ PixelYA8 yv av
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    {-# INLINE writePixel #-}
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA8 yv av) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr `M.write` (baseIdx + 0)) yv
+        (arr `M.write` (baseIdx + 1)) av
+
+    {-# INLINE unsafePixelAt #-}
+    unsafePixelAt v idx =
+        PixelYA8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1)
+    {-# INLINE unsafeReadPixel #-}
+    unsafeReadPixel vec idx =
+        PixelYA8 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1)
+    {-# INLINE unsafeWritePixel #-}
+    unsafeWritePixel v idx (PixelYA8 y a) =
+        M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) a
+
+instance ColorConvertible PixelYA8 PixelRGB8 where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelYA8 y _) = PixelRGB8 y y y
+
+instance ColorConvertible PixelYA8 PixelRGB16 where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelYA8 y _) = PixelRGB16 (fromIntegral y * 257) (fromIntegral y * 257) (fromIntegral y * 257)
+
+instance ColorConvertible PixelYA8 PixelRGBA8 where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelYA8 y a) = PixelRGBA8 y y y a
+
+instance ColorPlane PixelYA8 PlaneLuma where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelYA8 PlaneAlpha where
+    toComponentIndex _ _ = 1
+
+instance TransparentPixel PixelYA8 Pixel8 where
+    {-# INLINE dropTransparency #-}
+    dropTransparency (PixelYA8 y _) = y
+    {-# INLINE getTransparency #-}
+    getTransparency (PixelYA8 _ a) = a
+
+instance LumaPlaneExtractable PixelYA8 where
+    {-# INLINE computeLuma #-}
+    computeLuma (PixelYA8 y _) = y
+    extractLumaPlane = extractComponent PlaneLuma
+
+--------------------------------------------------
+----            PixelYA16 instances
+--------------------------------------------------
+instance Pixel PixelYA16 where
+    type PixelBaseComponent PixelYA16 = Word16
+
+    {-# INLINE pixelOpacity #-}
+    pixelOpacity (PixelYA16 _ a) = a
+
+    {-# INLINE mixWith #-}
+    mixWith f (PixelYA16 ya aa) (PixelYA16 yb ab) =
+        PixelYA16 (f 0 ya yb) (f 1 aa ab)
+
+    {-# INLINE mixWithAlpha #-}
+    mixWithAlpha f fa (PixelYA16 ya aa) (PixelYA16 yb ab) =
+        PixelYA16 (f 0 ya yb) (fa aa ab)
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelYA16 y a) = PixelYA16 (f y) (f a)
+    {-# INLINE componentCount #-}
+    componentCount _ = 2
+    {-# INLINE pixelAt #-}
+    pixelAt image@(Image { imageData = arr }) x y = PixelYA16 (arr ! (baseIdx + 0))
+                                                              (arr ! (baseIdx + 1))
+        where baseIdx = pixelBaseIndex image x y
+
+    {-# INLINE readPixel #-}
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        yv <- arr `M.read` baseIdx
+        av <- arr `M.read` (baseIdx + 1)
+        return $ PixelYA16 yv av
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    {-# INLINE writePixel #-}
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA16 yv av) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr `M.write` (baseIdx + 0)) yv
+        (arr `M.write` (baseIdx + 1)) av
+
+    {-# INLINE unsafePixelAt #-}
+    unsafePixelAt v idx =
+        PixelYA16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1)
+    {-# INLINE unsafeReadPixel #-}
+    unsafeReadPixel vec idx =
+        PixelYA16 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1)
+    {-# INLINE unsafeWritePixel #-}
+    unsafeWritePixel v idx (PixelYA16 y a) =
+        M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) a
+
+instance ColorConvertible PixelYA16 PixelRGB16 where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelYA16 y _) = PixelRGB16 y y y
+
+instance ColorConvertible PixelYA16 PixelRGBA16 where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelYA16 y a) = PixelRGBA16 y y y a
+
+instance ColorPlane PixelYA16 PlaneLuma where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelYA16 PlaneAlpha where
+    toComponentIndex _ _ = 1
+
+instance TransparentPixel PixelYA16 Pixel16 where
+    {-# INLINE dropTransparency #-}
+    dropTransparency (PixelYA16 y _) = y
+    {-# INLINE getTransparency #-}
+    getTransparency (PixelYA16 _ a) = a
+
+--------------------------------------------------
+----            PixelRGBF instances
+--------------------------------------------------
+instance Pixel PixelRGBF where
+    type PixelBaseComponent PixelRGBF = PixelF
+
+    {-# INLINE pixelOpacity #-}
+    pixelOpacity = const 1.0
+
+    {-# INLINE mixWith #-}
+    mixWith f (PixelRGBF ra ga ba) (PixelRGBF rb gb bb) =
+        PixelRGBF (f 0 ra rb) (f 1 ga gb) (f 2 ba bb)
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelRGBF r g b) = PixelRGBF (f r) (f g) (f b)
+
+    {-# INLINE componentCount #-}
+    componentCount _ = 3
+
+    {-# INLINE pixelAt #-}
+    pixelAt image@(Image { imageData = arr }) x y = PixelRGBF (arr ! (baseIdx + 0))
+                                                              (arr ! (baseIdx + 1))
+                                                              (arr ! (baseIdx + 2))
+        where baseIdx = pixelBaseIndex image x y
+
+    {-# INLINE readPixel #-}
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        rv <- arr `M.read` baseIdx
+        gv <- arr `M.read` (baseIdx + 1)
+        bv <- arr `M.read` (baseIdx + 2)
+        return $ PixelRGBF rv gv bv
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    {-# INLINE writePixel #-}
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBF rv gv bv) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr `M.write` (baseIdx + 0)) rv
+        (arr `M.write` (baseIdx + 1)) gv
+        (arr `M.write` (baseIdx + 2)) bv
+
+    {-# INLINE unsafePixelAt #-}
+    unsafePixelAt v idx =
+        PixelRGBF (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2)
+    {-# INLINE unsafeReadPixel #-}
+    unsafeReadPixel vec idx =
+        PixelRGBF `liftM` M.unsafeRead vec idx
+                  `ap` M.unsafeRead vec (idx + 1)
+                  `ap` M.unsafeRead vec (idx + 2)
+    {-# INLINE unsafeWritePixel #-}
+    unsafeWritePixel v idx (PixelRGBF r g b) =
+        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g
+                              >> M.unsafeWrite v (idx + 2) b
+
+instance ColorPlane PixelRGBF PlaneRed where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelRGBF PlaneGreen where
+    toComponentIndex _ _ = 1
+
+instance ColorPlane PixelRGBF PlaneBlue where
+    toComponentIndex _ _ = 2
+
+--------------------------------------------------
+----            PixelRGB16 instances
+--------------------------------------------------
+instance Pixel PixelRGB16 where
+    type PixelBaseComponent PixelRGB16 = Pixel16
+
+    {-# INLINE pixelOpacity #-}
+    pixelOpacity = const maxBound
+
+    {-# INLINE mixWith #-}
+    mixWith f (PixelRGB16 ra ga ba) (PixelRGB16 rb gb bb) =
+        PixelRGB16 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb)
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelRGB16 r g b) = PixelRGB16 (f r) (f g) (f b)
+
+    {-# INLINE componentCount #-}
+    componentCount _ = 3
+
+    {-# INLINE pixelAt #-}
+    pixelAt image@(Image { imageData = arr }) x y = PixelRGB16 (arr ! (baseIdx + 0))
+                                                               (arr ! (baseIdx + 1))
+                                                               (arr ! (baseIdx + 2))
+        where baseIdx = pixelBaseIndex image x y
+
+    {-# INLINE readPixel #-}
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        rv <- arr `M.read` baseIdx
+        gv <- arr `M.read` (baseIdx + 1)
+        bv <- arr `M.read` (baseIdx + 2)
+        return $ PixelRGB16 rv gv bv
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    {-# INLINE writePixel #-}
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB16 rv gv bv) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr `M.write` (baseIdx + 0)) rv
+        (arr `M.write` (baseIdx + 1)) gv
+        (arr `M.write` (baseIdx + 2)) bv
+
+    {-# INLINE unsafePixelAt #-}
+    unsafePixelAt v idx =
+        PixelRGB16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2)
+    {-# INLINE unsafeReadPixel #-}
+    unsafeReadPixel vec idx =
+        PixelRGB16 `liftM` M.unsafeRead vec idx
+                   `ap` M.unsafeRead vec (idx + 1)
+                   `ap` M.unsafeRead vec (idx + 2)
+    {-# INLINE unsafeWritePixel #-}
+    unsafeWritePixel v idx (PixelRGB16 r g b) =
+        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g
+                              >> M.unsafeWrite v (idx + 2) b
+
+instance ColorPlane PixelRGB16 PlaneRed where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelRGB16 PlaneGreen where
+    toComponentIndex _ _ = 1
+
+instance ColorPlane PixelRGB16 PlaneBlue where
+    toComponentIndex _ _ = 2
+
+instance ColorSpaceConvertible PixelRGB16 PixelCMYK16 where
+    {-# INLINE convertPixel #-}
+    convertPixel (PixelRGB16 r g b) = integralRGBToCMYK PixelCMYK16 (r, g, b)
+
+instance ColorConvertible PixelRGB16 PixelRGBA16 where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelRGB16 r g b) = PixelRGBA16 r g b maxBound
+
+instance LumaPlaneExtractable PixelRGB16 where
+    {-# INLINE computeLuma #-}
+    computeLuma (PixelRGB16 r g b) =
+        floor $ (0.3 :: Double) * fromIntegral r
+              + 0.59 * fromIntegral g
+              + 0.11 * fromIntegral b
+
+--------------------------------------------------
+----            PixelRGB8 instances
+--------------------------------------------------
+instance Pixel PixelRGB8 where
+    type PixelBaseComponent PixelRGB8 = Word8
+
+    {-# INLINE pixelOpacity #-}
+    pixelOpacity = const maxBound
+
+    {-# INLINE mixWith #-}
+    mixWith f (PixelRGB8 ra ga ba) (PixelRGB8 rb gb bb) =
+        PixelRGB8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb)
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelRGB8 r g b) = PixelRGB8 (f r) (f g) (f b)
+
+    {-# INLINE componentCount #-}
+    componentCount _ = 3
+
+    {-# INLINE pixelAt #-}
+    pixelAt image@(Image { imageData = arr }) x y = PixelRGB8 (arr ! (baseIdx + 0))
+                                                              (arr ! (baseIdx + 1))
+                                                              (arr ! (baseIdx + 2))
+        where baseIdx = pixelBaseIndex image x y
+
+    {-# INLINE readPixel #-}
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        rv <- arr `M.read` baseIdx
+        gv <- arr `M.read` (baseIdx + 1)
+        bv <- arr `M.read` (baseIdx + 2)
+        return $ PixelRGB8 rv gv bv
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    {-# INLINE writePixel #-}
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB8 rv gv bv) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr `M.write` (baseIdx + 0)) rv
+        (arr `M.write` (baseIdx + 1)) gv
+        (arr `M.write` (baseIdx + 2)) bv
+
+    {-# INLINE unsafePixelAt #-}
+    unsafePixelAt v idx =
+        PixelRGB8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2)
+    {-# INLINE unsafeReadPixel #-}
+    unsafeReadPixel vec idx =
+        PixelRGB8 `liftM` M.unsafeRead vec idx
+                  `ap` M.unsafeRead vec (idx + 1)
+                  `ap` M.unsafeRead vec (idx + 2)
+    {-# INLINE unsafeWritePixel #-}
+    unsafeWritePixel v idx (PixelRGB8 r g b) =
+        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g
+                              >> M.unsafeWrite v (idx + 2) b
+
+instance ColorConvertible PixelRGB8 PixelRGBA8 where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelRGB8 r g b) = PixelRGBA8 r g b maxBound
+
+instance ColorConvertible PixelRGB8 PixelRGBF where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelRGB8 r g b) = PixelRGBF (toF r) (toF g) (toF b)
+        where toF v = fromIntegral v / 255.0
+
+instance ColorConvertible PixelRGB8 PixelRGB16 where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelRGB8 r g b) = PixelRGB16 (promotePixel r) (promotePixel g) (promotePixel b)
+
+instance ColorConvertible PixelRGB8 PixelRGBA16 where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelRGB8 r g b) = PixelRGBA16 (promotePixel r) (promotePixel g) (promotePixel b) maxBound
+
+instance ColorPlane PixelRGB8 PlaneRed where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelRGB8 PlaneGreen where
+    toComponentIndex _ _ = 1
+
+instance ColorPlane PixelRGB8 PlaneBlue where
+    toComponentIndex _ _ = 2
+
+instance LumaPlaneExtractable PixelRGB8 where
+    {-# INLINE computeLuma #-}
+    computeLuma (PixelRGB8 r g b) =
+        floor $ (0.3 :: Double) * fromIntegral r
+              + 0.59 * fromIntegral g
+              + 0.11 * fromIntegral b
+
+--------------------------------------------------
+----            PixelRGBA8 instances
+--------------------------------------------------
+instance Pixel PixelRGBA8 where
+    type PixelBaseComponent PixelRGBA8 = Word8
+
+    {-# INLINE pixelOpacity #-}
+    pixelOpacity (PixelRGBA8 _ _ _ a) = a
+
+    {-# INLINE mixWith #-}
+    mixWith f (PixelRGBA8 ra ga ba aa) (PixelRGBA8 rb gb bb ab) =
+        PixelRGBA8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (f 3 aa ab)
+
+    {-# INLINE mixWithAlpha #-}
+    mixWithAlpha f fa (PixelRGBA8 ra ga ba aa) (PixelRGBA8 rb gb bb ab) =
+        PixelRGBA8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (fa aa ab)
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelRGBA8 r g b a) = PixelRGBA8 (f r) (f g) (f b) (f a)
+
+    {-# INLINE componentCount #-}
+    componentCount _ = 4
+
+    {-# INLINE pixelAt #-}
+    pixelAt image@(Image { imageData = arr }) x y = PixelRGBA8 (arr ! (baseIdx + 0))
+                                                               (arr ! (baseIdx + 1))
+                                                               (arr ! (baseIdx + 2))
+                                                               (arr ! (baseIdx + 3))
+        where baseIdx = pixelBaseIndex image x y
+
+    {-# INLINE readPixel #-}
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        rv <- arr `M.read` baseIdx
+        gv <- arr `M.read` (baseIdx + 1)
+        bv <- arr `M.read` (baseIdx + 2)
+        av <- arr `M.read` (baseIdx + 3)
+        return $ PixelRGBA8 rv gv bv av
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    {-# INLINE writePixel #-}
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA8 rv gv bv av) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr `M.write` (baseIdx + 0)) rv
+        (arr `M.write` (baseIdx + 1)) gv
+        (arr `M.write` (baseIdx + 2)) bv
+        (arr `M.write` (baseIdx + 3)) av
+
+    {-# INLINE unsafePixelAt #-}
+    unsafePixelAt v idx =
+        PixelRGBA8 (V.unsafeIndex v idx)
+                   (V.unsafeIndex v $ idx + 1)
+                   (V.unsafeIndex v $ idx + 2)
+                   (V.unsafeIndex v $ idx + 3)
+
+    {-# INLINE unsafeReadPixel #-}
+    unsafeReadPixel vec idx =
+        PixelRGBA8 `liftM` M.unsafeRead vec idx
+                   `ap` M.unsafeRead vec (idx + 1)
+                   `ap` M.unsafeRead vec (idx + 2)
+                   `ap` M.unsafeRead vec (idx + 3)
+
+    {-# INLINE unsafeWritePixel #-}
+    unsafeWritePixel v idx (PixelRGBA8 r g b a) =
+        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g
+                              >> M.unsafeWrite v (idx + 2) b
+                              >> M.unsafeWrite v (idx + 3) a
+
+instance ColorConvertible PixelRGBA8 PixelRGBA16 where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelRGBA8 r g b a) = PixelRGBA16 (promotePixel r) (promotePixel g) (promotePixel b) (promotePixel a)
+
+instance ColorPlane PixelRGBA8 PlaneRed where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelRGBA8 PlaneGreen where
+    toComponentIndex _ _ = 1
+
+instance ColorPlane PixelRGBA8 PlaneBlue where
+    toComponentIndex _ _ = 2
+
+instance ColorPlane PixelRGBA8 PlaneAlpha where
+    toComponentIndex _ _ = 3
+
+--------------------------------------------------
+----            PixelRGBA16 instances
+--------------------------------------------------
+instance Pixel PixelRGBA16 where
+    type PixelBaseComponent PixelRGBA16 = Pixel16
+
+    {-# INLINE pixelOpacity #-}
+    pixelOpacity (PixelRGBA16 _ _ _ a) = a
+
+    {-# INLINE mixWith #-}
+    mixWith f (PixelRGBA16 ra ga ba aa) (PixelRGBA16 rb gb bb ab) =
+        PixelRGBA16 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (f 3 aa ab)
+
+    {-# INLINE mixWithAlpha #-}
+    mixWithAlpha f fa (PixelRGBA16 ra ga ba aa) (PixelRGBA16 rb gb bb ab) =
+        PixelRGBA16 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (fa aa ab)
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelRGBA16 r g b a) = PixelRGBA16 (f r) (f g) (f b) (f a)
+
+    {-# INLINE componentCount #-}
+    componentCount _ = 4
+
+    {-# INLINE pixelAt #-}
+    pixelAt image@(Image { imageData = arr }) x y =
+                PixelRGBA16 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1))
+                            (arr ! (baseIdx + 2)) (arr ! (baseIdx + 3))
+        where baseIdx = pixelBaseIndex image x y
+
+    {-# INLINE readPixel #-}
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        rv <- arr `M.read` baseIdx
+        gv <- arr `M.read` (baseIdx + 1)
+        bv <- arr `M.read` (baseIdx + 2)
+        av <- arr `M.read` (baseIdx + 3)
+        return $ PixelRGBA16 rv gv bv av
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    {-# INLINE writePixel #-}
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA16 rv gv bv av) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr `M.write` (baseIdx + 0)) rv
+        (arr `M.write` (baseIdx + 1)) gv
+        (arr `M.write` (baseIdx + 2)) bv
+        (arr `M.write` (baseIdx + 3)) av
+
+    {-# INLINE unsafePixelAt #-}
+    unsafePixelAt v idx =
+        PixelRGBA16 (V.unsafeIndex v idx)
+                    (V.unsafeIndex v $ idx + 1)
+                    (V.unsafeIndex v $ idx + 2)
+                    (V.unsafeIndex v $ idx + 3)
+    {-# INLINE unsafeReadPixel #-}
+    unsafeReadPixel vec idx =
+        PixelRGBA16 `liftM` M.unsafeRead vec idx
+                    `ap` M.unsafeRead vec (idx + 1)
+                    `ap` M.unsafeRead vec (idx + 2)
+                    `ap` M.unsafeRead vec (idx + 3)
+    {-# INLINE unsafeWritePixel #-}
+    unsafeWritePixel v idx (PixelRGBA16 r g b a) =
+        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g
+                              >> M.unsafeWrite v (idx + 2) b
+                              >> M.unsafeWrite v (idx + 3) a
+
+
+instance TransparentPixel PixelRGBA16 PixelRGB16 where
+    {-# INLINE dropTransparency #-}
+    dropTransparency (PixelRGBA16 r g b _) = PixelRGB16 r g b
+    {-# INLINE getTransparency #-}
+    getTransparency (PixelRGBA16 _ _ _ a) = a
+
+instance ColorPlane PixelRGBA16 PlaneRed where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelRGBA16 PlaneGreen where
+    toComponentIndex _ _ = 1
+
+instance ColorPlane PixelRGBA16 PlaneBlue where
+    toComponentIndex _ _ = 2
+
+instance ColorPlane PixelRGBA16 PlaneAlpha where
+    toComponentIndex _ _ = 3
+
+--------------------------------------------------
+----            PixelYCbCr8 instances
+--------------------------------------------------
+instance Pixel PixelYCbCr8 where
+    type PixelBaseComponent PixelYCbCr8 = Word8
+
+    {-# INLINE pixelOpacity #-}
+    pixelOpacity = const maxBound
+
+    {-# INLINE mixWith #-}
+    mixWith f (PixelYCbCr8 ya cba cra) (PixelYCbCr8 yb cbb crb) =
+        PixelYCbCr8 (f 0 ya yb) (f 1 cba cbb) (f 2 cra crb)
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelYCbCr8 y cb cr) = PixelYCbCr8 (f y) (f cb) (f cr)
+    {-# INLINE componentCount #-}
+    componentCount _ = 3
+    {-# INLINE pixelAt #-}
+    pixelAt image@(Image { imageData = arr }) x y = PixelYCbCr8 (arr ! (baseIdx + 0))
+                                                                (arr ! (baseIdx + 1))
+                                                                (arr ! (baseIdx + 2))
+        where baseIdx = pixelBaseIndex image x y
+
+    {-# INLINE readPixel #-}
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        yv <- arr `M.read` baseIdx
+        cbv <- arr `M.read` (baseIdx + 1)
+        crv <- arr `M.read` (baseIdx + 2)
+        return $ PixelYCbCr8 yv cbv crv
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    {-# INLINE writePixel #-}
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCr8 yv cbv crv) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr `M.write` (baseIdx + 0)) yv
+        (arr `M.write` (baseIdx + 1)) cbv
+        (arr `M.write` (baseIdx + 2)) crv
+
+    {-# INLINE unsafePixelAt #-}
+    unsafePixelAt v idx =
+        PixelYCbCr8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2)
+    {-# INLINE unsafeReadPixel #-}
+    unsafeReadPixel vec idx =
+        PixelYCbCr8 `liftM` M.unsafeRead vec idx
+                    `ap` M.unsafeRead vec (idx + 1)
+                    `ap` M.unsafeRead vec (idx + 2)
+    {-# INLINE unsafeWritePixel #-}
+    unsafeWritePixel v idx (PixelYCbCr8 y cb cr) =
+        M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) cb
+                              >> M.unsafeWrite v (idx + 2) cr
+
+instance (Pixel a) => ColorSpaceConvertible a a where
+    convertPixel = id
+    convertImage = id
+
+scaleBits, oneHalf :: Int
+scaleBits = 16
+oneHalf = 1 `unsafeShiftL` (scaleBits - 1)
+
+fix :: Float -> Int
+fix x = floor $ x * fromIntegral ((1 :: Int) `unsafeShiftL` scaleBits) + 0.5
+
+
+rYTab, gYTab, bYTab, rCbTab, gCbTab, bCbTab, gCrTab, bCrTab :: V.Vector Int
+rYTab = V.fromListN 256 [fix 0.29900 * i | i <- [0..255] ]
+gYTab = V.fromListN 256 [fix 0.58700 * i | i <- [0..255] ]
+bYTab = V.fromListN 256 [fix 0.11400 * i + oneHalf | i <- [0..255] ]
+rCbTab = V.fromListN 256 [(- fix 0.16874) * i | i <- [0..255] ]
+gCbTab = V.fromListN 256 [(- fix 0.33126) * i | i <- [0..255] ]
+bCbTab = V.fromListN 256 [fix 0.5 * i + (128 `unsafeShiftL` scaleBits) + oneHalf - 1| i <- [0..255] ]
+gCrTab = V.fromListN 256 [(- fix 0.41869) * i | i <- [0..255] ]
+bCrTab = V.fromListN 256 [(- fix 0.08131) * i | i <- [0..255] ]
+
+
+instance ColorSpaceConvertible PixelRGB8 PixelYCbCr8 where
+    {-# INLINE convertPixel #-}
+    convertPixel (PixelRGB8 r g b) = PixelYCbCr8 (fromIntegral y) (fromIntegral cb) (fromIntegral cr)
+      where ri = fromIntegral r
+            gi = fromIntegral g
+            bi = fromIntegral b
+
+            y  = (rYTab `V.unsafeIndex` ri + gYTab `V.unsafeIndex` gi + bYTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits
+            cb = (rCbTab `V.unsafeIndex` ri + gCbTab `V.unsafeIndex` gi + bCbTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits
+            cr = (bCbTab `V.unsafeIndex` ri + gCrTab `V.unsafeIndex` gi + bCrTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits
+
+    convertImage Image { imageWidth = w, imageHeight = h, imageData = d } = Image w h newData
+        where maxi = w * h
+
+              rY  = fix 0.29900
+              gY  = fix 0.58700
+              bY  = fix 0.11400
+              rCb = - fix 0.16874
+              gCb = - fix 0.33126
+              bCb = fix 0.5
+              gCr = - fix 0.41869
+              bCr = - fix 0.08131
+
+              newData = runST $ do
+                block <- M.new $ maxi * 3
+                let traductor _ idx | idx >= maxi = return block
+                    traductor readIdx idx = do
+                        let ri = fromIntegral $ d `V.unsafeIndex` readIdx
+                            gi = fromIntegral $ d `V.unsafeIndex` (readIdx + 1)
+                            bi = fromIntegral $ d `V.unsafeIndex` (readIdx + 2)
+
+                            y  = (rY * ri + gY * gi + bY * bi + oneHalf) `unsafeShiftR` scaleBits
+                            cb = (rCb * ri + gCb * gi + bCb * bi + (128 `unsafeShiftL` scaleBits) + oneHalf - 1) `unsafeShiftR` scaleBits
+                            cr = (bCb * ri + (128 `unsafeShiftL` scaleBits) + oneHalf - 1+ gCr * gi + bCr * bi) `unsafeShiftR` scaleBits
+
+                        (block `M.unsafeWrite` (readIdx + 0)) $ fromIntegral y
+                        (block `M.unsafeWrite` (readIdx + 1)) $ fromIntegral cb
+                        (block `M.unsafeWrite` (readIdx + 2)) $ fromIntegral cr
+                        traductor (readIdx + 3) (idx + 1)
+
+                traductor 0 0 >>= V.freeze
+
+crRTab, cbBTab, crGTab, cbGTab :: V.Vector Int
+crRTab = V.fromListN 256 [(fix 1.40200 * x + oneHalf) `unsafeShiftR` scaleBits | x <- [-128 .. 127]]
+cbBTab = V.fromListN 256 [(fix 1.77200 * x + oneHalf) `unsafeShiftR` scaleBits | x <- [-128 .. 127]]
+crGTab = V.fromListN 256 [negate (fix 0.71414) * x | x <- [-128 .. 127]]
+cbGTab = V.fromListN 256 [negate (fix 0.34414) * x + oneHalf | x <- [-128 .. 127]]
+
+instance ColorSpaceConvertible PixelYCbCr8 PixelRGB8 where
+    {-# INLINE convertPixel #-}
+    convertPixel (PixelYCbCr8 y cb cr) = PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b)
+        where clampWord8 = fromIntegral . max 0 . min 255
+              yi = fromIntegral y
+              cbi = fromIntegral cb
+              cri = fromIntegral cr
+
+              r = yi +  crRTab `V.unsafeIndex` cri
+              g = yi + (cbGTab `V.unsafeIndex` cbi + crGTab `V.unsafeIndex` cri) `unsafeShiftR` scaleBits
+              b = yi +  cbBTab `V.unsafeIndex` cbi
+
+    convertImage Image { imageWidth = w, imageHeight = h, imageData = d } = Image w h newData
+        where maxi = w * h
+              clampWord8 v | v < 0 = 0
+                           | v > 255 = 255
+                           | otherwise = fromIntegral v
+
+              newData = runST $ do
+                block <- M.new $ maxi * 3
+                let traductor _ idx | idx >= maxi = return block
+                    traductor readIdx idx = do
+                        let yi =  fromIntegral $ d `V.unsafeIndex` readIdx
+                            cbi = fromIntegral $ d `V.unsafeIndex` (readIdx + 1)
+                            cri = fromIntegral $ d `V.unsafeIndex` (readIdx + 2)
+
+                            r = yi +  crRTab `V.unsafeIndex` cri
+                            g = yi + (cbGTab `V.unsafeIndex` cbi + crGTab `V.unsafeIndex` cri) `unsafeShiftR` scaleBits
+                            b = yi +  cbBTab `V.unsafeIndex` cbi
+
+                        (block `M.unsafeWrite` (readIdx + 0)) $ clampWord8 r
+                        (block `M.unsafeWrite` (readIdx + 1)) $ clampWord8 g
+                        (block `M.unsafeWrite` (readIdx + 2)) $ clampWord8 b
+                        traductor (readIdx + 3) (idx + 1)
+
+                traductor 0 0 >>= V.freeze
+
+instance ColorPlane PixelYCbCr8 PlaneLuma where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelYCbCr8 PlaneCb where
+    toComponentIndex _ _ = 1
+
+instance ColorPlane PixelYCbCr8 PlaneCr where
+    toComponentIndex _ _ = 2
+
+--------------------------------------------------
+----            PixelCMYK8 instances
+--------------------------------------------------
+instance Pixel PixelCMYK8 where
+    type PixelBaseComponent PixelCMYK8 = Word8
+
+    {-# INLINE pixelOpacity #-}
+    pixelOpacity = const maxBound
+
+    {-# INLINE mixWith #-}
+    mixWith f (PixelCMYK8 ca ma ya ka) (PixelCMYK8 cb mb yb kb) =
+        PixelCMYK8 (f 0 ca cb) (f 1 ma mb) (f 2 ya yb) (f 3 ka kb)
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelCMYK8 c m y k) = PixelCMYK8 (f c) (f m) (f y) (f k)
+
+    {-# INLINE componentCount #-}
+    componentCount _ = 4
+
+    {-# INLINE pixelAt #-}
+    pixelAt image@(Image { imageData = arr }) x y = PixelCMYK8 (arr ! (baseIdx + 0))
+                                                               (arr ! (baseIdx + 1))
+                                                               (arr ! (baseIdx + 2))
+                                                               (arr ! (baseIdx + 3))
+        where baseIdx = pixelBaseIndex image x y
+
+    {-# INLINE readPixel #-}
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        rv <- arr `M.read` baseIdx
+        gv <- arr `M.read` (baseIdx + 1)
+        bv <- arr `M.read` (baseIdx + 2)
+        av <- arr `M.read` (baseIdx + 3)
+        return $ PixelCMYK8 rv gv bv av
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    {-# INLINE writePixel #-}
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelCMYK8 rv gv bv av) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr `M.write` (baseIdx + 0)) rv
+        (arr `M.write` (baseIdx + 1)) gv
+        (arr `M.write` (baseIdx + 2)) bv
+        (arr `M.write` (baseIdx + 3)) av
+
+    {-# INLINE unsafePixelAt #-}
+    unsafePixelAt v idx =
+        PixelCMYK8 (V.unsafeIndex v idx)
+                   (V.unsafeIndex v $ idx + 1)
+                   (V.unsafeIndex v $ idx + 2)
+                   (V.unsafeIndex v $ idx + 3)
+
+    {-# INLINE unsafeReadPixel #-}
+    unsafeReadPixel vec idx =
+        PixelCMYK8 `liftM` M.unsafeRead vec idx
+                   `ap` M.unsafeRead vec (idx + 1)
+                   `ap` M.unsafeRead vec (idx + 2)
+                   `ap` M.unsafeRead vec (idx + 3)
+
+    {-# INLINE unsafeWritePixel #-}
+    unsafeWritePixel v idx (PixelCMYK8 r g b a) =
+        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g
+                              >> M.unsafeWrite v (idx + 2) b
+                              >> M.unsafeWrite v (idx + 3) a
+
+instance ColorSpaceConvertible PixelCMYK8 PixelRGB8 where
+  convertPixel (PixelCMYK8 c m y k) =
+      PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b)
+    where
+      clampWord8 = fromIntegral . max 0 . min 255 . (`div` 255)
+      ik :: Int
+      ik = 255 - fromIntegral k
+
+      r = (255 - fromIntegral c) * ik
+      g = (255 - fromIntegral m) * ik
+      b = (255 - fromIntegral y) * ik
+
+--------------------------------------------------
+----            PixelYCbCrK8 instances
+--------------------------------------------------
+instance Pixel PixelYCbCrK8 where
+    type PixelBaseComponent PixelYCbCrK8 = Word8
+
+    {-# INLINE pixelOpacity #-}
+    pixelOpacity = const maxBound
+
+    {-# INLINE mixWith #-}
+    mixWith f (PixelYCbCrK8 ya cba cra ka) (PixelYCbCrK8 yb cbb crb kb) =
+        PixelYCbCrK8 (f 0 ya yb) (f 1 cba cbb) (f 2 cra crb) (f 3 ka kb)
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelYCbCrK8 y cb cr k) = PixelYCbCrK8 (f y) (f cb) (f cr) (f k)
+
+    {-# INLINE componentCount #-}
+    componentCount _ = 4
+
+    {-# INLINE pixelAt #-}
+    pixelAt image@(Image { imageData = arr }) x y =
+        PixelYCbCrK8 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1))
+                     (arr ! (baseIdx + 2)) (arr ! (baseIdx + 3))
+        where baseIdx = pixelBaseIndex image x y
+
+    {-# INLINE readPixel #-}
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        yv <- arr `M.read` baseIdx
+        cbv <- arr `M.read` (baseIdx + 1)
+        crv <- arr `M.read` (baseIdx + 2)
+        kv <- arr `M.read` (baseIdx + 3)
+        return $ PixelYCbCrK8 yv cbv crv kv
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    {-# INLINE writePixel #-}
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCrK8 yv cbv crv kv) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr `M.write` (baseIdx + 0)) yv
+        (arr `M.write` (baseIdx + 1)) cbv
+        (arr `M.write` (baseIdx + 2)) crv
+        (arr `M.write` (baseIdx + 3)) kv
+
+    {-# INLINE unsafePixelAt #-}
+    unsafePixelAt v idx =
+        PixelYCbCrK8 (V.unsafeIndex v idx)
+                     (V.unsafeIndex v $ idx + 1)
+                     (V.unsafeIndex v $ idx + 2)
+                     (V.unsafeIndex v $ idx + 3)
+
+    {-# INLINE unsafeReadPixel #-}
+    unsafeReadPixel vec idx =
+      PixelYCbCrK8 `liftM` M.unsafeRead vec idx
+                   `ap` M.unsafeRead vec (idx + 1)
+                   `ap` M.unsafeRead vec (idx + 2)
+                   `ap` M.unsafeRead vec (idx + 3)
+
+    {-# INLINE unsafeWritePixel #-}
+    unsafeWritePixel v idx (PixelYCbCrK8 y cb cr k) =
+        M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) cb
+                              >> M.unsafeWrite v (idx + 2) cr
+                              >> M.unsafeWrite v (idx + 3) k
+
+instance ColorSpaceConvertible PixelYCbCrK8 PixelRGB8 where
+  convertPixel (PixelYCbCrK8 y cb cr _k) = PixelRGB8 (clamp r) (clamp g) (clamp b)
+    where
+      tof :: Word8 -> Float
+      tof = fromIntegral
+
+      clamp :: Float -> Word8
+      clamp = floor . max 0 . min 255
+
+      yf = tof y
+
+      r = yf + 1.402 * tof cr - 179.456
+      g = yf - 0.3441363 * tof cb - 0.71413636 * tof cr + 135.4589
+      b = yf + 1.772 * tof cb - 226.816
+
+instance ColorSpaceConvertible PixelYCbCrK8 PixelCMYK8 where
+  convertPixel (PixelYCbCrK8 y cb cr k) = PixelCMYK8 c m ye k
+    where
+      tof :: Word8 -> Float
+      tof = fromIntegral
+
+      clamp :: Float -> Word8
+      clamp = floor . max 0 . min 255
+
+      yf = tof y
+
+      r = yf + 1.402 * tof cr - 179.456
+      g = yf - 0.3441363 * tof cb - 0.71413636 * tof cr + 135.4589
+      b = yf + 1.772 * tof cb - 226.816
+
+      c = clamp $ 255 - r
+      m = clamp $ 255 - g
+      ye = clamp $ 255 - b
+
+{-# SPECIALIZE integralRGBToCMYK :: (Word8 -> Word8 -> Word8 -> Word8 -> b)
+                                 -> (Word8, Word8, Word8) -> b #-}
+{-# SPECIALIZE integralRGBToCMYK :: (Word16 -> Word16 -> Word16 -> Word16 -> b)
+                                 -> (Word16, Word16, Word16) -> b #-}
+-- | Convert RGB8 or RGB16 to CMYK8 and CMYK16 respectfully.
+--
+-- /Note/ - 32bit precision is not supported. Make sure to adjust implementation if ever
+-- used with Word32.
+integralRGBToCMYK :: (Bounded a, Integral a)
+                  => (a -> a -> a -> a -> b)    -- ^ Pixel building function
+                  -> (a, a, a)                  -- ^ RGB sample
+                  -> b                          -- ^ Resulting sample
+integralRGBToCMYK build (r, g, b)
+  | kMax == 0 = build 0 0 0 maxVal -- prevent division by zero
+  | otherwise = build (fromIntegral c) (fromIntegral m) (fromIntegral y) k
+    where maxVal = maxBound
+          max32 = fromIntegral maxVal :: Word32
+          kMax32 = fromIntegral kMax :: Word32
+          kMax = max r (max g b)
+          k = maxVal - kMax
+          c = max32 * (kMax32 - fromIntegral r) `div` kMax32
+          m = max32 * (kMax32 - fromIntegral g) `div` kMax32
+          y = max32 * (kMax32 - fromIntegral b) `div` kMax32
+
+instance ColorSpaceConvertible PixelRGB8 PixelCMYK8 where
+  convertPixel (PixelRGB8 r g b) = integralRGBToCMYK PixelCMYK8 (r, g, b)
+
+instance ColorPlane PixelCMYK8 PlaneCyan where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelCMYK8 PlaneMagenta where
+    toComponentIndex _ _ = 1
+
+instance ColorPlane PixelCMYK8 PlaneYellow where
+    toComponentIndex _ _ = 2
+
+instance ColorPlane PixelCMYK8 PlaneBlack where
+    toComponentIndex _ _ = 3
+
+--------------------------------------------------
+----            PixelCMYK16 instances
+--------------------------------------------------
+instance Pixel PixelCMYK16 where
+    type PixelBaseComponent PixelCMYK16 = Word16
+
+    {-# INLINE pixelOpacity #-}
+    pixelOpacity = const maxBound
+
+    {-# INLINE mixWith #-}
+    mixWith f (PixelCMYK16 ca ma ya ka) (PixelCMYK16 cb mb yb kb) =
+        PixelCMYK16 (f 0 ca cb) (f 1 ma mb) (f 2 ya yb) (f 3 ka kb)
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelCMYK16 c m y k) = PixelCMYK16 (f c) (f m) (f y) (f k)
+
+    {-# INLINE componentCount #-}
+    componentCount _ = 4
+
+    {-# INLINE pixelAt #-}
+    pixelAt image@(Image { imageData = arr }) x y = PixelCMYK16 (arr ! (baseIdx + 0))
+                                                               (arr ! (baseIdx + 1))
+                                                               (arr ! (baseIdx + 2))
+                                                               (arr ! (baseIdx + 3))
+        where baseIdx = pixelBaseIndex image x y
+
+    {-# INLINE readPixel #-}
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        rv <- arr `M.read` baseIdx
+        gv <- arr `M.read` (baseIdx + 1)
+        bv <- arr `M.read` (baseIdx + 2)
+        av <- arr `M.read` (baseIdx + 3)
+        return $ PixelCMYK16 rv gv bv av
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    {-# INLINE writePixel #-}
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelCMYK16 rv gv bv av) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr `M.write` (baseIdx + 0)) rv
+        (arr `M.write` (baseIdx + 1)) gv
+        (arr `M.write` (baseIdx + 2)) bv
+        (arr `M.write` (baseIdx + 3)) av
+
+    {-# INLINE unsafePixelAt #-}
+    unsafePixelAt v idx =
+        PixelCMYK16 (V.unsafeIndex v idx)
+                   (V.unsafeIndex v $ idx + 1)
+                   (V.unsafeIndex v $ idx + 2)
+                   (V.unsafeIndex v $ idx + 3)
+
+    {-# INLINE unsafeReadPixel #-}
+    unsafeReadPixel vec idx =
+        PixelCMYK16 `liftM` M.unsafeRead vec idx
+                   `ap` M.unsafeRead vec (idx + 1)
+                   `ap` M.unsafeRead vec (idx + 2)
+                   `ap` M.unsafeRead vec (idx + 3)
+    {-# INLINE unsafeWritePixel #-}
+    unsafeWritePixel v idx (PixelCMYK16 r g b a) =
+        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g
+                              >> M.unsafeWrite v (idx + 2) b
+                              >> M.unsafeWrite v (idx + 3) a
+
+instance ColorSpaceConvertible PixelCMYK16 PixelRGB16 where
+  convertPixel (PixelCMYK16 c m y k) =
+      PixelRGB16 (clampWord16 r) (clampWord16 g) (clampWord16 b)
+    where
+          clampWord16 = fromIntegral . (`unsafeShiftR` 16)
+          ik :: Int
+          ik = 65535 - fromIntegral k
+
+          r = (65535 - fromIntegral c) * ik
+          g = (65535 - fromIntegral m) * ik
+          b = (65535 - fromIntegral y) * ik
+
+instance ColorPlane PixelCMYK16 PlaneCyan where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelCMYK16 PlaneMagenta where
+    toComponentIndex _ _ = 1
+
+instance ColorPlane PixelCMYK16 PlaneYellow where
+    toComponentIndex _ _ = 2
+
+instance ColorPlane PixelCMYK16 PlaneBlack where
+    toComponentIndex _ _ = 3
+
+-- | Perform a gamma correction for an image with HDR pixels.
+gammaCorrection :: PixelF          -- ^ Gamma value, should be between 0.5 and 3.0
+                -> Image PixelRGBF -- ^ Image to treat.
+                -> Image PixelRGBF
+gammaCorrection gammaVal = pixelMap gammaCorrector
+  where gammaExponent = 1.0 / gammaVal
+        fixVal v = v ** gammaExponent
+        gammaCorrector (PixelRGBF r g b) =
+            PixelRGBF (fixVal r) (fixVal g) (fixVal b)
+
+-- | Perform a tone mapping operation on an High dynamic range image.
+toneMapping :: PixelF          -- ^ Exposure parameter
+            -> Image PixelRGBF -- ^ Image to treat.
+            -> Image PixelRGBF
+toneMapping exposure img = Image (imageWidth img) (imageHeight img) scaledData
+ where coeff = exposure * (exposure / maxBrightness + 1.0) / (exposure + 1.0);
+       maxBrightness = pixelFold (\luma _ _ px -> max luma $ computeLuma px) 0 img
+       scaledData = V.map (* coeff) $ imageData img
+
+--------------------------------------------------
+----            Packable pixel
+--------------------------------------------------
+
+-- | This typeclass exist for performance reason, it allow
+-- to pack a pixel value to a simpler "primitive" data
+-- type to allow faster writing to moemory.
+class PackeablePixel a where
+    -- | Primitive type asociated to the current pixel
+    -- It's Word32 for PixelRGBA8 for instance
+    type PackedRepresentation a
+
+    -- | The packing function, allowing to transform
+    -- to a primitive.
+    packPixel :: a -> PackedRepresentation a
+
+    -- | Inverse transformation, to speed up
+    -- reading
+    unpackPixel :: PackedRepresentation a -> a
+
+instance PackeablePixel Pixel8 where
+    type PackedRepresentation Pixel8 = Pixel8
+    packPixel = id
+    {-# INLINE packPixel #-}
+    unpackPixel = id
+    {-# INLINE unpackPixel #-}
+
+instance PackeablePixel Pixel16 where
+    type PackedRepresentation Pixel16 = Pixel16
+    packPixel = id
+    {-# INLINE packPixel #-}
+    unpackPixel = id
+    {-# INLINE unpackPixel #-}
+
+instance PackeablePixel Pixel32 where
+    type PackedRepresentation Pixel32 = Pixel32
+    packPixel = id
+    {-# INLINE packPixel #-}
+    unpackPixel = id
+    {-# INLINE unpackPixel #-}
+
+instance PackeablePixel PixelF where
+    type PackedRepresentation PixelF = PixelF
+    packPixel = id
+    {-# INLINE packPixel #-}
+    unpackPixel = id
+    {-# INLINE unpackPixel #-}
+
+
+instance PackeablePixel PixelRGBA8 where
+    type PackedRepresentation PixelRGBA8 = Word32
+    {-# INLINE packPixel #-}
+    packPixel (PixelRGBA8 r g b a) =
+        (fi r `unsafeShiftL` (0 * bitCount)) .|.
+        (fi g `unsafeShiftL` (1 * bitCount)) .|.
+        (fi b `unsafeShiftL` (2 * bitCount)) .|.
+        (fi a `unsafeShiftL` (3 * bitCount))
+      where fi = fromIntegral
+            bitCount = 8
+
+    {-# INLINE unpackPixel #-}
+    unpackPixel w =
+        PixelRGBA8 (low w)
+                   (low $ w `unsafeShiftR` bitCount)
+                   (low $ w `unsafeShiftR` (2 * bitCount))
+                   (low $ w `unsafeShiftR` (3 * bitCount))
+      where
+        low v = fromIntegral (v .&. 0xFF)
+        bitCount = 8
+
+instance PackeablePixel PixelRGBA16 where
+    type PackedRepresentation PixelRGBA16 = Word64
+    {-# INLINE packPixel #-}
+    packPixel (PixelRGBA16 r g b a) =
+        (fi r `unsafeShiftL` (0 * bitCount)) .|.
+        (fi g `unsafeShiftL` (1 * bitCount)) .|.
+        (fi b `unsafeShiftL` (2 * bitCount)) .|.
+        (fi a `unsafeShiftL` (3 * bitCount))
+      where fi = fromIntegral
+            bitCount = 16
+
+    {-# INLINE unpackPixel #-}
+    unpackPixel w =
+        PixelRGBA16 (low w)
+                    (low $ w `unsafeShiftR` bitCount)
+                    (low $ w `unsafeShiftR` (2 * bitCount))
+                    (low $ w `unsafeShiftR` (3 * bitCount))
+      where
+        low v = fromIntegral (v .&. 0xFFFF)
+        bitCount = 16
+
+instance PackeablePixel PixelCMYK8 where
+    type PackedRepresentation PixelCMYK8 = Word32
+    {-# INLINE packPixel #-}
+    packPixel (PixelCMYK8 c m y k) =
+        (fi c `unsafeShiftL` (0 * bitCount)) .|.
+        (fi m `unsafeShiftL` (1 * bitCount)) .|.
+        (fi y `unsafeShiftL` (2 * bitCount)) .|.
+        (fi k `unsafeShiftL` (3 * bitCount))
+      where fi = fromIntegral
+            bitCount = 8
+
+    {-# INLINE unpackPixel #-}
+    unpackPixel w =
+        PixelCMYK8 (low w)
+                   (low $ w `unsafeShiftR` bitCount)
+                   (low $ w `unsafeShiftR` (2 * bitCount))
+                   (low $ w `unsafeShiftR` (3 * bitCount))
+      where
+        low v = fromIntegral (v .&. 0xFF)
+        bitCount = 8
+
+instance PackeablePixel PixelCMYK16 where
+    type PackedRepresentation PixelCMYK16 = Word64
+    {-# INLINE packPixel #-}
+    packPixel (PixelCMYK16 c m y k) =
+        (fi c `unsafeShiftL` (0 * bitCount)) .|.
+        (fi m `unsafeShiftL` (1 * bitCount)) .|.
+        (fi y `unsafeShiftL` (2 * bitCount)) .|.
+        (fi k `unsafeShiftL` (3 * bitCount))
+      where fi = fromIntegral
+            bitCount = 16
+
+    {-# INLINE unpackPixel #-}
+    unpackPixel w =
+        PixelCMYK16 (low w)
+                    (low $ w `unsafeShiftR` bitCount)
+                    (low $ w `unsafeShiftR` (2 * bitCount))
+                    (low $ w `unsafeShiftR` (3 * bitCount))
+      where
+        low v = fromIntegral (v .&. 0xFFFF)
+        bitCount = 16
+
+instance PackeablePixel PixelYA16 where
+    type PackedRepresentation PixelYA16 = Word32
+    {-# INLINE packPixel #-}
+    packPixel (PixelYA16 y a) =
+        (fi y `unsafeShiftL` (0 * bitCount)) .|.
+        (fi a `unsafeShiftL` (1 * bitCount))
+      where fi = fromIntegral
+            bitCount = 16
+
+    {-# INLINE unpackPixel #-}
+    unpackPixel w = PixelYA16 (low w) (low $ w `unsafeShiftR` bitCount)
+      where
+        low v = fromIntegral (v .&. 0xFFFF)
+        bitCount = 16
+
+instance PackeablePixel PixelYA8 where
+    type PackedRepresentation PixelYA8 = Word16
+    {-# INLINE packPixel #-}
+    packPixel (PixelYA8 y a) =
+        (fi y `unsafeShiftL` (0 * bitCount)) .|.
+        (fi a `unsafeShiftL` (1 * bitCount))
+      where fi = fromIntegral
+            bitCount = 8
+
+    {-# INLINE unpackPixel #-}
+    unpackPixel w = PixelYA8 (low w) (low $ w `unsafeShiftR` bitCount)
+      where
+        low v = fromIntegral (v .&. 0xFF)
+        bitCount = 8
+
+-- | This function will fill an image with a simple packeable
+-- pixel. It will be faster than any unsafeWritePixel.
+fillImageWith :: ( Pixel px, PackeablePixel px
+                 , PrimMonad m
+                 , M.Storable (PackedRepresentation px))
+              => MutableImage (PrimState m) px -> px -> m ()
+fillImageWith img px = M.set converted $ packPixel px
+  where
+    (ptr, s, s2) = M.unsafeToForeignPtr $ mutableImageData img
+    !packedPtr = castForeignPtr ptr
+    !converted =
+        M.unsafeFromForeignPtr packedPtr s (s2 `div` componentCount px)
+
+-- | Fill a packeable pixel between two bounds.
+unsafeWritePixelBetweenAt
+    :: ( PrimMonad m
+       , Pixel px, PackeablePixel px
+       , M.Storable (PackedRepresentation px))
+    => MutableImage (PrimState m) px -- ^ Image to write into
+    -> px                -- ^ Pixel to write
+    -> Int               -- ^ Start index in pixel base component
+    -> Int               -- ^ pixel count of pixel to write
+    -> m ()
+unsafeWritePixelBetweenAt img px start count = M.set converted packed
+  where
+    !packed = packPixel px
+    !pixelData = mutableImageData img
+
+    !toSet = M.slice start count pixelData
+    (ptr, s, s2) = M.unsafeToForeignPtr toSet
+    !packedPtr = castForeignPtr ptr
+    !converted =
+        M.unsafeFromForeignPtr packedPtr s s2
+
+-- | Read a packeable pixel from an image. Equivalent to
+-- unsafeReadPixel
+readPackedPixelAt :: forall m px.
+                     ( Pixel px, PackeablePixel px
+                     , M.Storable (PackedRepresentation px)
+                     , PrimMonad m
+                     )
+                  => MutableImage (PrimState m) px -- ^ Image to read from
+                  -> Int  -- ^ Index in (PixelBaseComponent px) count
+                  -> m px
+{-# INLINE readPackedPixelAt #-}
+readPackedPixelAt img idx = do
+    unpacked <- M.unsafeRead converted (idx `div` compCount)
+    return $ unpackPixel unpacked
+    where
+    !compCount = componentCount (undefined :: px)
+    (ptr, s, s2) = M.unsafeToForeignPtr $ mutableImageData img
+    !packedPtr = castForeignPtr ptr
+    !converted =
+        M.unsafeFromForeignPtr packedPtr s s2
+
+
+-- | Write a packeable pixel into an image. equivalent to unsafeWritePixel.
+writePackedPixelAt :: ( Pixel px, PackeablePixel px
+                      , M.Storable (PackedRepresentation px)
+                      , PrimMonad m
+                      )
+                   => MutableImage (PrimState m) px -- ^ Image to write into
+                   -> Int  -- ^ Index in (PixelBaseComponent px) count
+                   -> px   -- ^ Pixel to write
+                   -> m ()
+{-# INLINE writePackedPixelAt #-}
+writePackedPixelAt img idx px =
+    M.unsafeWrite converted (idx `div` compCount) packed
+  where
+    !packed = packPixel px
+    !compCount = componentCount px
+
+    (ptr, s, s2) = M.unsafeToForeignPtr $ mutableImageData img
+    !packedPtr = castForeignPtr ptr
+    !converted =
+        M.unsafeFromForeignPtr packedPtr s s2
+
+{-# ANN module "HLint: ignore Reduce duplication" #-}
+
+ src/Codec/Picture/VectorByteConversion.hs view
@@ -0,0 +1,52 @@+{-# 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
+
+mkBS :: ForeignPtr Word8 -> Int -> Int -> S.ByteString
+#if MIN_VERSION_bytestring(0,11,0)
+mkBS fptr off = S.BS (fptr `S.plusForeignPtr` off)
+#else
+mkBS = S.PS
+#endif
+
+blitVector :: Vector Word8 -> Int -> Int -> B.ByteString
+blitVector vec atIndex = mkBS ptr (offset + atIndex)
+  where (ptr, offset, _length) = unsafeToForeignPtr vec
+
+toByteString :: forall a. (Storable a) => Vector a -> B.ByteString
+toByteString vec = mkBS (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
+