{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-}
-- | Modules used for Bitmap file (.bmp) file loading and writing

module Codec.Picture.Bitmap( -- * Functions

                             writeBitmap
                           , encodeBitmap
                           , encodeBitmapWithMetadata
                           , decodeBitmap
                           , decodeBitmapWithMetadata
                           , decodeBitmapWithPaletteAndMetadata
                           , encodeDynamicBitmap
                           , encodeBitmapWithPaletteAndMetadata
                           , writeDynamicBitmap
                             -- * Accepted format in output

                           , BmpEncodable( )
                           ) where

#if !MIN_VERSION_base(4,8,0)
import Data.Monoid( mempty )
import Control.Applicative( (<$>) )
#endif

import Control.Arrow( first )
import Control.Monad( replicateM, when, foldM_, forM_, void )
import Control.Monad.ST ( ST, runST )
import Data.Maybe( fromMaybe )
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Storable.Mutable as M
import Data.Binary( Binary( .. ) )
import Data.Binary.Put( Put
                      , runPut
                      , putInt32le
                      , putWord16le
                      , putWord32le
                      , putByteString
                      )

import Data.Binary.Get( Get
                      , getWord8
                      , getWord16le
                      , getWord32le
                      , getInt32le
                      , getByteString
                      , bytesRead
                      , skip
                      , label
                      )

import Data.Bits
import Data.Int( Int32 )
import Data.Word( Word32, Word16, Word8 )
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Lazy as L

import Codec.Picture.InternalHelper
import Codec.Picture.Types
import Codec.Picture.VectorByteConversion
import qualified Codec.Picture.Metadata as Met
import Codec.Picture.Metadata ( Metadatas )

data BmpHeader = BmpHeader
    { BmpHeader -> Word16
magicIdentifier :: !Word16
    , BmpHeader -> Word32
fileSize        :: !Word32 -- ^ in bytes

    , BmpHeader -> Word16
reserved1       :: !Word16
    , BmpHeader -> Word16
reserved2       :: !Word16
    , BmpHeader -> Word32
dataOffset      :: !Word32
    }

bitmapMagicIdentifier :: Word16
bitmapMagicIdentifier :: Word16
bitmapMagicIdentifier = Word16
0x4D42

instance Binary BmpHeader where
    put :: BmpHeader -> Put
put BmpHeader
hdr = do
        Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ BmpHeader -> Word16
magicIdentifier BmpHeader
hdr
        Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpHeader -> Word32
fileSize BmpHeader
hdr
        Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ BmpHeader -> Word16
reserved1 BmpHeader
hdr
        Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ BmpHeader -> Word16
reserved2 BmpHeader
hdr
        Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpHeader -> Word32
dataOffset BmpHeader
hdr

    get :: Get BmpHeader
get = do
        Word16
ident <- Get Word16
getWord16le
        Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word16
ident Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word16
bitmapMagicIdentifier)
             (String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid Bitmap magic identifier")
        Word32
fsize <- Get Word32
getWord32le
        Word16
r1 <- Get Word16
getWord16le
        Word16
r2 <- Get Word16
getWord16le
        Word32
offset <- Get Word32
getWord32le
        BmpHeader -> Get BmpHeader
forall (m :: * -> *) a. Monad m => a -> m a
return BmpHeader :: Word16 -> Word32 -> Word16 -> Word16 -> Word32 -> BmpHeader
BmpHeader
            { magicIdentifier :: Word16
magicIdentifier = Word16
ident
            , fileSize :: Word32
fileSize = Word32
fsize
            , reserved1 :: Word16
reserved1 = Word16
r1
            , reserved2 :: Word16
reserved2 = Word16
r2
            , dataOffset :: Word32
dataOffset = Word32
offset
            }

-- | The type of color space declared in a Windows BMP file.

data ColorSpaceType = CalibratedRGB
                    | DeviceDependentRGB
                    | DeviceDependentCMYK
                    | SRGB
                    | WindowsColorSpace
                    | ProfileEmbedded
                    | ProfileLinked
                    | UnknownColorSpace Word32
                    deriving (ColorSpaceType -> ColorSpaceType -> Bool
(ColorSpaceType -> ColorSpaceType -> Bool)
-> (ColorSpaceType -> ColorSpaceType -> Bool) -> Eq ColorSpaceType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ColorSpaceType -> ColorSpaceType -> Bool
$c/= :: ColorSpaceType -> ColorSpaceType -> Bool
== :: ColorSpaceType -> ColorSpaceType -> Bool
$c== :: ColorSpaceType -> ColorSpaceType -> Bool
Eq, Int -> ColorSpaceType -> ShowS
[ColorSpaceType] -> ShowS
ColorSpaceType -> String
(Int -> ColorSpaceType -> ShowS)
-> (ColorSpaceType -> String)
-> ([ColorSpaceType] -> ShowS)
-> Show ColorSpaceType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ColorSpaceType] -> ShowS
$cshowList :: [ColorSpaceType] -> ShowS
show :: ColorSpaceType -> String
$cshow :: ColorSpaceType -> String
showsPrec :: Int -> ColorSpaceType -> ShowS
$cshowsPrec :: Int -> ColorSpaceType -> ShowS
Show)

-- | BITMAPxHEADER with compatibility up to V5. This header was first introduced

-- with Windows 2.0 as the BITMAPCOREHEADER, and was later extended in Windows

-- 3.1, Windows 95 and Windows 98. The original BITMAPCOREHEADER includes all

-- fields up to 'bitPerPixel'. The Windows 3.1 BITMAPINFOHEADER adds all the

-- fields up to 'importantColors'.

--

-- Some Windows 3.1 bitmaps with 16 or 32 bits per pixel might also have three

-- bitmasks following the BITMAPINFOHEADER. These bitmasks were later

-- incorporated into the bitmap header structure in the unreleased

-- BITMAPV2INFOHEADER. The (also unreleased) BITMAPV3INFOHEADER added another

-- bitmask for an alpha channel.

--

-- The later Windows 95 and Windows 98 extensions to the BITMAPINFOHEADER extend

-- the BITMAPV3INFOHEADER, adding support for color correction.

--

--  * BITMAPV4HEADER (Windows 95) may include a simple color profile in a

--      proprietary format. The fields in this color profile (which includes gamma

--      values) are not to be used unless the 'colorSpaceType' field is

--      'CalibratedRGB'.

--

--  * BITMAPV5HEADER (Windows 98) adds support for an ICC color profile. The

--      presence of an ICC color profile is indicated by setting the 'colorSpaceType'

--      field to 'ProfileEmbedded' or 'ProfileLinked'. If it is 'ProfileLinked' then

--      the profile data is actually a Windows-1252 encoded string containing the

--      fully qualified path to an ICC color profile.

data BmpV5Header = BmpV5Header
    { BmpV5Header -> Word32
size              :: !Word32 -- Header size in bytes

    , BmpV5Header -> Int32
width             :: !Int32
    , BmpV5Header -> Int32
height            :: !Int32
    , BmpV5Header -> Word16
planes            :: !Word16 -- Number of colour planes

    , BmpV5Header -> Word16
bitPerPixel       :: !Word16
    , BmpV5Header -> Word32
bitmapCompression :: !Word32
    , BmpV5Header -> Word32
byteImageSize     :: !Word32
    , BmpV5Header -> Int32
xResolution       :: !Int32  -- ^ Pixels per meter

    , BmpV5Header -> Int32
yResolution       :: !Int32  -- ^ Pixels per meter

    , BmpV5Header -> Word32
colorCount        :: !Word32 -- ^ Number of colors in the palette

    , BmpV5Header -> Word32
importantColours  :: !Word32
    -- Fields added to the header in V2

    , BmpV5Header -> Word32
redMask           :: !Word32 -- ^ Red bitfield mask, set to 0 if not used

    , BmpV5Header -> Word32
greenMask         :: !Word32 -- ^ Green bitfield mask, set to 0 if not used

    , BmpV5Header -> Word32
blueMask          :: !Word32 -- ^ Blue bitfield mask, set to 0 if not used

    -- Fields added to the header in V3

    , BmpV5Header -> Word32
alphaMask         :: !Word32 -- ^ Alpha bitfield mask, set to 0 if not used

    -- Fields added to the header in V4

    , BmpV5Header -> ColorSpaceType
colorSpaceType    :: !ColorSpaceType
    , BmpV5Header -> ByteString
colorSpace        :: !B.ByteString -- ^ Windows color space, not decoded

    -- Fields added to the header in V5

    , BmpV5Header -> Word32
iccIntent         :: !Word32
    , BmpV5Header -> Word32
iccProfileData    :: !Word32
    , BmpV5Header -> Word32
iccProfileSize    :: !Word32
    }
    deriving Int -> BmpV5Header -> ShowS
[BmpV5Header] -> ShowS
BmpV5Header -> String
(Int -> BmpV5Header -> ShowS)
-> (BmpV5Header -> String)
-> ([BmpV5Header] -> ShowS)
-> Show BmpV5Header
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BmpV5Header] -> ShowS
$cshowList :: [BmpV5Header] -> ShowS
show :: BmpV5Header -> String
$cshow :: BmpV5Header -> String
showsPrec :: Int -> BmpV5Header -> ShowS
$cshowsPrec :: Int -> BmpV5Header -> ShowS
Show

-- | Size of the Windows BITMAPV4INFOHEADER color space information.

sizeofColorProfile :: Int
sizeofColorProfile :: Int
sizeofColorProfile = Int
48

-- | Sizes of basic BMP headers.

sizeofBmpHeader, sizeofBmpCoreHeader, sizeofBmpInfoHeader :: Word32
sizeofBmpHeader :: Word32
sizeofBmpHeader = Word32
2 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
4 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
2 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
2 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
4
sizeofBmpCoreHeader :: Word32
sizeofBmpCoreHeader = Word32
12
sizeofBmpInfoHeader :: Word32
sizeofBmpInfoHeader = Word32
40

-- | Sizes of extended BMP headers.

sizeofBmpV2Header, sizeofBmpV3Header, sizeofBmpV4Header, sizeofBmpV5Header :: Word32
sizeofBmpV2Header :: Word32
sizeofBmpV2Header = Word32
52
sizeofBmpV3Header :: Word32
sizeofBmpV3Header = Word32
56
sizeofBmpV4Header :: Word32
sizeofBmpV4Header = Word32
108
sizeofBmpV5Header :: Word32
sizeofBmpV5Header = Word32
124

instance Binary ColorSpaceType where
    put :: ColorSpaceType -> Put
put ColorSpaceType
CalibratedRGB         = Word32 -> Put
putWord32le Word32
0
    put ColorSpaceType
DeviceDependentRGB    = Word32 -> Put
putWord32le Word32
1
    put ColorSpaceType
DeviceDependentCMYK   = Word32 -> Put
putWord32le Word32
2
    put ColorSpaceType
ProfileEmbedded       = Word32 -> Put
putWord32le Word32
0x4D424544
    put ColorSpaceType
ProfileLinked         = Word32 -> Put
putWord32le Word32
0x4C494E4B
    put ColorSpaceType
SRGB                  = Word32 -> Put
putWord32le Word32
0x73524742
    put ColorSpaceType
WindowsColorSpace     = Word32 -> Put
putWord32le Word32
0x57696E20
    put (UnknownColorSpace Word32
x) = Word32 -> Put
putWord32le Word32
x
    get :: Get ColorSpaceType
get = do
      Word32
w <- Get Word32
getWord32le
      ColorSpaceType -> Get ColorSpaceType
forall (m :: * -> *) a. Monad m => a -> m a
return (ColorSpaceType -> Get ColorSpaceType)
-> ColorSpaceType -> Get ColorSpaceType
forall a b. (a -> b) -> a -> b
$ case Word32
w of
        Word32
0          -> ColorSpaceType
CalibratedRGB
        Word32
1          -> ColorSpaceType
DeviceDependentRGB
        Word32
2          -> ColorSpaceType
DeviceDependentCMYK
        Word32
0x4D424544 -> ColorSpaceType
ProfileEmbedded
        Word32
0x4C494E4B -> ColorSpaceType
ProfileLinked
        Word32
0x73524742 -> ColorSpaceType
SRGB
        Word32
0x57696E20 -> ColorSpaceType
WindowsColorSpace
        Word32
_          -> Word32 -> ColorSpaceType
UnknownColorSpace Word32
w

instance Binary BmpV5Header where
    put :: BmpV5Header -> Put
put BmpV5Header
hdr = do
        Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
size BmpV5Header
hdr

        if (BmpV5Header -> Word32
size BmpV5Header
hdr Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
sizeofBmpCoreHeader) then do
          Word16 -> Put
putWord16le (Word16 -> Put) -> (Int32 -> Word16) -> Int32 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Put) -> Int32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
width BmpV5Header
hdr
          Word16 -> Put
putWord16le (Word16 -> Put) -> (Int32 -> Word16) -> Int32 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Put) -> Int32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
height BmpV5Header
hdr
          Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word16
planes BmpV5Header
hdr
          Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word16
bitPerPixel BmpV5Header
hdr
        else do
          Int32 -> Put
putInt32le (Int32 -> Put) -> Int32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
width BmpV5Header
hdr
          Int32 -> Put
putInt32le (Int32 -> Put) -> Int32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
height BmpV5Header
hdr
          Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word16
planes BmpV5Header
hdr
          Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word16
bitPerPixel BmpV5Header
hdr

        Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BmpV5Header -> Word32
size BmpV5Header
hdr Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
sizeofBmpCoreHeader) (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ do
          Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
bitmapCompression BmpV5Header
hdr
          Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
byteImageSize BmpV5Header
hdr
          Int32 -> Put
putInt32le (Int32 -> Put) -> Int32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
xResolution BmpV5Header
hdr
          Int32 -> Put
putInt32le (Int32 -> Put) -> Int32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
yResolution BmpV5Header
hdr
          Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
colorCount BmpV5Header
hdr
          Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
importantColours BmpV5Header
hdr

        Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BmpV5Header -> Word32
size BmpV5Header
hdr Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
sizeofBmpInfoHeader Bool -> Bool -> Bool
|| BmpV5Header -> Word32
bitmapCompression BmpV5Header
hdr Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
3) (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ do
          Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
redMask BmpV5Header
hdr
          Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
greenMask BmpV5Header
hdr
          Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
blueMask BmpV5Header
hdr

        Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BmpV5Header -> Word32
size BmpV5Header
hdr Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
sizeofBmpV2Header) (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$
          Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
alphaMask BmpV5Header
hdr

        Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BmpV5Header -> Word32
size BmpV5Header
hdr Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
sizeofBmpV3Header) (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ do
          ColorSpaceType -> Put
forall t. Binary t => t -> Put
put (ColorSpaceType -> Put) -> ColorSpaceType -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> ColorSpaceType
colorSpaceType BmpV5Header
hdr
          ByteString -> Put
putByteString (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> ByteString
colorSpace BmpV5Header
hdr

        Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BmpV5Header -> Word32
size BmpV5Header
hdr Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
sizeofBmpV4Header) (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ do
          Word32 -> Put
forall t. Binary t => t -> Put
put (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
iccIntent BmpV5Header
hdr
          Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
iccProfileData BmpV5Header
hdr
          Word32 -> Put
putWord32le (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
iccProfileSize BmpV5Header
hdr
          Word32 -> Put
putWord32le Word32
0 -- reserved field


    get :: Get BmpV5Header
get = do
      Word32
readSize <- Get Word32
getWord32le
      if Word32
readSize Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
sizeofBmpCoreHeader
        then Word32 -> Get BmpV5Header
getBitmapCoreHeader Word32
readSize
        else Word32 -> Get BmpV5Header
getBitmapInfoHeader Word32
readSize

      where
        getBitmapCoreHeader :: Word32 -> Get BmpV5Header
getBitmapCoreHeader Word32
readSize = do
          Word16
readWidth <- Get Word16
getWord16le
          Word16
readHeight <- Get Word16
getWord16le
          Word16
readPlanes <- Get Word16
getWord16le
          Word16
readBitPerPixel <- Get Word16
getWord16le
          BmpV5Header -> Get BmpV5Header
forall (m :: * -> *) a. Monad m => a -> m a
return BmpV5Header :: Word32
-> Int32
-> Int32
-> Word16
-> Word16
-> Word32
-> Word32
-> Int32
-> Int32
-> Word32
-> Word32
-> Word32
-> Word32
-> Word32
-> Word32
-> ColorSpaceType
-> ByteString
-> Word32
-> Word32
-> Word32
-> BmpV5Header
BmpV5Header {
              size :: Word32
size = Word32
readSize,
              width :: Int32
width = Word16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
readWidth,
              height :: Int32
height = Word16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
readHeight,
              planes :: Word16
planes = Word16
readPlanes,
              bitPerPixel :: Word16
bitPerPixel = Word16
readBitPerPixel,
              bitmapCompression :: Word32
bitmapCompression = Word32
0,
              byteImageSize :: Word32
byteImageSize = Word32
0,
              xResolution :: Int32
xResolution = Int32
2835,
              yResolution :: Int32
yResolution = Int32
2835,
              colorCount :: Word32
colorCount = Word32
2 Word32 -> Word16 -> Word32
forall a b. (Num a, Integral b) => a -> b -> a
^ Word16
readBitPerPixel,
              importantColours :: Word32
importantColours = Word32
0,
              redMask :: Word32
redMask = Word32
0,
              greenMask :: Word32
greenMask = Word32
0,
              blueMask :: Word32
blueMask = Word32
0,
              alphaMask :: Word32
alphaMask = Word32
0,
              colorSpaceType :: ColorSpaceType
colorSpaceType = ColorSpaceType
DeviceDependentRGB,
              colorSpace :: ByteString
colorSpace = ByteString
B.empty,
              iccIntent :: Word32
iccIntent = Word32
0,
              iccProfileData :: Word32
iccProfileData = Word32
0,
              iccProfileSize :: Word32
iccProfileSize = Word32
0
          }

        getBitmapInfoHeader :: Word32 -> Get BmpV5Header
getBitmapInfoHeader Word32
readSize = do
          Int32
readWidth <- Get Int32
getInt32le
          Int32
readHeight <- Get Int32
getInt32le
          Word16
readPlanes <- Get Word16
getWord16le
          Word16
readBitPerPixel <- Get Word16
getWord16le
          Word32
readBitmapCompression <- Get Word32
getWord32le
          Word32
readByteImageSize <- Get Word32
getWord32le
          Int32
readXResolution <- Get Int32
getInt32le
          Int32
readYResolution <- Get Int32
getInt32le
          Word32
readColorCount <- Get Word32
getWord32le
          Word32
readImportantColours <- Get Word32
getWord32le

          (Word32
readRedMask, Word32
readGreenMask, Word32
readBlueMask) <-
            if Word32
readSize Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
sizeofBmpInfoHeader Bool -> Bool -> Bool
&& Word32
readBitmapCompression Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
3
              then (Word32, Word32, Word32) -> Get (Word32, Word32, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
0, Word32
0, Word32
0)
              else do
                -- fields added to the header in V2, but sometimes present

                -- immediately after a plain BITMAPINFOHEADER

                Word32
innerReadRedMask <- Get Word32
getWord32le
                Word32
innerReadGreenMask <- Get Word32
getWord32le
                Word32
innerReadBlueMask <- Get Word32
getWord32le
                (Word32, Word32, Word32) -> Get (Word32, Word32, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
innerReadRedMask, Word32
innerReadGreenMask, Word32
innerReadBlueMask)

          -- field added in V3 (undocumented)

          Word32
readAlphaMask <- if Word32
readSize Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
sizeofBmpV3Header then Word32 -> Get Word32
forall (m :: * -> *) a. Monad m => a -> m a
return Word32
0 else Get Word32
getWord32le

          (ColorSpaceType
readColorSpaceType, ByteString
readColorSpace) <-
            if Word32
readSize Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
sizeofBmpV4Header
              then (ColorSpaceType, ByteString) -> Get (ColorSpaceType, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ColorSpaceType
DeviceDependentRGB, ByteString
B.empty)
              else do
                -- fields added in V4 (Windows 95)

                ColorSpaceType
csType <- Get ColorSpaceType
forall t. Binary t => Get t
get
                ByteString
cs <- Int -> Get ByteString
getByteString Int
sizeofColorProfile
                (ColorSpaceType, ByteString) -> Get (ColorSpaceType, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ColorSpaceType
csType, ByteString
cs)

          (Word32
readIccIntent, Word32
readIccProfileData, Word32
readIccProfileSize) <-
            if Word32
readSize Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
sizeofBmpV5Header
              then (Word32, Word32, Word32) -> Get (Word32, Word32, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
0, Word32
0, Word32
0)
              else do
                -- fields added in V5 (Windows 98)

                Word32
innerIccIntent <- Get Word32
getWord32le
                Word32
innerIccProfileData <- Get Word32
getWord32le
                Word32
innerIccProfileSize <- Get Word32
getWord32le
                Get Word32 -> Get ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Get Word32
getWord32le -- reserved field

                (Word32, Word32, Word32) -> Get (Word32, Word32, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
innerIccIntent, Word32
innerIccProfileData, Word32
innerIccProfileSize)

          BmpV5Header -> Get BmpV5Header
forall (m :: * -> *) a. Monad m => a -> m a
return BmpV5Header :: Word32
-> Int32
-> Int32
-> Word16
-> Word16
-> Word32
-> Word32
-> Int32
-> Int32
-> Word32
-> Word32
-> Word32
-> Word32
-> Word32
-> Word32
-> ColorSpaceType
-> ByteString
-> Word32
-> Word32
-> Word32
-> BmpV5Header
BmpV5Header {
              size :: Word32
size = Word32
readSize,
              width :: Int32
width = Int32
readWidth,
              height :: Int32
height = Int32
readHeight,
              planes :: Word16
planes = Word16
readPlanes,
              bitPerPixel :: Word16
bitPerPixel = Word16
readBitPerPixel,
              bitmapCompression :: Word32
bitmapCompression = Word32
readBitmapCompression,
              byteImageSize :: Word32
byteImageSize = Word32
readByteImageSize,
              xResolution :: Int32
xResolution = Int32
readXResolution,
              yResolution :: Int32
yResolution = Int32
readYResolution,
              colorCount :: Word32
colorCount = Word32
readColorCount,
              importantColours :: Word32
importantColours = Word32
readImportantColours,
              redMask :: Word32
redMask = Word32
readRedMask,
              greenMask :: Word32
greenMask = Word32
readGreenMask,
              blueMask :: Word32
blueMask = Word32
readBlueMask,
              alphaMask :: Word32
alphaMask = Word32
readAlphaMask,
              colorSpaceType :: ColorSpaceType
colorSpaceType = ColorSpaceType
readColorSpaceType,
              colorSpace :: ByteString
colorSpace = ByteString
readColorSpace,
              iccIntent :: Word32
iccIntent = Word32
readIccIntent,
              iccProfileData :: Word32
iccProfileData = Word32
readIccProfileData,
              iccProfileSize :: Word32
iccProfileSize = Word32
readIccProfileSize
          }

newtype BmpPalette = BmpPalette [(Word8, Word8, Word8, Word8)]

putPalette :: BmpPalette -> Put
putPalette :: BmpPalette -> Put
putPalette (BmpPalette [(Word8, Word8, Word8, Word8)]
p) = ((Word8, Word8, Word8, Word8) -> Put)
-> [(Word8, Word8, Word8, Word8)] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Word8
r, Word8
g, Word8
b, Word8
a) -> Word8 -> Put
forall t. Binary t => t -> Put
put Word8
r Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
forall t. Binary t => t -> Put
put Word8
g Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
forall t. Binary t => t -> Put
put Word8
b Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
forall t. Binary t => t -> Put
put Word8
a) [(Word8, Word8, Word8, Word8)]
p

putICCProfile :: Maybe B.ByteString -> Put
putICCProfile :: Maybe ByteString -> Put
putICCProfile Maybe ByteString
Nothing = () -> Put
forall (m :: * -> *) a. Monad m => a -> m a
return ()
putICCProfile (Just ByteString
bytes) = ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
bytes

-- | All the instance of this class can be written as a bitmap file

-- using this library.

class BmpEncodable pixel where
    bitsPerPixel   :: pixel -> Int
    bmpEncode      :: Image pixel -> Put
    hasAlpha       :: Image pixel -> Bool
    defaultPalette :: pixel -> BmpPalette
    defaultPalette pixel
_ = [(Word8, Word8, Word8, Word8)] -> BmpPalette
BmpPalette []

stridePut :: M.STVector s Word8 -> Int -> Int -> ST s ()
{-# INLINE stridePut #-}
stridePut :: STVector s Word8 -> Int -> Int -> ST s ()
stridePut STVector s Word8
vec = Int -> Int -> ST s ()
inner
 where inner :: Int -> Int -> ST s ()
inner  Int
_ Int
0 = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       inner Int
ix Int
n = do
           (STVector s Word8
MVector (PrimState (ST s)) Word8
vec MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
ix) Word8
0
           Int -> Int -> ST s ()
inner (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

instance BmpEncodable Pixel8 where
    hasAlpha :: Image Word8 -> Bool
hasAlpha Image Word8
_ = Bool
False
    defaultPalette :: Word8 -> BmpPalette
defaultPalette Word8
_ = [(Word8, Word8, Word8, Word8)] -> BmpPalette
BmpPalette [(Word8
x,Word8
x,Word8
x, Word8
255) | Word8
x <- [Word8
0 .. Word8
255]]
    bitsPerPixel :: Word8 -> Int
bitsPerPixel Word8
_ = Int
8
    bmpEncode :: Image Word8 -> Put
bmpEncode (Image {imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h, imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
imageData = Vector (PixelBaseComponent Word8)
arr}) =
      [Int] -> (Int -> Put) -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 .. Int
0] ((Int -> Put) -> Put) -> (Int -> Put) -> Put
forall a b. (a -> b) -> a -> b
$ \Int
l -> Vector Word8 -> Put
putVector (Vector Word8 -> Put) -> Vector Word8 -> Put
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Vector Word8)) -> Vector Word8
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Vector Word8)) -> Vector Word8)
-> (forall s. ST s (Vector Word8)) -> Vector Word8
forall a b. (a -> b) -> a -> b
$ Int -> ST s (Vector Word8)
forall s. Int -> ST s (Vector Word8)
encodeLine Int
l
        where stride :: Int
stride = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
linePadding Int
8 Int
w
              putVector :: Vector Word8 -> Put
putVector Vector Word8
vec = ByteString -> Put
putByteString (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ Vector Word8 -> Int -> Int -> ByteString
blitVector Vector Word8
vec Int
0 Int
lineWidth
              lineWidth :: Int
lineWidth = Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
stride

              encodeLine :: forall s. Int -> ST s (VS.Vector Word8)
              encodeLine :: Int -> ST s (Vector Word8)
encodeLine Int
line = do
                  STVector s Word8
buff <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
lineWidth

                  let lineIdx :: Int
lineIdx = Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
w
                      inner :: Int -> ST s ()
inner Int
col | Int
col Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
w = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                      inner Int
col = do
                          let v :: Word8
v = Vector Word8
Vector (PixelBaseComponent Word8)
arr Vector Word8 -> Int -> Word8
forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` (Int
lineIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
col)
                          (STVector s Word8
MVector (PrimState (ST s)) Word8
buff MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
col) Word8
v
                          Int -> ST s ()
inner (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

                  Int -> ST s ()
inner Int
0

                  STVector s Word8 -> Int -> Int -> ST s ()
forall s. STVector s Word8 -> Int -> Int -> ST s ()
stridePut STVector s Word8
buff Int
w Int
stride
                  MVector (PrimState (ST s)) Word8 -> ST s (Vector Word8)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze STVector s Word8
MVector (PrimState (ST s)) Word8
buff

instance BmpEncodable PixelRGBA8 where
    hasAlpha :: Image PixelRGBA8 -> Bool
hasAlpha Image PixelRGBA8
_ = Bool
True
    bitsPerPixel :: PixelRGBA8 -> Int
bitsPerPixel PixelRGBA8
_ = Int
32
    bmpEncode :: Image PixelRGBA8 -> Put
bmpEncode (Image {imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h, imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
imageData = Vector (PixelBaseComponent PixelRGBA8)
arr}) =
      [Int] -> (Int -> Put) -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 .. Int
0] ((Int -> Put) -> Put) -> (Int -> Put) -> Put
forall a b. (a -> b) -> a -> b
$ \Int
l -> Vector Word8 -> Put
putVector (Vector Word8 -> Put) -> Vector Word8 -> Put
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Vector Word8)) -> Vector Word8
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Vector Word8)) -> Vector Word8)
-> (forall s. ST s (Vector Word8)) -> Vector Word8
forall a b. (a -> b) -> a -> b
$ Int -> ST s (Vector Word8)
forall s. Int -> ST s (Vector Word8)
putLine Int
l
      where
        putVector :: Vector Word8 -> Put
putVector Vector Word8
vec = ByteString -> Put
putByteString (ByteString -> Put) -> (Int -> ByteString) -> Int -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word8 -> Int -> Int -> ByteString
blitVector Vector Word8
vec Int
0 (Int -> Put) -> Int -> Put
forall a b. (a -> b) -> a -> b
$ Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4

        putLine :: forall s. Int -> ST s (VS.Vector Word8)
        putLine :: Int -> ST s (Vector Word8)
putLine Int
line = do
            MVector s Word8
buff <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new (Int -> ST s (MVector (PrimState (ST s)) Word8))
-> Int -> ST s (MVector (PrimState (ST s)) Word8)
forall a b. (a -> b) -> a -> b
$ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
w
            let initialIndex :: Int
initialIndex = Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4
                inner :: Int -> Int -> Int -> ST s ()
inner Int
col Int
_ Int
_ | Int
col Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
w = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                inner Int
col Int
writeIdx Int
readIdx = do
                    let r :: Word8
r = Vector Word8
Vector (PixelBaseComponent PixelRGBA8)
arr Vector Word8 -> Int -> Word8
forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` Int
readIdx
                        g :: Word8
g = Vector Word8
Vector (PixelBaseComponent PixelRGBA8)
arr Vector Word8 -> Int -> Word8
forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                        b :: Word8
b = Vector Word8
Vector (PixelBaseComponent PixelRGBA8)
arr Vector Word8 -> Int -> Word8
forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
                        a :: Word8
a = Vector Word8
Vector (PixelBaseComponent PixelRGBA8)
arr Vector Word8 -> Int -> Word8
forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)

                    (MVector s Word8
MVector (PrimState (ST s)) Word8
buff MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) Word8
b
                    (MVector s Word8
MVector (PrimState (ST s)) Word8
buff MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Word8
g
                    (MVector s Word8
MVector (PrimState (ST s)) Word8
buff MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)) Word8
r
                    (MVector s Word8
MVector (PrimState (ST s)) Word8
buff MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)) Word8
a

                    Int -> Int -> Int -> ST s ()
inner (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)

            Int -> Int -> Int -> ST s ()
inner Int
0 Int
0 Int
initialIndex
            MVector (PrimState (ST s)) Word8 -> ST s (Vector Word8)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze MVector s Word8
MVector (PrimState (ST s)) Word8
buff

instance BmpEncodable PixelRGB8 where
    hasAlpha :: Image PixelRGB8 -> Bool
hasAlpha Image PixelRGB8
_ = Bool
False
    bitsPerPixel :: PixelRGB8 -> Int
bitsPerPixel PixelRGB8
_ = Int
24
    bmpEncode :: Image PixelRGB8 -> Put
bmpEncode (Image {imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h, imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
imageData = Vector (PixelBaseComponent PixelRGB8)
arr}) =
       [Int] -> (Int -> Put) -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 .. Int
0] ((Int -> Put) -> Put) -> (Int -> Put) -> Put
forall a b. (a -> b) -> a -> b
$ \Int
l -> Vector Word8 -> Put
putVector (Vector Word8 -> Put) -> Vector Word8 -> Put
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (Vector Word8)) -> Vector Word8
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Vector Word8)) -> Vector Word8)
-> (forall s. ST s (Vector Word8)) -> Vector Word8
forall a b. (a -> b) -> a -> b
$ Int -> ST s (Vector Word8)
forall s. Int -> ST s (Vector Word8)
putLine Int
l
        where
          stride :: Int
stride = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
linePadding Int
24 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
w

          putVector :: Vector Word8 -> Put
putVector Vector Word8
vec = ByteString -> Put
putByteString (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ Vector Word8 -> Int -> Int -> ByteString
blitVector Vector Word8
vec Int
0 (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
stride)

          putLine :: forall s. Int -> ST s (VS.Vector Word8)
          putLine :: Int -> ST s (Vector Word8)
putLine Int
line = do
              MVector s Word8
buff <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new (Int -> ST s (MVector (PrimState (ST s)) Word8))
-> Int -> ST s (MVector (PrimState (ST s)) Word8)
forall a b. (a -> b) -> a -> b
$ Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
stride
              let initialIndex :: Int
initialIndex = Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3
                  inner :: Int -> Int -> Int -> ST s ()
inner Int
col Int
_ Int
_ | Int
col Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
w = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  inner Int
col Int
writeIdx Int
readIdx = do
                      let r :: Word8
r = Vector Word8
Vector (PixelBaseComponent PixelRGB8)
arr Vector Word8 -> Int -> Word8
forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` Int
readIdx
                          g :: Word8
g = Vector Word8
Vector (PixelBaseComponent PixelRGB8)
arr Vector Word8 -> Int -> Word8
forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                          b :: Word8
b = Vector Word8
Vector (PixelBaseComponent PixelRGB8)
arr Vector Word8 -> Int -> Word8
forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)

                      (MVector s Word8
MVector (PrimState (ST s)) Word8
buff MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) Word8
b
                      (MVector s Word8
MVector (PrimState (ST s)) Word8
buff MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Word8
g
                      (MVector s Word8
MVector (PrimState (ST s)) Word8
buff MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)) Word8
r

                      Int -> Int -> Int -> ST s ()
inner (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)

              Int -> Int -> Int -> ST s ()
inner Int
0 Int
0 Int
initialIndex
              MVector (PrimState (ST s)) Word8 -> ST s (Vector Word8)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze MVector s Word8
MVector (PrimState (ST s)) Word8
buff

-- | Information required to extract data from a bitfield.

data Bitfield t = Bitfield
    { Bitfield t -> t
bfMask :: !t            -- ^ The original bitmask.

    , Bitfield t -> Int
bfShift :: !Int         -- ^ The computed number of bits to shift right.

    , Bitfield t -> Float
bfScale :: !Float       -- ^ The scale factor to fit the data into 8 bits.

    } deriving (Bitfield t -> Bitfield t -> Bool
(Bitfield t -> Bitfield t -> Bool)
-> (Bitfield t -> Bitfield t -> Bool) -> Eq (Bitfield t)
forall t. Eq t => Bitfield t -> Bitfield t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bitfield t -> Bitfield t -> Bool
$c/= :: forall t. Eq t => Bitfield t -> Bitfield t -> Bool
== :: Bitfield t -> Bitfield t -> Bool
$c== :: forall t. Eq t => Bitfield t -> Bitfield t -> Bool
Eq, Int -> Bitfield t -> ShowS
[Bitfield t] -> ShowS
Bitfield t -> String
(Int -> Bitfield t -> ShowS)
-> (Bitfield t -> String)
-> ([Bitfield t] -> ShowS)
-> Show (Bitfield t)
forall t. Show t => Int -> Bitfield t -> ShowS
forall t. Show t => [Bitfield t] -> ShowS
forall t. Show t => Bitfield t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bitfield t] -> ShowS
$cshowList :: forall t. Show t => [Bitfield t] -> ShowS
show :: Bitfield t -> String
$cshow :: forall t. Show t => Bitfield t -> String
showsPrec :: Int -> Bitfield t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> Bitfield t -> ShowS
Show)

-- | Four bitfields (red, green, blue, alpha)

data Bitfields4 t = Bitfields4 !(Bitfield t)
                               !(Bitfield t)
                               !(Bitfield t)
                               !(Bitfield t)
                               deriving (Bitfields4 t -> Bitfields4 t -> Bool
(Bitfields4 t -> Bitfields4 t -> Bool)
-> (Bitfields4 t -> Bitfields4 t -> Bool) -> Eq (Bitfields4 t)
forall t. Eq t => Bitfields4 t -> Bitfields4 t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bitfields4 t -> Bitfields4 t -> Bool
$c/= :: forall t. Eq t => Bitfields4 t -> Bitfields4 t -> Bool
== :: Bitfields4 t -> Bitfields4 t -> Bool
$c== :: forall t. Eq t => Bitfields4 t -> Bitfields4 t -> Bool
Eq, Int -> Bitfields4 t -> ShowS
[Bitfields4 t] -> ShowS
Bitfields4 t -> String
(Int -> Bitfields4 t -> ShowS)
-> (Bitfields4 t -> String)
-> ([Bitfields4 t] -> ShowS)
-> Show (Bitfields4 t)
forall t. Show t => Int -> Bitfields4 t -> ShowS
forall t. Show t => [Bitfields4 t] -> ShowS
forall t. Show t => Bitfields4 t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bitfields4 t] -> ShowS
$cshowList :: forall t. Show t => [Bitfields4 t] -> ShowS
show :: Bitfields4 t -> String
$cshow :: forall t. Show t => Bitfields4 t -> String
showsPrec :: Int -> Bitfields4 t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> Bitfields4 t -> ShowS
Show)

-- | Default bitfields 32 bit bitmaps.

defaultBitfieldsRGB32 :: Bitfields3 Word32
defaultBitfieldsRGB32 :: Bitfields3 Word32
defaultBitfieldsRGB32 = Bitfield Word32
-> Bitfield Word32 -> Bitfield Word32 -> Bitfields3 Word32
forall t. Bitfield t -> Bitfield t -> Bitfield t -> Bitfields3 t
Bitfields3 (Word32 -> Bitfield Word32
forall t. (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield Word32
0x00FF0000)
                                   (Word32 -> Bitfield Word32
forall t. (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield Word32
0x0000FF00)
                                   (Word32 -> Bitfield Word32
forall t. (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield Word32
0x000000FF)

-- | Default bitfields for 16 bit bitmaps.

defaultBitfieldsRGB16 :: Bitfields3 Word16
defaultBitfieldsRGB16 :: Bitfields3 Word16
defaultBitfieldsRGB16 = Bitfield Word16
-> Bitfield Word16 -> Bitfield Word16 -> Bitfields3 Word16
forall t. Bitfield t -> Bitfield t -> Bitfield t -> Bitfields3 t
Bitfields3 (Word16 -> Bitfield Word16
forall t. (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield Word16
0x7C00)
                                   (Word16 -> Bitfield Word16
forall t. (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield Word16
0x03E0)
                                   (Word16 -> Bitfield Word16
forall t. (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield Word16
0x001F)

-- | Three bitfields (red, gree, blue).

data Bitfields3 t = Bitfields3 !(Bitfield t)
                               !(Bitfield t)
                               !(Bitfield t)
                               deriving (Bitfields3 t -> Bitfields3 t -> Bool
(Bitfields3 t -> Bitfields3 t -> Bool)
-> (Bitfields3 t -> Bitfields3 t -> Bool) -> Eq (Bitfields3 t)
forall t. Eq t => Bitfields3 t -> Bitfields3 t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bitfields3 t -> Bitfields3 t -> Bool
$c/= :: forall t. Eq t => Bitfields3 t -> Bitfields3 t -> Bool
== :: Bitfields3 t -> Bitfields3 t -> Bool
$c== :: forall t. Eq t => Bitfields3 t -> Bitfields3 t -> Bool
Eq, Int -> Bitfields3 t -> ShowS
[Bitfields3 t] -> ShowS
Bitfields3 t -> String
(Int -> Bitfields3 t -> ShowS)
-> (Bitfields3 t -> String)
-> ([Bitfields3 t] -> ShowS)
-> Show (Bitfields3 t)
forall t. Show t => Int -> Bitfields3 t -> ShowS
forall t. Show t => [Bitfields3 t] -> ShowS
forall t. Show t => Bitfields3 t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bitfields3 t] -> ShowS
$cshowList :: forall t. Show t => [Bitfields3 t] -> ShowS
show :: Bitfields3 t -> String
$cshow :: forall t. Show t => Bitfields3 t -> String
showsPrec :: Int -> Bitfields3 t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> Bitfields3 t -> ShowS
Show)

-- | Pixel formats used to encode RGBA image data.

data RGBABmpFormat = RGBA32 !(Bitfields4 Word32)
                   | RGBA16 !(Bitfields4 Word16)
                   deriving (RGBABmpFormat -> RGBABmpFormat -> Bool
(RGBABmpFormat -> RGBABmpFormat -> Bool)
-> (RGBABmpFormat -> RGBABmpFormat -> Bool) -> Eq RGBABmpFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RGBABmpFormat -> RGBABmpFormat -> Bool
$c/= :: RGBABmpFormat -> RGBABmpFormat -> Bool
== :: RGBABmpFormat -> RGBABmpFormat -> Bool
$c== :: RGBABmpFormat -> RGBABmpFormat -> Bool
Eq, Int -> RGBABmpFormat -> ShowS
[RGBABmpFormat] -> ShowS
RGBABmpFormat -> String
(Int -> RGBABmpFormat -> ShowS)
-> (RGBABmpFormat -> String)
-> ([RGBABmpFormat] -> ShowS)
-> Show RGBABmpFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RGBABmpFormat] -> ShowS
$cshowList :: [RGBABmpFormat] -> ShowS
show :: RGBABmpFormat -> String
$cshow :: RGBABmpFormat -> String
showsPrec :: Int -> RGBABmpFormat -> ShowS
$cshowsPrec :: Int -> RGBABmpFormat -> ShowS
Show)

-- | Pixel formats used to encode RGB image data.

data RGBBmpFormat = RGB32 !(Bitfields3 Word32)
                  | RGB24
                  | RGB16 !(Bitfields3 Word16)
                  deriving (RGBBmpFormat -> RGBBmpFormat -> Bool
(RGBBmpFormat -> RGBBmpFormat -> Bool)
-> (RGBBmpFormat -> RGBBmpFormat -> Bool) -> Eq RGBBmpFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RGBBmpFormat -> RGBBmpFormat -> Bool
$c/= :: RGBBmpFormat -> RGBBmpFormat -> Bool
== :: RGBBmpFormat -> RGBBmpFormat -> Bool
$c== :: RGBBmpFormat -> RGBBmpFormat -> Bool
Eq, Int -> RGBBmpFormat -> ShowS
[RGBBmpFormat] -> ShowS
RGBBmpFormat -> String
(Int -> RGBBmpFormat -> ShowS)
-> (RGBBmpFormat -> String)
-> ([RGBBmpFormat] -> ShowS)
-> Show RGBBmpFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RGBBmpFormat] -> ShowS
$cshowList :: [RGBBmpFormat] -> ShowS
show :: RGBBmpFormat -> String
$cshow :: RGBBmpFormat -> String
showsPrec :: Int -> RGBBmpFormat -> ShowS
$cshowsPrec :: Int -> RGBBmpFormat -> ShowS
Show)

-- | Pixel formats used to encode indexed or grayscale images.

data IndexedBmpFormat = OneBPP | FourBPP | EightBPP deriving Int -> IndexedBmpFormat -> ShowS
[IndexedBmpFormat] -> ShowS
IndexedBmpFormat -> String
(Int -> IndexedBmpFormat -> ShowS)
-> (IndexedBmpFormat -> String)
-> ([IndexedBmpFormat] -> ShowS)
-> Show IndexedBmpFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IndexedBmpFormat] -> ShowS
$cshowList :: [IndexedBmpFormat] -> ShowS
show :: IndexedBmpFormat -> String
$cshow :: IndexedBmpFormat -> String
showsPrec :: Int -> IndexedBmpFormat -> ShowS
$cshowsPrec :: Int -> IndexedBmpFormat -> ShowS
Show

-- | Extract pixel data from a bitfield.

extractBitfield :: (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield :: Bitfield t -> t -> Word8
extractBitfield Bitfield t
bf t
t = if Bitfield t -> Float
forall t. Bitfield t -> Float
bfScale Bitfield t
bf Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
1
                        then t -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral t
field
                        else Float -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
round (Float -> Word8) -> Float -> Word8
forall a b. (a -> b) -> a -> b
$ Bitfield t -> Float
forall t. Bitfield t -> Float
bfScale Bitfield t
bf Float -> Float -> Float
forall a. Num a => a -> a -> a
* t -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral t
field
  where field :: t
field = (t
t t -> t -> t
forall a. Bits a => a -> a -> a
.&. Bitfield t -> t
forall t. Bitfield t -> t
bfMask Bitfield t
bf) t -> Int -> t
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Bitfield t -> Int
forall t. Bitfield t -> Int
bfShift Bitfield t
bf

-- | Convert a bit mask into a 'BitField'.

makeBitfield :: (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield :: t -> Bitfield t
makeBitfield t
mask = t -> Int -> Float -> Bitfield t
forall t. t -> Int -> Float -> Bitfield t
Bitfield t
mask Int
shiftBits Float
scale
  where
    shiftBits :: Int
shiftBits = t -> Int
forall b. FiniteBits b => b -> Int
countTrailingZeros t
mask
    scale :: Float
scale = Float
255 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ t -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (t
mask t -> Int -> t
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
shiftBits)

-- | Helper method to cast a 'B.ByteString' to a 'VS.Vector' of some type.

castByteString :: VS.Storable a => B.ByteString -> VS.Vector a
#if MIN_VERSION_bytestring(0,11,0)
castByteString (BI.BS fp len) = VS.unsafeCast $ VS.unsafeFromForeignPtr fp 0 len
#else
castByteString :: ByteString -> Vector a
castByteString (BI.PS ForeignPtr Word8
fp Int
offset Int
len) = Vector Word8 -> Vector a
forall a b. (Storable a, Storable b) => Vector a -> Vector b
VS.unsafeCast (Vector Word8 -> Vector a) -> Vector Word8 -> Vector a
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Int -> Int -> Vector Word8
forall a. Storable a => ForeignPtr a -> Int -> Int -> Vector a
VS.unsafeFromForeignPtr ForeignPtr Word8
fp Int
offset Int
len
#endif

decodeImageRGBA8 :: RGBABmpFormat -> BmpV5Header -> B.ByteString -> Image PixelRGBA8
decodeImageRGBA8 :: RGBABmpFormat -> BmpV5Header -> ByteString -> Image PixelRGBA8
decodeImageRGBA8 RGBABmpFormat
pixelFormat (BmpV5Header { width :: BmpV5Header -> Int32
width = Int32
w, height :: BmpV5Header -> Int32
height = Int32
h, bitPerPixel :: BmpV5Header -> Word16
bitPerPixel = Word16
bpp }) ByteString
str = Int
-> Int
-> Vector (PixelBaseComponent PixelRGBA8)
-> Image PixelRGBA8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
wi Int
hi Vector Word8
Vector (PixelBaseComponent PixelRGBA8)
stArray where
  wi :: Int
wi = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
w
  hi :: Int
hi = Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
h
  stArray :: Vector Word8
stArray = (forall s. ST s (Vector Word8)) -> Vector Word8
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Vector Word8)) -> Vector Word8)
-> (forall s. ST s (Vector Word8)) -> Vector Word8
forall a b. (a -> b) -> a -> b
$ do
      MVector s Word8
arr <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> Int32 -> Int
forall a b. (a -> b) -> a -> b
$ Int32
w Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32 -> Int32
forall a. Num a => a -> a
abs Int32
h Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
4)
      if Int32
h Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> Int32
0 then
        (Int -> Int -> ST s Int) -> Int -> [Int] -> ST s ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (MVector s Word8 -> Int -> Int -> ST s Int
forall s. MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr) Int
0 [Int
0 .. Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
      else
        (Int -> Int -> ST s Int) -> Int -> [Int] -> ST s ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (MVector s Word8 -> Int -> Int -> ST s Int
forall s. MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr) Int
0 [Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 .. Int
0]
      MVector (PrimState (ST s)) Word8 -> ST s (Vector Word8)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze MVector s Word8
MVector (PrimState (ST s)) Word8
arr

  paddingWords :: Int
paddingWords = (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int -> Int
linePadding Int
intBPP Int
wi) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
intBPP
  intBPP :: Int
intBPP = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
bpp

  readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int
  readLine :: MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr Int
readIndex Int
line = case RGBABmpFormat
pixelFormat of
      RGBA32 Bitfields4 Word32
bitfields -> Bitfields4 Word32 -> Vector Word32 -> Int -> Int -> ST s Int
forall t.
(FiniteBits t, Integral t, Storable t, Show t) =>
Bitfields4 t -> Vector t -> Int -> Int -> ST s Int
inner Bitfields4 Word32
bitfields (ByteString -> Vector Word32
forall a. Storable a => ByteString -> Vector a
castByteString ByteString
str) Int
readIndex Int
writeIndex
      RGBA16 Bitfields4 Word16
bitfields -> Bitfields4 Word16 -> Vector Word16 -> Int -> Int -> ST s Int
forall t.
(FiniteBits t, Integral t, Storable t, Show t) =>
Bitfields4 t -> Vector t -> Int -> Int -> ST s Int
inner Bitfields4 Word16
bitfields (ByteString -> Vector Word16
forall a. Storable a => ByteString -> Vector a
castByteString ByteString
str) Int
readIndex Int
writeIndex
    where
      lastIndex :: Int
lastIndex = Int
wi Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4
      writeIndex :: Int
writeIndex = Int
wi Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
line) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4

      inner
        :: (FiniteBits t, Integral t, M.Storable t, Show t)
        => Bitfields4 t
        -> VS.Vector t
        -> Int
        -> Int
        -> ST s Int
      inner :: Bitfields4 t -> Vector t -> Int -> Int -> ST s Int
inner (Bitfields4 Bitfield t
r Bitfield t
g Bitfield t
b Bitfield t
a) Vector t
inStr = Int -> Int -> ST s Int
inner0
        where
          inner0 :: Int -> Int -> ST s Int
          inner0 :: Int -> Int -> ST s Int
inner0 Int
readIdx Int
writeIdx | Int
writeIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lastIndex = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
paddingWords
          inner0 Int
readIdx Int
writeIdx = do
            let word :: t
word = Vector t
inStr Vector t -> Int -> t
forall a. Storable a => Vector a -> Int -> a
VS.! Int
readIdx
            (MVector s Word8
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite`  Int
writeIdx     ) (Bitfield t -> t -> Word8
forall t. (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield Bitfield t
r t
word)
            (MVector s Word8
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) (Bitfield t -> t -> Word8
forall t. (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield Bitfield t
g t
word)
            (MVector s Word8
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)) (Bitfield t -> t -> Word8
forall t. (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield Bitfield t
b t
word)
            (MVector s Word8
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)) (Bitfield t -> t -> Word8
forall t. (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield Bitfield t
a t
word)
            Int -> Int -> ST s Int
inner0 (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)

decodeImageRGB8 :: RGBBmpFormat -> BmpV5Header -> B.ByteString -> Image PixelRGB8
decodeImageRGB8 :: RGBBmpFormat -> BmpV5Header -> ByteString -> Image PixelRGB8
decodeImageRGB8 RGBBmpFormat
pixelFormat (BmpV5Header { width :: BmpV5Header -> Int32
width = Int32
w, height :: BmpV5Header -> Int32
height = Int32
h, bitPerPixel :: BmpV5Header -> Word16
bitPerPixel = Word16
bpp }) ByteString
str = Int
-> Int -> Vector (PixelBaseComponent PixelRGB8) -> Image PixelRGB8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
wi Int
hi Vector Word8
Vector (PixelBaseComponent PixelRGB8)
stArray where
  wi :: Int
wi = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
w
  hi :: Int
hi = Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
h
  stArray :: Vector Word8
stArray = (forall s. ST s (Vector Word8)) -> Vector Word8
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Vector Word8)) -> Vector Word8)
-> (forall s. ST s (Vector Word8)) -> Vector Word8
forall a b. (a -> b) -> a -> b
$ do
      MVector s Word8
arr <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> Int32 -> Int
forall a b. (a -> b) -> a -> b
$ Int32
w Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32 -> Int32
forall a. Num a => a -> a
abs Int32
h Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
3)
      if Int32
h Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> Int32
0 then
        (Int -> Int -> ST s Int) -> Int -> [Int] -> ST s ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (MVector s Word8 -> Int -> Int -> ST s Int
forall s. MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr) Int
0 [Int
0 .. Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
      else
        (Int -> Int -> ST s Int) -> Int -> [Int] -> ST s ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (MVector s Word8 -> Int -> Int -> ST s Int
forall s. MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr) Int
0 [Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 .. Int
0]
      MVector (PrimState (ST s)) Word8 -> ST s (Vector Word8)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze MVector s Word8
MVector (PrimState (ST s)) Word8
arr

  paddingBytes :: Int
paddingBytes = Int -> Int -> Int
linePadding Int
intBPP Int
wi
  paddingWords :: Int
paddingWords = (Int -> Int -> Int
linePadding Int
intBPP Int
wi Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
intBPP
  intBPP :: Int
intBPP = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
bpp

  readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int
  readLine :: MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr Int
readIndex Int
line = case RGBBmpFormat
pixelFormat of
      RGB16 Bitfields3 Word16
bitfields -> Bitfields3 Word16 -> Vector Word16 -> Int -> Int -> ST s Int
forall t.
(FiniteBits t, Integral t, Storable t, Show t) =>
Bitfields3 t -> Vector t -> Int -> Int -> ST s Int
innerBF Bitfields3 Word16
bitfields (ByteString -> Vector Word16
forall a. Storable a => ByteString -> Vector a
castByteString ByteString
str) Int
readIndex Int
writeIndex
      RGB32 Bitfields3 Word32
bitfields -> Bitfields3 Word32 -> Vector Word32 -> Int -> Int -> ST s Int
forall t.
(FiniteBits t, Integral t, Storable t, Show t) =>
Bitfields3 t -> Vector t -> Int -> Int -> ST s Int
innerBF Bitfields3 Word32
bitfields (ByteString -> Vector Word32
forall a. Storable a => ByteString -> Vector a
castByteString ByteString
str) Int
readIndex Int
writeIndex
      RGBBmpFormat
RGB24 -> Int -> Int -> ST s Int
inner24 Int
readIndex Int
writeIndex
    where
      lastIndex :: Int
lastIndex = Int
wi Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3
      writeIndex :: Int
writeIndex = Int
wi Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
line) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3

      inner24 :: Int -> Int -> ST s Int
inner24 Int
readIdx Int
writeIdx | Int
writeIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lastIndex = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
paddingBytes
      inner24 Int
readIdx Int
writeIdx = do
          (MVector s Word8
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite`  Int
writeIdx     ) (ByteString
str ByteString -> Int -> Word8
`B.index` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2))
          (MVector s Word8
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) (ByteString
str ByteString -> Int -> Word8
`B.index` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
          (MVector s Word8
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)) (ByteString
str ByteString -> Int -> Word8
`B.index`  Int
readIdx)
          Int -> Int -> ST s Int
inner24 (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)

      innerBF
        :: (FiniteBits t, Integral t, M.Storable t, Show t)
        => Bitfields3 t
        -> VS.Vector t
        -> Int
        -> Int
        -> ST s Int
      innerBF :: Bitfields3 t -> Vector t -> Int -> Int -> ST s Int
innerBF (Bitfields3 Bitfield t
r Bitfield t
g Bitfield t
b) Vector t
inStr = Int -> Int -> ST s Int
innerBF0
        where
          innerBF0 :: Int -> Int -> ST s Int
          innerBF0 :: Int -> Int -> ST s Int
innerBF0 Int
readIdx Int
writeIdx | Int
writeIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lastIndex = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
paddingWords
          innerBF0 Int
readIdx Int
writeIdx = do
            let word :: t
word = Vector t
inStr Vector t -> Int -> t
forall a. Storable a => Vector a -> Int -> a
VS.! Int
readIdx
            (MVector s Word8
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite`  Int
writeIdx     ) (Bitfield t -> t -> Word8
forall t. (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield Bitfield t
r t
word)
            (MVector s Word8
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) (Bitfield t -> t -> Word8
forall t. (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield Bitfield t
g t
word)
            (MVector s Word8
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)) (Bitfield t -> t -> Word8
forall t. (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
extractBitfield Bitfield t
b t
word)
            Int -> Int -> ST s Int
innerBF0 (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)

decodeImageY8 :: IndexedBmpFormat -> BmpV5Header -> B.ByteString -> Image Pixel8
decodeImageY8 :: IndexedBmpFormat -> BmpV5Header -> ByteString -> Image Word8
decodeImageY8 IndexedBmpFormat
lowBPP (BmpV5Header { width :: BmpV5Header -> Int32
width = Int32
w, height :: BmpV5Header -> Int32
height = Int32
h, bitPerPixel :: BmpV5Header -> Word16
bitPerPixel = Word16
bpp }) ByteString
str = Int -> Int -> Vector (PixelBaseComponent Word8) -> Image Word8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
wi Int
hi Vector Word8
Vector (PixelBaseComponent Word8)
stArray where
  wi :: Int
wi = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
w
  hi :: Int
hi = Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
h
  stArray :: Vector Word8
stArray = (forall s. ST s (Vector Word8)) -> Vector Word8
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Vector Word8)) -> Vector Word8)
-> (forall s. ST s (Vector Word8)) -> Vector Word8
forall a b. (a -> b) -> a -> b
$ do
      MVector s Word8
arr <- Int -> ST s (MVector s Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new (Int -> ST s (MVector s Word8))
-> (Int32 -> Int) -> Int32 -> ST s (MVector s Word8)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> ST s (MVector s Word8))
-> Int32 -> ST s (MVector s Word8)
forall a b. (a -> b) -> a -> b
$ Int32
w Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32 -> Int32
forall a. Num a => a -> a
abs Int32
h
      if Int32
h Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> Int32
0 then
        (Int -> Int -> ST s Int) -> Int -> [Int] -> ST s ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (MVector s Word8 -> Int -> Int -> ST s Int
forall s. MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr) Int
0 [Int
0 .. Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
      else
        (Int -> Int -> ST s Int) -> Int -> [Int] -> ST s ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ (MVector s Word8 -> Int -> Int -> ST s Int
forall s. MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr) Int
0 [Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 .. Int
0]
      MVector (PrimState (ST s)) Word8 -> ST s (Vector Word8)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze MVector s Word8
MVector (PrimState (ST s)) Word8
arr

  padding :: Int
padding = Int -> Int -> Int
linePadding (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
bpp) Int
wi

  readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int
  readLine :: MVector s Word8 -> Int -> Int -> ST s Int
readLine MVector s Word8
arr Int
readIndex Int
line = case IndexedBmpFormat
lowBPP of
      IndexedBmpFormat
OneBPP -> Int -> Int -> ST s Int
inner1 Int
readIndex Int
writeIndex
      IndexedBmpFormat
FourBPP -> Int -> Int -> ST s Int
inner4 Int
readIndex Int
writeIndex
      IndexedBmpFormat
EightBPP -> Int -> Int -> ST s Int
inner8 Int
readIndex Int
writeIndex
    where
      lastIndex :: Int
lastIndex = Int
wi Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      writeIndex :: Int
writeIndex = Int
wi Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
line)

      inner8 :: Int -> Int -> ST s Int
inner8 Int
readIdx Int
writeIdx | Int
writeIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lastIndex = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
padding
      inner8 Int
readIdx Int
writeIdx = do
        (MVector s Word8
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) (ByteString
str ByteString -> Int -> Word8
`B.index` Int
readIdx)
        Int -> Int -> ST s Int
inner8 (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

      inner4 :: Int -> Int -> ST s Int
inner4 Int
readIdx Int
writeIdx | Int
writeIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lastIndex = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
padding
      inner4 Int
readIdx Int
writeIdx = do
        let byte :: Word8
byte = ByteString
str ByteString -> Int -> Word8
`B.index` Int
readIdx
        if Int
writeIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lastIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 then do
          (MVector s Word8
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) (Word8
byte Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4)
          Int -> Int -> ST s Int
inner4 (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        else do
          (MVector s Word8
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
writeIdx) (Word8
byte Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4)
          (MVector s Word8
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) (Word8
byte Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x0F)
          Int -> Int -> ST s Int
inner4 (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)

      inner1 :: Int -> Int -> ST s Int
inner1 Int
readIdx Int
writeIdx | Int
writeIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lastIndex = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ST s Int) -> Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
padding
      inner1 Int
readIdx Int
writeIdx = do
        let byte :: Word8
byte = ByteString
str ByteString -> Int -> Word8
`B.index` Int
readIdx
        let toWrite :: Int
toWrite = (Int
lastIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
writeIdx) Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` Int
8
        [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. (Int
toWrite Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i ->
          Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
byte Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` (Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ (MVector s Word8
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i)) Word8
1
        Int -> Int -> ST s Int
inner1 (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
toWrite)

decodeImageY8RLE :: Bool -> BmpV5Header -> B.ByteString -> Image Pixel8
decodeImageY8RLE :: Bool -> BmpV5Header -> ByteString -> Image Word8
decodeImageY8RLE Bool
is4bpp (BmpV5Header { width :: BmpV5Header -> Int32
width = Int32
w, height :: BmpV5Header -> Int32
height = Int32
h, byteImageSize :: BmpV5Header -> Word32
byteImageSize = Word32
sz }) ByteString
str = Int -> Int -> Vector (PixelBaseComponent Word8) -> Image Word8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
wi Int
hi Vector Word8
Vector (PixelBaseComponent Word8)
stArray where
  wi :: Int
wi = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
w
  hi :: Int
hi = Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
h
  xOffsetMax :: Int
xOffsetMax = Int
wi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

  stArray :: Vector Word8
stArray = (forall s. ST s (Vector Word8)) -> Vector Word8
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Vector Word8)) -> Vector Word8)
-> (forall s. ST s (Vector Word8)) -> Vector Word8
forall a b. (a -> b) -> a -> b
$ do
    MVector s Word8
arr <- Int -> ST s (MVector s Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new (Int -> ST s (MVector s Word8))
-> (Int32 -> Int) -> Int32 -> ST s (MVector s Word8)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> ST s (MVector s Word8))
-> Int32 -> ST s (MVector s Word8)
forall a b. (a -> b) -> a -> b
$ Int32
w Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32 -> Int32
forall a. Num a => a -> a
abs Int32
h
    MVector s Word8 -> [Word8] -> (Int, Int) -> ST s ()
forall s. MVector s Word8 -> [Word8] -> (Int, Int) -> ST s ()
decodeRLE MVector s Word8
arr (ByteString -> [Word8]
B.unpack (Int -> ByteString -> ByteString
B.take (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
sz) ByteString
str)) ((Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
wi, Int
0)
    MVector (PrimState (ST s)) Word8 -> ST s (Vector Word8)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze MVector s Word8
MVector (PrimState (ST s)) Word8
arr

  decodeRLE :: forall s . M.MVector s Word8 -> [Word8] -> (Int, Int) -> ST s ()
  decodeRLE :: MVector s Word8 -> [Word8] -> (Int, Int) -> ST s ()
decodeRLE MVector s Word8
arr = [Word8] -> (Int, Int) -> ST s ()
inner
    where
      inner :: [Word8] -> (Int, Int) -> ST s ()
      inner :: [Word8] -> (Int, Int) -> ST s ()
inner [] (Int, Int)
_ = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      inner (Word8
0 : Word8
0 : [Word8]
rest) (Int
yOffset, Int
_) = [Word8] -> (Int, Int) -> ST s ()
inner [Word8]
rest (Int
yOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
wi, Int
0)
      inner (Word8
0 : Word8
1 : [Word8]
_) (Int, Int)
_ = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      inner (Word8
0 : Word8
2 : Word8
hOffset : Word8
vOffset : [Word8]
rest) (Int
yOffset, Int
_) =
        [Word8] -> (Int, Int) -> ST s ()
inner [Word8]
rest (Int
yOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
wi Int -> Int -> Int
forall a. Num a => a -> a -> a
* Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
vOffset), Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
hOffset)
      inner (Word8
0 : Word8
n : [Word8]
rest) (Int, Int)
writePos =
        let isPadded :: Bool
isPadded = if Bool
is4bpp then (Word8
n Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
3) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x3 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
2 else Word8 -> Bool
forall a. Integral a => a -> Bool
odd Word8
n
        in Bool -> Int -> [Word8] -> (Int, Int) -> ST s ()
copyN Bool
isPadded (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n) [Word8]
rest (Int, Int)
writePos
      inner (Word8
n : Word8
b : [Word8]
rest) (Int, Int)
writePos = Int -> Word8 -> [Word8] -> (Int, Int) -> ST s ()
writeN (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n) Word8
b [Word8]
rest (Int, Int)
writePos
      inner [Word8]
_ (Int, Int)
_ = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      -- | Write n copies of a byte to the output array.

      writeN :: Int -> Word8 -> [Word8] -> (Int, Int) -> ST s ()
      writeN :: Int -> Word8 -> [Word8] -> (Int, Int) -> ST s ()
writeN Int
0 Word8
_ [Word8]
rest (Int, Int)
writePos = [Word8] -> (Int, Int) -> ST s ()
inner [Word8]
rest (Int, Int)
writePos
      writeN Int
n Word8
b [Word8]
rest (Int, Int)
writePos =
        case (Bool
is4bpp, Int
n) of
          (Bool
True, Int
1) ->
            Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte (Word8
b Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) (Int, Int)
writePos ST s (Int, Int) -> ((Int, Int) -> ST s ()) -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Word8 -> [Word8] -> (Int, Int) -> ST s ()
writeN (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Word8
b [Word8]
rest
          (Bool
True, Int
_) ->
            Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte (Word8
b Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) (Int, Int)
writePos
              ST s (Int, Int)
-> ((Int, Int) -> ST s (Int, Int)) -> ST s (Int, Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte (Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x0F) ST s (Int, Int) -> ((Int, Int) -> ST s ()) -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Word8 -> [Word8] -> (Int, Int) -> ST s ()
writeN (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Word8
b [Word8]
rest
          (Bool
False, Int
_) ->
            Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte Word8
b (Int, Int)
writePos ST s (Int, Int) -> ((Int, Int) -> ST s ()) -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Word8 -> [Word8] -> (Int, Int) -> ST s ()
writeN (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Word8
b [Word8]
rest

      -- | Copy the next byte to the output array, possibly ignoring a padding byte at the end.

      copyN :: Bool -> Int -> [Word8] -> (Int, Int) -> ST s ()
      copyN :: Bool -> Int -> [Word8] -> (Int, Int) -> ST s ()
copyN Bool
_ Int
_ [] (Int, Int)
_ = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      copyN Bool
False Int
0 [Word8]
rest (Int, Int)
writePos = [Word8] -> (Int, Int) -> ST s ()
inner [Word8]
rest (Int, Int)
writePos
      copyN Bool
True Int
0 (Word8
_:[Word8]
rest) (Int, Int)
writePos = [Word8] -> (Int, Int) -> ST s ()
inner [Word8]
rest (Int, Int)
writePos
      copyN Bool
isPadded Int
n (Word8
b : [Word8]
rest) (Int, Int)
writePos =
        case (Bool
is4bpp, Int
n) of
          (Bool
True, Int
1) ->
            Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte (Word8
b Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) (Int, Int)
writePos ST s (Int, Int) -> ((Int, Int) -> ST s ()) -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Int -> [Word8] -> (Int, Int) -> ST s ()
copyN Bool
isPadded (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Word8]
rest
          (Bool
True, Int
_) ->
            Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte (Word8
b Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) (Int, Int)
writePos
              ST s (Int, Int)
-> ((Int, Int) -> ST s (Int, Int)) -> ST s (Int, Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte (Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x0F) ST s (Int, Int) -> ((Int, Int) -> ST s ()) -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Int -> [Word8] -> (Int, Int) -> ST s ()
copyN Bool
isPadded (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) [Word8]
rest
          (Bool
False, Int
_) ->
            Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte Word8
b (Int, Int)
writePos ST s (Int, Int) -> ((Int, Int) -> ST s ()) -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Int -> [Word8] -> (Int, Int) -> ST s ()
copyN Bool
isPadded (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Word8]
rest

      -- | Write the next byte to the output array.

      writeByte :: Word8 -> (Int, Int) -> ST s (Int, Int)
      writeByte :: Word8 -> (Int, Int) -> ST s (Int, Int)
writeByte Word8
byte (Int
yOffset, Int
xOffset) = do
        (MVector s Word8
MVector (PrimState (ST s)) Word8
arr MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
yOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
xOffset)) Word8
byte
        (Int, Int) -> ST s (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
yOffset, (Int
xOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` Int
xOffsetMax)

pixel4Get :: Get [Word8]
pixel4Get :: Get [Word8]
pixel4Get = do
    Word8
b <- Get Word8
getWord8
    Word8
g <- Get Word8
getWord8
    Word8
r <- Get Word8
getWord8
    Word8
_ <- Get Word8
getWord8
    [Word8] -> Get [Word8]
forall (m :: * -> *) a. Monad m => a -> m a
return [Word8
r, Word8
g, Word8
b]

pixel3Get :: Get [Word8]
pixel3Get :: Get [Word8]
pixel3Get = do
    Word8
b <- Get Word8
getWord8
    Word8
g <- Get Word8
getWord8
    Word8
r <- Get Word8
getWord8
    [Word8] -> Get [Word8]
forall (m :: * -> *) a. Monad m => a -> m a
return [Word8
r, Word8
g, Word8
b]

metadataOfHeader :: BmpV5Header -> Maybe B.ByteString -> Metadatas
metadataOfHeader :: BmpV5Header -> Maybe ByteString -> Metadatas
metadataOfHeader BmpV5Header
hdr Maybe ByteString
iccProfile =
    Metadatas
cs Metadatas -> Metadatas -> Metadatas
forall a. Monoid a => a -> a -> a
`mappend` SourceFormat -> Int32 -> Int32 -> Word -> Word -> Metadatas
forall nSize nDpi.
(Integral nSize, Integral nDpi) =>
SourceFormat -> nSize -> nSize -> nDpi -> nDpi -> Metadatas
Met.simpleMetadata SourceFormat
Met.SourceBitmap (BmpV5Header -> Int32
width BmpV5Header
hdr) (Int32 -> Int32
forall a. Num a => a -> a
abs (Int32 -> Int32) -> Int32 -> Int32
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
height BmpV5Header
hdr) Word
dpiX Word
dpiY
  where
    dpiX :: Word
dpiX = Word -> Word
Met.dotsPerMeterToDotPerInch (Word -> Word) -> (Int32 -> Word) -> Int32 -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Word) -> Int32 -> Word
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
xResolution BmpV5Header
hdr
    dpiY :: Word
dpiY = Word -> Word
Met.dotsPerMeterToDotPerInch (Word -> Word) -> (Int32 -> Word) -> Int32 -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Word) -> Int32 -> Word
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
yResolution BmpV5Header
hdr
    cs :: Metadatas
cs = case BmpV5Header -> ColorSpaceType
colorSpaceType BmpV5Header
hdr of
          ColorSpaceType
CalibratedRGB -> Keys ColorSpace -> ColorSpace -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton
            Keys ColorSpace
Met.ColorSpace (ByteString -> ColorSpace
Met.WindowsBitmapColorSpace (ByteString -> ColorSpace) -> ByteString -> ColorSpace
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> ByteString
colorSpace BmpV5Header
hdr)
          ColorSpaceType
SRGB -> Keys ColorSpace -> ColorSpace -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton Keys ColorSpace
Met.ColorSpace ColorSpace
Met.SRGB
          ColorSpaceType
ProfileEmbedded -> case Maybe ByteString
iccProfile of
                              Maybe ByteString
Nothing -> Metadatas
Met.empty
                              Just ByteString
profile -> Keys ColorSpace -> ColorSpace -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Met.singleton Keys ColorSpace
Met.ColorSpace
                                                (ByteString -> ColorSpace
Met.ICCProfile ByteString
profile)
          ColorSpaceType
_ -> Metadatas
Met.empty

-- | Try to decode a bitmap image.

-- Right now this function can output the following image:

--

--   - 'ImageY8'

--

--   - 'ImageRGB8'

--

--   - 'ImageRGBA8'

--

decodeBitmap :: B.ByteString -> Either String DynamicImage
decodeBitmap :: ByteString -> Either String DynamicImage
decodeBitmap = ((DynamicImage, Metadatas) -> DynamicImage)
-> Either String (DynamicImage, Metadatas)
-> Either String DynamicImage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynamicImage, Metadatas) -> DynamicImage
forall a b. (a, b) -> a
fst (Either String (DynamicImage, Metadatas)
 -> Either String DynamicImage)
-> (ByteString -> Either String (DynamicImage, Metadatas))
-> ByteString
-> Either String DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String (DynamicImage, Metadatas)
decodeBitmapWithMetadata

-- | Same as 'decodeBitmap' but also extracts metadata.

decodeBitmapWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
decodeBitmapWithMetadata :: ByteString -> Either String (DynamicImage, Metadatas)
decodeBitmapWithMetadata ByteString
byte =
  (PalettedImage -> DynamicImage)
-> (PalettedImage, Metadatas) -> (DynamicImage, Metadatas)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first PalettedImage -> DynamicImage
palettedToTrueColor ((PalettedImage, Metadatas) -> (DynamicImage, Metadatas))
-> Either String (PalettedImage, Metadatas)
-> Either String (DynamicImage, Metadatas)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String (PalettedImage, Metadatas)
decodeBitmapWithPaletteAndMetadata ByteString
byte

-- | Same as 'decodeBitmap' but also extracts metadata and provide separated palette.

decodeBitmapWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)
decodeBitmapWithPaletteAndMetadata :: ByteString -> Either String (PalettedImage, Metadatas)
decodeBitmapWithPaletteAndMetadata ByteString
str = (Get (PalettedImage, Metadatas)
 -> ByteString -> Either String (PalettedImage, Metadatas))
-> ByteString
-> Get (PalettedImage, Metadatas)
-> Either String (PalettedImage, Metadatas)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Get (PalettedImage, Metadatas)
-> ByteString -> Either String (PalettedImage, Metadatas)
forall a. Get a -> ByteString -> Either String a
runGetStrict ByteString
str (Get (PalettedImage, Metadatas)
 -> Either String (PalettedImage, Metadatas))
-> Get (PalettedImage, Metadatas)
-> Either String (PalettedImage, Metadatas)
forall a b. (a -> b) -> a -> b
$ do
  BmpHeader
fileHeader <- Get BmpHeader
forall t. Binary t => Get t
get :: Get BmpHeader
  BmpV5Header
bmpHeader  <- Get BmpV5Header
forall t. Binary t => Get t
get :: Get BmpV5Header

  Int64
readed <- Get Int64
bytesRead
  Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
readed Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BmpHeader -> Word32
dataOffset BmpHeader
fileHeader))
       (String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid bmp image, data in header")

  Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BmpV5Header -> Int32
width BmpV5Header
bmpHeader Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int32
0)
       (String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get ()) -> String -> Get ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid bmp width, " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int32 -> String
forall a. Show a => a -> String
show (BmpV5Header -> Int32
width BmpV5Header
bmpHeader))

  Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BmpV5Header -> Int32
height BmpV5Header
bmpHeader Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
0)
       (String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get ()) -> String -> Get ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid bmp height (0) ")

  BmpHeader -> BmpV5Header -> Get (PalettedImage, Metadatas)
decodeBitmapWithHeaders BmpHeader
fileHeader BmpV5Header
bmpHeader

-- | Decode the rest of a bitmap, after the headers have been decoded.

decodeBitmapWithHeaders :: BmpHeader -> BmpV5Header -> Get (PalettedImage, Metadatas)
decodeBitmapWithHeaders :: BmpHeader -> BmpV5Header -> Get (PalettedImage, Metadatas)
decodeBitmapWithHeaders BmpHeader
fileHdr BmpV5Header
hdr = do
    PalettedImage
img <- Get PalettedImage
bitmapData
    Maybe ByteString
profile <- Get (Maybe ByteString)
getICCProfile
    (PalettedImage, Metadatas) -> Get (PalettedImage, Metadatas)
forall (m :: * -> *) a. Monad m => a -> m a
return ((PalettedImage, Metadatas) -> Get (PalettedImage, Metadatas))
-> (PalettedImage, Metadatas) -> Get (PalettedImage, Metadatas)
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> PalettedImage -> (PalettedImage, Metadatas)
addMetadata Maybe ByteString
profile PalettedImage
img

  where
    bpp :: Int
bpp = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word16
bitPerPixel BmpV5Header
hdr :: Int
    paletteColorCount :: Int
paletteColorCount
      | BmpV5Header -> Word32
colorCount BmpV5Header
hdr Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 = Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
bpp
      | Bool
otherwise = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
colorCount BmpV5Header
hdr

    addMetadata :: Maybe ByteString -> PalettedImage -> (PalettedImage, Metadatas)
addMetadata Maybe ByteString
profile PalettedImage
i = (PalettedImage
i, BmpV5Header -> Maybe ByteString -> Metadatas
metadataOfHeader BmpV5Header
hdr Maybe ByteString
profile)

    getData :: Get ByteString
getData = do
      Int64
readed <- Get Int64
bytesRead
      String -> Get () -> Get ()
forall a. String -> Get a -> Get a
label String
"Start of pixel data" (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
        Int -> Get ()
skip (Int -> Get ()) -> (Word32 -> Int) -> Word32 -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Get ()) -> Word32 -> Get ()
forall a b. (a -> b) -> a -> b
$ BmpHeader -> Word32
dataOffset BmpHeader
fileHdr Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
readed
      let pixelBytes :: Int
pixelBytes = if BmpV5Header -> Word32
bitmapCompression BmpV5Header
hdr Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
1 Bool -> Bool -> Bool
|| BmpV5Header -> Word32
bitmapCompression BmpV5Header
hdr Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
2
                          then Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
byteImageSize BmpV5Header
hdr
                          else Int -> Int -> Int -> Int
sizeofPixelData Int
bpp (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> Int32 -> Int
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
width BmpV5Header
hdr)
                                                   (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> Int32 -> Int
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Int32
height BmpV5Header
hdr)
      String -> Get ByteString -> Get ByteString
forall a. String -> Get a -> Get a
label String
"Pixel data" (Get ByteString -> Get ByteString)
-> Get ByteString -> Get ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Get ByteString
getByteString Int
pixelBytes

    getICCProfile :: Get (Maybe ByteString)
getICCProfile =
      if BmpV5Header -> Word32
size BmpV5Header
hdr Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
sizeofBmpV5Header
          Bool -> Bool -> Bool
&& BmpV5Header -> ColorSpaceType
colorSpaceType BmpV5Header
hdr ColorSpaceType -> ColorSpaceType -> Bool
forall a. Eq a => a -> a -> Bool
== ColorSpaceType
ProfileLinked
          Bool -> Bool -> Bool
&& BmpV5Header -> Word32
iccProfileData BmpV5Header
hdr Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0
          Bool -> Bool -> Bool
&& BmpV5Header -> Word32
iccProfileSize BmpV5Header
hdr Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0
      then do
        Int64
readSoFar <- Get Int64
bytesRead
        String -> Get () -> Get ()
forall a. String -> Get a -> Get a
label String
"Start of embedded ICC color profile" (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
          Int -> Get ()
skip (Int -> Get ()) -> Int -> Get ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BmpV5Header -> Word32
iccProfileData BmpV5Header
hdr) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
readSoFar
        ByteString
profile <- String -> Get ByteString -> Get ByteString
forall a. String -> Get a -> Get a
label String
"Embedded ICC color profile" (Get ByteString -> Get ByteString)
-> Get ByteString -> Get ByteString
forall a b. (a -> b) -> a -> b
$
                      Int -> Get ByteString
getByteString (Int -> Get ByteString)
-> (Word32 -> Int) -> Word32 -> Get ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Get ByteString) -> Word32 -> Get ByteString
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
iccProfileSize BmpV5Header
hdr
        Maybe ByteString -> Get (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
profile)
      else Maybe ByteString -> Get (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing

    bitmapData :: Get PalettedImage
bitmapData = case (BmpV5Header -> Word16
bitPerPixel BmpV5Header
hdr, BmpV5Header -> Word16
planes BmpV5Header
hdr, BmpV5Header -> Word32
bitmapCompression BmpV5Header
hdr) of
      (Word16
32, Word16
1, Word32
0) -> do
        ByteString
rest <- Get ByteString
getData
        PalettedImage -> Get PalettedImage
forall (m :: * -> *) a. Monad m => a -> m a
return (PalettedImage -> Get PalettedImage)
-> (Image PixelRGB8 -> PalettedImage)
-> Image PixelRGB8
-> Get PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage (DynamicImage -> PalettedImage)
-> (Image PixelRGB8 -> DynamicImage)
-> Image PixelRGB8
-> PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 (Image PixelRGB8 -> Get PalettedImage)
-> Image PixelRGB8 -> Get PalettedImage
forall a b. (a -> b) -> a -> b
$
          RGBBmpFormat -> BmpV5Header -> ByteString -> Image PixelRGB8
decodeImageRGB8 (Bitfields3 Word32 -> RGBBmpFormat
RGB32 Bitfields3 Word32
defaultBitfieldsRGB32) BmpV5Header
hdr ByteString
rest
        -- (2, 1, 0, 3) means BGRA pixel order

      (Word16
32, Word16
1, Word32
3) -> do
        Bitfield Word32
r <- Word32 -> Get (Bitfield Word32)
forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield (Word32 -> Get (Bitfield Word32))
-> Word32 -> Get (Bitfield Word32)
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
redMask BmpV5Header
hdr
        Bitfield Word32
g <- Word32 -> Get (Bitfield Word32)
forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield (Word32 -> Get (Bitfield Word32))
-> Word32 -> Get (Bitfield Word32)
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
greenMask BmpV5Header
hdr
        Bitfield Word32
b <- Word32 -> Get (Bitfield Word32)
forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield (Word32 -> Get (Bitfield Word32))
-> Word32 -> Get (Bitfield Word32)
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
blueMask BmpV5Header
hdr
        ByteString
rest     <- Get ByteString
getData
        if BmpV5Header -> Word32
alphaMask BmpV5Header
hdr Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0
          then PalettedImage -> Get PalettedImage
forall (m :: * -> *) a. Monad m => a -> m a
return (PalettedImage -> Get PalettedImage)
-> (Image PixelRGB8 -> PalettedImage)
-> Image PixelRGB8
-> Get PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage (DynamicImage -> PalettedImage)
-> (Image PixelRGB8 -> DynamicImage)
-> Image PixelRGB8
-> PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 (Image PixelRGB8 -> Get PalettedImage)
-> Image PixelRGB8 -> Get PalettedImage
forall a b. (a -> b) -> a -> b
$
            RGBBmpFormat -> BmpV5Header -> ByteString -> Image PixelRGB8
decodeImageRGB8 (Bitfields3 Word32 -> RGBBmpFormat
RGB32 (Bitfields3 Word32 -> RGBBmpFormat)
-> Bitfields3 Word32 -> RGBBmpFormat
forall a b. (a -> b) -> a -> b
$ Bitfield Word32
-> Bitfield Word32 -> Bitfield Word32 -> Bitfields3 Word32
forall t. Bitfield t -> Bitfield t -> Bitfield t -> Bitfields3 t
Bitfields3 Bitfield Word32
r Bitfield Word32
g Bitfield Word32
b) BmpV5Header
hdr ByteString
rest
          else do
            Bitfield Word32
a <- Word32 -> Get (Bitfield Word32)
forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield (Word32 -> Get (Bitfield Word32))
-> Word32 -> Get (Bitfield Word32)
forall a b. (a -> b) -> a -> b
$ BmpV5Header -> Word32
alphaMask BmpV5Header
hdr
            PalettedImage -> Get PalettedImage
forall (m :: * -> *) a. Monad m => a -> m a
return (PalettedImage -> Get PalettedImage)
-> (Image PixelRGBA8 -> PalettedImage)
-> Image PixelRGBA8
-> Get PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage (DynamicImage -> PalettedImage)
-> (Image PixelRGBA8 -> DynamicImage)
-> Image PixelRGBA8
-> PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGBA8 -> DynamicImage
ImageRGBA8 (Image PixelRGBA8 -> Get PalettedImage)
-> Image PixelRGBA8 -> Get PalettedImage
forall a b. (a -> b) -> a -> b
$
              RGBABmpFormat -> BmpV5Header -> ByteString -> Image PixelRGBA8
decodeImageRGBA8 (Bitfields4 Word32 -> RGBABmpFormat
RGBA32 (Bitfields4 Word32 -> RGBABmpFormat)
-> Bitfields4 Word32 -> RGBABmpFormat
forall a b. (a -> b) -> a -> b
$ Bitfield Word32
-> Bitfield Word32
-> Bitfield Word32
-> Bitfield Word32
-> Bitfields4 Word32
forall t.
Bitfield t
-> Bitfield t -> Bitfield t -> Bitfield t -> Bitfields4 t
Bitfields4 Bitfield Word32
r Bitfield Word32
g Bitfield Word32
b Bitfield Word32
a) BmpV5Header
hdr ByteString
rest
      (Word16
24, Word16
1, Word32
0) -> do
        ByteString
rest <- Get ByteString
getData
        PalettedImage -> Get PalettedImage
forall (m :: * -> *) a. Monad m => a -> m a
return (PalettedImage -> Get PalettedImage)
-> (Image PixelRGB8 -> PalettedImage)
-> Image PixelRGB8
-> Get PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage (DynamicImage -> PalettedImage)
-> (Image PixelRGB8 -> DynamicImage)
-> Image PixelRGB8
-> PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 (Image PixelRGB8 -> Get PalettedImage)
-> Image PixelRGB8 -> Get PalettedImage
forall a b. (a -> b) -> a -> b
$
          RGBBmpFormat -> BmpV5Header -> ByteString -> Image PixelRGB8
decodeImageRGB8 RGBBmpFormat
RGB24 BmpV5Header
hdr ByteString
rest
      (Word16
16, Word16
1, Word32
0) -> do
        ByteString
rest <- Get ByteString
getData
        PalettedImage -> Get PalettedImage
forall (m :: * -> *) a. Monad m => a -> m a
return (PalettedImage -> Get PalettedImage)
-> (Image PixelRGB8 -> PalettedImage)
-> Image PixelRGB8
-> Get PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage (DynamicImage -> PalettedImage)
-> (Image PixelRGB8 -> DynamicImage)
-> Image PixelRGB8
-> PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 (Image PixelRGB8 -> Get PalettedImage)
-> Image PixelRGB8 -> Get PalettedImage
forall a b. (a -> b) -> a -> b
$
          RGBBmpFormat -> BmpV5Header -> ByteString -> Image PixelRGB8
decodeImageRGB8 (Bitfields3 Word16 -> RGBBmpFormat
RGB16 Bitfields3 Word16
defaultBitfieldsRGB16) BmpV5Header
hdr ByteString
rest
      (Word16
16, Word16
1, Word32
3) -> do
        Bitfield Word16
r <- Word16 -> Get (Bitfield Word16)
forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield (Word16 -> Get (Bitfield Word16))
-> (Word32 -> Word16) -> Word32 -> Get (Bitfield Word16)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Get (Bitfield Word16))
-> Word32 -> Get (Bitfield Word16)
forall a b. (a -> b) -> a -> b
$ Word32
0xFFFF Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. BmpV5Header -> Word32
redMask BmpV5Header
hdr
        Bitfield Word16
g <- Word16 -> Get (Bitfield Word16)
forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield (Word16 -> Get (Bitfield Word16))
-> (Word32 -> Word16) -> Word32 -> Get (Bitfield Word16)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Get (Bitfield Word16))
-> Word32 -> Get (Bitfield Word16)
forall a b. (a -> b) -> a -> b
$ Word32
0xFFFF Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. BmpV5Header -> Word32
greenMask BmpV5Header
hdr
        Bitfield Word16
b <- Word16 -> Get (Bitfield Word16)
forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield (Word16 -> Get (Bitfield Word16))
-> (Word32 -> Word16) -> Word32 -> Get (Bitfield Word16)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Get (Bitfield Word16))
-> Word32 -> Get (Bitfield Word16)
forall a b. (a -> b) -> a -> b
$ Word32
0xFFFF Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. BmpV5Header -> Word32
blueMask BmpV5Header
hdr
        ByteString
rest     <- Get ByteString
getData
        if BmpV5Header -> Word32
alphaMask BmpV5Header
hdr Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0
          then PalettedImage -> Get PalettedImage
forall (m :: * -> *) a. Monad m => a -> m a
return (PalettedImage -> Get PalettedImage)
-> (Image PixelRGB8 -> PalettedImage)
-> Image PixelRGB8
-> Get PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage (DynamicImage -> PalettedImage)
-> (Image PixelRGB8 -> DynamicImage)
-> Image PixelRGB8
-> PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 (Image PixelRGB8 -> Get PalettedImage)
-> Image PixelRGB8 -> Get PalettedImage
forall a b. (a -> b) -> a -> b
$
            RGBBmpFormat -> BmpV5Header -> ByteString -> Image PixelRGB8
decodeImageRGB8 (Bitfields3 Word16 -> RGBBmpFormat
RGB16 (Bitfields3 Word16 -> RGBBmpFormat)
-> Bitfields3 Word16 -> RGBBmpFormat
forall a b. (a -> b) -> a -> b
$ Bitfield Word16
-> Bitfield Word16 -> Bitfield Word16 -> Bitfields3 Word16
forall t. Bitfield t -> Bitfield t -> Bitfield t -> Bitfields3 t
Bitfields3 Bitfield Word16
r Bitfield Word16
g Bitfield Word16
b) BmpV5Header
hdr ByteString
rest
          else do
            Bitfield Word16
a <- Word16 -> Get (Bitfield Word16)
forall t (m :: * -> *).
(FiniteBits t, Integral t, Num t, MonadFail m) =>
t -> m (Bitfield t)
getBitfield (Word16 -> Get (Bitfield Word16))
-> (Word32 -> Word16) -> Word32 -> Get (Bitfield Word16)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Get (Bitfield Word16))
-> Word32 -> Get (Bitfield Word16)
forall a b. (a -> b) -> a -> b
$ Word32
0xFFFF Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. BmpV5Header -> Word32
alphaMask BmpV5Header
hdr
            PalettedImage -> Get PalettedImage
forall (m :: * -> *) a. Monad m => a -> m a
return (PalettedImage -> Get PalettedImage)
-> (Image PixelRGBA8 -> PalettedImage)
-> Image PixelRGBA8
-> Get PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> PalettedImage
TrueColorImage (DynamicImage -> PalettedImage)
-> (Image PixelRGBA8 -> DynamicImage)
-> Image PixelRGBA8
-> PalettedImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGBA8 -> DynamicImage
ImageRGBA8 (Image PixelRGBA8 -> Get PalettedImage)
-> Image PixelRGBA8 -> Get PalettedImage
forall a b. (a -> b) -> a -> b
$
              RGBABmpFormat -> BmpV5Header -> ByteString -> Image PixelRGBA8
decodeImageRGBA8 (Bitfields4 Word16 -> RGBABmpFormat
RGBA16 (Bitfields4 Word16 -> RGBABmpFormat)
-> Bitfields4 Word16 -> RGBABmpFormat
forall a b. (a -> b) -> a -> b
$ Bitfield Word16
-> Bitfield Word16
-> Bitfield Word16
-> Bitfield Word16
-> Bitfields4 Word16
forall t.
Bitfield t
-> Bitfield t -> Bitfield t -> Bitfield t -> Bitfields4 t
Bitfields4 Bitfield Word16
r Bitfield Word16
g Bitfield Word16
b Bitfield Word16
a) BmpV5Header
hdr ByteString
rest
      ( Word16
_, Word16
1, Word32
compression) -> do
        [[Word8]]
table <- if BmpV5Header -> Word32
size BmpV5Header
hdr Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
sizeofBmpCoreHeader
                    then Int -> Get [Word8] -> Get [[Word8]]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
paletteColorCount Get [Word8]
pixel3Get
                    else Int -> Get [Word8] -> Get [[Word8]]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
paletteColorCount Get [Word8]
pixel4Get
        ByteString
rest <- Get ByteString
getData
        let palette :: Palette' PixelRGB8
palette = Palette' :: forall px. Int -> Vector (PixelBaseComponent px) -> Palette' px
Palette'
              { _paletteSize :: Int
_paletteSize = Int
paletteColorCount
              , _paletteData :: Vector (PixelBaseComponent PixelRGB8)
_paletteData = Int -> [Word8] -> Vector Word8
forall a. Storable a => Int -> [a] -> Vector a
VS.fromListN (Int
paletteColorCount Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3) ([Word8] -> Vector Word8) -> [Word8] -> Vector Word8
forall a b. (a -> b) -> a -> b
$ [[Word8]] -> [Word8]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Word8]]
table
              }
        Image Word8
image <-
          case (Int
bpp, Word32
compression) of
            (Int
8, Word32
0) -> Image Word8 -> Get (Image Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Image Word8 -> Get (Image Word8))
-> Image Word8 -> Get (Image Word8)
forall a b. (a -> b) -> a -> b
$ IndexedBmpFormat -> BmpV5Header -> ByteString -> Image Word8
decodeImageY8 IndexedBmpFormat
EightBPP BmpV5Header
hdr ByteString
rest
            (Int
4, Word32
0) -> Image Word8 -> Get (Image Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Image Word8 -> Get (Image Word8))
-> Image Word8 -> Get (Image Word8)
forall a b. (a -> b) -> a -> b
$ IndexedBmpFormat -> BmpV5Header -> ByteString -> Image Word8
decodeImageY8 IndexedBmpFormat
FourBPP BmpV5Header
hdr ByteString
rest
            (Int
1, Word32
0) -> Image Word8 -> Get (Image Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Image Word8 -> Get (Image Word8))
-> Image Word8 -> Get (Image Word8)
forall a b. (a -> b) -> a -> b
$ IndexedBmpFormat -> BmpV5Header -> ByteString -> Image Word8
decodeImageY8 IndexedBmpFormat
OneBPP BmpV5Header
hdr ByteString
rest
            (Int
8, Word32
1) -> Image Word8 -> Get (Image Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Image Word8 -> Get (Image Word8))
-> Image Word8 -> Get (Image Word8)
forall a b. (a -> b) -> a -> b
$ Bool -> BmpV5Header -> ByteString -> Image Word8
decodeImageY8RLE Bool
False BmpV5Header
hdr ByteString
rest
            (Int
4, Word32
2) -> Image Word8 -> Get (Image Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Image Word8 -> Get (Image Word8))
-> Image Word8 -> Get (Image Word8)
forall a b. (a -> b) -> a -> b
$ Bool -> BmpV5Header -> ByteString -> Image Word8
decodeImageY8RLE Bool
True BmpV5Header
hdr ByteString
rest
            (Int
a, Word32
b) -> String -> Get (Image Word8)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get (Image Word8)) -> String -> Get (Image Word8)
forall a b. (a -> b) -> a -> b
$ String
"Can't handle BMP file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int, Int, Word32) -> String
forall a. Show a => a -> String
show (Int
a, Int
1 :: Int, Word32
b)

        PalettedImage -> Get PalettedImage
forall (m :: * -> *) a. Monad m => a -> m a
return (PalettedImage -> Get PalettedImage)
-> PalettedImage -> Get PalettedImage
forall a b. (a -> b) -> a -> b
$ Image Word8 -> Palette' PixelRGB8 -> PalettedImage
PalettedRGB8 Image Word8
image Palette' PixelRGB8
palette

      (Word16, Word16, Word32)
a          -> String -> Get PalettedImage
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get PalettedImage) -> String -> Get PalettedImage
forall a b. (a -> b) -> a -> b
$ String
"Can't handle BMP file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Word16, Word16, Word32) -> String
forall a. Show a => a -> String
show (Word16, Word16, Word32)
a

-- | Decode a bitfield. Will fail if the bitfield is empty.

#if MIN_VERSION_base(4,13,0)
getBitfield :: (FiniteBits t, Integral t, Num t, MonadFail m) => t -> m (Bitfield t)
#else
getBitfield :: (FiniteBits t, Integral t, Num t, Monad m) => t -> m (Bitfield t)
#endif
getBitfield :: t -> m (Bitfield t)
getBitfield t
0 = String -> m (Bitfield t)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (Bitfield t)) -> String -> m (Bitfield t)
forall a b. (a -> b) -> a -> b
$
  String
"Codec.Picture.Bitmap.getBitfield: bitfield cannot be 0"
getBitfield t
w = Bitfield t -> m (Bitfield t)
forall (m :: * -> *) a. Monad m => a -> m a
return (t -> Bitfield t
forall t. (FiniteBits t, Integral t) => t -> Bitfield t
makeBitfield t
w)

-- | Compute the size of the pixel data

sizeofPixelData :: Int -> Int -> Int -> Int
sizeofPixelData :: Int -> Int -> Int -> Int
sizeofPixelData Int
bpp Int
lineWidth Int
nLines = ((Int
bpp Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int -> Int
forall a. Num a => a -> a
abs Int
lineWidth) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
31) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
32) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int
forall a. Num a => a -> a
abs Int
nLines

-- | Write an image in a file use the bitmap format.

writeBitmap :: (BmpEncodable pixel)
            => FilePath -> Image pixel -> IO ()
writeBitmap :: String -> Image pixel -> IO ()
writeBitmap String
filename Image pixel
img = String -> ByteString -> IO ()
L.writeFile String
filename (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Image pixel -> ByteString
forall pixel. BmpEncodable pixel => Image pixel -> ByteString
encodeBitmap Image pixel
img

linePadding :: Int -> Int -> Int
linePadding :: Int -> Int -> Int
linePadding Int
bpp Int
imgWidth = (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
bytesPerLine Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4
  where bytesPerLine :: Int
bytesPerLine = (Int
bpp Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8

-- | Encode an image into a bytestring in .bmp format ready to be written

-- on disk.

encodeBitmap :: forall pixel. (BmpEncodable pixel) => Image pixel -> L.ByteString
encodeBitmap :: Image pixel -> ByteString
encodeBitmap = BmpPalette -> Image pixel -> ByteString
forall pixel.
BmpEncodable pixel =>
BmpPalette -> Image pixel -> ByteString
encodeBitmapWithPalette (pixel -> BmpPalette
forall pixel. BmpEncodable pixel => pixel -> BmpPalette
defaultPalette (pixel
forall a. HasCallStack => a
undefined :: pixel))

-- | Equivalent to 'encodeBitmap' but also store

-- the following metadatas:

--

--  * 'Codec.Picture.Metadata.DpiX'

--  * 'Codec.Picture.Metadata.DpiY'

--

encodeBitmapWithMetadata :: forall pixel. BmpEncodable pixel
                         => Metadatas -> Image pixel -> L.ByteString
encodeBitmapWithMetadata :: Metadatas -> Image pixel -> ByteString
encodeBitmapWithMetadata Metadatas
metas =
  Metadatas -> BmpPalette -> Image pixel -> ByteString
forall pixel.
BmpEncodable pixel =>
Metadatas -> BmpPalette -> Image pixel -> ByteString
encodeBitmapWithPaletteAndMetadata Metadatas
metas (pixel -> BmpPalette
forall pixel. BmpEncodable pixel => pixel -> BmpPalette
defaultPalette (pixel
forall a. HasCallStack => a
undefined :: pixel))

-- | Write a dynamic image in a .bmp image file if possible.

-- The same restriction as 'encodeDynamicBitmap' apply.

writeDynamicBitmap :: FilePath -> DynamicImage -> IO (Either String Bool)
writeDynamicBitmap :: String -> DynamicImage -> IO (Either String Bool)
writeDynamicBitmap String
path DynamicImage
img = case DynamicImage -> Either String ByteString
encodeDynamicBitmap DynamicImage
img of
        Left String
err -> Either String Bool -> IO (Either String Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Bool -> IO (Either String Bool))
-> Either String Bool -> IO (Either String Bool)
forall a b. (a -> b) -> a -> b
$ String -> Either String Bool
forall a b. a -> Either a b
Left String
err
        Right ByteString
b  -> String -> ByteString -> IO ()
L.writeFile String
path ByteString
b IO () -> IO (Either String Bool) -> IO (Either String Bool)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either String Bool -> IO (Either String Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
True)

-- | Encode a dynamic image in BMP if possible, supported images are:

--

--   - 'ImageY8'

--

--   - 'ImageRGB8'

--

--   - 'ImageRGBA8'

--

encodeDynamicBitmap :: DynamicImage -> Either String L.ByteString
encodeDynamicBitmap :: DynamicImage -> Either String ByteString
encodeDynamicBitmap (ImageRGB8 Image PixelRGB8
img) = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Image PixelRGB8 -> ByteString
forall pixel. BmpEncodable pixel => Image pixel -> ByteString
encodeBitmap Image PixelRGB8
img
encodeDynamicBitmap (ImageRGBA8 Image PixelRGBA8
img) = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Image PixelRGBA8 -> ByteString
forall pixel. BmpEncodable pixel => Image pixel -> ByteString
encodeBitmap Image PixelRGBA8
img
encodeDynamicBitmap (ImageY8 Image Word8
img) = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Image Word8 -> ByteString
forall pixel. BmpEncodable pixel => Image pixel -> ByteString
encodeBitmap Image Word8
img
encodeDynamicBitmap DynamicImage
_ = String -> Either String ByteString
forall a b. a -> Either a b
Left String
"Unsupported image format for bitmap export"

extractDpiOfMetadata :: Metadatas -> (Word32, Word32)
extractDpiOfMetadata :: Metadatas -> (Word32, Word32)
extractDpiOfMetadata Metadatas
metas = (Keys Word -> Word32
fetch Keys Word
Met.DpiX, Keys Word -> Word32
fetch Keys Word
Met.DpiY) where
  fetch :: Keys Word -> Word32
fetch Keys Word
k = Word32 -> (Word -> Word32) -> Maybe Word -> Word32
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word32
0 (Word -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Word32) -> (Word -> Word) -> Word -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Word
Met.dotPerInchToDotsPerMeter) (Maybe Word -> Word32) -> Maybe Word -> Word32
forall a b. (a -> b) -> a -> b
$ Keys Word -> Metadatas -> Maybe Word
forall a. Keys a -> Metadatas -> Maybe a
Met.lookup Keys Word
k Metadatas
metas

-- | Convert an image to a bytestring ready to be serialized.

encodeBitmapWithPalette :: forall pixel. (BmpEncodable pixel)
                        => BmpPalette -> Image pixel -> L.ByteString
encodeBitmapWithPalette :: BmpPalette -> Image pixel -> ByteString
encodeBitmapWithPalette = Metadatas -> BmpPalette -> Image pixel -> ByteString
forall pixel.
BmpEncodable pixel =>
Metadatas -> BmpPalette -> Image pixel -> ByteString
encodeBitmapWithPaletteAndMetadata Metadatas
forall a. Monoid a => a
mempty

-- | Equivalent to 'encodeBitmapWithPalette' but also store

-- the following metadatas:

--

--  * 'Codec.Picture.Metadata.DpiX'

--  * 'Codec.Picture.Metadata.DpiY'

--

encodeBitmapWithPaletteAndMetadata :: forall pixel. (BmpEncodable pixel)
                                   => Metadatas -> BmpPalette -> Image pixel
                                   -> L.ByteString
encodeBitmapWithPaletteAndMetadata :: Metadatas -> BmpPalette -> Image pixel -> ByteString
encodeBitmapWithPaletteAndMetadata Metadatas
metas pal :: BmpPalette
pal@(BmpPalette [(Word8, Word8, Word8, Word8)]
palette) Image pixel
img =
  Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ BmpHeader -> Put
forall t. Binary t => t -> Put
put BmpHeader
hdr Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BmpV5Header -> Put
forall t. Binary t => t -> Put
put BmpV5Header
info Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BmpPalette -> Put
putPalette BmpPalette
pal Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Image pixel -> Put
forall pixel. BmpEncodable pixel => Image pixel -> Put
bmpEncode Image pixel
img
                   Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe ByteString -> Put
putICCProfile Maybe ByteString
colorProfileData

    where imgWidth :: Int
imgWidth = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Image pixel -> Int
forall a. Image a -> Int
imageWidth Image pixel
img
          imgHeight :: Int
imgHeight = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Image pixel -> Int
forall a. Image a -> Int
imageHeight Image pixel
img
          (Word32
dpiX, Word32
dpiY) = Metadatas -> (Word32, Word32)
extractDpiOfMetadata Metadatas
metas
          cs :: Maybe ColorSpace
cs = Keys ColorSpace -> Metadatas -> Maybe ColorSpace
forall a. Keys a -> Metadatas -> Maybe a
Met.lookup Keys ColorSpace
Met.ColorSpace Metadatas
metas
          colorType :: ColorSpaceType
colorType = case Maybe ColorSpace
cs of
                        Just ColorSpace
Met.SRGB -> ColorSpaceType
SRGB
                        Just (Met.WindowsBitmapColorSpace ByteString
_) -> ColorSpaceType
CalibratedRGB
                        Just (Met.ICCProfile ByteString
_) -> ColorSpaceType
ProfileEmbedded
                        Maybe ColorSpace
Nothing -> ColorSpaceType
DeviceDependentRGB

          colorSpaceInfo :: ByteString
colorSpaceInfo = case Maybe ColorSpace
cs of
                            Just (Met.WindowsBitmapColorSpace ByteString
bytes) -> ByteString
bytes
                            Maybe ColorSpace
_ -> [Word8] -> ByteString
B.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
sizeofColorProfile Word8
0

          colorProfileData :: Maybe ByteString
colorProfileData = case Maybe ColorSpace
cs of
                              Just (Met.ICCProfile ByteString
bytes) -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bytes
                              Maybe ColorSpace
_ -> Maybe ByteString
forall a. Maybe a
Nothing

          headerSize :: Word32
headerSize | ColorSpaceType
colorType ColorSpaceType -> ColorSpaceType -> Bool
forall a. Eq a => a -> a -> Bool
== ColorSpaceType
ProfileEmbedded                = Word32
sizeofBmpV5Header
                     | ColorSpaceType
colorType ColorSpaceType -> ColorSpaceType -> Bool
forall a. Eq a => a -> a -> Bool
== ColorSpaceType
CalibratedRGB Bool -> Bool -> Bool
|| Image pixel -> Bool
forall pixel. BmpEncodable pixel => Image pixel -> Bool
hasAlpha Image pixel
img  = Word32
sizeofBmpV4Header
                     | Bool
otherwise                                   = Word32
sizeofBmpInfoHeader

          paletteSize :: Word32
paletteSize = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ [(Word8, Word8, Word8, Word8)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Word8, Word8, Word8, Word8)]
palette
          bpp :: Int
bpp = pixel -> Int
forall pixel. BmpEncodable pixel => pixel -> Int
bitsPerPixel (pixel
forall a. HasCallStack => a
undefined :: pixel)

          profileSize :: Word32
profileSize = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int -> (ByteString -> Int) -> Maybe ByteString -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 ByteString -> Int
B.length Maybe ByteString
colorProfileData
          imagePixelSize :: Word32
imagePixelSize = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int
sizeofPixelData Int
bpp Int
imgWidth Int
imgHeight
          offsetToData :: Word32
offsetToData = Word32
sizeofBmpHeader Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
headerSize Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
4 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
paletteSize
          offsetToICCProfile :: Maybe Word32
offsetToICCProfile = Word32
offsetToData Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
imagePixelSize Word32 -> Maybe ByteString -> Maybe Word32
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe ByteString
colorProfileData
          sizeOfFile :: Word32
sizeOfFile = Word32
sizeofBmpHeader Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
headerSize Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
4 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
paletteSize
                        Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
imagePixelSize Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
profileSize

          hdr :: BmpHeader
hdr = BmpHeader :: Word16 -> Word32 -> Word16 -> Word16 -> Word32 -> BmpHeader
BmpHeader {
              magicIdentifier :: Word16
magicIdentifier = Word16
bitmapMagicIdentifier,
              fileSize :: Word32
fileSize = Word32
sizeOfFile,
              reserved1 :: Word16
reserved1 = Word16
0,
              reserved2 :: Word16
reserved2 = Word16
0,
              dataOffset :: Word32
dataOffset = Word32
offsetToData
          }

          info :: BmpV5Header
info = BmpV5Header :: Word32
-> Int32
-> Int32
-> Word16
-> Word16
-> Word32
-> Word32
-> Int32
-> Int32
-> Word32
-> Word32
-> Word32
-> Word32
-> Word32
-> Word32
-> ColorSpaceType
-> ByteString
-> Word32
-> Word32
-> Word32
-> BmpV5Header
BmpV5Header {
              size :: Word32
size = Word32
headerSize,
              width :: Int32
width = Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
imgWidth,
              height :: Int32
height = Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
imgHeight,
              planes :: Word16
planes = Word16
1,
              bitPerPixel :: Word16
bitPerPixel = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bpp,
              bitmapCompression :: Word32
bitmapCompression = if Image pixel -> Bool
forall pixel. BmpEncodable pixel => Image pixel -> Bool
hasAlpha Image pixel
img then Word32
3 else Word32
0,
              byteImageSize :: Word32
byteImageSize = Word32
imagePixelSize,
              xResolution :: Int32
xResolution = Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
dpiX,
              yResolution :: Int32
yResolution = Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
dpiY,
              colorCount :: Word32
colorCount = Word32
paletteSize,
              importantColours :: Word32
importantColours = Word32
0,
              redMask :: Word32
redMask   = if Image pixel -> Bool
forall pixel. BmpEncodable pixel => Image pixel -> Bool
hasAlpha Image pixel
img then Word32
0x00FF0000 else Word32
0,
              greenMask :: Word32
greenMask = if Image pixel -> Bool
forall pixel. BmpEncodable pixel => Image pixel -> Bool
hasAlpha Image pixel
img then Word32
0x0000FF00 else Word32
0,
              blueMask :: Word32
blueMask  = if Image pixel -> Bool
forall pixel. BmpEncodable pixel => Image pixel -> Bool
hasAlpha Image pixel
img then Word32
0x000000FF else Word32
0,
              alphaMask :: Word32
alphaMask = if Image pixel -> Bool
forall pixel. BmpEncodable pixel => Image pixel -> Bool
hasAlpha Image pixel
img then Word32
0xFF000000 else Word32
0,
              colorSpaceType :: ColorSpaceType
colorSpaceType = ColorSpaceType
colorType,
              colorSpace :: ByteString
colorSpace = ByteString
colorSpaceInfo,
              iccIntent :: Word32
iccIntent = Word32
0,
              iccProfileData :: Word32
iccProfileData = Word32 -> Maybe Word32 -> Word32
forall a. a -> Maybe a -> a
fromMaybe Word32
0 Maybe Word32
offsetToICCProfile,
              iccProfileSize :: Word32
iccProfileSize = Word32
profileSize
          }


{-# ANN module "HLint: ignore Reduce duplication" #-}