diff --git a/Codec/BMP.hs b/Codec/BMP.hs --- a/Codec/BMP.hs +++ b/Codec/BMP.hs @@ -37,29 +37,29 @@ -- > size stated in the header, to accept output of foolish Win7 codec. -- module Codec.BMP - ( -- * Data Structures - BMP (..) - , FileHeader (..) - , BitmapInfo (..) - , BitmapInfoV3 (..) - , BitmapInfoV4 (..) - , BitmapInfoV5 (..) - , Compression (..) - , CIEXYZ (..) - , Error (..) + ( -- * Data Structures + BMP (..) + , FileHeader (..) + , BitmapInfo (..) + , BitmapInfoV3 (..) + , BitmapInfoV4 (..) + , BitmapInfoV5 (..) + , Compression (..) + , CIEXYZ (..) + , Error (..) -- * Reading - , readBMP, hGetBMP, parseBMP + , readBMP, hGetBMP, parseBMP -- * Writing - , writeBMP, hPutBMP, renderBMP + , writeBMP, hPutBMP, renderBMP -- * Pack and Unpack - , packRGBA32ToBMP + , packRGBA32ToBMP , packRGBA32ToBMP32 , packRGBA32ToBMP24 - , unpackBMPToRGBA32 - , bmpDimensions) + , unpackBMPToRGBA32 + , bmpDimensions) where import Codec.BMP.Base import Codec.BMP.Error @@ -71,8 +71,8 @@ import Codec.BMP.BitmapInfoV4 import Codec.BMP.BitmapInfoV5 import System.IO -import Data.ByteString as BS -import Data.ByteString.Lazy as BSL +import Data.ByteString as BS +import Data.ByteString.Lazy as BSL import Data.Binary import Data.Binary.Get @@ -82,14 +82,14 @@ -- If there is anything wrong this gives an `Error` instead. readBMP :: FilePath -> IO (Either Error BMP) readBMP fileName - = do h <- openBinaryFile fileName ReadMode - hGetBMP h - + = do h <- openBinaryFile fileName ReadMode + hGetBMP h + -- | Get a BMP image from a file handle. hGetBMP :: Handle -> IO (Either Error BMP) hGetBMP h - = do -- lazily load the whole file - buf <- BSL.hGetContents h + = do -- lazily load the whole file + buf <- BSL.hGetContents h return $ parseBMP buf @@ -97,27 +97,27 @@ parseBMP :: BSL.ByteString -> Either Error BMP parseBMP buf = let -- split off the file header - (bufFileHeader, bufRest) - = BSL.splitAt (fromIntegral sizeOfFileHeader) buf + (bufFileHeader, bufRest) + = BSL.splitAt (fromIntegral sizeOfFileHeader) buf in if (fromIntegral $ BSL.length bufFileHeader) /= sizeOfFileHeader - then Left ErrorFileHeaderTruncated - else parseBMP2 bufRest (decode bufFileHeader) - + then Left ErrorFileHeaderTruncated + else parseBMP2 bufRest (decode bufFileHeader) + parseBMP2 buf fileHeader -- Check the magic before doing anything else. | fileHeaderType fileHeader /= bmpMagic = Left $ ErrorBadMagic (fileHeaderType fileHeader) - + | otherwise - = let -- Next comes the image header. - -- The first word tells us how long it is. - sizeHeader = runGet getWord32le buf - - -- split off the image header - (bufImageHeader, bufRest) - = BSL.splitAt (fromIntegral sizeHeader) buf + = let -- Next comes the image header. + -- The first word tells us how long it is. + sizeHeader = runGet getWord32le buf + -- split off the image header + (bufImageHeader, bufRest) + = BSL.splitAt (fromIntegral sizeHeader) buf + -- How much non-header data is present in the file. -- For uncompressed data without a colour table, the remaining data -- should be the image, but there may also be padding bytes on the @@ -126,67 +126,67 @@ = (fromIntegral $ BSL.length bufRest) :: Word32 in if (fromIntegral $ BSL.length bufImageHeader) /= sizeHeader - then Left ErrorImageHeaderTruncated - else parseBMP3 fileHeader bufImageHeader bufRest physicalBufferSize + then Left ErrorImageHeaderTruncated + else parseBMP3 fileHeader bufImageHeader bufRest physicalBufferSize parseBMP3 fileHeader bufImageHeader bufRest physicalBufferSize - | BSL.length bufImageHeader == 40 - = let info = decode bufImageHeader - in case checkBitmapInfoV3 info physicalBufferSize of - Just err -> Left err - Nothing + | BSL.length bufImageHeader == 40 + = let info = decode bufImageHeader + in case checkBitmapInfoV3 info physicalBufferSize of + Just err -> Left err + Nothing | Just imageSize <- imageSizeFromBitmapInfoV3 info -> parseBMP4 fileHeader (InfoV3 info) bufRest imageSize | otherwise -> Left $ ErrorInternalErrorPleaseReport - | BSL.length bufImageHeader == 108 - = let info = decode bufImageHeader - in case checkBitmapInfoV4 info physicalBufferSize of - Just err -> Left err - Nothing + | BSL.length bufImageHeader == 108 + = let info = decode bufImageHeader + in case checkBitmapInfoV4 info physicalBufferSize of + Just err -> Left err + Nothing | Just imageSize <- imageSizeFromBitmapInfoV4 info -> parseBMP4 fileHeader (InfoV4 info) bufRest imageSize | otherwise -> Left $ ErrorInternalErrorPleaseReport - - | BSL.length bufImageHeader == 124 - = let info = decode bufImageHeader - in case checkBitmapInfoV5 info physicalBufferSize of - Just err -> Left err - Nothing + + | BSL.length bufImageHeader == 124 + = let info = decode bufImageHeader + in case checkBitmapInfoV5 info physicalBufferSize of + Just err -> Left err + Nothing | Just imageSize <- imageSizeFromBitmapInfoV5 info -> parseBMP4 fileHeader (InfoV5 info) bufRest imageSize | otherwise -> Left $ ErrorInternalErrorPleaseReport - - | otherwise - = Left $ ErrorUnhandledBitmapHeaderSize + + | otherwise + = Left $ ErrorUnhandledBitmapHeaderSize $ fromIntegral $ BSL.length bufImageHeader parseBMP4 fileHeader imageHeader bufImage (sizeImage :: Int) = let bufLen = fromIntegral $ BSL.length bufImage in if bufLen < sizeImage - then Left $ ErrorImageDataTruncated sizeImage bufLen - else Right $ BMP - { bmpFileHeader = fileHeader - , bmpBitmapInfo = imageHeader - , bmpRawImageData = BS.concat $ BSL.toChunks bufImage } + then Left $ ErrorImageDataTruncated sizeImage bufLen + else Right $ BMP + { bmpFileHeader = fileHeader + , bmpBitmapInfo = imageHeader + , bmpRawImageData = BS.concat $ BSL.toChunks bufImage } -- Writing -------------------------------------------------------------------- -- | Wrapper for `hPutBMP` writeBMP :: FilePath -> BMP -> IO () writeBMP fileName bmp - = do h <- openBinaryFile fileName WriteMode - hPutBMP h bmp - hFlush h - hClose h + = do h <- openBinaryFile fileName WriteMode + hPutBMP h bmp + hFlush h + hClose h -- | Put a BMP image to a file handle. @@ -204,11 +204,11 @@ -- | Get the width and height of an image. --- It's better to use this function than to access the headers directly. +-- It's better to use this function than to access the headers directly. bmpDimensions :: BMP -> (Int, Int) -bmpDimensions bmp - = let info = getBitmapInfoV3 $ bmpBitmapInfo bmp - in ( fromIntegral $ dib3Width info - , fromIntegral $ dib3Height info) +bmpDimensions bmp + = let info = getBitmapInfoV3 $ bmpBitmapInfo bmp + in ( fromIntegral $ dib3Width info + , fromIntegral $ dib3Height info) diff --git a/Codec/BMP/Base.hs b/Codec/BMP/Base.hs --- a/Codec/BMP/Base.hs +++ b/Codec/BMP/Base.hs @@ -1,6 +1,6 @@ {-# OPTIONS_HADDOCK hide #-} module Codec.BMP.Base - ( BMP (..)) + ( BMP (..)) where import Codec.BMP.FileHeader import Codec.BMP.BitmapInfo @@ -8,14 +8,14 @@ -- | A BMP image. --- For an uncompressed image, the image data contains triples of BGR +-- For an uncompressed image, the image data contains triples of BGR -- component values. Each line may also have zero pad values on the end, -- to bring them up to a multiple of 4 bytes in length. data BMP - = BMP - { bmpFileHeader :: FileHeader - , bmpBitmapInfo :: BitmapInfo - , bmpRawImageData :: ByteString } - deriving Show + = BMP + { bmpFileHeader :: FileHeader + , bmpBitmapInfo :: BitmapInfo + , bmpRawImageData :: ByteString } + deriving Show diff --git a/Codec/BMP/BitmapInfo.hs b/Codec/BMP/BitmapInfo.hs --- a/Codec/BMP/BitmapInfo.hs +++ b/Codec/BMP/BitmapInfo.hs @@ -1,7 +1,7 @@ {-# OPTIONS_HADDOCK hide #-} module Codec.BMP.BitmapInfo - ( BitmapInfo (..) - , getBitmapInfoV3) + ( BitmapInfo (..) + , getBitmapInfoV3) where import Codec.BMP.BitmapInfoV3 @@ -15,10 +15,10 @@ -- | A wrapper for the various image header types. -- data BitmapInfo - = InfoV3 BitmapInfoV3 - | InfoV4 BitmapInfoV4 - | InfoV5 BitmapInfoV5 - deriving (Show) + = InfoV3 BitmapInfoV3 + | InfoV4 BitmapInfoV4 + | InfoV5 BitmapInfoV5 + deriving (Show) instance Binary BitmapInfo where @@ -36,25 +36,25 @@ return $ InfoV5 info) <|> (error "Codec.BMP.BitmapInfo.get: unhandled header size") - + put xx = case xx of - InfoV3 info -> put info - InfoV4 info -> put info - InfoV5 info -> put info - + InfoV3 info -> put info + InfoV4 info -> put info + InfoV5 info -> put info + -- | Get the common `BitmapInfoV3` structure from a `BitmapInfo` getBitmapInfoV3 :: BitmapInfo -> BitmapInfoV3 getBitmapInfoV3 bi = case bi of - InfoV3 info -> info - InfoV4 info -> dib4InfoV3 info - InfoV5 info -> dib4InfoV3 $ dib5InfoV4 info - + InfoV3 info -> info + InfoV4 info -> dib4InfoV3 info + InfoV5 info -> dib4InfoV3 $ dib5InfoV4 info + - - - - - + + + + + diff --git a/Codec/BMP/BitmapInfoV3.hs b/Codec/BMP/BitmapInfoV3.hs --- a/Codec/BMP/BitmapInfoV3.hs +++ b/Codec/BMP/BitmapInfoV3.hs @@ -1,15 +1,15 @@ {-# OPTIONS_HADDOCK hide #-} module Codec.BMP.BitmapInfoV3 - ( BitmapInfoV3 (..) - , Compression (..) - , sizeOfBitmapInfoV3 - , checkBitmapInfoV3 + ( BitmapInfoV3 (..) + , Compression (..) + , sizeOfBitmapInfoV3 + , checkBitmapInfoV3 , imageSizeFromBitmapInfoV3) where import Codec.BMP.Error import Codec.BMP.Compression import Data.Binary -import Data.Binary.Get +import Data.Binary.Get import Data.Binary.Put import Data.Int import Debug.Trace @@ -17,50 +17,50 @@ -- | Device Independent Bitmap (DIB) header for Windows V3. data BitmapInfoV3 - = BitmapInfoV3 - { -- | (+0) Size of the image header, in bytes. - dib3Size :: Word32 + = BitmapInfoV3 + { -- | (+0) Size of the image header, in bytes. + dib3Size :: Word32 - -- | (+4) Width of the image, in pixels. - , dib3Width :: Word32 - - -- | (+8) Height of the image, in pixels. - , dib3Height :: Word32 - + -- | (+4) Width of the image, in pixels. + , dib3Width :: Word32 + + -- | (+8) Height of the image, in pixels. + , dib3Height :: Word32 + -- | If the height field in the file is negative then this is interpreted -- as an image with the rows flipped. , dib3HeightFlipped :: Bool - -- | (+12) Number of color planes. - , dib3Planes :: Word16 + -- | (+12) Number of color planes. + , dib3Planes :: Word16 - -- | (+14) Number of bits per pixel. - , dib3BitCount :: Word16 + -- | (+14) Number of bits per pixel. + , dib3BitCount :: Word16 - -- | (+16) Image compression mode. - , dib3Compression :: Compression + -- | (+16) Image compression mode. + , dib3Compression :: Compression - -- | (+20) Size of raw image data. - -- Some encoders set this to zero, so we need to calculate it based + -- | (+20) Size of raw image data. + -- Some encoders set this to zero, so we need to calculate it based -- on the overall file size. - -- - -- If it is non-zero then we check it matches the file size - header + -- + -- If it is non-zero then we check it matches the file size - header -- size. - , dib3ImageSize :: Word32 + , dib3ImageSize :: Word32 - -- | (+24) Prefered resolution in pixels per meter, along the X axis. - , dib3PelsPerMeterX :: Word32 + -- | (+24) Prefered resolution in pixels per meter, along the X axis. + , dib3PelsPerMeterX :: Word32 - -- | (+28) Prefered resolution in pixels per meter, along the Y axis. - , dib3PelsPerMeterY :: Word32 + -- | (+28) Prefered resolution in pixels per meter, along the Y axis. + , dib3PelsPerMeterY :: Word32 - -- | (+32) Number of color entries that are used. - , dib3ColorsUsed :: Word32 + -- | (+32) Number of color entries that are used. + , dib3ColorsUsed :: Word32 - -- | (+36) Number of significant colors. - , dib3ColorsImportant :: Word32 - } - deriving (Show) + -- | (+36) Number of significant colors. + , dib3ColorsImportant :: Word32 + } + deriving (Show) -- | Size of `BitmapInfoV3` header (in bytes) @@ -70,68 +70,68 @@ instance Binary BitmapInfoV3 where get - = do size <- getWord32le - width <- getWord32le + = do size <- getWord32le + width <- getWord32le -- We're supposed to treat the height field as a signed integer. -- If it's negative it means the image is flipped along the X axis. -- (which is crazy, but we just have to eat it) - heightW32 <- getWord32le + heightW32 <- getWord32le let heightI32 = (fromIntegral heightW32 :: Int32) let (height, flipped) = if heightI32 < 0 then (fromIntegral (abs heightI32), True) else (heightW32, False) - planes <- getWord16le - bitc <- getWord16le - comp <- get - imgsize <- getWord32le - pelsX <- getWord32le - pelsY <- getWord32le - cused <- getWord32le - cimp <- getWord32le - - return $ BitmapInfoV3 - { dib3Size = size - , dib3Width = width - , dib3Height = height + planes <- getWord16le + bitc <- getWord16le + comp <- get + imgsize <- getWord32le + pelsX <- getWord32le + pelsY <- getWord32le + cused <- getWord32le + cimp <- getWord32le + + return $ BitmapInfoV3 + { dib3Size = size + , dib3Width = width + , dib3Height = height , dib3HeightFlipped = flipped - , dib3Planes = planes - , dib3BitCount = bitc - , dib3Compression = comp - , dib3ImageSize = imgsize - , dib3PelsPerMeterX = pelsX - , dib3PelsPerMeterY = pelsY - , dib3ColorsUsed = cused - , dib3ColorsImportant = cimp } + , dib3Planes = planes + , dib3BitCount = bitc + , dib3Compression = comp + , dib3ImageSize = imgsize + , dib3PelsPerMeterX = pelsX + , dib3PelsPerMeterY = pelsY + , dib3ColorsUsed = cused + , dib3ColorsImportant = cimp } put header - = do putWord32le $ dib3Size header - putWord32le $ dib3Width header - putWord32le $ dib3Height header - putWord16le $ dib3Planes header - putWord16le $ dib3BitCount header - put $ dib3Compression header - putWord32le $ dib3ImageSize header - putWord32le $ dib3PelsPerMeterX header - putWord32le $ dib3PelsPerMeterY header - putWord32le $ dib3ColorsUsed header - putWord32le $ dib3ColorsImportant header - - --- | Check headers for problems and unsupported features. + = do putWord32le $ dib3Size header + putWord32le $ dib3Width header + putWord32le $ dib3Height header + putWord16le $ dib3Planes header + putWord16le $ dib3BitCount header + put $ dib3Compression header + putWord32le $ dib3ImageSize header + putWord32le $ dib3PelsPerMeterX header + putWord32le $ dib3PelsPerMeterY header + putWord32le $ dib3ColorsUsed header + putWord32le $ dib3ColorsImportant header + + +-- | Check headers for problems and unsupported features. checkBitmapInfoV3 :: BitmapInfoV3 -> Word32 -> Maybe Error checkBitmapInfoV3 header physicalBufferSize -- We only handle a single color plane. - | dib3Planes header /= 1 - = Just $ ErrorUnhandledPlanesCount $ dib3Planes header - + | dib3Planes header /= 1 + = Just $ ErrorUnhandledPlanesCount $ dib3Planes header + -- We only handle 24 and 32 bit images. - | dib3BitCount header /= 24 + | dib3BitCount header /= 24 , dib3BitCount header /= 32 - = Just $ ErrorUnhandledColorDepth $ dib3BitCount header + = Just $ ErrorUnhandledColorDepth $ dib3BitCount header -- If the image size field in the header is non-zero, -- then it must be less than the physical size of the image buffer. @@ -158,9 +158,9 @@ && dib3Compression header /= CompressionBitFields = Just $ ErrorUnhandledCompressionMode (dib3Compression header) - | otherwise - = Nothing - + | otherwise + = Nothing + -- | Compute the size of the image data from the header. -- diff --git a/Codec/BMP/BitmapInfoV4.hs b/Codec/BMP/BitmapInfoV4.hs --- a/Codec/BMP/BitmapInfoV4.hs +++ b/Codec/BMP/BitmapInfoV4.hs @@ -1,47 +1,47 @@ {-# OPTIONS_HADDOCK hide #-} module Codec.BMP.BitmapInfoV4 - ( BitmapInfoV4 (..) - , CIEXYZ (..) - , sizeOfBitmapInfoV4 - , checkBitmapInfoV4 + ( BitmapInfoV4 (..) + , CIEXYZ (..) + , sizeOfBitmapInfoV4 + , checkBitmapInfoV4 , imageSizeFromBitmapInfoV4) where import Codec.BMP.Error import Codec.BMP.CIEXYZ import Codec.BMP.BitmapInfoV3 import Data.Binary -import Data.Binary.Get +import Data.Binary.Get import Data.Binary.Put -- | Device Independent Bitmap (DIB) header for Windows V4 (95 and newer) data BitmapInfoV4 - = BitmapInfoV4 - { -- | Size of the image header, in bytes. - dib4InfoV3 :: BitmapInfoV3 + = BitmapInfoV4 + { -- | Size of the image header, in bytes. + dib4InfoV3 :: BitmapInfoV3 - -- | Color masks specify components of each pixel. - -- Only used with the bitfields compression mode. - , dib4RedMask :: Word32 - , dib4GreenMask :: Word32 - , dib4BlueMask :: Word32 - , dib4AlphaMask :: Word32 + -- | Color masks specify components of each pixel. + -- Only used with the bitfields compression mode. + , dib4RedMask :: Word32 + , dib4GreenMask :: Word32 + , dib4BlueMask :: Word32 + , dib4AlphaMask :: Word32 - -- | The color space used by the image. - , dib4ColorSpaceType :: Word32 + -- | The color space used by the image. + , dib4ColorSpaceType :: Word32 - -- | Specifies the XYZ coords of the three colors that correspond to + -- | Specifies the XYZ coords of the three colors that correspond to -- the RGB endpoints for the logical color space associated with the -- bitmap. Only used when ColorSpaceType specifies a calibrated image. - , dib4Endpoints :: (CIEXYZ, CIEXYZ, CIEXYZ) + , dib4Endpoints :: (CIEXYZ, CIEXYZ, CIEXYZ) - -- | Toned response curves for each component. - -- Only used when the ColorSpaceType specifies a calibrated image. - , dib4GammaRed :: Word32 - , dib4GammaGreen :: Word32 - , dib4GammaBlue :: Word32 - } - deriving (Show) + -- | Toned response curves for each component. + -- Only used when the ColorSpaceType specifies a calibrated image. + , dib4GammaRed :: Word32 + , dib4GammaGreen :: Word32 + , dib4GammaBlue :: Word32 + } + deriving (Show) -- | Size of `BitmapInfoV4` header (in bytes) @@ -51,53 +51,53 @@ instance Binary BitmapInfoV4 where get - = do infoV3 <- get - rmask <- getWord32le - gmask <- getWord32le - bmask <- getWord32le - amask <- getWord32le - cstype <- getWord32le - ends <- get - rgamma <- getWord32le - ggamma <- getWord32le - bgamma <- getWord32le - - return $ BitmapInfoV4 - { dib4InfoV3 = infoV3 - , dib4RedMask = rmask - , dib4GreenMask = gmask - , dib4BlueMask = bmask - , dib4AlphaMask = amask - , dib4ColorSpaceType = cstype - , dib4Endpoints = ends - , dib4GammaRed = rgamma - , dib4GammaGreen = ggamma - , dib4GammaBlue = bgamma } - + = do infoV3 <- get + rmask <- getWord32le + gmask <- getWord32le + bmask <- getWord32le + amask <- getWord32le + cstype <- getWord32le + ends <- get + rgamma <- getWord32le + ggamma <- getWord32le + bgamma <- getWord32le + + return $ BitmapInfoV4 + { dib4InfoV3 = infoV3 + , dib4RedMask = rmask + , dib4GreenMask = gmask + , dib4BlueMask = bmask + , dib4AlphaMask = amask + , dib4ColorSpaceType = cstype + , dib4Endpoints = ends + , dib4GammaRed = rgamma + , dib4GammaGreen = ggamma + , dib4GammaBlue = bgamma } + put header - = do put $ dib4InfoV3 header - putWord32le $ dib4RedMask header - putWord32le $ dib4GreenMask header - putWord32le $ dib4BlueMask header - putWord32le $ dib4AlphaMask header - putWord32le $ dib4ColorSpaceType header - put $ dib4Endpoints header - putWord32le $ dib4GammaRed header - putWord32le $ dib4GammaGreen header - putWord32le $ dib4GammaBlue header + = do put $ dib4InfoV3 header + putWord32le $ dib4RedMask header + putWord32le $ dib4GreenMask header + putWord32le $ dib4BlueMask header + putWord32le $ dib4AlphaMask header + putWord32le $ dib4ColorSpaceType header + put $ dib4Endpoints header + putWord32le $ dib4GammaRed header + putWord32le $ dib4GammaGreen header + putWord32le $ dib4GammaBlue header - --- | Check headers for problems and unsupported features. --- With a V4 header we support both the uncompressed 24bit RGB format, --- and the uncompressed 32bit RGBA format. + +-- | Check headers for problems and unsupported features. +-- With a V4 header we support both the uncompressed 24bit RGB format, +-- and the uncompressed 32bit RGBA format. -- checkBitmapInfoV4 :: BitmapInfoV4 -> Word32 -> Maybe Error checkBitmapInfoV4 headerV4 physicalBufferSize - + -- We only handle a single color plane. - | dib3Planes headerV3 /= 1 - = Just $ ErrorUnhandledPlanesCount $ dib3Planes headerV3 + | dib3Planes headerV3 /= 1 + = Just $ ErrorUnhandledPlanesCount $ dib3Planes headerV3 -- We only handle 24 and 32 bit images. | dib3BitCount headerV3 /= 24 @@ -124,31 +124,31 @@ (fromIntegral physicalBufferSize) - -- Check for valid compression modes ---- + -- Check for valid compression modes ---- -- uncompressed 32bit RGBA stated as CompressionRGB. | dib3BitCount headerV3 == 32 , dib3Compression headerV3 == CompressionRGB = Nothing - - -- uncompressed 32bit RGBA stated as CompressionBitFields. - | dib3BitCount headerV3 == 32 - , dib3Compression headerV3 == CompressionBitFields - , dib4AlphaMask headerV4 == 0xff000000 - , dib4RedMask headerV4 == 0x00ff0000 - , dib4GreenMask headerV4 == 0x0000ff00 - , dib4BlueMask headerV4 == 0x000000ff - = Nothing + + -- uncompressed 32bit RGBA stated as CompressionBitFields. + | dib3BitCount headerV3 == 32 + , dib3Compression headerV3 == CompressionBitFields + , dib4AlphaMask headerV4 == 0xff000000 + , dib4RedMask headerV4 == 0x00ff0000 + , dib4GreenMask headerV4 == 0x0000ff00 + , dib4BlueMask headerV4 == 0x000000ff + = Nothing -- uncompressed 24bit RGB | dib3BitCount headerV3 == 24 , dib3Compression headerV3 == CompressionRGB = Nothing - - -- Some unsupported compression mode ---- - | otherwise - = Just $ ErrorUnhandledCompressionMode (dib3Compression headerV3) - - where headerV3 = dib4InfoV3 headerV4 + + -- Some unsupported compression mode ---- + | otherwise + = Just $ ErrorUnhandledCompressionMode (dib3Compression headerV3) + + where headerV3 = dib4InfoV3 headerV4 -- | Compute the size of the image data from the header. diff --git a/Codec/BMP/BitmapInfoV5.hs b/Codec/BMP/BitmapInfoV5.hs --- a/Codec/BMP/BitmapInfoV5.hs +++ b/Codec/BMP/BitmapInfoV5.hs @@ -1,36 +1,36 @@ {-# OPTIONS_HADDOCK hide #-} module Codec.BMP.BitmapInfoV5 - ( BitmapInfoV5 (..) - , sizeOfBitmapInfoV5 - , checkBitmapInfoV5 + ( BitmapInfoV5 (..) + , sizeOfBitmapInfoV5 + , checkBitmapInfoV5 , imageSizeFromBitmapInfoV5) where import Codec.BMP.Error import Codec.BMP.BitmapInfoV4 import Data.Binary -import Data.Binary.Get +import Data.Binary.Get import Data.Binary.Put -- | Device Independent Bitmap (DIB) header for Windows V5 (98/2000 and newer) data BitmapInfoV5 - = BitmapInfoV5 - { dib5InfoV4 :: BitmapInfoV4 - - -- | Rendering intent for the bitmap. - , dib5Intent :: Word32 + = BitmapInfoV5 + { dib5InfoV4 :: BitmapInfoV4 + + -- | Rendering intent for the bitmap. + , dib5Intent :: Word32 - -- | Offset (in bytes) from the beginning of the header to the start + -- | Offset (in bytes) from the beginning of the header to the start -- of the profile data. - , dib5ProfileData :: Word32 + , dib5ProfileData :: Word32 - -- | Size (in bytes) of embedded profile data. - , dib5ProfileSize :: Word32 - - -- | Reserved, should be zero. - , dib5Reserved :: Word32 - } - deriving (Show) + -- | Size (in bytes) of embedded profile data. + , dib5ProfileSize :: Word32 + + -- | Reserved, should be zero. + , dib5Reserved :: Word32 + } + deriving (Show) -- | Size of `BitmapInfoV5` header (in bytes) sizeOfBitmapInfoV5 :: Int @@ -39,33 +39,33 @@ instance Binary BitmapInfoV5 where get - = do infoV4 <- get - intent <- getWord32le - pdata <- getWord32le - psize <- getWord32le - res <- getWord32le - - return $ BitmapInfoV5 - { dib5InfoV4 = infoV4 - , dib5Intent = intent - , dib5ProfileData = pdata - , dib5ProfileSize = psize - , dib5Reserved = res } - + = do infoV4 <- get + intent <- getWord32le + pdata <- getWord32le + psize <- getWord32le + res <- getWord32le + + return $ BitmapInfoV5 + { dib5InfoV4 = infoV4 + , dib5Intent = intent + , dib5ProfileData = pdata + , dib5ProfileSize = psize + , dib5Reserved = res } + put header - = do put $ dib5InfoV4 header - putWord32le $ dib5Intent header - putWord32le $ dib5ProfileData header - putWord32le $ dib5ProfileSize header - putWord32le $ dib5Reserved header + = do put $ dib5InfoV4 header + putWord32le $ dib5Intent header + putWord32le $ dib5ProfileData header + putWord32le $ dib5ProfileSize header + putWord32le $ dib5Reserved header - --- | Check headers for problems and unsupported features. --- The V5 header doesn't give us any more useful info than the V4 one. + +-- | Check headers for problems and unsupported features. +-- The V5 header doesn't give us any more useful info than the V4 one. checkBitmapInfoV5 :: BitmapInfoV5 -> Word32 -> Maybe Error checkBitmapInfoV5 header expectedImageSize - = checkBitmapInfoV4 (dib5InfoV4 header) expectedImageSize + = checkBitmapInfoV4 (dib5InfoV4 header) expectedImageSize -- | Compute the size of the image data from the header. diff --git a/Codec/BMP/CIEXYZ.hs b/Codec/BMP/CIEXYZ.hs --- a/Codec/BMP/CIEXYZ.hs +++ b/Codec/BMP/CIEXYZ.hs @@ -1,6 +1,6 @@ module Codec.BMP.CIEXYZ - (CIEXYZ(..)) + (CIEXYZ(..)) where import Data.Word import Data.Binary @@ -11,19 +11,19 @@ -- | Contains the XYZ coordinates of a specific color in a specified color -- space. data CIEXYZ - = CIEXYZ Word32 Word32 Word32 - deriving Show + = CIEXYZ Word32 Word32 Word32 + deriving Show instance Binary CIEXYZ where get - = do r <- getWord32le - g <- getWord32le - b <- getWord32le - return $ CIEXYZ r g b - + = do r <- getWord32le + g <- getWord32le + b <- getWord32le + return $ CIEXYZ r g b + put (CIEXYZ r g b) - = do putWord32le r - putWord32le g - putWord32le b + = do putWord32le r + putWord32le g + putWord32le b diff --git a/Codec/BMP/Error.hs b/Codec/BMP/Error.hs --- a/Codec/BMP/Error.hs +++ b/Codec/BMP/Error.hs @@ -1,6 +1,6 @@ {-# OPTIONS_HADDOCK hide #-} module Codec.BMP.Error - (Error(..)) + (Error(..)) where import Codec.BMP.Compression import Data.Word @@ -14,39 +14,39 @@ { errorMagic :: Word16 } -- | File is too short to contain a file header. - | ErrorFileHeaderTruncated + | ErrorFileHeaderTruncated -- | File is too short to contain an image header. - | ErrorImageHeaderTruncated + | ErrorImageHeaderTruncated -- | File is too short to contain the image data. - | ErrorImageDataTruncated + | ErrorImageDataTruncated { errorBytesNeeded :: Int , errorBytesAvailable :: Int } -- | Reserved fields should be zero. - | ErrorReservedFieldNotZero + | ErrorReservedFieldNotZero -- | The offset to the image data from the file header doesn't -- point anywhere sensible. - | ErrorDodgyFileHeaderFieldOffset + | ErrorDodgyFileHeaderFieldOffset { errorFileHeaderOffset :: Word32 } -- | We handle V3 V4 and V5 image headers, but the size of -- the header indicates it has some other format. - | ErrorUnhandledBitmapHeaderSize + | ErrorUnhandledBitmapHeaderSize { errorBitmapHeaderSize :: Word32 } -- | We only handle single color planes. - | ErrorUnhandledPlanesCount + | ErrorUnhandledPlanesCount { errorPlanesCount :: Word16 } -- | We only handle 24 and 32 bit images. - | ErrorUnhandledColorDepth + | ErrorUnhandledColorDepth { errorColorDepth :: Word16 } -- | We only handle uncompressed images. - | ErrorUnhandledCompressionMode + | ErrorUnhandledCompressionMode { errorCompression :: Compression} -- | Mismatch between the image size stated in the header @@ -57,5 +57,5 @@ -- | Something went wrong in the library. | ErrorInternalErrorPleaseReport - deriving (Eq, Show) + deriving (Eq, Show) diff --git a/Codec/BMP/FileHeader.hs b/Codec/BMP/FileHeader.hs --- a/Codec/BMP/FileHeader.hs +++ b/Codec/BMP/FileHeader.hs @@ -1,36 +1,36 @@ {-# OPTIONS_HADDOCK hide #-} module Codec.BMP.FileHeader - ( FileHeader (..) - , bmpMagic - , sizeOfFileHeader - , checkFileHeader) + ( FileHeader (..) + , bmpMagic + , sizeOfFileHeader + , checkFileHeader) where import Codec.BMP.BitmapInfoV3 import Codec.BMP.Error import Data.Binary -import Data.Binary.Get +import Data.Binary.Get import Data.Binary.Put -- | BMP file header. data FileHeader - = FileHeader - { -- | (+0) Magic numbers 0x42 0x4d - fileHeaderType :: Word16 - - -- | (+2) Size of the file, in bytes. - , fileHeaderFileSize :: Word32 + = FileHeader + { -- | (+0) Magic numbers 0x42 0x4d + fileHeaderType :: Word16 + + -- | (+2) Size of the file, in bytes. + , fileHeaderFileSize :: Word32 - -- | (+6) Reserved, must be zero. - , fileHeaderReserved1 :: Word16 + -- | (+6) Reserved, must be zero. + , fileHeaderReserved1 :: Word16 - -- | (+8) Reserved, must be zero. - , fileHeaderReserved2 :: Word16 + -- | (+8) Reserved, must be zero. + , fileHeaderReserved2 :: Word16 - -- | (+10) Offset in bytes to the start of the pixel data. - , fileHeaderOffset :: Word32 - } - deriving (Show) + -- | (+10) Offset in bytes to the start of the pixel data. + , fileHeaderOffset :: Word32 + } + deriving (Show) -- | Size of a file header (in bytes). @@ -45,32 +45,32 @@ instance Binary FileHeader where get - = do t <- getWord16le - size <- getWord32le - res1 <- getWord16le - res2 <- getWord16le - offset <- getWord32le - - return $ FileHeader - { fileHeaderType = t - , fileHeaderFileSize = size - , fileHeaderReserved1 = res1 - , fileHeaderReserved2 = res2 - , fileHeaderOffset = offset } + = do t <- getWord16le + size <- getWord32le + res1 <- getWord16le + res2 <- getWord16le + offset <- getWord32le + + return $ FileHeader + { fileHeaderType = t + , fileHeaderFileSize = size + , fileHeaderReserved1 = res1 + , fileHeaderReserved2 = res2 + , fileHeaderOffset = offset } put header - = do putWord16le $ fileHeaderType header - putWord32le $ fileHeaderFileSize header - putWord16le $ fileHeaderReserved1 header - putWord16le $ fileHeaderReserved2 header - putWord32le $ fileHeaderOffset header - + = do putWord16le $ fileHeaderType header + putWord32le $ fileHeaderFileSize header + putWord16le $ fileHeaderReserved1 header + putWord16le $ fileHeaderReserved2 header + putWord32le $ fileHeaderOffset header + -- | Check a file header for problems and unsupported features. -checkFileHeader :: FileHeader -> Maybe Error +checkFileHeader :: FileHeader -> Maybe Error checkFileHeader header - | fileHeaderType header /= bmpMagic - = Just $ ErrorBadMagic (fileHeaderType header) + | fileHeaderType header /= bmpMagic + = Just $ ErrorBadMagic (fileHeaderType header) | fileHeaderFileSize header < fromIntegral sizeOfFileHeader @@ -80,16 +80,16 @@ < fromIntegral (sizeOfFileHeader + sizeOfBitmapInfoV3) = Just $ ErrorImageHeaderTruncated - | fileHeaderReserved1 header /= 0 - = Just $ ErrorReservedFieldNotZero + | fileHeaderReserved1 header /= 0 + = Just $ ErrorReservedFieldNotZero - | fileHeaderReserved2 header /= 0 - = Just $ ErrorReservedFieldNotZero + | fileHeaderReserved2 header /= 0 + = Just $ ErrorReservedFieldNotZero - | fromIntegral (fileHeaderOffset header) + | fromIntegral (fileHeaderOffset header) /= sizeOfFileHeader + sizeOfBitmapInfoV3 - = Just $ ErrorDodgyFileHeaderFieldOffset - $ fromIntegral $ fileHeaderOffset header + = Just $ ErrorDodgyFileHeaderFieldOffset + $ fromIntegral $ fileHeaderOffset header - | otherwise - = Nothing + | otherwise + = Nothing diff --git a/Codec/BMP/Pack.hs b/Codec/BMP/Pack.hs --- a/Codec/BMP/Pack.hs +++ b/Codec/BMP/Pack.hs @@ -14,9 +14,9 @@ import System.IO.Unsafe import Data.Word import Data.Maybe -import Data.ByteString as BS -import Data.ByteString.Unsafe as BS -import Prelude as P +import Data.ByteString as BS +import Data.ByteString.Unsafe as BS +import Prelude as P -- | Pack a string of RGBA component values into a 32-bit BMP image. @@ -97,167 +97,167 @@ -- | Wrap pre-packed image data into BMP image. -- packDataToBMP - :: Int -- ^ Number of bits per pixel - -> Int -- ^ Width of image (must be positive). - -> Int -- ^ Height of image (must be positive). - -> ByteString -- ^ A string of RGBA component values. + :: Int -- ^ Number of bits per pixel + -> Int -- ^ Width of image (must be positive). + -> Int -- ^ Height of image (must be positive). + -> ByteString -- ^ A string of RGBA component values. -- Must have length (@width * height * 4@) - -> BMP - + -> BMP + packDataToBMP bits width height imageData = let fileHeader - = FileHeader - { fileHeaderType = bmpMagic + = FileHeader + { fileHeaderType = bmpMagic - , fileHeaderFileSize + , fileHeaderFileSize = fromIntegral - $ sizeOfFileHeader + sizeOfBitmapInfoV3 + $ sizeOfFileHeader + sizeOfBitmapInfoV3 + BS.length imageData - , fileHeaderReserved1 = 0 - , fileHeaderReserved2 = 0 - , fileHeaderOffset + , fileHeaderReserved1 = 0 + , fileHeaderReserved2 = 0 + , fileHeaderOffset = fromIntegral (sizeOfFileHeader + sizeOfBitmapInfoV3)} - bitmapInfoV3 - = BitmapInfoV3 - { dib3Size = fromIntegral sizeOfBitmapInfoV3 - , dib3Width = fromIntegral width - , dib3Height = fromIntegral height + bitmapInfoV3 + = BitmapInfoV3 + { dib3Size = fromIntegral sizeOfBitmapInfoV3 + , dib3Width = fromIntegral width + , dib3Height = fromIntegral height , dib3HeightFlipped = False - , dib3Planes = 1 - , dib3BitCount = fromIntegral bits - , dib3Compression = CompressionRGB - , dib3ImageSize = fromIntegral $ BS.length imageData + , dib3Planes = 1 + , dib3BitCount = fromIntegral bits + , dib3Compression = CompressionRGB + , dib3ImageSize = fromIntegral $ BS.length imageData - -- The default resolution seems to be 72 pixels per inch. - -- This equates to 2834 pixels per meter. - -- Dunno WTF this should be in the header though... - , dib3PelsPerMeterX = 2834 - , dib3PelsPerMeterY = 2834 + -- The default resolution seems to be 72 pixels per inch. + -- This equates to 2834 pixels per meter. + -- Dunno WTF this should be in the header though... + , dib3PelsPerMeterX = 2834 + , dib3PelsPerMeterY = 2834 - , dib3ColorsUsed = 0 - , dib3ColorsImportant = 0 } - + , dib3ColorsUsed = 0 + , dib3ColorsImportant = 0 } + -- We might as well check to see if we've made a well-formed BMP file. -- It would be sad if we couldn't read a file we just wrote. - errs = catMaybes - [ checkFileHeader fileHeader - , checkBitmapInfoV3 bitmapInfoV3 + errs = catMaybes + [ checkFileHeader fileHeader + , checkBitmapInfoV3 bitmapInfoV3 (fromIntegral $ BS.length imageData)] - - in case errs of - [] -> BMP - { bmpFileHeader = fileHeader - , bmpBitmapInfo = InfoV3 bitmapInfoV3 - , bmpRawImageData = imageData } - - _ -> error $ "Codec.BMP: Constructed BMP file has errors, sorry." + + in case errs of + [] -> BMP + { bmpFileHeader = fileHeader + , bmpBitmapInfo = InfoV3 bitmapInfoV3 + , bmpRawImageData = imageData } + + _ -> error $ "Codec.BMP: Constructed BMP file has errors, sorry." ++ show errs ------------------------------------------------------------------------------- -- | Pack RGBA data into the format need by BMP image data. packRGBA32ToBGR24 - :: Int -- ^ Width of image. - -> Int -- ^ Height of image. - -> ByteString -- ^ Source bytestring holding the image data. - -> ByteString -- output bytestring. - + :: Int -- ^ Width of image. + -> Int -- ^ Height of image. + -> ByteString -- ^ Source bytestring holding the image data. + -> ByteString -- output bytestring. + packRGBA32ToBGR24 width height str | height * width * 4 /= BS.length str = error "Codec.BMP: Image dimensions don't match input data." | otherwise - = let padPerLine - = case (width * 3) `mod` 4 of - 0 -> 0 - x -> 4 - x - - sizeDest = height * (width * 3 + padPerLine) - in unsafePerformIO - $ allocaBytes sizeDest $ \bufDest -> - BS.unsafeUseAsCString str $ \bufSrc -> - do packRGBA32ToBGR24' width height padPerLine + = let padPerLine + = case (width * 3) `mod` 4 of + 0 -> 0 + x -> 4 - x + + sizeDest = height * (width * 3 + padPerLine) + in unsafePerformIO + $ allocaBytes sizeDest $ \bufDest -> + BS.unsafeUseAsCString str $ \bufSrc -> + do packRGBA32ToBGR24' width height padPerLine (castPtr bufSrc) (castPtr bufDest) - bs <- packCStringLen (bufDest, sizeDest) - return bs - - + bs <- packCStringLen (bufDest, sizeDest) + return bs + + packRGBA32ToBGR24' width height pad ptrSrc ptrDest = go 0 0 0 0 where - go posX posY oSrc oDest + go posX posY oSrc oDest - -- add padding bytes at the end of each line. - | posX == width - = do mapM_ (\n -> pokeByteOff ptrDest (oDest + n) (0 :: Word8)) - $ P.take pad [0 .. ] - go 0 (posY + 1) oSrc (oDest + pad) - - -- we've finished the image. - | posY == height - = return () - - -- process a pixel - | otherwise - = do red :: Word8 <- peekByteOff ptrSrc (oSrc + 0) - green :: Word8 <- peekByteOff ptrSrc (oSrc + 1) - blue :: Word8 <- peekByteOff ptrSrc (oSrc + 2) - - pokeByteOff ptrDest (oDest + 0) blue - pokeByteOff ptrDest (oDest + 1) green - pokeByteOff ptrDest (oDest + 2) red - - go (posX + 1) posY (oSrc + 4) (oDest + 3) + -- add padding bytes at the end of each line. + | posX == width + = do mapM_ (\n -> pokeByteOff ptrDest (oDest + n) (0 :: Word8)) + $ P.take pad [0 .. ] + go 0 (posY + 1) oSrc (oDest + pad) + + -- we've finished the image. + | posY == height + = return () + + -- process a pixel + | otherwise + = do red :: Word8 <- peekByteOff ptrSrc (oSrc + 0) + green :: Word8 <- peekByteOff ptrSrc (oSrc + 1) + blue :: Word8 <- peekByteOff ptrSrc (oSrc + 2) + + pokeByteOff ptrDest (oDest + 0) blue + pokeByteOff ptrDest (oDest + 1) green + pokeByteOff ptrDest (oDest + 2) red + + go (posX + 1) posY (oSrc + 4) (oDest + 3) ------------------------------------------------------------------------------- -- | Pack RGBA data into the byte order needed by BMP image data. packRGBA32ToBGRA32 - :: Int -- ^ Width of image. - -> Int -- ^ Height of image. - -> ByteString -- ^ Source bytestring holding the image data. - -> ByteString + :: Int -- ^ Width of image. + -> Int -- ^ Height of image. + -> ByteString -- ^ Source bytestring holding the image data. + -> ByteString packRGBA32ToBGRA32 width height str | height * width * 4 /= BS.length str = error "Codec.BMP: Image dimensions don't match input data." | otherwise - = let sizeDest = height * (width * 4) - in unsafePerformIO - $ allocaBytes sizeDest $ \bufDest -> - BS.unsafeUseAsCString str $ \bufSrc -> - do packRGBA32ToBGRA32' width height + = let sizeDest = height * (width * 4) + in unsafePerformIO + $ allocaBytes sizeDest $ \bufDest -> + BS.unsafeUseAsCString str $ \bufSrc -> + do packRGBA32ToBGRA32' width height (castPtr bufSrc) (castPtr bufDest) - bs <- packCStringLen (bufDest, sizeDest) - return bs - + bs <- packCStringLen (bufDest, sizeDest) + return bs + packRGBA32ToBGRA32' width height ptrSrc ptrDest = go 0 0 0 0 where - go posX posY oSrc oDest + go posX posY oSrc oDest - -- advance to the next line. - | posX == width - = do go 0 (posY + 1) oSrc oDest - - -- we've finished the image. - | posY == height - = return () - - -- process a pixel - | otherwise - = do red :: Word8 <- peekByteOff ptrSrc (oSrc + 0) - green :: Word8 <- peekByteOff ptrSrc (oSrc + 1) - blue :: Word8 <- peekByteOff ptrSrc (oSrc + 2) - alpha :: Word8 <- peekByteOff ptrSrc (oSrc + 3) - - pokeByteOff ptrDest (oDest + 0) blue - pokeByteOff ptrDest (oDest + 1) green - pokeByteOff ptrDest (oDest + 2) red - pokeByteOff ptrDest (oDest + 3) alpha - - go (posX + 1) posY (oSrc + 4) (oDest + 4) + -- advance to the next line. + | posX == width + = do go 0 (posY + 1) oSrc oDest + + -- we've finished the image. + | posY == height + = return () + + -- process a pixel + | otherwise + = do red :: Word8 <- peekByteOff ptrSrc (oSrc + 0) + green :: Word8 <- peekByteOff ptrSrc (oSrc + 1) + blue :: Word8 <- peekByteOff ptrSrc (oSrc + 2) + alpha :: Word8 <- peekByteOff ptrSrc (oSrc + 3) + + pokeByteOff ptrDest (oDest + 0) blue + pokeByteOff ptrDest (oDest + 1) green + pokeByteOff ptrDest (oDest + 2) red + pokeByteOff ptrDest (oDest + 3) alpha + + go (posX + 1) posY (oSrc + 4) (oDest + 4) diff --git a/Codec/BMP/Unpack.hs b/Codec/BMP/Unpack.hs --- a/Codec/BMP/Unpack.hs +++ b/Codec/BMP/Unpack.hs @@ -1,7 +1,7 @@ {-# OPTIONS_HADDOCK hide #-} module Codec.BMP.Unpack - (unpackBMPToRGBA32) -where + (unpackBMPToRGBA32) +where import Codec.BMP.Base import Codec.BMP.BitmapInfo import Codec.BMP.BitmapInfoV3 @@ -10,23 +10,23 @@ import Foreign.Storable import System.IO.Unsafe import Data.Word -import Data.ByteString as BS -import Data.ByteString.Unsafe as BS -import Prelude as P +import Data.ByteString as BS +import Data.ByteString.Unsafe as BS +import Prelude as P -- | Unpack a BMP image to a string of RGBA component values. unpackBMPToRGBA32 :: BMP -> ByteString unpackBMPToRGBA32 bmp - = let info = getBitmapInfoV3 $ bmpBitmapInfo bmp - width = fromIntegral $ dib3Width info - height = fromIntegral $ dib3Height info + = let info = getBitmapInfoV3 $ bmpBitmapInfo bmp + width = fromIntegral $ dib3Width info + height = fromIntegral $ dib3Height info flipX = dib3HeightFlipped info - bitCount = dib3BitCount info - in case bitCount of - 24 -> packRGB24ToRGBA32 width height flipX (bmpRawImageData bmp) - 32 -> packRGB32ToRGBA32 width height flipX (bmpRawImageData bmp) - _ -> error "Codec.BMP: Unhandled bitcount." + bitCount = dib3BitCount info + in case bitCount of + 24 -> packRGB24ToRGBA32 width height flipX (bmpRawImageData bmp) + 32 -> packRGB32ToRGBA32 width height flipX (bmpRawImageData bmp) + _ -> error "Codec.BMP: Unhandled bitcount." -- | Unpack raw, uncompressed 24 bit BMP image data to a string of @@ -34,36 +34,36 @@ -- -- The alpha component is set to 255 for every pixel. packRGB24ToRGBA32 - :: Int -- ^ Width of image. - -> Int -- ^ Height of image. + :: Int -- ^ Width of image. + -> Int -- ^ Height of image. -> Bool -- ^ Image data is flipped along the X axis. - -> ByteString -- ^ Input string. - -> ByteString - + -> ByteString -- ^ Input string. + -> ByteString + packRGB24ToRGBA32 width height flipX str - = let -- Number of bytes per line in the source file, + = let -- Number of bytes per line in the source file, -- including padding bytes. - srcBytesPerLine = BS.length str `div` height - sizeDest = width * height * 4 + srcBytesPerLine = BS.length str `div` height + sizeDest = width * height * 4 -- We allow padding bytes on the end of the image data. - in if BS.length str < height * srcBytesPerLine - then error "Codec.BMP: Image data is truncated." - else unsafePerformIO - $ allocaBytes sizeDest $ \bufDest -> - BS.unsafeUseAsCString str $ \bufSrc -> - do packRGB24ToRGBA32' + in if BS.length str < height * srcBytesPerLine + then error "Codec.BMP: Image data is truncated." + else unsafePerformIO + $ allocaBytes sizeDest $ \bufDest -> + BS.unsafeUseAsCString str $ \bufSrc -> + do packRGB24ToRGBA32' width height flipX srcBytesPerLine (castPtr bufSrc) (castPtr bufDest) - packCStringLen (bufDest, sizeDest) + packCStringLen (bufDest, sizeDest) - + -- We're doing this via Ptrs because we don't want to take the -- overhead of doing the bounds checks in ByteString.index. packRGB24ToRGBA32' width height flipX srcBytesPerLine ptrSrc ptrDst = go 0 - where + where go posY -- we've finished the image. | posY == height @@ -81,23 +81,23 @@ !oDst = width * 4 * posY in go_line 0 posY oSrc oDst - go_line posX posY oSrc oDst - -- move to the next line. - | posX == width - = go (posY + 1) - - -- process a pixel. - | otherwise - = do blue :: Word8 <- peekByteOff ptrSrc (oSrc + 0) - green :: Word8 <- peekByteOff ptrSrc (oSrc + 1) - red :: Word8 <- peekByteOff ptrSrc (oSrc + 2) + go_line posX posY oSrc oDst + -- move to the next line. + | posX == width + = go (posY + 1) + + -- process a pixel. + | otherwise + = do blue :: Word8 <- peekByteOff ptrSrc (oSrc + 0) + green :: Word8 <- peekByteOff ptrSrc (oSrc + 1) + red :: Word8 <- peekByteOff ptrSrc (oSrc + 2) - pokeByteOff ptrDst (oDst + 0) red - pokeByteOff ptrDst (oDst + 1) green - pokeByteOff ptrDst (oDst + 2) blue - pokeByteOff ptrDst (oDst + 3) (255 :: Word8) - - go_line (posX + 1) posY (oSrc + 3) (oDst + 4) + pokeByteOff ptrDst (oDst + 0) red + pokeByteOff ptrDst (oDst + 1) green + pokeByteOff ptrDst (oDst + 2) blue + pokeByteOff ptrDst (oDst + 3) (255 :: Word8) + + go_line (posX + 1) posY (oSrc + 3) (oDst + 4) -- | Unpack raw, uncompressed 32 bit BMP image data to a string of @@ -105,31 +105,31 @@ -- Note in the BMP file the components are arse-around ABGR instead of RGBA. -- The 'unpacking' here is really just flipping the components around. packRGB32ToRGBA32 - :: Int -- ^ Width of image. - -> Int -- ^ Height of image. + :: Int -- ^ Width of image. + -> Int -- ^ Height of image. -> Bool -- ^ Image data is flipped along the X axis. - -> ByteString -- ^ Input string. - -> ByteString - + -> ByteString -- ^ Input string. + -> ByteString + packRGB32ToRGBA32 width height flipX str = let sizeDest = height * width * 4 in if BS.length str < sizeDest - then error "Codec.BMP: Image data is truncated." - else unsafePerformIO - $ allocaBytes sizeDest $ \bufDest -> - BS.unsafeUseAsCString str $ \bufSrc -> - do packRGB32ToRGBA32' width height + then error "Codec.BMP: Image data is truncated." + else unsafePerformIO + $ allocaBytes sizeDest $ \bufDest -> + BS.unsafeUseAsCString str $ \bufSrc -> + do packRGB32ToRGBA32' width height flipX (castPtr bufSrc) (castPtr bufDest) - packCStringLen (bufDest, sizeDest) + packCStringLen (bufDest, sizeDest) - + -- We're doing this via Ptrs because we don't want to take the -- overhead of doing the bounds checks in ByteString.index. packRGB32ToRGBA32' width height flipX ptrSrc ptrDst = go 0 - where - go posY + where + go posY -- we've finished the image. | posY == height = return () @@ -139,7 +139,7 @@ = let !oSrc = width * 4 * (height - 1 - posY) !oDst = width * 4 * posY in go_line 0 posY oSrc oDst - + -- Image source data is in the natural order. | otherwise = let !oSrc = width * 4 * posY @@ -150,18 +150,18 @@ -- move to the next line. | posX == width = go (posY + 1) - - -- process a pixel. - | otherwise - = do blue :: Word8 <- peekByteOff ptrSrc (oSrc + 0) - green :: Word8 <- peekByteOff ptrSrc (oSrc + 1) - red :: Word8 <- peekByteOff ptrSrc (oSrc + 2) - alpha :: Word8 <- peekByteOff ptrSrc (oSrc + 3) + + -- process a pixel. + | otherwise + = do blue :: Word8 <- peekByteOff ptrSrc (oSrc + 0) + green :: Word8 <- peekByteOff ptrSrc (oSrc + 1) + red :: Word8 <- peekByteOff ptrSrc (oSrc + 2) + alpha :: Word8 <- peekByteOff ptrSrc (oSrc + 3) - pokeByteOff ptrDst (oDst + 0) red - pokeByteOff ptrDst (oDst + 1) green - pokeByteOff ptrDst (oDst + 2) blue - pokeByteOff ptrDst (oDst + 3) alpha - - go_line (posX + 1) posY (oSrc + 4) (oDst + 4) + pokeByteOff ptrDst (oDst + 0) red + pokeByteOff ptrDst (oDst + 1) green + pokeByteOff ptrDst (oDst + 2) blue + pokeByteOff ptrDst (oDst + 3) alpha + + go_line (posX + 1) posY (oSrc + 4) (oDst + 4) diff --git a/bmp.cabal b/bmp.cabal --- a/bmp.cabal +++ b/bmp.cabal @@ -1,5 +1,5 @@ Name: bmp -Version: 1.2.6.1 +Version: 1.2.6.2 License: MIT License-file: LICENSE Author: Ben Lippmeier @@ -23,7 +23,7 @@ build-Depends: base == 4.*, bytestring == 0.10.*, - binary == 0.8.4.* + binary >= 0.6 && < 0.9 ghc-options: -O2 -Wall -fno-warn-missing-signatures