JuicyPixels 3.3.2 → 3.3.3

raw patch · 39 files changed

+4717/−4172 lines, 39 filesdep ~basedep ~primitivePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, primitive

API changes (from Hackage documentation)

Files

• JuicyPixels.cabal +18/−18
• README.md +6/−4
• changelog +8/−0
• src/Codec/Picture.hs +2/−0
• src/Codec/Picture/Bitmap.hs +641/−148
• src/Codec/Picture/Gif.hs +2/−2
• src/Codec/Picture/Gif/Internal/LZW.hs +194/−0
• src/Codec/Picture/Gif/Internal/LZWEncoding.hs +101/−0
• src/Codec/Picture/Gif/LZW.hs +0/−194
• src/Codec/Picture/Gif/LZWEncoding.hs +0/−101
• src/Codec/Picture/Jpg.hs +8/−8
• src/Codec/Picture/Jpg/Common.hs +0/−240
• src/Codec/Picture/Jpg/DefaultTable.hs +0/−294
• src/Codec/Picture/Jpg/FastDct.hs +0/−218
• src/Codec/Picture/Jpg/FastIdct.hs +0/−229
• src/Codec/Picture/Jpg/Internal/Common.hs +240/−0
• src/Codec/Picture/Jpg/Internal/DefaultTable.hs +294/−0
• src/Codec/Picture/Jpg/Internal/FastDct.hs +218/−0
• src/Codec/Picture/Jpg/Internal/FastIdct.hs +229/−0
• src/Codec/Picture/Jpg/Internal/Metadata.hs +41/−0
• src/Codec/Picture/Jpg/Internal/Progressive.hs +332/−0
• src/Codec/Picture/Jpg/Internal/Types.hs +753/−0
• src/Codec/Picture/Jpg/Metadata.hs +0/−41
• src/Codec/Picture/Jpg/Progressive.hs +0/−332
• src/Codec/Picture/Jpg/Types.hs +0/−753
• src/Codec/Picture/Metadata.hs +42/−3
• src/Codec/Picture/Png.hs +3/−3
• src/Codec/Picture/Png/Export.hs +0/−268
• src/Codec/Picture/Png/Internal/Export.hs +268/−0
• src/Codec/Picture/Png/Internal/Metadata.hs +136/−0
• src/Codec/Picture/Png/Internal/Type.hs +450/−0
• src/Codec/Picture/Png/Metadata.hs +0/−135
• src/Codec/Picture/Png/Type.hs +0/−450
• src/Codec/Picture/Saving.hs +1/−1
• src/Codec/Picture/Tiff.hs +3/−3
• src/Codec/Picture/Tiff/Internal/Metadata.hs +237/−0
• src/Codec/Picture/Tiff/Internal/Types.hs +490/−0
• src/Codec/Picture/Tiff/Metadata.hs +0/−237
• src/Codec/Picture/Tiff/Types.hs +0/−490

@@ -1,5 +1,5 @@ Name:                JuicyPixels
-Version:             3.3.2
+Version:             3.3.3
 Synopsis:            Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance)
 Description:
     <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>>
@@ -28,7 +28,7 @@ Source-Repository this
     Type:      git
     Location:  git://github.com/Twinside/Juicy.Pixels.git
-    Tag:       v3.3.2
+    Tag:       v3.3.3
 
 Flag Mmap
     Description: Enable the file loading via mmap (memory map)
@@ -49,7 +49,21 @@                     Codec.Picture.Metadata.Exif,
                     Codec.Picture.Saving,
                     Codec.Picture.Types,
-                    Codec.Picture.ColorQuant
+                    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.8     && < 6,
@@ -64,21 +78,7 @@                  containers          >= 0.4.2   && < 0.7
 
   -- Modules not exported by this package.
-  Other-modules: Codec.Picture.Jpg.DefaultTable,
-                 Codec.Picture.Jpg.Metadata,
-                 Codec.Picture.Jpg.FastIdct,
-                 Codec.Picture.Jpg.FastDct,
-                 Codec.Picture.Jpg.Types,
-                 Codec.Picture.Jpg.Common,
-                 Codec.Picture.Jpg.Progressive,
-                 Codec.Picture.Gif.LZW,
-                 Codec.Picture.Gif.LZWEncoding,
-                 Codec.Picture.Png.Export,
-                 Codec.Picture.Png.Type,
-                 Codec.Picture.Png.Metadata,
-                 Codec.Picture.Tiff.Metadata,
-                 Codec.Picture.Tiff.Types,
-                 Codec.Picture.BitWriter,
+  Other-modules: Codec.Picture.BitWriter,
                  Codec.Picture.InternalHelper,
                  Codec.Picture.VectorByteConversion
 

@@ -51,11 +51,13 @@         * in a gAMA field : 'Gamma'
         * DPI information in a pHYs chunk.
 
- - Bitmap (.bmp) (mainly used as a debug output format)
+ - Bitmap (.bmp)
     * Reading
-        - 32bits (RGBA) images
-        - 24bits (RGB) images
-        - 8bits (greyscale & paletted) images
+        - 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

@@ -1,6 +1,14 @@ Change log
 ==========
 
+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.2 October 2018
 -------------------
 

@@ -23,6 +23,8 @@                      , decodeImageWithMetadata
                      , decodeImageWithPaletteAndMetadata
                      , pixelMap
+                     , dynamicMap
+                     , dynamicPixelMap
                      , generateImage
                      , generateFoldImage
                      , withImage

@@ -25,7 +25,7 @@ #endif
 
 import Control.Arrow( first )
-import Control.Monad( replicateM, when, foldM_, forM_ )
+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
@@ -33,6 +33,7 @@ import Data.Binary( Binary( .. ) )
 import Data.Binary.Put( Put
                       , runPut
+                      , putInt32le
                       , putWord16le
                       , putWord32le
                       , putByteString 
@@ -42,14 +43,18 @@                       , getWord8
                       , getWord16le 
                       , getWord32le
-                      , getWord32be
+                      , 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
@@ -93,8 +98,43 @@             , 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)
 
-data BmpInfoHeader = BmpInfoHeader
+-- | 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
@@ -102,67 +142,224 @@     , bitPerPixel       :: !Word16
     , bitmapCompression :: !Word32
     , byteImageSize     :: !Word32
-    , xResolution       :: !Int32 -- ^ Pixels per meter
-    , yResolution       :: !Int32 -- ^ Pixels per meter
-    , colorCount        :: !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
 
-sizeofBmpHeader, sizeofBmpInfo  :: Word32
+-- | 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
-sizeofBmpInfo = 3 * 4 + 2 * 2 + 6 * 4
+sizeofBmpCoreHeader = 12
+sizeofBmpInfoHeader = 40
 
-instance Binary BmpInfoHeader where
+-- | 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
-        putWord32le . fromIntegral $ width hdr
-        putWord32le . fromIntegral $ height hdr
-        putWord16le $ planes hdr
-        putWord16le $ bitPerPixel hdr
-        putWord32le $ bitmapCompression hdr
-        putWord32le $ byteImageSize hdr
-        putWord32le . fromIntegral $ xResolution hdr
-        putWord32le . fromIntegral $ yResolution hdr
-        putWord32le $ colorCount hdr
-        putWord32le $ importantColours 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
-        readWidth <- fromIntegral <$> getWord32le
-        readHeight <- fromIntegral <$> getWord32le
-        readPlanes <- getWord16le
-        readBitPerPixel <- getWord16le
-        readBitmapCompression <- getWord32le
-        readByteImageSize <- getWord32le
-        readXResolution <- fromIntegral <$> getWord32le
-        readYResolution <- fromIntegral <$> 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
-        }
+      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 []
 
@@ -175,6 +372,7 @@            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}) =
@@ -200,6 +398,7 @@                   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
@@ -228,6 +427,7 @@             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
@@ -255,8 +455,72 @@               inner 0 0 initialIndex
               VS.unsafeFreeze buff
 
-decodeImageRGBA8 :: BmpInfoHeader -> (Int, Int, Int, Int) -> B.ByteString -> Image PixelRGBA8
-decodeImageRGBA8 (BmpInfoHeader { width = w, height = h }) (posR, posG, posB, posA) str = Image wi hi stArray where
+-- | 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
+castByteString (BI.PS fp offset len) = VS.unsafeCast $ VS.unsafeFromForeignPtr fp offset len
+
+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
@@ -267,24 +531,38 @@         foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0]
       VS.unsafeFreeze arr
 
-  stride = linePadding 32 wi -- will be 0
+  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 = inner readIndex writeIndex where
-    lastIndex = wi * (hi - 1 - line + 1) * 4
-    writeIndex = wi * (hi - 1 - line) * 4
+  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 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + stride
-    inner readIdx writeIdx = do
-        -- 32-bit BMP pixels are BGRA
-        (arr `M.unsafeWrite`  writeIdx     ) (str `B.index` (readIdx + posR))
-        (arr `M.unsafeWrite` (writeIdx + 1)) (str `B.index` (readIdx + posG))
-        (arr `M.unsafeWrite` (writeIdx + 2)) (str `B.index` (readIdx + posB))
-        (arr `M.unsafeWrite` (writeIdx + 3)) (str `B.index` (readIdx + posA))
-        inner (readIdx + 4) (writeIdx + 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 :: BmpInfoHeader -> B.ByteString -> Image PixelRGB8
-decodeImageRGB8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray where
+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
@@ -295,22 +573,46 @@         foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0]
       VS.unsafeFreeze arr
 
-  stride = linePadding 24 wi
+  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 = inner readIndex writeIndex where
-    lastIndex = wi * (hi - 1 - line + 1) * 3
-    writeIndex = wi * (hi - 1 - line) * 3
+  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
 
-    inner readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + stride
-    inner 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)
-        inner (readIdx + 3) (writeIdx + 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)
 
-decodeImageY8 :: BmpInfoHeader -> B.ByteString -> Image Pixel8
-decodeImageY8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray where
+      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
@@ -321,33 +623,131 @@         foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0]
       VS.unsafeFreeze arr
 
-  stride = linePadding 8 wi
+  padding = linePadding (fromIntegral bpp) wi
   
   readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int
-  readLine arr readIndex line = inner readIndex writeIndex where
-    lastIndex = wi * (hi - 1 - line + 1)
-    writeIndex = wi * (hi - 1 - line)
+  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)
 
-    inner readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + stride
-    inner readIdx writeIdx = do
-      (arr `M.unsafeWrite` writeIdx) (str `B.index` readIdx)
-      inner (readIdx + 1) (writeIdx + 1)
+      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)
 
-pixelGet :: Get [Word8]
-pixelGet = do
+      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]
+    return [r, g, b]
 
-metadataOfHeader :: BmpInfoHeader -> Metadatas
-metadataOfHeader hdr = 
-  Met.simpleMetadata Met.SourceBitmap (width hdr) (abs $ height hdr) dpiX dpiY
+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 <> 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:
@@ -369,71 +769,130 @@ -- | Same as 'decodeBitmap' but also extracts metadata and provide separated palette.
 decodeBitmapWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)
 decodeBitmapWithPaletteAndMetadata str = flip runGetStrict str $ do
-  hdr      <- get :: Get BmpHeader
-  bmpHeader <- get :: Get BmpInfoHeader
+  fileHeader <- get :: Get BmpHeader
+  bmpHeader  <- get :: Get BmpV5Header
 
   readed <- bytesRead
-  when (readed > fromIntegral (dataOffset hdr))
+  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) ")
 
-  let bpp = fromIntegral $ bitPerPixel bmpHeader :: Int
-      paletteColorCount
-        | colorCount bmpHeader == 0 = 2 ^ bpp
-        | otherwise = fromIntegral $ colorCount bmpHeader
-      getData = do
-        readed' <- bytesRead
-        skip . fromIntegral $ dataOffset hdr - fromIntegral readed'
-        getRemainingBytes
-      addMetadata i = (i, metadataOfHeader bmpHeader)
+  decodeBitmapWithHeaders fileHeader bmpHeader
 
-  case (bitPerPixel bmpHeader, planes  bmpHeader,
-              bitmapCompression bmpHeader) of
-    (32, 1, 0) -> do
-      rest <- getData
-      return . addMetadata . TrueColorImage . ImageRGBA8 
-             $ decodeImageRGBA8 bmpHeader (2, 1, 0, 3) rest
-      -- (2, 1, 0, 3) means BGRA pixel order
-    (32, 1, 3) -> do
-      posRed   <- getBitfield
-      posGreen <- getBitfield
-      posBlue  <- getBitfield
-      posAlpha <- getBitfield
-      rest     <- getData
-      return . addMetadata . TrueColorImage . ImageRGBA8 $
-        decodeImageRGBA8 bmpHeader (posRed, posGreen, posBlue, posAlpha) rest
-    (24, 1, 0) -> do
-      rest <- getData
-      return . addMetadata . TrueColorImage . ImageRGB8  $ 
-        decodeImageRGB8  bmpHeader rest
-    ( 8, 1, 0) -> do
-      table <- replicateM paletteColorCount pixelGet
-      rest <- getData
-      let palette = Palette'
-            { _paletteSize = paletteColorCount
-            , _paletteData = VS.fromListN (paletteColorCount * 3) $ concat table
-            }
-      return . addMetadata $ PalettedRGB8 (decodeImageY8 bmpHeader rest) palette
+-- | 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
 
-    a          -> fail $ "Can't handle BMP file " ++ show a
+  where
+    bpp = fromIntegral $ bitPerPixel hdr :: Int
+    paletteColorCount
+      | colorCount hdr == 0 = 2 ^ bpp
+      | otherwise = fromIntegral $ colorCount hdr
 
+    addMetadata profile i = (i, metadataOfHeader hdr profile)
 
-getBitfield :: Get Int
-getBitfield = do
-  w32 <- getWord32be
-  case w32 of
-    0xFF000000 -> return 0
-    0x00FF0000 -> return 1
-    0x0000FF00 -> return 2
-    0x000000FF -> return 3
-    _          -> fail $
-      "Codec.Picture.Bitmap.getBitfield: unsupported bitfield of " ++ show w32
+    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.
+getBitfield :: (FiniteBits t, Integral t, Num t, Monad m) => t -> m (Bitfield t)
+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 ()
@@ -441,7 +900,7 @@ 
 linePadding :: Int -> Int -> Int
 linePadding bpp imgWidth = (4 - (bytesPerLine `mod` 4)) `mod` 4
-    where bytesPerLine = imgWidth * (fromIntegral bpp `div` 8)
+  where bytesPerLine = (bpp * imgWidth + 7) `div` 8
 
 -- | Encode an image into a bytestring in .bmp format ready to be written
 -- on disk.
@@ -482,8 +941,7 @@ 
 extractDpiOfMetadata :: Metadatas -> (Word32, Word32)
 extractDpiOfMetadata metas = (fetch Met.DpiX, fetch Met.DpiY) where
-  fetch k = fromMaybe 0
-          $ fromIntegral . Met.dotPerInchToDotsPerMeter <$> Met.lookup k metas
+  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)
@@ -501,34 +959,69 @@                                    -> 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)
-          padding = linePadding bpp imgWidth
-          imagePixelSize = fromIntegral $ (imgWidth * div bpp 8 + padding) * imgHeight
+
+          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 = sizeofBmpHeader + sizeofBmpInfo + 4 * paletteSize + imagePixelSize,
+              fileSize = sizeOfFile,
               reserved1 = 0,
               reserved2 = 0,
-              dataOffset = sizeofBmpHeader + sizeofBmpInfo + 4 * paletteSize
+              dataOffset = offsetToData
           }
 
-          info = BmpInfoHeader {
-              size = sizeofBmpInfo,
+          info = BmpV5Header {
+              size = headerSize,
               width = fromIntegral imgWidth,
               height = fromIntegral imgHeight,
               planes = 1,
               bitPerPixel = fromIntegral bpp,
-              bitmapCompression = 0, -- no compression
+              bitmapCompression = if hasAlpha img then 3 else 0,
               byteImageSize = imagePixelSize,
               xResolution = fromIntegral dpiX,
               yResolution = fromIntegral dpiY,
-              colorCount = 0,
-              importantColours = paletteSize
+              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
           }
 
 

@@ -69,8 +69,8 @@ import Codec.Picture.Metadata( Metadatas
                              , SourceFormat( SourceGif )
                              , basicMetadata )
-import Codec.Picture.Gif.LZW
-import Codec.Picture.Gif.LZWEncoding
+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.

@@ -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
+

@@ -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

@@ -1,194 +0,0 @@-{-# LANGUAGE CPP #-}-module Codec.Picture.Gif.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-

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

@@ -52,14 +52,14 @@ import Codec.Picture.Metadata( Metadatas
                              , SourceFormat( SourceJpeg )
                              , basicMetadata )
-import Codec.Picture.Tiff.Types
-import Codec.Picture.Tiff.Metadata
-import Codec.Picture.Jpg.Types
-import Codec.Picture.Jpg.Common
-import Codec.Picture.Jpg.Progressive
-import Codec.Picture.Jpg.DefaultTable
-import Codec.Picture.Jpg.FastDct
-import Codec.Picture.Jpg.Metadata
+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)

@@ -1,240 +0,0 @@-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE CPP #-}
-module Codec.Picture.Jpg.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.Types
-import Codec.Picture.Jpg.FastIdct
-import Codec.Picture.Jpg.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
-

@@ -1,294 +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
-                                     , HuffmanPackedTree
-                                     , MacroBlock
-                                     , QuantificationTable
-                                     , HuffmanWriterCode 
-                                     , scaleQuantisationMatrix
-                                     , makeMacroBlock
-                                     , makeInverseTable
-                                     , buildHuffmanTree
-                                     , packHuffmanTree
-                                     , huffmanPackedDecode
-
-                                     , defaultChromaQuantizationTable
-
-                                     , defaultLumaQuantizationTable
-
-                                     , defaultAcChromaHuffmanTree
-                                     , defaultAcChromaHuffmanTable
-
-                                     , defaultAcLumaHuffmanTree 
-                                     , defaultAcLumaHuffmanTable 
-
-                                     , defaultDcChromaHuffmanTree 
-                                     , defaultDcChromaHuffmanTable
-
-                                     , defaultDcLumaHuffmanTree
-                                     , defaultDcLumaHuffmanTable
-                                     ) where
-
-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 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)
-
--- | 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
-      ]
-    ]
-

@@ -1,218 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-module Codec.Picture.Jpg.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.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" #-}-

@@ -1,229 +0,0 @@-{-# 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.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.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
-

@@ -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
+

@@ -0,0 +1,294 @@+{-# 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 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 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)
+
+-- | 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
+      ]
+    ]
+

@@ -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" #-}
+

@@ -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
+

@@ -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
+    }
+

@@ -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
+

@@ -0,0 +1,753 @@+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE CPP #-}
+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( .. )
+                              , calculateSize
+                              , dctBlockSize
+                              ) where
+
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( pure, (<*>), (<$>) )
+#endif
+
+import Control.Monad( when, replicateM, forM, forM_, unless )
+import Control.Monad.ST( ST )
+import Data.Bits( (.|.), (.&.), unsafeShiftL, unsafeShiftR )
+import Data.List( partition )
+import Data.Monoid( (<>) )
+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 Data.Int( Int16 )
+import Data.Word(Word8, Word16 )
+import Data.Binary( Binary(..) )
+
+import Data.Binary.Get( Get
+                      , getWord8
+                      , getWord16be
+                      , getByteString
+                      , skip
+                      , bytesRead
+                      )
+
+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 Debug.Trace-}
+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)
+
+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
+    | JpgScans           !JpgFrameKind !JpgFrameHeader
+    | JpgIntervalRestart !Word16
+    deriving Show
+
+data JpgColorSpace
+  = JpgColorSpaceYCbCr
+  | JpgColorSpaceYCC
+  | JpgColorSpaceY
+  | JpgColorSpaceYA
+  | JpgColorSpaceYCCA
+  | JpgColorSpaceYCCK
+  | JpgColorSpaceCMYK
+  | JpgColorSpaceRGB
+  | JpgColorSpaceRGBA
+  deriving Show
+
+data AdobeTransform
+  = AdobeUnknown    -- ^ Value 0
+  | AdobeYCbCr      -- ^ value 1
+  | AdobeYCck       -- ^ value 2
+  deriving Show
+
+data JpgAdobeApp14 = JpgAdobeApp14
+  { _adobeDctVersion :: !Word16
+  , _adobeFlag0      :: !Word16
+  , _adobeFlag1      :: !Word16
+  , _adobeTransform  :: !AdobeTransform
+  }
+  deriving Show
+
+-- | Size: 1
+data JFifUnit
+  = JFifUnitUnknown   -- ^ 0
+  | JFifPixelsPerInch -- ^ 1
+  | JFifPixelsPerCentimeter -- ^ 2
+  deriving Show
+
+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 Show
+
+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 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
+
+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 Show
+
+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
+
+    get = do
+        let startOfImageMarker = 0xD8
+            -- endOfImageMarker = 0xD9
+        checkMarker commonMarkerFirstByte startOfImageMarker
+        eatUntilCode
+        frames <- parseFrames
+        {-checkMarker commonMarkerFirstByte endOfImageMarker-}
+        return JpgImage { jpgFrame = frames }
+
+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")
+
+extractScanContent :: L.ByteString -> (L.ByteString, L.ByteString)
+extractScanContent str = aux 0
+  where maxi = fromIntegral $ L.length str - 1
+
+        aux n | n >= maxi = (str, L.empty)
+              | v == 0xFF && vNext /= 0 && not isReset = L.splitAt n str
+              | otherwise = aux (n + 1)
+            where v = str `L.index` n
+                  vNext = str `L.index` (n + 1)
+                  isReset = 0xD0 <= vNext && vNext <= 0xD7
+
+parseAdobe14 :: B.ByteString -> [JpgFrame] -> [JpgFrame]
+parseAdobe14 str lst = go where
+  go = case runGetStrict get str of
+    Left _err -> lst
+    Right app14 -> JpgAdobeAPP14 app14 : lst
+
+-- | Parse JFIF or JFXX information. Right now only JFIF.
+parseJF__  :: B.ByteString -> [JpgFrame] -> [JpgFrame]
+parseJF__  str lst = go where
+  go = case runGetStrict get str of
+    Left _err -> lst
+    Right jfif -> JpgJFIF jfif : lst
+
+parseExif :: B.ByteString -> [JpgFrame] -> [JpgFrame]
+parseExif str lst 
+  | exifHeader `B.isPrefixOf` str = go
+  | otherwise = lst
+  where
+    exifHeader = BC.pack "Exif\0\0"
+    tiff = B.drop (B.length exifHeader) str
+    go = case runGetStrict (getP tiff) tiff of
+      Left _err -> lst
+      Right (_hdr :: TiffHeader, []) -> lst
+      Right (_hdr :: TiffHeader, ifds : _) -> JpgExif ifds : lst
+
+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
+
+parseFrames :: Get [JpgFrame]
+parseFrames = do
+    kind <- get
+    let parseNextFrame = do
+            word <- getWord8
+            when (word /= 0xFF) $ do
+                readedData <- bytesRead
+                fail $ "Invalid Frame marker (" ++ show word
+                     ++ ", bytes read : " ++ show readedData ++ ")"
+            parseFrames
+
+    case kind of
+        JpgEndOfImage -> return []
+        JpgAppSegment 0 ->
+            parseJF__ <$> takeCurrentFrame <*> parseNextFrame
+        JpgAppSegment 1 ->
+            parseExif <$> takeCurrentFrame <*> parseNextFrame
+        JpgAppSegment 14 ->
+            parseAdobe14 <$> takeCurrentFrame <*> parseNextFrame
+        JpgAppSegment c ->
+            (\frm lst -> JpgAppFrame c frm : lst) <$> takeCurrentFrame <*> parseNextFrame
+        JpgExtensionSegment c ->
+            (\frm lst -> JpgExtension c frm : lst) <$> takeCurrentFrame <*> parseNextFrame
+        JpgQuantizationTable ->
+            (\(TableList quants) lst -> JpgQuantTable quants : lst) <$> get <*> parseNextFrame
+        JpgRestartInterval ->
+            (\(RestartInterval i) lst -> JpgIntervalRestart i : lst) <$> get <*> parseNextFrame
+        JpgHuffmanTableMarker ->
+            (\(TableList huffTables) lst ->
+                    JpgHuffmanTable [(t, packHuffmanTree . buildPackedHuffmanTree $ huffCodes t) | t <- huffTables] : lst)
+                    <$> get <*> parseNextFrame
+        JpgStartOfScan ->
+            (\frm imgData ->
+                let (d, other) = extractScanContent imgData
+                in
+                case runGet parseFrames (L.drop 1 other) of
+                  Left _ -> [JpgScanBlob frm d]
+                  Right lst -> JpgScanBlob frm d : lst
+            ) <$> get <*> getRemainingLazyBytes
+
+        _ -> (\hdr lst -> JpgScans kind hdr : lst) <$> get <*> parseNextFrame
+
+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
+        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
+            0xD9 -> JpgEndOfImage
+            0xDA -> JpgStartOfScan
+            0xDB -> JpgQuantizationTable
+            0xDD -> JpgRestartInterval
+            a | a >= 0xF0 -> JpgExtensionSegment a
+              | a >= 0xE0 -> JpgAppSegment (a - 0xE0)
+              | a >= 0xD0 && a <= 0xD7 -> JpgRestartIntervalEnd a
+              | otherwise -> error ("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

@@ -1,41 +0,0 @@-{-# LANGUAGE CPP #-}-module Codec.Picture.Jpg.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.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-    }-

@@ -1,332 +0,0 @@-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE CPP #-}
-module Codec.Picture.Jpg.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.Common
-import Codec.Picture.Jpg.Types
-import Codec.Picture.Jpg.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
-

@@ -1,753 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE CPP #-}
-module Codec.Picture.Jpg.Types( MutableMacroBlock
-                              , createEmptyMutableMacroBlock
-                              , printMacroBlock
-                              , printPureMacroBlock
-                              , DcCoefficient
-                              , JpgImage( .. )
-                              , JpgComponent( .. )
-                              , JpgFrameHeader( .. )
-                              , JpgFrame( .. )
-                              , JpgFrameKind( .. )
-                              , JpgScanHeader( .. )
-                              , JpgQuantTableSpec( .. )
-                              , JpgHuffmanTableSpec( .. )
-                              , JpgImageKind( .. )
-                              , JpgScanSpecification( .. )
-                              , JpgColorSpace( .. )
-                              , AdobeTransform( .. )
-                              , JpgAdobeApp14( .. )
-                              , JpgJFIFApp0( .. )
-                              , JFifUnit( .. )
-                              , calculateSize
-                              , dctBlockSize
-                              ) where
-
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative( pure, (<*>), (<$>) )
-#endif
-
-import Control.Monad( when, replicateM, forM, forM_, unless )
-import Control.Monad.ST( ST )
-import Data.Bits( (.|.), (.&.), unsafeShiftL, unsafeShiftR )
-import Data.List( partition )
-import Data.Monoid( (<>) )
-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 Data.Int( Int16 )
-import Data.Word(Word8, Word16 )
-import Data.Binary( Binary(..) )
-
-import Data.Binary.Get( Get
-                      , getWord8
-                      , getWord16be
-                      , getByteString
-                      , skip
-                      , bytesRead
-                      )
-
-import Data.Binary.Put( Put
-                      , putWord8
-                      , putWord16be
-                      , putLazyByteString
-                      , putByteString
-                      , runPut
-                      )
-
-import Codec.Picture.InternalHelper
-import Codec.Picture.Jpg.DefaultTable
-import Codec.Picture.Tiff.Types
-import Codec.Picture.Tiff.Metadata( exifOffsetIfd )
-import Codec.Picture.Metadata.Exif
-
-{-import Debug.Trace-}
-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)
-
-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
-    | JpgScans           !JpgFrameKind !JpgFrameHeader
-    | JpgIntervalRestart !Word16
-    deriving Show
-
-data JpgColorSpace
-  = JpgColorSpaceYCbCr
-  | JpgColorSpaceYCC
-  | JpgColorSpaceY
-  | JpgColorSpaceYA
-  | JpgColorSpaceYCCA
-  | JpgColorSpaceYCCK
-  | JpgColorSpaceCMYK
-  | JpgColorSpaceRGB
-  | JpgColorSpaceRGBA
-  deriving Show
-
-data AdobeTransform
-  = AdobeUnknown    -- ^ Value 0
-  | AdobeYCbCr      -- ^ value 1
-  | AdobeYCck       -- ^ value 2
-  deriving Show
-
-data JpgAdobeApp14 = JpgAdobeApp14
-  { _adobeDctVersion :: !Word16
-  , _adobeFlag0      :: !Word16
-  , _adobeFlag1      :: !Word16
-  , _adobeTransform  :: !AdobeTransform
-  }
-  deriving Show
-
--- | Size: 1
-data JFifUnit
-  = JFifUnitUnknown   -- ^ 0
-  | JFifPixelsPerInch -- ^ 1
-  | JFifPixelsPerCentimeter -- ^ 2
-  deriving Show
-
-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 Show
-
-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 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
-
-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 Show
-
-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
-
-    get = do
-        let startOfImageMarker = 0xD8
-            -- endOfImageMarker = 0xD9
-        checkMarker commonMarkerFirstByte startOfImageMarker
-        eatUntilCode
-        frames <- parseFrames
-        {-checkMarker commonMarkerFirstByte endOfImageMarker-}
-        return JpgImage { jpgFrame = frames }
-
-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")
-
-extractScanContent :: L.ByteString -> (L.ByteString, L.ByteString)
-extractScanContent str = aux 0
-  where maxi = fromIntegral $ L.length str - 1
-
-        aux n | n >= maxi = (str, L.empty)
-              | v == 0xFF && vNext /= 0 && not isReset = L.splitAt n str
-              | otherwise = aux (n + 1)
-            where v = str `L.index` n
-                  vNext = str `L.index` (n + 1)
-                  isReset = 0xD0 <= vNext && vNext <= 0xD7
-
-parseAdobe14 :: B.ByteString -> [JpgFrame] -> [JpgFrame]
-parseAdobe14 str lst = go where
-  go = case runGetStrict get str of
-    Left _err -> lst
-    Right app14 -> JpgAdobeAPP14 app14 : lst
-
--- | Parse JFIF or JFXX information. Right now only JFIF.
-parseJF__  :: B.ByteString -> [JpgFrame] -> [JpgFrame]
-parseJF__  str lst = go where
-  go = case runGetStrict get str of
-    Left _err -> lst
-    Right jfif -> JpgJFIF jfif : lst
-
-parseExif :: B.ByteString -> [JpgFrame] -> [JpgFrame]
-parseExif str lst 
-  | exifHeader `B.isPrefixOf` str = go
-  | otherwise = lst
-  where
-    exifHeader = BC.pack "Exif\0\0"
-    tiff = B.drop (B.length exifHeader) str
-    go = case runGetStrict (getP tiff) tiff of
-      Left _err -> lst
-      Right (_hdr :: TiffHeader, []) -> lst
-      Right (_hdr :: TiffHeader, ifds : _) -> JpgExif ifds : lst
-
-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
-
-parseFrames :: Get [JpgFrame]
-parseFrames = do
-    kind <- get
-    let parseNextFrame = do
-            word <- getWord8
-            when (word /= 0xFF) $ do
-                readedData <- bytesRead
-                fail $ "Invalid Frame marker (" ++ show word
-                     ++ ", bytes read : " ++ show readedData ++ ")"
-            parseFrames
-
-    case kind of
-        JpgEndOfImage -> return []
-        JpgAppSegment 0 ->
-            parseJF__ <$> takeCurrentFrame <*> parseNextFrame
-        JpgAppSegment 1 ->
-            parseExif <$> takeCurrentFrame <*> parseNextFrame
-        JpgAppSegment 14 ->
-            parseAdobe14 <$> takeCurrentFrame <*> parseNextFrame
-        JpgAppSegment c ->
-            (\frm lst -> JpgAppFrame c frm : lst) <$> takeCurrentFrame <*> parseNextFrame
-        JpgExtensionSegment c ->
-            (\frm lst -> JpgExtension c frm : lst) <$> takeCurrentFrame <*> parseNextFrame
-        JpgQuantizationTable ->
-            (\(TableList quants) lst -> JpgQuantTable quants : lst) <$> get <*> parseNextFrame
-        JpgRestartInterval ->
-            (\(RestartInterval i) lst -> JpgIntervalRestart i : lst) <$> get <*> parseNextFrame
-        JpgHuffmanTableMarker ->
-            (\(TableList huffTables) lst ->
-                    JpgHuffmanTable [(t, packHuffmanTree . buildPackedHuffmanTree $ huffCodes t) | t <- huffTables] : lst)
-                    <$> get <*> parseNextFrame
-        JpgStartOfScan ->
-            (\frm imgData ->
-                let (d, other) = extractScanContent imgData
-                in
-                case runGet parseFrames (L.drop 1 other) of
-                  Left _ -> [JpgScanBlob frm d]
-                  Right lst -> JpgScanBlob frm d : lst
-            ) <$> get <*> getRemainingLazyBytes
-
-        _ -> (\hdr lst -> JpgScans kind hdr : lst) <$> get <*> parseNextFrame
-
-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
-        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
-            0xD9 -> JpgEndOfImage
-            0xDA -> JpgStartOfScan
-            0xDB -> JpgQuantizationTable
-            0xDD -> JpgRestartInterval
-            a | a >= 0xF0 -> JpgExtensionSegment a
-              | a >= 0xE0 -> JpgAppSegment (a - 0xE0)
-              | a >= 0xD0 && a <= 0xD7 -> JpgRestartIntervalEnd a
-              | otherwise -> error ("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

@@ -17,6 +17,7 @@                              , Value( .. )
                              , Elem( .. )
                              , SourceFormat( .. )
+                             , ColorSpace( .. )
 
                                -- * Functions
                              , Codec.Picture.Metadata.lookup
@@ -49,6 +50,7 @@ 
 
 import Control.DeepSeq( NFData( .. ) )
+import qualified Data.ByteString as B
 import qualified Data.Foldable as F
 
 import Codec.Picture.Metadata.Exif
@@ -61,7 +63,7 @@     Refl :: Equiv a a
 #endif
 
--- | Type describing the original file format of the ilfe.
+-- | Type describing the original file format of the file.
 data SourceFormat
   = SourceJpeg
   | SourceGif
@@ -75,6 +77,38 @@ 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.
 --
@@ -86,16 +120,20 @@ --          information can avoid the full decompression of the image.
 --          Ignored for image writing.
 --
---   * 'Height' Image height in pixels. Relyiung on the metadata for this
---          information can void the full decomrpession of the image.
+--   * '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
@@ -140,6 +178,7 @@ 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

@@ -52,9 +52,9 @@ 
 import Codec.Picture.Types
 import Codec.Picture.Metadata
-import Codec.Picture.Png.Type
-import Codec.Picture.Png.Export
-import Codec.Picture.Png.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.

@@ -1,268 +0,0 @@-{-# 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.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 )
-import Data.Monoid( (<>) )
-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.Type
-import Codec.Picture.Png.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 bes tored in the `gAMA` chunk.
-    --
-    --  * 'Codec.Picture.Metadata.Gamma'
-    --
-    -- The followings metadata will be stored in a `pHYs` chunk
-    --
-    --  * 'Codec.Picture.Metadata.DpiX'
-    --  * 'Codec.Picture.Metadata.DpiY' 
-    encodePngWithMetadata :: Metadatas -> Image a -> Lb.ByteString
-
-preparePngHeader :: Image a -> PngImageType -> Word8 -> PngIHdr
-preparePngHeader (Image { 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"

@@ -0,0 +1,268 @@+{-# 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 )
+import Data.Monoid( (<>) )
+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 bes tored in the `gAMA` chunk.
+    --
+    --  * 'Codec.Picture.Metadata.Gamma'
+    --
+    -- The followings metadata will be stored in a `pHYs` chunk
+    --
+    --  * 'Codec.Picture.Metadata.DpiX'
+    --  * 'Codec.Picture.Metadata.DpiY' 
+    encodePngWithMetadata :: Metadatas -> Image a -> Lb.ByteString
+
+preparePngHeader :: Image a -> PngImageType -> Word8 -> PngIHdr
+preparePngHeader (Image { 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"

@@ -0,0 +1,136 @@+{-# 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 )
+import Data.Binary.Put( putLazyByteString, putWord8 )
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.Monoid( (<>) )
+
+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
+
+textToMetadata :: PngText -> Metadatas
+textToMetadata ptext = case pngKeyword 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 $ pngData ptext)
+  where
+    strValue k = Met.singleton k . L.unpack $ pngData ptext
+
+getTexts :: [L.ByteString] -> Metadatas
+getTexts = foldMap (eitherFoldMap textToMetadata . runGet get) where
+ 
+
+extractMetadatas :: PngRawImage -> Metadatas
+extractMetadatas img = getDpis (chunksOf pHYsSignature)
+                    <> getGamma (chunksOf gammaSignature)
+                    <> getTexts (chunksOf tEXtSignature)
+  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
+

@@ -0,0 +1,450 @@+{-# 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
+                             , 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]
+