bmp 1.2.6.1 → 1.2.6.2
raw patch · 12 files changed
+565/−565 lines, 12 filesdep ~binaryPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: binary
API changes (from Hackage documentation)
Files
- Codec/BMP.hs +70/−70
- Codec/BMP/Base.hs +7/−7
- Codec/BMP/BitmapInfo.hs +20/−20
- Codec/BMP/BitmapInfoV3.hs +81/−81
- Codec/BMP/BitmapInfoV4.hs +81/−81
- Codec/BMP/BitmapInfoV5.hs +40/−40
- Codec/BMP/CIEXYZ.hs +11/−11
- Codec/BMP/Error.hs +11/−11
- Codec/BMP/FileHeader.hs +49/−49
- Codec/BMP/Pack.hs +119/−119
- Codec/BMP/Unpack.hs +74/−74
- bmp.cabal +2/−2
Codec/BMP.hs view
@@ -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)
Codec/BMP/Base.hs view
@@ -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
Codec/BMP/BitmapInfo.hs view
@@ -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+ - - - - - + + + + +
Codec/BMP/BitmapInfoV3.hs view
@@ -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. --
Codec/BMP/BitmapInfoV4.hs view
@@ -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.
Codec/BMP/BitmapInfoV5.hs view
@@ -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.
Codec/BMP/CIEXYZ.hs view
@@ -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
Codec/BMP/Error.hs view
@@ -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)
Codec/BMP/FileHeader.hs view
@@ -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
Codec/BMP/Pack.hs view
@@ -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)
Codec/BMP/Unpack.hs view
@@ -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)
bmp.cabal view
@@ -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