JuicyPixels 3.1.7.1 → 3.2

raw patch · 17 files changed

+804/−121 lines, 17 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• JuicyPixels.cabal +4/−3
• changelog +9/−0
• src/Codec/Picture.hs +19/−2
• src/Codec/Picture/BitWriter.hs +2/−2
• src/Codec/Picture/Bitmap.hs +8/−8
• src/Codec/Picture/ColorQuant.hs +6/−6
• src/Codec/Picture/Gif.hs +114/−53
• src/Codec/Picture/Gif/LZW.hs +2/−4
• src/Codec/Picture/HDR.hs +9/−9
• src/Codec/Picture/Jpg.hs +7/−7
• src/Codec/Picture/Png.hs +5/−6
• src/Codec/Picture/Png/Type.hs +4/−0
• src/Codec/Picture/Saving.hs +1/−1
• src/Codec/Picture/Tga.hs +503/−0
• src/Codec/Picture/Tiff.hs +9/−11
• src/Codec/Picture/Types.hs +101/−8
• src/Codec/Picture/VectorByteConversion.hs +1/−1

@@ -1,6 +1,6 @@ Name:                JuicyPixels
-Version:             3.1.7.1
-Synopsis:            Picture loading/serialization (in png, jpeg, bitmap, gif, tiff and radiance)
+Version:             3.2
+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.1.7.1
+    Tag:       v3.2
 
 Flag Mmap
     Description: Enable the file loading via mmap (memory map)
@@ -43,6 +43,7 @@                     Codec.Picture.Png,
                     Codec.Picture.Jpg,
                     Codec.Picture.HDR,
+                    Codec.Picture.Tga,
                     Codec.Picture.Tiff,
                     Codec.Picture.Saving,
                     Codec.Picture.Types,

@@ -1,5 +1,14 @@ -*-change-log-*-
 
+v3.2 2014
+ BREAKING CHANGES:
+   the Codec.Picture.Gif functions has changed interfaces.
+
+ * Adding TGA reading.
+ * Adding TGA writing.
+ * Packeable pixel unpack.
+ * Returning gif with transparency (breaking Codec.Picture.Gif interface)
+
 v3.1.7.1 August 2014
  * Previous gif fix was not working withing the readImage
    function, only in specialized gif images. Correcting

@@ -74,6 +74,13 @@                      , encodeDynamicPng
                      , writeDynamicPng
 
+                     -- ** TGA handling
+                     , readTGA
+                     , decodeTga
+                     , TgaSaveable
+                     , encodeTga
+                     , writeTga
+
                      -- ** Tiff handling
                      , readTiff
                      , TiffSaveable
@@ -153,6 +160,11 @@                          , TiffSaveable
                          , encodeTiff
                          , writeTiff )
+import Codec.Picture.Tga( TgaSaveable
+                        , decodeTga
+                        , encodeTga
+                        , writeTga
+                        )
 import Codec.Picture.Saving
 import Codec.Picture.Types
 import Codec.Picture.ColorQuant
@@ -192,7 +204,7 @@ -- All the images of the animation are separated
 -- by the same delay.
 encodeGifAnimation :: GifDelay -> GifLooping
-                   -> [Image PixelRGB8] -> Either String (L.ByteString)
+                   -> [Image PixelRGB8] -> Either String L.ByteString
 encodeGifAnimation delay looping lst =
     encodeGifImages looping
         [(pal, delay, img)
@@ -236,6 +248,7 @@                                  ,("GIF", decodeGif)
                                  ,("HDR", decodeHDR)
                                  ,("Tiff", decodeTiff)
+                                 ,("TGA", decodeTga)
                                  ]
 
 -- | Helper function trying to load a png file from a file on disk.
@@ -252,7 +265,7 @@ 
 -- | Helper function trying to load all the images of an animated
 -- gif file.
-readGifImages :: FilePath -> IO (Either String [Image PixelRGB8])
+readGifImages :: FilePath -> IO (Either String [DynamicImage])
 readGifImages = withImageDecoder decodeGifImages
 
 -- | Try to load a jpeg file and decompress. The colorspace is still
@@ -269,6 +282,10 @@ -- RGB with floating point precision.
 readHDR :: FilePath -> IO (Either String DynamicImage)
 readHDR = withImageDecoder decodeHDR
+
+-- | Try to load a .tga file from disk.
+readTGA :: FilePath -> IO (Either String DynamicImage)
+readTGA = withImageDecoder decodeTga
 
 -- | Save an image to a '.jpg' file, will do everything it can to save an image.
 saveJpgImage :: Int -> FilePath -> DynamicImage -> IO ()

@@ -111,7 +111,7 @@ 
 {-# INLINE getNextBitsMSBFirst #-}
 getNextBitsMSBFirst :: Int -> BoolReader s Word32
-getNextBitsMSBFirst count = aux 0 count
+getNextBitsMSBFirst = aux 0
   where aux acc 0 = return acc
         aux acc n = do
             bit <- getNextBitMSB
@@ -274,7 +274,7 @@     currWord <- readSTRef $ bwsBitAcc st
     currCount <- readSTRef $  bwsBitReaded st
     serialize d c currWord currCount
-  where dumpByte    i = pushByte' st i
+  where dumpByte = pushByte' st
 
         serialize bitData bitCount currentWord count
             | bitCount + count == 8 = do

@@ -174,7 +174,7 @@                   let lineIdx = line * w
                       inner col | col >= w = return ()
                       inner col = do
-                          let v = (arr `VS.unsafeIndex` (lineIdx + col))
+                          let v = arr `VS.unsafeIndex` (lineIdx + col)
                           (buff `M.unsafeWrite` col) v
                           inner (col + 1)
 
@@ -226,9 +226,9 @@               let initialIndex = line * w * 3
                   inner col _ _ | col >= w = return ()
                   inner col writeIdx readIdx = do
-                      let r = (arr `VS.unsafeIndex` readIdx)
-                          g = (arr `VS.unsafeIndex` (readIdx + 1))
-                          b = (arr `VS.unsafeIndex` (readIdx + 2))
+                      let r = arr `VS.unsafeIndex` readIdx
+                          g = arr `VS.unsafeIndex` (readIdx + 1)
+                          b = arr `VS.unsafeIndex` (readIdx + 2)
                       
                       (buff `M.unsafeWrite` writeIdx) b
                       (buff `M.unsafeWrite` (writeIdx + 1)) g
@@ -270,7 +270,7 @@   where wi = fromIntegral w
         hi = fromIntegral h
         stArray = runST $ do
-            arr <- M.new (fromIntegral $ w * h * 1)
+            arr <- M.new . fromIntegral $ w * h
             forM_ [hi - 1, hi - 2 .. 0] (readLine arr)
             VS.unsafeFreeze arr
 
@@ -278,9 +278,9 @@         
         readLine :: forall s. M.MVector s Word8 -> Int -> ST s ()
         readLine arr line =
-            let readIndex = (wi * 1 + stride) * line
-                lastIndex = wi * (hi - 1 - line + 1) * 1
-                writeIndex = wi * (hi - 1 - line) * 1
+            let readIndex = (wi + stride) * line
+                lastIndex = wi * (hi - 1 - line + 1)
+                writeIndex = wi * (hi - 1 - line)
 
                 inner _ writeIdx | writeIdx >= lastIndex = return ()
                 inner readIdx writeIdx = do

@@ -211,7 +211,7 @@     (Fold stepL beginL doneL) <*> (Fold stepR beginR doneR) =
         let step (Pair xL xR) a = Pair (stepL xL a) (stepR xR a)
             begin = Pair beginL beginR
-            done (Pair xL xR) = (doneL xL) (doneR xR)
+            done (Pair xL xR) = doneL xL $ doneR xR
         in  Fold step begin done
     {-# INLINABLE (<*>) #-}
 
@@ -321,9 +321,9 @@     (PixelRGBF mr mg mb) = meanColor cluster
     (px1, px2) = VU.partition (cond . rgbIntUnpack) $ colors cluster
     cond = case maxAxis $ dims cluster of
-      RAxis -> (\(PixelRGB8 r _ _) -> fromIntegral r < mr)
-      GAxis -> (\(PixelRGB8 _ g _) -> fromIntegral g < mg)
-      BAxis -> (\(PixelRGB8 _ _ b) -> fromIntegral b < mb)
+      RAxis -> \(PixelRGB8 r _ _) -> fromIntegral r < mr
+      GAxis -> \(PixelRGB8 _ g _) -> fromIntegral g < mg
+      BAxis -> \(PixelRGB8 _ _ b) -> fromIntegral b < mb
 
 rgbIntPack :: PixelRGB8 -> PackedRGB
 rgbIntPack (PixelRGB8 r g b) =
@@ -337,7 +337,7 @@   where
     r = fromIntegral $ v `unsafeShiftR` (2 * 8)
     g = fromIntegral $ v `unsafeShiftR` 8
-    b = fromIntegral $ v
+    b = fromIntegral v
 
 initCluster :: Image PixelRGB8 -> Cluster
 initCluster img = mkCluster $ VU.generate ((w * h) `div` subSampling) packer
@@ -379,4 +379,4 @@       , fromIntegral b1 - fromIntegral b2 )
 
 nearestColorIdx :: PixelRGB8 -> Vector PixelRGB8 -> Pixel8
-nearestColorIdx p ps  = fromIntegral $ V.minIndex (V.map (\px -> dist2Px px p) ps)
+nearestColorIdx p ps  = fromIntegral $ V.minIndex (V.map (`dist2Px` p) ps)

@@ -1,4 +1,6 @@ {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 -- | Module implementing GIF decoding.
 module Codec.Picture.Gif ( -- * Reading
                            decodeGif
@@ -19,7 +21,7 @@                          ) where
 
 import Control.Applicative( pure, (<$>), (<*>) )
-import Control.Monad( replicateM, replicateM_ )
+import Control.Monad( replicateM, replicateM_, unless )
 import Control.Monad.ST( runST )
 import Control.Monad.Trans.Class( lift )
 
@@ -325,9 +327,7 @@ skipSubDataBlocks :: Get ()
 skipSubDataBlocks = do
   s <- fromIntegral <$> getWord8
-  if s == 0 then
-    return ()
-  else
+  unless (s == 0) $
     skip s >> skipSubDataBlocks
 
 parseGifBlocks :: Get [Block]
@@ -407,7 +407,7 @@ --------------------------------------------------
 getPalette :: Word8 -> Get Palette
 getPalette bitDepth = 
-    replicateM (size * 3) get >>= return . Image size 1 . V.fromList
+    Image size 1 . V.fromList <$> replicateM (size * 3) get
   where size = 2 ^ (fromIntegral bitDepth :: Int)
 
 putPalette :: Int -> Palette -> Put
@@ -430,7 +430,7 @@     put v = do
       put $ gifVersion v
       let descr = gifScreenDescriptor v
-      put $ descr
+      put descr
       putPalette (fromIntegral $ colorTableSize descr) $ gifGlobalMap v
 
     get = do
@@ -441,7 +441,7 @@           if hasGlobalMap screenDesc then
             getPalette $ colorTableSize screenDesc
           else
-            return $ greyPalette
+            return greyPalette
 
         return GifHeader
             { gifVersion = version
@@ -498,6 +498,13 @@ substituteColors palette = pixelMap swaper
   where swaper n = pixelAt palette (fromIntegral n) 0
 
+substituteColorsWithTransparency :: Int -> Image PixelRGBA8 -> Image Pixel8 -> Image PixelRGBA8
+substituteColorsWithTransparency transparent palette = pixelMap swaper where
+  swaper n | ix == transparent = PixelRGBA8 0 0 0 0
+           | otherwise = promotePixel $ pixelAt palette ix 0
+    where ix = fromIntegral n
+
+
 decodeImage :: GifImage -> Image Pixel8
 decodeImage img = runST $ runBoolReader $ do
     outputVector <- lift . M.new $ width * height
@@ -532,9 +539,10 @@                        , [1, 1 + 2 .. height - 1]
                        ]
 
-paletteOf :: Palette -> GifImage -> Palette
+paletteOf :: (ColorConvertible PixelRGB8 px)
+          => Image px -> GifImage -> Image px
 paletteOf global GifImage { imgLocalPalette = Nothing } = global
-paletteOf      _ GifImage { imgLocalPalette = Just p  } = p
+paletteOf      _ GifImage { imgLocalPalette = Just p  } = promoteImage p
 
 getFrameDelays :: GifFile -> [GifDelay]
 getFrameDelays GifFile { gifImages = [] } = []
@@ -544,59 +552,110 @@                 Nothing -> 0
                 Just e -> fromIntegral $ gceDelay e
 
-decodeAllGifImages :: GifFile -> [Image PixelRGB8]
+transparentColorOf :: Maybe GraphicControlExtension -> Int
+transparentColorOf Nothing = 300
+transparentColorOf (Just ext)
+  | gceTransparentFlag ext = fromIntegral $ gceTransparentColorIndex ext
+  | otherwise = 300
+
+hasTransparency :: Maybe GraphicControlExtension -> Bool
+hasTransparency Nothing = False
+hasTransparency (Just control) = gceTransparentFlag control
+
+decodeAllGifImages :: GifFile -> [DynamicImage]
 decodeAllGifImages GifFile { gifImages = [] } = []
 decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette
-                                                   , gifScreenDescriptor = wholeDescriptor
-                                                   }
-                           , gifImages = (firstControl, firstImage) : rest } = map paletteApplyer $
- scanl generator initState  rest
-    where initState = (paletteOf palette firstImage, firstControl, decodeImage firstImage)
-          globalWidth = fromIntegral $ screenWidth wholeDescriptor
-          globalHeight = fromIntegral $ screenHeight wholeDescriptor
+                                                   , gifScreenDescriptor = wholeDescriptor }
+                           , gifImages = (firstControl, firstImage) : rest }
+  | not (hasTransparency firstControl) =
+      let backImage =
+              generateImage (\_ _ -> backgroundColor) globalWidth globalHeight
+          thisPalette = paletteOf palette firstImage
+          initState =
+            (thisPalette, firstControl, substituteColors thisPalette $ decodeImage firstImage)
+          scanner = gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage
+      in
+      [ImageRGB8 img | (_, _, img) <- scanl scanner initState rest]
 
-          background = backgroundIndex wholeDescriptor
-          backgroundImage = generateImage (\_ _ -> background) globalWidth globalHeight
+  | otherwise =
+      let backImage :: Image PixelRGBA8
+          backImage =
+            generateImage (\_ _ -> transparentBackground) globalWidth globalHeight
 
-          paletteApplyer (pal, _, img) = substituteColors pal img
+          thisPalette :: Image PixelRGBA8
+          thisPalette = paletteOf (promoteImage palette) firstImage
 
-          generator (_, prevControl, img1)
-                    (controlExt, img2@(GifImage { imgDescriptor = descriptor })) =
-                        (thisPalette, controlExt, thisImage)
-               where thisPalette = paletteOf palette img2
-                     thisImage = generateImage pixeler globalWidth globalHeight
-                     localWidth = fromIntegral $ gDescImageWidth descriptor
-                     localHeight = fromIntegral $ gDescImageHeight descriptor
+          transparentCode = transparentColorOf firstControl
+          decoded = 
+            substituteColorsWithTransparency transparentCode thisPalette $
+                decodeImage firstImage
 
-                     left = fromIntegral $ gDescPixelsFromLeft descriptor
-                     top = fromIntegral $ gDescPixelsFromTop descriptor
+          initState = (thisPalette, firstControl, decoded)
+          scanner =
+            gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage in
+      [ImageRGBA8 img | (_, _, img) <- scanl scanner initState rest]
 
-                     isPixelInLocalImage x y =
-                         x >= left && x < left + localWidth && y >= top && y < top + localHeight
+    where 
+      globalWidth = fromIntegral $ screenWidth wholeDescriptor
+      globalHeight = fromIntegral $ screenHeight wholeDescriptor
 
-                     decoded = decodeImage img2
+      transparentBackground = PixelRGBA8 r g b 0
+          where PixelRGB8 r g b = backgroundColor
 
-                     transparent :: Int
-                     transparent = case controlExt of
-                        Nothing  -> 300
-                        Just ext -> if gceTransparentFlag ext
-                            then fromIntegral $ gceTransparentColorIndex ext
-                            else 300
+      backgroundColor
+        | hasGlobalMap wholeDescriptor =
+            pixelAt palette (fromIntegral $ backgroundIndex wholeDescriptor) 0
+        | otherwise = PixelRGB8 0 0 0
 
-                     oldImage = case gceDisposalMethod <$> prevControl of
-                        Nothing -> img1
-                        Just DisposalAny -> img1
-                        Just DisposalDoNot -> img1
-                        Just DisposalRestoreBackground -> backgroundImage
-                        Just DisposalRestorePrevious -> img1
-                        Just (DisposalUnknown _) -> img1
+gifAnimationApplyer :: forall px.
+                       (Pixel px, ColorConvertible PixelRGB8 px)
+                    => (Int, Int) -> Image px -> Image px
+                    -> (Image px, Maybe GraphicControlExtension, Image px)
+                    -> (Maybe GraphicControlExtension, GifImage)
+                    -> (Image px, Maybe GraphicControlExtension, Image px)
+gifAnimationApplyer (globalWidth, globalHeight) globalPalette backgroundImage
+          (_, prevControl, img1)
+          (controlExt, img2@(GifImage { imgDescriptor = descriptor })) =
+            (thisPalette, controlExt, thisImage)
+  where
+    thisPalette :: Image px
+    thisPalette = paletteOf globalPalette img2
 
-                     pixeler x y
-                        | isPixelInLocalImage x y && fromIntegral val /= transparent = val
-                            where val = pixelAt decoded (x - left) (y - top)
-                     pixeler x y = pixelAt oldImage x y
+    thisImage = generateImage pixeler globalWidth globalHeight
+    localWidth = fromIntegral $ gDescImageWidth descriptor
+    localHeight = fromIntegral $ gDescImageHeight descriptor
 
-decodeFirstGifImage :: GifFile -> Either String (Image PixelRGB8)
+    left = fromIntegral $ gDescPixelsFromLeft descriptor
+    top = fromIntegral $ gDescPixelsFromTop descriptor
+
+    isPixelInLocalImage x y =
+        x >= left && x < left + localWidth && y >= top && y < top + localHeight
+
+    decoded :: Image Pixel8
+    decoded = decodeImage img2
+
+    transparent :: Int
+    transparent = case controlExt of
+        Nothing  -> 300
+        Just ext -> if gceTransparentFlag ext
+            then fromIntegral $ gceTransparentColorIndex ext
+            else 300
+
+    oldImage = case gceDisposalMethod <$> prevControl of
+        Nothing -> img1
+        Just DisposalAny -> img1
+        Just DisposalDoNot -> img1
+        Just DisposalRestoreBackground -> backgroundImage
+        Just DisposalRestorePrevious -> img1
+        Just (DisposalUnknown _) -> img1
+
+    pixeler x y
+      | isPixelInLocalImage x y && code /= transparent = val where
+          code = fromIntegral $ pixelAt decoded (x - left) (y - top)
+          val = pixelAt thisPalette (fromIntegral code) 0
+    pixeler x y = pixelAt oldImage x y
+
+decodeFirstGifImage :: GifFile -> Either String DynamicImage
 decodeFirstGifImage img@GifFile { gifImages = (firstImage:_) } =
     case decodeAllGifImages img { gifImages = [firstImage] } of
       [] -> Left "No image after decoding"
@@ -609,12 +668,14 @@ --
 --  * PixelRGB8
 --
+--  * PixelRGBA8
+--
 decodeGif :: B.ByteString -> Either String DynamicImage
-decodeGif img = ImageRGB8 <$> (decode img >>= decodeFirstGifImage)
+decodeGif img = decode img >>= decodeFirstGifImage
 
 -- | Transform a raw gif to a list of images, representing
 -- all the images of an animation.
-decodeGifImages :: B.ByteString -> Either String [Image PixelRGB8]
+decodeGifImages :: B.ByteString -> Either String [DynamicImage]
 decodeGifImages img = decodeAllGifImages <$> decode img
 
 -- | Extract a list of frame delays from a raw gif.
@@ -703,7 +764,7 @@     toSerialize = [(controlExtension delay, GifImage
         { imgDescriptor = imageDescriptor lzwKeySize (paletteEqual palette) img
         , imgLocalPalette = Just palette
-        , imgLzwRootSize = fromIntegral $ lzwKeySize
+        , imgLzwRootSize = fromIntegral lzwKeySize
         , imgData = B.concat . L.toChunks . lzwEncode lzwKeySize $ imageData img
         }) | (palette, delay, img) <- imageList
            , let lzwKeySize = computeMinimumLzwKeySize palette

@@ -2,7 +2,7 @@ 
 import Data.Word( Word8 )
 import Control.Applicative( (<$>) )
-import Control.Monad( when )
+import Control.Monad( when, unless )
 
 import Data.Bits( (.&.) )
 
@@ -122,9 +122,7 @@           | code == endOfInfo = return ()
           | code == clearCode = do
               toOutput <- getNextCode startCodeSize
-              if toOutput == endOfInfo then
-                return ()
-              else do
+              unless (toOutput == endOfInfo) $ do
                 dataSize <- writeString outWriteIdx toOutput
                 getNextCode startCodeSize >>=
                   loop (outWriteIdx + dataSize)

@@ -15,7 +15,7 @@ import Data.Word( Word8 )
 import Data.Monoid( (<>) )
 import Control.Applicative( pure, (<$>), (<*>) )
-import Control.Monad( when, foldM, foldM_, forM, forM_ )
+import Control.Monad( when, foldM, foldM_, forM, forM_, unless )
 import Control.Monad.Trans.Class( lift )
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
@@ -166,7 +166,7 @@ --  * PixelRGBF
 --
 decodeHDR :: B.ByteString -> Either String DynamicImage
-decodeHDR str = runST $ runExceptT $ do
+decodeHDR str = runST $ runExceptT $
     case runGet decodeHeader $ L.fromChunks [str] of
       Left err -> throwE err
       Right rez ->
@@ -187,11 +187,11 @@     letter <- getChar8
     space <- getChar8
 
-    when (not $ isSign sign && isAxisLetter letter && space == ' ')
-         (fail "Invalid radiance size declaration")
+    unless (isSign sign && isAxisLetter letter && space == ' ')
+           (fail "Invalid radiance size declaration")
 
     let numDec acc c | isDigit c =
-            getChar8 >>= numDec (acc * 10 + ord c - (ord '0'))
+            getChar8 >>= numDec (acc * 10 + ord c - ord '0')
         numDec acc _
             | sign == '-' = pure $ negate acc
             | otherwise = pure acc
@@ -371,7 +371,7 @@             case val == prev of
                True -> runLength (n + 1) 0 prev (idx + 1) at
                False | n < 4 -> runLength 0 (n + 1) val (idx + 1) at
-               False -> do
+               False ->
                     pushRun n prev at >>=
                         runLength 1 0 val (idx + 1)
 
@@ -379,7 +379,7 @@             val <- vec `M.unsafeRead` idx
             if val /= prev
                then runLength 0 (n + 1) val (idx + 1) at
-               else do
+               else
                 pushData (idx - 1) (n - 1) at >>=
                     runLength (2 :: Int) 0 val (idx + 1)
 
@@ -464,7 +464,7 @@ 
             (\v -> blitVector v 0 endIndex) <$> V.unsafeFreeze buff
 
-    pure $ RadianceHeader
+    pure RadianceHeader
         { radianceInfos = []
         , radianceFormat = FormatRGBE
         , radianceHeight = h
@@ -473,7 +473,7 @@         }
     
 
-decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s (PixelRGBF))
+decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s PixelRGBF)
 decodeRadiancePicture hdr = do
     let width = abs $ radianceWidth hdr
         height = abs $ radianceHeight hdr

@@ -144,7 +144,7 @@             val7 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 7))
 
             (img `M.unsafeWrite` idx) val0
-            (img `M.unsafeWrite` (idx + (3 * 1))) val1
+            (img `M.unsafeWrite` (idx + (3    ))) val1
             (img `M.unsafeWrite` (idx + (3 * 2))) val2
             (img `M.unsafeWrite` (idx + (3 * 3))) val3
             (img `M.unsafeWrite` (idx + (3 * 4))) val4
@@ -189,8 +189,8 @@             (img `M.unsafeWrite` idx)       v0
             (img `M.unsafeWrite` (idx + 3)) v0
 
-            (img `M.unsafeWrite` (idx + 6 * 1))      v1
-            (img `M.unsafeWrite` (idx + 6 * 1 + 3))  v1
+            (img `M.unsafeWrite` (idx + 6    ))      v1
+            (img `M.unsafeWrite` (idx + 6     + 3))  v1
 
             (img `M.unsafeWrite` (idx + 6 * 2))      v2
             (img `M.unsafeWrite` (idx + 6 * 2 + 3))  v2
@@ -350,7 +350,7 @@               if idx >= V.length (dcDecoderTables s) then s
               else
                 let neu = dcDecoderTables s // [(idx, tree)] in 
-                s { dcDecoderTables = neu `seq` neu }
+                s { dcDecoderTables = neu }
                     where idx = fromIntegral $ huffmanTableDest spec
                           
             AcComponent -> modify $ \s ->
@@ -412,7 +412,7 @@             acTree = acHuffmanTree comp
             quantId = fromIntegral .  quantizationTableDest
                     $ jpgComponents frame !! compIdx
-            qTable = quants V.! (min 3 quantId)
+            qTable = quants V.! min 3 quantId
             xd = blockMcuX comp
             yd = blockMcuY comp
             (subX, subY) = subSampling comp
@@ -730,8 +730,8 @@                                   let blockY = my * sizeY + subY
                                       blockX = mx * sizeX + subX
                                   prev_dc <- dc_table `M.unsafeRead` comp
-                                  (dc_coeff, neo_block) <- (extractor comp blockX blockY >>=
-                                                          encodeMacroBlock table workData zigzaged prev_dc)
+                                  (dc_coeff, neo_block) <- extractor comp blockX blockY >>=
+                                                          encodeMacroBlock table workData zigzaged prev_dc
                                   (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff
                                   serializeMacroBlock writeState dc ac neo_block
 

@@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 -- | Module used for loading & writing \'Portable Network Graphics\' (PNG)
@@ -27,7 +26,7 @@                         ) where
 
 import Control.Applicative( (<$>) )
-import Control.Monad( forM_, foldM_, when )
+import Control.Monad( forM_, foldM_, when, void )
 import Control.Monad.ST( ST, runST )
 import Data.Binary( Binary( get) )
 
@@ -151,7 +150,7 @@                                                  b' = fromIntegral valB
                                                  average = fromIntegral ((a' + b') `div` (2 :: Word16)) 
                                                  writeVal = byte + average 
-                                             (thisLine `M.unsafeWrite` idx) $ writeVal
+                                             (thisLine `M.unsafeWrite` idx) writeVal
                                              inner (idx + 1) $ readIdx + 1
 
           filterPaeth !previousLine !thisLine = inner beginZeroes
@@ -297,7 +296,7 @@             lowBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 1)
             let fullValue = fromIntegral lowBits .|. (fromIntegral highBits `unsafeShiftL` 8)
                 writeIdx = destSampleIndex + sample
-            (arr `M.unsafeWrite` writeIdx) $ fullValue
+            (arr `M.unsafeWrite` writeIdx) fullValue
 
 -- | Transform a scanline to a bunch of bytes. Bytes are then packed
 -- into pixels at a further step.
@@ -317,7 +316,7 @@                      -> B.ByteString
                      -> ST s ()
 scanLineInterleaving depth sampleCount (imgWidth, imgHeight) unpacker str =
-    pngFiltering (unpacker (1,1) (0, 0)) strideInfo (byteWidth, imgHeight) str 0 >> return ()
+    void $ pngFiltering (unpacker (1,1) (0, 0)) strideInfo (byteWidth, imgHeight) str 0
         where byteWidth = byteSizeOfBitLength depth sampleCount imgWidth
               strideInfo | depth < 8 = 1
                          | otherwise = sampleCount * (depth `div` 8)
@@ -327,7 +326,7 @@ adam7Unpack :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s)
             -> B.ByteString -> ST s ()
 adam7Unpack depth sampleCount (imgWidth, imgHeight) unpacker str =
-  foldM_ (\i f -> f i) 0 subImages >> return ()
+  void $ foldM_ (\i f -> f i) 0 subImages
     where Adam7MatrixInfo { adam7StartingRow  = startRows
                           , adam7RowIncrement = rowIncrement
                           , adam7StartingCol  = startCols

@@ -10,6 +10,7 @@                              , iDATSignature
                              , iENDSignature
                              , tRNSSignature
+                             , gammaSignature
                              -- * Low level types
                              , ChunkSignature
                              , PngRawImage( .. )
@@ -292,6 +293,9 @@ 
 tRNSSignature :: ChunkSignature
 tRNSSignature = signature "tRNS"
+
+gammaSignature :: ChunkSignature
+gammaSignature = signature "gAMA"
 
 instance Binary PngImageType where
     put PngGreyscale = putWord8 0

@@ -27,7 +27,7 @@ componentToLDR = truncate . (255 *) . min 1.0 . max 0.0
 
 toStandardDef :: Image PixelRGBF -> Image PixelRGB8
-toStandardDef img = pixelMap pixelConverter img
+toStandardDef = pixelMap pixelConverter
   where pixelConverter (PixelRGBF rf gf bf) = PixelRGB8 r g b
           where r = componentToLDR rf
                 g = componentToLDR gf

@@ -0,0 +1,503 @@+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE BangPatterns #-}
+-- | Module implementing function to read and write
+-- Targa (*.tga) files.
+module Codec.Picture.Tga( decodeTga
+                        , TgaSaveable
+                        , encodeTga
+                        , writeTga
+                        )  where
+
+import Control.Monad.ST( ST, runST )
+import Control.Applicative( (<$>), (<*>), pure )
+import Data.Bits( (.&.)
+                , (.|.)
+                , bit
+                , testBit
+                , setBit
+                , unsafeShiftL
+                , unsafeShiftR )
+import Data.Monoid( mempty )
+import Data.Word( Word8, Word16 )
+import Data.Binary( Binary( .. ), encode )
+import Data.Binary.Get( Get
+                      , getByteString 
+                      , getWord8
+                      , getWord16le
+                      )
+import Data.Binary.Put( putWord8
+                      , putWord16le
+                      , putByteString
+                      )
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as Lb
+import qualified Data.ByteString.Unsafe as U
+import qualified Data.Vector.Storable.Mutable as M
+
+import Codec.Picture.Types
+import Codec.Picture.InternalHelper
+import Codec.Picture.VectorByteConversion
+
+data TgaColorMapType
+  = ColorMapWithoutTable
+  | ColorMapWithTable
+  | ColorMapUnknown Word8
+
+instance Binary TgaColorMapType where
+  get = do
+    v <- getWord8
+    return $ case v of
+      0 -> ColorMapWithoutTable
+      1 -> ColorMapWithTable
+      n -> ColorMapUnknown n
+
+  put v = case v of
+    ColorMapWithoutTable -> putWord8 0
+    ColorMapWithTable -> putWord8 1
+    (ColorMapUnknown vv) -> putWord8 vv
+
+data TgaImageType
+  = ImageTypeNoData Bool
+  | ImageTypeColorMapped Bool
+  | ImageTypeTrueColor Bool
+  | ImageTypeMonochrome Bool
+
+isRleEncoded :: TgaImageType -> Bool
+isRleEncoded v = case v of
+  ImageTypeNoData      yn -> yn
+  ImageTypeColorMapped yn -> yn
+  ImageTypeTrueColor   yn -> yn
+  ImageTypeMonochrome  yn -> yn
+
+imageTypeOfCode :: Monad m => Word8 -> m TgaImageType
+imageTypeOfCode v = case v .&. 3 of
+    0 -> return $ ImageTypeNoData isEncoded
+    1 -> return $ ImageTypeColorMapped isEncoded
+    2 -> return $ ImageTypeTrueColor isEncoded
+    3 -> return $ ImageTypeMonochrome isEncoded
+    _ -> fail $ "Unknown TGA image type " ++ show v
+  where
+    isEncoded = testBit v 3
+
+codeOfImageType :: TgaImageType -> Word8
+codeOfImageType v = case v of
+    ImageTypeNoData encoded -> setVal 0 encoded
+    ImageTypeColorMapped encoded -> setVal 1 encoded
+    ImageTypeTrueColor encoded -> setVal 2 encoded
+    ImageTypeMonochrome encoded -> setVal 3 encoded
+    where
+      setVal vv True = setBit vv 3
+      setVal vv False = vv
+
+instance Binary TgaImageType where
+  get = getWord8 >>= imageTypeOfCode
+  put = putWord8 . codeOfImageType
+    
+data TgaImageDescription = TgaImageDescription
+  { _tgaIdXOrigin       :: Bool
+  , _tgaIdYOrigin       :: Bool
+  , _tgaIdAttributeBits :: Word8
+  }
+
+instance Binary TgaImageDescription where
+  put desc = putWord8 $ xOrig .|. yOrig .|. attr
+    where
+      xOrig | _tgaIdXOrigin desc = bit 4
+            | otherwise = 0
+
+      yOrig | not $ _tgaIdYOrigin desc = bit 5
+            | otherwise = 0
+      
+      attr = _tgaIdAttributeBits desc .&. 0xF
+
+  get = toDescr <$> getWord8 where
+    toDescr v = TgaImageDescription
+      { _tgaIdXOrigin       = testBit v 4
+      , _tgaIdYOrigin       = not $ testBit v 5
+      , _tgaIdAttributeBits = v .&. 0xF
+      }
+
+data TgaHeader = TgaHeader
+  { _tgaHdrIdLength         :: {-# UNPACK #-} !Word8
+  , _tgaHdrColorMapType     :: !TgaColorMapType
+  , _tgaHdrImageType        :: !TgaImageType
+  , _tgaHdrMapStart         :: {-# UNPACK #-} !Word16
+  , _tgaHdrMapLength        :: {-# UNPACK #-} !Word16
+  , _tgaHdrMapDepth         :: {-# UNPACK #-} !Word8
+  , _tgaHdrXOffset          :: {-# UNPACK #-} !Word16
+  , _tgaHdrYOffset          :: {-# UNPACK #-} !Word16
+  , _tgaHdrWidth            :: {-# UNPACK #-} !Word16
+  , _tgaHdrHeight           :: {-# UNPACK #-} !Word16
+  , _tgaHdrPixelDepth       :: {-# UNPACK #-} !Word8
+  , _tgaHdrImageDescription :: {-# UNPACK #-} !TgaImageDescription
+  }
+
+instance Binary TgaHeader where
+  get = TgaHeader
+     <$> g8 <*> get <*> get <*> g16 <*> g16 <*> g8
+     <*> g16 <*> g16 <*> g16 <*> g16 <*> g8 <*> get
+   where g16 = getWord16le
+         g8 = getWord8
+
+  put v = do
+    let p8 = putWord8
+        p16 = putWord16le
+    p8  $ _tgaHdrIdLength v
+    put $ _tgaHdrColorMapType v
+    put $ _tgaHdrImageType v
+
+    p16 $ _tgaHdrMapStart v
+    p16 $ _tgaHdrMapLength v
+    p8  $ _tgaHdrMapDepth v
+    p16 $ _tgaHdrXOffset v
+    p16 $ _tgaHdrYOffset v
+    p16 $ _tgaHdrWidth v
+    p16 $ _tgaHdrHeight v
+    p8  $ _tgaHdrPixelDepth v
+    put $ _tgaHdrImageDescription v
+
+
+data TgaFile = TgaFile
+  { _tgaFileHeader :: !TgaHeader
+  , _tgaFileId     :: !B.ByteString
+  , _tgaPalette    :: !B.ByteString
+  , _tgaFileRest   :: !B.ByteString
+  }
+
+getPalette :: TgaHeader -> Get B.ByteString
+getPalette hdr | _tgaHdrMapLength hdr <= 0 = return mempty
+getPalette hdr = getByteString $ bytePerPixel * pixelCount
+  where
+    bytePerPixel = fromIntegral $ _tgaHdrMapDepth hdr `div` 8
+    pixelCount = fromIntegral $ _tgaHdrMapLength hdr
+
+instance Binary TgaFile where
+  get = do
+    hdr <- get
+    validateTga hdr
+    fileId <- getByteString . fromIntegral $ _tgaHdrIdLength hdr
+    palette <- getPalette hdr
+    rest <- getRemainingBytes
+
+    return TgaFile {
+        _tgaFileHeader = hdr
+      , _tgaFileId = fileId
+      , _tgaPalette = palette
+      , _tgaFileRest = rest
+      }
+
+  put file = do
+    put $ _tgaFileHeader file
+    putByteString $ _tgaFileId file
+    putByteString $ _tgaPalette file
+    putByteString $ _tgaFileRest file
+
+data Depth8 = Depth8
+data Depth15 = Depth15
+data Depth24 = Depth24
+data Depth32 = Depth32
+
+class (Pixel (Unpacked a)) => TGAPixel a where
+   type Unpacked a
+   packedByteSize :: a -> Int
+   tgaUnpack      :: a -> B.ByteString -> Int -> Unpacked a
+
+instance TGAPixel Depth8 where
+   type Unpacked Depth8 = Pixel8
+   packedByteSize _ = 1
+   tgaUnpack _ = U.unsafeIndex
+
+instance TGAPixel Depth15 where
+   type Unpacked Depth15 = PixelRGBA8
+   packedByteSize _ = 2
+   tgaUnpack _ str ix = PixelRGBA8 r g b a
+      where
+        v0 = U.unsafeIndex str ix
+        v1 = U.unsafeIndex str $ ix + 1
+        r = (v1 .&. 0x7c) `unsafeShiftL` 1;
+        g = ((v1 .&. 0x03) `unsafeShiftL` 6) .|. ((v0 .&. 0xe0) `unsafeShiftR` 2);
+        b = (v0 .&. 0x1f) `unsafeShiftL` 3
+        a = 255 -- v1 .&. 0x80
+
+instance TGAPixel Depth24 where
+   type Unpacked Depth24 = PixelRGB8
+   packedByteSize _ = 3
+   tgaUnpack _ str ix = PixelRGB8 r g b
+     where
+       b = U.unsafeIndex str ix
+       g = U.unsafeIndex str (ix + 1)
+       r = U.unsafeIndex str (ix + 2)
+
+instance TGAPixel Depth32 where
+   type Unpacked Depth32 = PixelRGBA8
+   packedByteSize _ = 4
+   tgaUnpack _ str ix = PixelRGBA8 r g b a
+     where
+       b = U.unsafeIndex str ix
+       g = U.unsafeIndex str (ix + 1)
+       r = U.unsafeIndex str (ix + 2)
+       a = 255 - U.unsafeIndex str (ix + 3)
+
+prepareUnpacker :: TgaFile
+                -> (forall tgapx. (TGAPixel tgapx) => tgapx -> TgaFile -> Image (Unpacked tgapx))
+                -> Either String DynamicImage
+prepareUnpacker file f =
+  let hdr = _tgaFileHeader file
+      flipper :: (Pixel px) => Image px -> Image px
+      flipper = flipImage $ _tgaHdrImageDescription hdr
+  in
+  case _tgaHdrPixelDepth hdr of
+    8  -> pure . ImageY8 . flipper $ f Depth8 file
+    16 -> pure . ImageRGBA8 . flipper $ f Depth15 file
+    24 -> pure . ImageRGB8 . flipper $ f Depth24 file
+    32 -> pure . ImageRGBA8 . flipper $ f Depth32 file
+    n  -> fail $ "Invalid bit depth (" ++ show n ++ ")"
+
+applyPalette :: (Pixel px)
+             => (Image px -> DynamicImage) -> Image px
+             -> DynamicImage
+             -> Either String DynamicImage
+applyPalette f palette (ImageY8 img) =
+  pure . f $ pixelMap (\v -> pixelAt palette (fromIntegral v) 0) img
+applyPalette _ _ _ =
+  fail "Bad colorspace for image"
+
+unparse :: TgaFile -> Either String DynamicImage
+unparse file =
+  let hdr = _tgaFileHeader file
+      imageType = _tgaHdrImageType hdr
+
+      unpacker :: forall tgapx. (TGAPixel tgapx)
+               => tgapx -> TgaFile -> Image (Unpacked tgapx)
+      unpacker | isRleEncoded imageType = unpackRLETga
+               | otherwise = unpackUncompressedTga
+
+      decodedPalette = unparse file
+        { _tgaFileHeader = hdr
+            { _tgaHdrHeight = 1
+            , _tgaHdrWidth = _tgaHdrMapLength hdr
+            , _tgaHdrPixelDepth = _tgaHdrMapDepth hdr
+            , _tgaHdrImageType = ImageTypeTrueColor False
+            }
+        , _tgaFileRest = _tgaPalette file
+        }
+  in
+  case imageType of
+    ImageTypeNoData _ -> fail "No data detected in TGA file"
+    ImageTypeTrueColor _ ->
+      prepareUnpacker file unpacker
+    ImageTypeMonochrome _ ->
+      prepareUnpacker file unpacker
+    ImageTypeColorMapped _ ->
+      case decodedPalette of
+        Left str -> Left str
+        Right (ImageY8 img) ->
+          prepareUnpacker file unpacker >>= applyPalette ImageY8 img
+        Right (ImageRGB8 img) ->
+          prepareUnpacker file unpacker >>= applyPalette ImageRGB8 img
+        Right (ImageRGBA8 img) ->
+          prepareUnpacker file unpacker >>= applyPalette ImageRGBA8 img
+        Right _ -> fail "Unknown pixel type"
+
+writeRun :: (Pixel px)
+         => M.STVector s (PixelBaseComponent px) -> Int -> px -> Int
+         -> ST s Int
+writeRun imgData localMaxi px = run
+  where
+    writeDelta = componentCount px
+    run writeIndex 
+      | writeIndex >= localMaxi = return writeIndex
+    run writeIndex = do
+      unsafeWritePixel imgData writeIndex px
+      run $ writeIndex + writeDelta
+
+copyData :: forall tgapx s
+          . (TGAPixel tgapx)
+         => tgapx
+         -> M.STVector s (PixelBaseComponent (Unpacked tgapx))
+         -> B.ByteString
+         -> Int -> Int
+         -> Int -> Int
+         -> ST s (Int, Int)
+copyData tgapx imgData readData maxi maxRead = go
+  where
+    readDelta = packedByteSize tgapx
+    writeDelta = componentCount (undefined :: Unpacked tgapx)
+
+    go writeIndex readIndex
+      | writeIndex >= maxi ||
+        readIndex >= maxRead = return (writeIndex, readIndex)
+    go writeIndex readIndex = do
+      let px = tgaUnpack tgapx readData readIndex :: Unpacked tgapx
+      unsafeWritePixel imgData writeIndex px
+      go (writeIndex + writeDelta) (readIndex + readDelta)
+
+unpackUncompressedTga :: forall tgapx
+                       . (TGAPixel tgapx)
+                      => tgapx -- ^ Type witness
+                      -> TgaFile
+                      -> Image (Unpacked tgapx)
+unpackUncompressedTga tga file = runST $ do
+    img <- MutableImage width height <$> M.new maxi
+    let imgData = mutableImageData img
+    _ <- copyData tga imgData readData maxi maxRead 0 0
+    unsafeFreezeImage img
+
+  where
+    hdr = _tgaFileHeader file
+    width = fromIntegral $ _tgaHdrWidth hdr
+    height = fromIntegral $ _tgaHdrHeight hdr
+    readData = _tgaFileRest file
+    compCount = componentCount (undefined :: Unpacked tgapx)
+    maxi = width * height * compCount
+    maxRead = B.length readData
+
+isRleChunk :: Word8 -> Bool
+isRleChunk v = testBit v 7
+
+runLength :: Word8 -> Int
+runLength v = fromIntegral (v .&. 0x7F) + 1
+
+unpackRLETga :: forall tgapx
+              . (TGAPixel tgapx)
+             => tgapx -- ^ Type witness
+             -> TgaFile
+             -> Image (Unpacked tgapx)
+unpackRLETga tga file = runST $ do
+    img <- MutableImage width height <$> M.new maxi
+    let imgData = mutableImageData img
+
+        go writeIndex readIndex
+            | writeIndex >= maxi = return () 
+            | readIndex >= maxRead = return ()
+        go writeIndex readIndex = do
+          let code = U.unsafeIndex readData readIndex
+              copyMax = min maxi $ writeIndex + runLength code * compCount
+          
+          if isRleChunk code then do
+            let px = tgaUnpack tga readData (readIndex + 1) :: Unpacked tgapx
+            lastWriteIndex <- writeRun imgData copyMax px writeIndex
+            go lastWriteIndex $ readIndex + 1 + readDelta
+
+          else do
+            (newWrite, newRead) <-
+                copyData tga imgData readData copyMax maxRead
+                    writeIndex (readIndex + 1)
+            go newWrite newRead
+
+    go 0 0
+    unsafeFreezeImage img
+
+  where
+    hdr = _tgaFileHeader file
+    width = fromIntegral $ _tgaHdrWidth hdr
+    height = fromIntegral $ _tgaHdrHeight hdr
+    readData = _tgaFileRest file
+    compCount = componentCount (undefined :: Unpacked tgapx)
+    maxi = width * height * compCount
+    maxRead = B.length readData
+    readDelta = packedByteSize tga
+
+flipImage :: (Pixel px)
+          => TgaImageDescription -> Image px -> Image px
+flipImage desc img
+    | xFlip && yFlip =
+        generateImage (\x y -> pixelAt img (wMax - x) (hMax - y)) w h
+    | xFlip =
+        generateImage (\x y -> pixelAt img (wMax - x) y) w h
+    | yFlip =
+        generateImage (\x y -> pixelAt img x (hMax - y)) w h
+    | otherwise = img
+  where
+    xFlip = _tgaIdXOrigin desc
+    yFlip = _tgaIdYOrigin desc
+    w = imageWidth img
+    h = imageHeight img
+
+    !wMax = w - 1
+    !hMax = h - 1
+
+validateTga :: (Monad m) => TgaHeader -> m ()
+validateTga hdr
+    | _tgaHdrWidth hdr <= 0 = fail "Width is null or negative"
+    | _tgaHdrHeight hdr <= 0 = fail "Height is null or negative"
+validateTga _ = return ()
+
+-- | Transform a raw tga image to an image, without modifying
+-- the underlying pixel type.
+--
+-- This function can output the following pixel types:
+--
+--    * PixelY8
+--
+--    * PixelRGB8
+--
+--    * PixelRGBA8
+--
+decodeTga :: B.ByteString -> Either String DynamicImage
+decodeTga byte = runGetStrict get byte >>= unparse
+
+-- | This typeclass determine if a pixel can be saved in the
+-- TGA format.
+class TgaSaveable a where
+    tgaDataOfImage :: Image a -> B.ByteString
+    tgaPixelDepthOfImage :: Image a -> Word8
+    tgaTypeOfImage :: Image a -> TgaImageType
+
+instance TgaSaveable Pixel8 where
+    tgaDataOfImage = toByteString . imageData
+    tgaPixelDepthOfImage _ = 8
+    tgaTypeOfImage _ = ImageTypeMonochrome False
+
+instance TgaSaveable PixelRGB8 where
+    tgaPixelDepthOfImage _ = 24
+    tgaTypeOfImage _ = ImageTypeTrueColor False
+    tgaDataOfImage = toByteString . imageData . pixelMap flipRgb
+      where
+        flipRgb (PixelRGB8 r g b) = PixelRGB8 b g r
+
+instance TgaSaveable PixelRGBA8 where
+    tgaPixelDepthOfImage _ = 32
+    tgaTypeOfImage _ = ImageTypeTrueColor False
+    tgaDataOfImage = toByteString . imageData . pixelMap flipRgba
+      where
+        flipRgba (PixelRGBA8 r g b a) = PixelRGBA8 b g r a
+
+-- | Helper function to directly write an image a tga on disk.
+writeTga :: (TgaSaveable pixel) => FilePath -> Image pixel -> IO ()
+writeTga path img = Lb.writeFile path $ encodeTga img
+
+-- | Transform a compatible image to a raw bytestring
+-- representing a Targa file.
+encodeTga :: (TgaSaveable px) => Image px -> Lb.ByteString
+encodeTga img = encode file
+  where
+    file = TgaFile
+      { _tgaFileHeader = TgaHeader
+            { _tgaHdrIdLength         = 0
+            , _tgaHdrColorMapType     = ColorMapWithoutTable
+            , _tgaHdrImageType        = tgaTypeOfImage img
+            , _tgaHdrMapStart         = 0
+            , _tgaHdrMapLength        = 0
+            , _tgaHdrMapDepth         = 0
+            , _tgaHdrXOffset          = 0
+            , _tgaHdrYOffset          = 0
+            , _tgaHdrWidth            = fromIntegral $ imageWidth img
+            , _tgaHdrHeight           = fromIntegral $ imageHeight img
+            , _tgaHdrPixelDepth       = tgaPixelDepthOfImage img
+            , _tgaHdrImageDescription = TgaImageDescription
+                    { _tgaIdXOrigin       = False
+                    , _tgaIdYOrigin       = False
+                    , _tgaIdAttributeBits = 0
+                    }
+            }
+      , _tgaFileId     = mempty
+      , _tgaPalette    = mempty
+      , _tgaFileRest   = tgaDataOfImage img
+      }
+

@@ -27,11 +27,11 @@ module Codec.Picture.Tiff( decodeTiff, TiffSaveable, encodeTiff, writeTiff ) where
 
 import Control.Applicative( (<$>), (<*>), pure )
-import Control.Monad( when, replicateM, foldM_ )
+import Control.Monad( when, replicateM, foldM_, unless )
 import Control.Monad.ST( ST, runST )
 import Control.Monad.Writer.Strict( execWriter, tell, Writer )
 import Data.Int( Int8 )
-import Data.Word( Word8, Word16 )
+import Data.Word( Word8, Word16, Word32 )
 import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR )
 import Data.Binary( Binary( .. ) )
 import Data.Binary.Get( Get
@@ -51,7 +51,6 @@ import qualified Data.Vector as V
 import qualified Data.Vector.Storable as VS
 import qualified Data.Vector.Storable.Mutable as M
-import Data.Word( Word32 )
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as Lb
 import qualified Data.ByteString.Unsafe as BU
@@ -614,7 +613,7 @@ 
                 choice
                     -- data
-                    | 0    <= v = do
+                    | 0    <= v =
                         copyByteString str outVec stride writeIdx
                                         (fromIntegral $ i + 1, fromIntegral v + 1)
                             >>= loop (i + 2 + fromIntegral v)
@@ -1055,7 +1054,7 @@                 $ tiffExtraSample nfo
 
             let subSampling = tiffYCbCrSubsampling nfo
-            when (not $ V.null subSampling) $
+            unless (V.null subSampling) $
                  ifdShorts TagYCbCrSubsampling subSampling
 
     putByteString rawData
@@ -1139,8 +1138,7 @@   | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format =
         pure . ImageCMYK16 $ gatherStrips (0 :: Word16) file nfo
 
-unpack file nfo@TiffInfo { tiffColorspace = TiffMonochromeWhite0 }
-  | otherwise = do
+unpack file nfo@TiffInfo { tiffColorspace = TiffMonochromeWhite0 } = do
     img <- unpack file (nfo { tiffColorspace = TiffMonochrome })
     case img of
       ImageY8 i -> pure . ImageY8 $ pixelMap (maxBound -) i
@@ -1149,7 +1147,7 @@                     in pure . ImageYA8 $ pixelMap negative i
       ImageYA16 i -> let negative (PixelYA16 y a) = PixelYA16 (maxBound - y) a
                      in pure . ImageYA16 $ pixelMap negative i
-      _ -> fail $ "Unsupported color type used with colorspace MonochromeWhite0"
+      _ -> fail "Unsupported color type used with colorspace MonochromeWhite0"
 
 unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome
                          , tiffBitsPerSample = lst
@@ -1168,7 +1166,7 @@         let toWord16 v = fromIntegral $ v `unsafeShiftR` 16
             img = gatherStrips (0 :: Word32) file nfo :: Image Pixel32
         in
-        pure . ImageY16 $ pixelMap (toWord16) img
+        pure . ImageY16 $ pixelMap toWord16 img
   | lst == V.fromList [2, 2] && all (TiffSampleUint ==) format =
         pure . ImageYA8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo
   | lst == V.fromList [4, 4] && all (TiffSampleUint ==) format =
@@ -1308,7 +1306,7 @@   where intSampleCount = componentCount (undefined :: px)
         sampleCount = fromIntegral intSampleCount
 
-        sampleType = (undefined :: PixelBaseComponent px)
+        sampleType = undefined :: PixelBaseComponent px
         pixelData = imageData img
 
         rawPixelData = toByteString pixelData
@@ -1328,7 +1326,7 @@             , tiffWidth              = width
             , tiffHeight             = height
             , tiffColorspace         = colorSpaceOfPixel (undefined :: px)
-            , tiffSampleCount        = fromIntegral $ sampleCount
+            , tiffSampleCount        = fromIntegral sampleCount
             , tiffRowPerStrip        = fromIntegral $ imageHeight img
             , tiffPlaneConfiguration = PlanarConfigContig
             , tiffSampleFormat       = [TiffSampleUint]

@@ -85,8 +85,9 @@                             -- * Packeable writing (unsafe but faster)
                           , PackeablePixel( .. )
                           , fillImageWith
-                          , unsafeWritePixelBetweenAt
+                          , readPackedPixelAt
                           , writePackedPixelAt
+                          , unsafeWritePixelBetweenAt
                           ) where
 
 import Control.Monad( foldM, liftM, ap )
@@ -95,7 +96,7 @@ import Control.Monad.Primitive ( PrimMonad, PrimState )
 import Foreign.ForeignPtr( castForeignPtr )
 import Foreign.Storable ( Storable )
-import Data.Bits( unsafeShiftL, unsafeShiftR, (.|.) )
+import Data.Bits( unsafeShiftL, unsafeShiftR, (.|.), (.&.) )
 import Data.Word( Word8, Word16, Word32, Word64 )
 import Data.List( foldl' )
 import Data.Vector.Storable ( (!) )
@@ -928,7 +929,7 @@ -- of an image or a pixel
 class (Pixel a, Pixel (PixelBaseComponent a)) => LumaPlaneExtractable a where
     -- | Compute the luminance part of a pixel
-    computeLuma      :: a -> (PixelBaseComponent a)
+    computeLuma      :: a -> PixelBaseComponent a
 
     -- | Extract a luma plane out of an image. This
     -- method is in the typeclass to help performant
@@ -1776,11 +1777,11 @@               rY  = fix 0.29900
               gY  = fix 0.58700
               bY  = fix 0.11400
-              rCb = (- fix 0.16874)
-              gCb = (- fix 0.33126)
+              rCb = - fix 0.16874
+              gCb = - fix 0.33126
               bCb = fix 0.5
-              gCr = (- fix 0.41869)
-              bCr = (- fix 0.08131)
+              gCr = - fix 0.41869
+              bCr = - fix 0.08131
 
               newData = runST $ do
                 block <- M.new $ maxi * 3
@@ -1952,7 +1953,7 @@           m = (ig - kInt) `div` ik
           y = (ib - kInt) `div` ik
 
-          clamp = fromIntegral . (max 0)
+          clamp = fromIntegral . max 0
 
 instance ColorSpaceConvertible PixelRGB8 PixelCMYK8 where
   convertPixel (PixelRGB8 r g b) = integralRGBToCMYK PixelCMYK8 (r, g, b)
@@ -2090,29 +2091,42 @@     -- to a primitive.
     packPixel :: a -> PackedRepresentation a
 
+    -- | Inverse transformation, to speed up
+    -- reading
+    unpackPixel :: PackedRepresentation a -> a
+
 instance PackeablePixel Pixel8 where
     type PackedRepresentation Pixel8 = Pixel8
     packPixel = id
     {-# INLINE packPixel #-}
+    unpackPixel = id
+    {-# INLINE unpackPixel #-}
 
 instance PackeablePixel Pixel16 where
     type PackedRepresentation Pixel16 = Pixel16
     packPixel = id
     {-# INLINE packPixel #-}
+    unpackPixel = id
+    {-# INLINE unpackPixel #-}
 
 instance PackeablePixel Pixel32 where
     type PackedRepresentation Pixel32 = Pixel32
     packPixel = id
     {-# INLINE packPixel #-}
+    unpackPixel = id
+    {-# INLINE unpackPixel #-}
 
 instance PackeablePixel PixelF where
     type PackedRepresentation PixelF = PixelF
     packPixel = id
     {-# INLINE packPixel #-}
+    unpackPixel = id
+    {-# INLINE unpackPixel #-}
 
 
 instance PackeablePixel PixelRGBA8 where
     type PackedRepresentation PixelRGBA8 = Word32
+    {-# INLINE packPixel #-}
     packPixel (PixelRGBA8 r g b a) =
         (fi r `unsafeShiftL` (0 * bitCount)) .|.
         (fi g `unsafeShiftL` (1 * bitCount)) .|.
@@ -2121,8 +2135,19 @@       where fi = fromIntegral
             bitCount = 8
 
+    {-# INLINE unpackPixel #-}
+    unpackPixel w =
+        PixelRGBA8 (low w)
+                   (low $ w `unsafeShiftR` bitCount)
+                   (low $ w `unsafeShiftR` (2 * bitCount))
+                   (low $ w `unsafeShiftR` (3 * bitCount))
+      where
+        low v = fromIntegral (v .&. 0xFF)
+        bitCount = 8
+
 instance PackeablePixel PixelRGBA16 where
     type PackedRepresentation PixelRGBA16 = Word64
+    {-# INLINE packPixel #-}
     packPixel (PixelRGBA16 r g b a) =
         (fi r `unsafeShiftL` (0 * bitCount)) .|.
         (fi g `unsafeShiftL` (1 * bitCount)) .|.
@@ -2131,8 +2156,19 @@       where fi = fromIntegral
             bitCount = 16
 
+    {-# INLINE unpackPixel #-}
+    unpackPixel w =
+        PixelRGBA16 (low w)
+                    (low $ w `unsafeShiftR` bitCount)
+                    (low $ w `unsafeShiftR` (2 * bitCount))
+                    (low $ w `unsafeShiftR` (3 * bitCount))
+      where
+        low v = fromIntegral (v .&. 0xFFFF)
+        bitCount = 16
+
 instance PackeablePixel PixelCMYK8 where
     type PackedRepresentation PixelCMYK8 = Word32
+    {-# INLINE packPixel #-}
     packPixel (PixelCMYK8 c m y k) =
         (fi c `unsafeShiftL` (0 * bitCount)) .|.
         (fi m `unsafeShiftL` (1 * bitCount)) .|.
@@ -2141,8 +2177,19 @@       where fi = fromIntegral
             bitCount = 8
 
+    {-# INLINE unpackPixel #-}
+    unpackPixel w =
+        PixelCMYK8 (low w)
+                   (low $ w `unsafeShiftR` bitCount)
+                   (low $ w `unsafeShiftR` (2 * bitCount))
+                   (low $ w `unsafeShiftR` (3 * bitCount))
+      where
+        low v = fromIntegral (v .&. 0xFF)
+        bitCount = 8
+
 instance PackeablePixel PixelCMYK16 where
     type PackedRepresentation PixelCMYK16 = Word64
+    {-# INLINE packPixel #-}
     packPixel (PixelCMYK16 c m y k) =
         (fi c `unsafeShiftL` (0 * bitCount)) .|.
         (fi m `unsafeShiftL` (1 * bitCount)) .|.
@@ -2151,22 +2198,46 @@       where fi = fromIntegral
             bitCount = 16
 
+    {-# INLINE unpackPixel #-}
+    unpackPixel w =
+        PixelCMYK16 (low w)
+                    (low $ w `unsafeShiftR` bitCount)
+                    (low $ w `unsafeShiftR` (2 * bitCount))
+                    (low $ w `unsafeShiftR` (3 * bitCount))
+      where
+        low v = fromIntegral (v .&. 0xFFFF)
+        bitCount = 16
+
 instance PackeablePixel PixelYA16 where
     type PackedRepresentation PixelYA16 = Word32
+    {-# INLINE packPixel #-}
     packPixel (PixelYA16 y a) =
         (fi y `unsafeShiftL` (0 * bitCount)) .|.
         (fi a `unsafeShiftL` (1 * bitCount))
       where fi = fromIntegral
             bitCount = 16
 
+    {-# INLINE unpackPixel #-}
+    unpackPixel w = PixelYA16 (low w) (low $ w `unsafeShiftR` bitCount)
+      where
+        low v = fromIntegral (v .&. 0xFFFF)
+        bitCount = 16
+
 instance PackeablePixel PixelYA8 where
     type PackedRepresentation PixelYA8 = Word16
+    {-# INLINE packPixel #-}
     packPixel (PixelYA8 y a) =
         (fi y `unsafeShiftL` (0 * bitCount)) .|.
         (fi a `unsafeShiftL` (1 * bitCount))
       where fi = fromIntegral
             bitCount = 8
 
+    {-# INLINE unpackPixel #-}
+    unpackPixel w = PixelYA8 (low w) (low $ w `unsafeShiftR` bitCount)
+      where
+        low v = fromIntegral (v .&. 0xFF)
+        bitCount = 8
+
 -- | This function will fill an image with a simple packeable
 -- pixel. It will be faster than any unsafeWritePixel.
 fillImageWith :: ( Pixel px, PackeablePixel px
@@ -2200,6 +2271,28 @@     !packedPtr = castForeignPtr ptr
     !converted =
         M.unsafeFromForeignPtr packedPtr s s2
+
+-- | Read a packeable pixel from an image. Equivalent to
+-- unsafeReadPixel
+readPackedPixelAt :: forall m px.
+                     ( Pixel px, PackeablePixel px
+                     , M.Storable (PackedRepresentation px)
+                     , PrimMonad m
+                     )
+                  => MutableImage (PrimState m) px -- ^ Image to read from
+                  -> Int  -- ^ Index in (PixelBaseComponent px) count
+                  -> m px
+{-# INLINE readPackedPixelAt #-}
+readPackedPixelAt img idx = do
+    unpacked <- M.unsafeRead converted (idx `div` compCount)
+    return $ unpackPixel unpacked
+    where
+    !compCount = componentCount (undefined :: px)
+    (ptr, s, s2) = M.unsafeToForeignPtr $ mutableImageData img
+    !packedPtr = castForeignPtr ptr
+    !converted =
+        M.unsafeFromForeignPtr packedPtr s s2
+
 
 -- | Write a packeable pixel into an image. equivalent to unsafeWritePixel.
 writePackedPixelAt :: ( Pixel px, PackeablePixel px

@@ -15,7 +15,7 @@ import Codec.Picture.Types
 
 blitVector :: Vector Word8 -> Int -> Int -> B.ByteString
-blitVector vec atIndex blitSize = S.PS ptr (offset + atIndex) blitSize
+blitVector vec atIndex = S.PS ptr (offset + atIndex)
   where (ptr, offset, _length) = unsafeToForeignPtr vec
 
 toByteString :: forall a. (Storable a) => Vector a -> B.ByteString