Merge branch 'master' into release

Conflicts:
	JuicyPixels.cabal

.travis.yml

@@ -12,8 +12,10 @@ matrix:
     addons: {apt: {packages: [cabal-install-1.18, ghc-7.6.3], sources: [hvr-ghc]}}
   - env: CABALVER=1.18 GHCVER=7.8.4 GHCOPTS="-Werror" JOPTS="-j2"
     addons: {apt: {packages: [cabal-install-1.18, ghc-7.8.4], sources: [hvr-ghc]}}
-  - env: CABALVER=head GHCVER=7.10.1 GHCOPTS="" JOPTS="-j2"
-    addons: {apt: {packages: [cabal-install-head, ghc-7.10.1],sources: [hvr-ghc]}}
+  - env: CABALVER=1.24 GHCVER=7.10.1 GHCOPTS="" JOPTS="-j2"
+    addons: {apt: {packages: [cabal-install-1.24, ghc-7.10.1],sources: [hvr-ghc]}}
+  - env: CABALVER=1.24 GHCVER=8.0.1 GHCOPTS="" JOPTS="-j2"
+    addons: {apt: {packages: [cabal-install-1.24, ghc-8.0.1],sources: [hvr-ghc]}}
 #  - env: CABALVER=head GHCVER=head GHCOPTS="-Werror" JOPTS="-j2"
 #    addons: {apt: {packages: [cabal-install-head,ghc-head],  sources: [hvr-ghc]}}
 

JuicyPixels.cabal

@@ -1,5 +1,5 @@
 Name:                JuicyPixels
-Version:             3.2.6.5
+Version:             3.2.7
 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 head
 Source-Repository this
     Type:      git
     Location:  git://github.com/Twinside/Juicy.Pixels.git
-    Tag:       v3.2.6.5
+    Tag:       v3.2.7
 
 Flag Mmap
     Description: Enable the file loading via mmap (memory map)
@@ -52,11 +52,10 @@ Library
                     Codec.Picture.ColorQuant
 
   Ghc-options: -O3 -Wall
-  Ghc-prof-options: -rtsopts -Wall -prof -auto-all
   Build-depends: base                >= 4.5     && < 5,
                  bytestring          >= 0.9     && < 0.11,
                  mtl                 >= 1.1     && < 2.3,
-                 binary              >= 0.5     && < 0.8,
+                 binary              >= 0.5     && < 0.9,
                  zlib                >= 0.5.3.1 && < 0.7,
                  transformers        >= 0.2,
                  vector              >= 0.9     && < 0.12,

README.md

@@ -52,6 +52,7 @@ Status
 
  - Bitmap (.bmp) (mainly used as a debug output format)
     * Reading
+        - 32bits (RGBA) images
         - 24bits (RGB) images
         - 8bits (greyscale & paletted) images
 
@@ -62,10 +63,12 @@ Status
 
     * Metadata (reading/writing): DPI information
 
- - Jpeg   (.jpg, .jpeg) 
+ - Jpeg   (.jpg, .jpeg)
     * Reading normal and interlaced baseline DCT image
         - YCbCr (default) CMYK/YCbCrK/RGB colorspaces
+
     * Writing non-interlaced JPG
+        - YCbCr (favored), Y, RGB & CMYK colorspaces
 
     * Metadata:
         - Reading and writing DpiX & DpiY from JFIF header.

changelog

@@ -1,6 +1,15 @@
 Change log
 ==========
 
+v3.2.7 January 2016
+-------------------
+ * Addition: convertRGB8 and convertRGBA8 helper functions
+ * Addition: new output colorspace for JPEG format: Y, RGB & CMYK
+ * Addition: RGBA8 bitmap reading (thanks to mtolly)
+ * Enhancement: Optimized JPG & Tiff reading (thanks to Calvin Beck)
+ * Enhancement: INLINE SPECIALIZE for pixelMap (Pixel8 -> Pixel8) (thx to Calvin Beck)
+ * Fix: GHC 8.0 compilation (thanks to phadej)
+
 v3.2.6.5 December 2015
 ----------------------
  * Fix: Compilation on GHC 7.6/7.8

src/Codec/Picture.hs

@@ -1,7 +1,10 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
 -- | Main module for image import/export into various image formats.
 --
 -- To use the library without thinking about it, look after 'decodeImage' and
@@ -23,6 +26,10 @@ module Codec.Picture (
                      , generateFoldImage
                      , withImage
 
+                      -- * RGB helper functions
+                     , convertRGB8
+                     , convertRGBA8
+
                      -- * Lens compatibility
                      , Traversal
                      , imagePixels
@@ -138,6 +145,7 @@ module Codec.Picture (
 import Control.Applicative( (<$>) )
 #endif
 
+import Data.Bits( unsafeShiftR )
 import Control.DeepSeq( NFData, deepseq )
 import qualified Control.Exception as Exc ( catch, IOException )
 import Codec.Picture.Metadata( Metadatas )
@@ -200,6 +208,7 @@ import System.IO.MMap ( mmapFileByteString )
 
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
+import qualified Data.Vector.Storable as VS
 
 -- | Return the first Right thing, accumulating error
 eitherLoad :: c -> [(String, c -> Either String b)] -> Either String b
@@ -263,13 +272,93 @@ readImage = withImageDecoder decodeImage
 readImageWithMetadata :: FilePath -> IO (Either String (DynamicImage, Metadatas))
 readImageWithMetadata = withImageDecoder decodeImageWithMetadata
 
+
 -- | If you want to decode an image in a bytestring without even thinking
 -- in term of format or whatever, this is the function to use. It will try
 -- to decode in each known format and if one decoding succeeds, it will return
 -- the decoded image in it's own colorspace.
 decodeImage :: B.ByteString -> Either String DynamicImage
 decodeImage = fmap fst . decodeImageWithMetadata 
 
+class Decimable px1 px2 where
+   decimateBitDepth :: Image px1 -> Image px2
+
+decimateWord16 :: ( Pixel px1, Pixel px2
+                  , PixelBaseComponent px1 ~ Pixel16
+                  , PixelBaseComponent px2 ~ Pixel8
+                  ) => Image px1 -> Image px2
+decimateWord16 (Image w h da) =
+  Image w h $ VS.map (\v -> fromIntegral $ v `unsafeShiftR` 8) da
+
+decimateFloat :: ( Pixel px1, Pixel px2
+                 , PixelBaseComponent px1 ~ PixelF
+                 , PixelBaseComponent px2 ~ Pixel8
+                 ) => Image px1 -> Image px2
+decimateFloat (Image w h da) =
+  Image w h $ VS.map (floor . (255*) . max 0 . min 1) da
+
+instance Decimable Pixel16 Pixel8 where
+   decimateBitDepth = decimateWord16
+
+instance Decimable PixelYA16 PixelYA8 where
+   decimateBitDepth = decimateWord16
+
+instance Decimable PixelRGB16 PixelRGB8 where
+   decimateBitDepth = decimateWord16
+
+instance Decimable PixelRGBA16 PixelRGBA8 where
+   decimateBitDepth = decimateWord16
+
+instance Decimable PixelCMYK16 PixelCMYK8 where
+   decimateBitDepth = decimateWord16
+
+instance Decimable PixelF Pixel8 where
+   decimateBitDepth = decimateFloat
+
+instance Decimable PixelRGBF PixelRGB8 where
+   decimateBitDepth = decimateFloat
+
+-- | Convert by any mean possible a dynamic image to an image
+-- in RGBA. The process can lose precision while converting from
+-- 16bits pixels or Floating point pixels.
+convertRGBA8 :: DynamicImage -> Image PixelRGBA8
+convertRGBA8 dynImage = case dynImage of
+  ImageY8     img -> promoteImage img
+  ImageY16    img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+  ImageYF     img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+  ImageYA8    img -> promoteImage img
+  ImageYA16   img -> promoteImage (decimateBitDepth img :: Image PixelYA8)
+  ImageRGB8   img -> promoteImage img
+  ImageRGB16  img -> promoteImage (decimateBitDepth img :: Image PixelRGB8)
+  ImageRGBF   img -> promoteImage (decimateBitDepth img :: Image PixelRGB8)
+  ImageRGBA8  img -> promoteImage img
+  ImageRGBA16 img -> decimateBitDepth img
+  ImageYCbCr8 img -> promoteImage (convertImage img :: Image PixelRGB8)
+  ImageCMYK8  img -> promoteImage (convertImage img :: Image PixelRGB8)
+  ImageCMYK16 img ->
+    promoteImage (convertImage (decimateBitDepth img :: Image PixelCMYK8) :: Image PixelRGB8)
+
+-- | Convert by any mean possible a dynamic image to an image
+-- in RGB. The process can lose precision while converting from
+-- 16bits pixels or Floating point pixels. Any alpha layer will
+-- be dropped
+convertRGB8 :: DynamicImage -> Image PixelRGB8
+convertRGB8 dynImage = case dynImage of
+  ImageY8     img -> promoteImage img
+  ImageY16    img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+  ImageYF     img -> promoteImage (decimateBitDepth img :: Image Pixel8)
+  ImageYA8    img -> promoteImage img
+  ImageYA16   img -> promoteImage (decimateBitDepth img :: Image PixelYA8)
+  ImageRGB8   img -> img
+  ImageRGB16  img -> decimateBitDepth img
+  ImageRGBF   img -> decimateBitDepth img :: Image PixelRGB8
+  ImageRGBA8  img -> dropAlphaLayer img
+  ImageRGBA16 img -> dropAlphaLayer (decimateBitDepth img :: Image PixelRGBA8)
+  ImageYCbCr8 img -> convertImage img
+  ImageCMYK8  img -> convertImage img
+  ImageCMYK16 img -> convertImage (decimateBitDepth img :: Image PixelCMYK8)
+
+
 -- | Equivalent to 'decodeImage', but also provide potential metadatas
 -- present in the given file.
 decodeImageWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
@@ -306,7 +395,7 @@ readGifImages = withImageDecoder decodeGifImages
 readJpeg :: FilePath -> IO (Either String DynamicImage)
 readJpeg = withImageDecoder decodeJpeg
 
--- | Try to load a .bmp file. The colorspace would be RGB or Y.
+-- | Try to load a .bmp file. The colorspace would be RGB, RGBA or Y.
 readBitmap :: FilePath -> IO (Either String DynamicImage)
 readBitmap = withImageDecoder decodeBitmap
 

src/Codec/Picture/BitWriter.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP #-}
 -- | This module implement helper functions to read & write data
 -- at bits level.
@@ -9,7 +10,9 @@ module Codec.Picture.BitWriter( BoolReader
                               , getNextBitsLSBFirst
                               , getNextBitsMSBFirst 
                               , getNextBitJpg
+                              , getNextIntJpg
                               , setDecodedString
+                              , setDecodedStringMSB
                               , setDecodedStringJpg
                               , runBoolReader
 
@@ -33,6 +36,7 @@ import Data.STRef
 import Control.Monad( when )
 import Control.Monad.ST( ST )
 import qualified Control.Monad.Trans.State.Strict as S
+import Data.Int ( Int32 )
 import Data.Word( Word8, Word32 )
 import Data.Bits( (.&.), (.|.), unsafeShiftR, unsafeShiftL )
 
@@ -42,6 +46,7 @@ import qualified Data.Vector.Storable as VS
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 
+
 --------------------------------------------------
 ----            Reader
 --------------------------------------------------
@@ -93,8 +98,8 @@ byteAlignJpg = do
   BoolState idx _ chain <- S.get
   when (idx /= 7) (setDecodedStringJpg chain)
 
-{-# INLINE getNextBitJpg #-}
 getNextBitJpg :: BoolReader s Bool
+{-# INLINE getNextBitJpg #-}
 getNextBitJpg = do
     BoolState idx v chain <- S.get
     let val = (v .&. (1 `unsafeShiftL` idx)) /= 0
@@ -103,25 +108,51 @@ getNextBitJpg = do
       else S.put $ BoolState (idx - 1) v chain
     return val
 
-{-# INLINE getNextBitMSB #-}
-getNextBitMSB :: BoolReader s Bool
-getNextBitMSB = do
+getNextIntJpg :: Int -> BoolReader s Int32
+{-# INLINE getNextIntJpg #-}
+getNextIntJpg = go 0 where
+  go !acc !0 = return acc
+  go !acc !n = do
     BoolState idx v chain <- S.get
-    let val = (v .&. (1 `unsafeShiftL` (7 - idx))) /= 0
-    if idx == 7
-      then setDecodedString chain
-      else S.put $ BoolState (idx + 1) v chain
-    return val
+    let !leftBits = 1 + fromIntegral idx
+    if n >= leftBits then do
+      setDecodedStringJpg chain
+      let !remaining = n - leftBits
+          !mask = (1 `unsafeShiftL` leftBits) - 1
+          !finalV = fromIntegral v .&. mask
+          !theseBits = finalV `unsafeShiftL` remaining
+      go (acc .|. theseBits) remaining
+    else do
+      let !remaining = leftBits - n
+          !mask = (1 `unsafeShiftL` n) - 1
+          !finalV = fromIntegral v `unsafeShiftR` remaining
+      S.put $ BoolState (fromIntegral remaining - 1) v chain
+      return $ (finalV .&. mask) .|. acc
+
+
+setDecodedStringMSB :: B.ByteString -> BoolReader s ()
+setDecodedStringMSB str = case B.uncons str of
+  Nothing        -> S.put $ BoolState      8 0 B.empty
+  Just (v, rest) -> S.put $ BoolState      8 v    rest
+
 
 {-# INLINE getNextBitsMSBFirst #-}
 getNextBitsMSBFirst :: Int -> BoolReader s Word32
-getNextBitsMSBFirst = aux 0
-  where aux acc 0 = return acc
-        aux acc n = do
-            bit <- getNextBitMSB
-            let nextVal | bit = (acc `unsafeShiftL` 1) .|. 1
-                        | otherwise = acc `unsafeShiftL` 1
-            aux nextVal (n - 1)
+getNextBitsMSBFirst requested = go 0 requested where
+  go :: Word32 -> Int -> BoolReader s Word32
+  go !acc !0 = return acc
+  go !acc !n = do
+    BoolState idx v chain <- S.get
+    let !leftBits = fromIntegral idx
+    if n >= leftBits then do
+      setDecodedStringMSB chain
+      let !theseBits = fromIntegral v `unsafeShiftL` (n - leftBits)
+      go (acc .|. theseBits) (n - leftBits)
+    else do
+      let !remaining = leftBits - n
+          !mask = (1 `unsafeShiftL` remaining) - 1
+      S.put $ BoolState (fromIntegral remaining) (v .&. mask) chain
+      return $ (fromIntegral v `unsafeShiftR` remaining) .|. acc
 
 {-# INLINE getNextBitsLSBFirst #-}
 getNextBitsLSBFirst :: Int -> BoolReader s Word32