    {-# 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
        { magicIdentifier :: !Word16
        , fileSize        :: !Word32 -- ^ in bytes
        , reserved1       :: !Word16
        , reserved2       :: !Word16
        , dataOffset      :: !Word32
        }

    bitmapMagicIdentifier :: Word16
    bitmapMagicIdentifier = 0x4D42

    instance Binary BmpHeader where
        put hdr = do
            putWord16le $ magicIdentifier hdr
            putWord32le $ fileSize hdr
            putWord16le $ reserved1 hdr
            putWord16le $ reserved2 hdr
            putWord32le $ dataOffset hdr

        get = do
            ident <- getWord16le
            when (ident /= bitmapMagicIdentifier)
                 (fail "Invalid Bitmap magic identifier")
            fsize <- getWord32le
            r1 <- getWord16le
            r2 <- getWord16le
            offset <- getWord32le
            return BmpHeader
                { magicIdentifier = ident
                , fileSize = fsize
                , reserved1 = r1
                , reserved2 = r2
                , dataOffset = offset
                }

    -- | The type of color space declared in a Windows BMP file.
    data ColorSpaceType = CalibratedRGB
                        | DeviceDependentRGB
                        | DeviceDependentCMYK
                        | SRGB
                        | WindowsColorSpace
                        | ProfileEmbedded
                        | ProfileLinked
                        | UnknownColorSpace Word32
                        deriving (Eq, 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
        { size              :: !Word32 -- Header size in bytes
        , width             :: !Int32
        , height            :: !Int32
        , planes            :: !Word16 -- Number of colour planes
        , bitPerPixel       :: !Word16
        , bitmapCompression :: !Word32
        , byteImageSize     :: !Word32
        , xResolution       :: !Int32  -- ^ Pixels per meter
        , yResolution       :: !Int32  -- ^ Pixels per meter
        , colorCount        :: !Word32 -- ^ Number of colors in the palette
        , importantColours  :: !Word32
        -- Fields added to the header in V2
        , redMask           :: !Word32 -- ^ Red bitfield mask, set to 0 if not used
        , greenMask         :: !Word32 -- ^ Green bitfield mask, set to 0 if not used
        , blueMask          :: !Word32 -- ^ Blue bitfield mask, set to 0 if not used
        -- Fields added to the header in V3
        , alphaMask         :: !Word32 -- ^ Alpha bitfield mask, set to 0 if not used
        -- Fields added to the header in V4
        , colorSpaceType    :: !ColorSpaceType
        , colorSpace        :: !B.ByteString -- ^ Windows color space, not decoded
        -- Fields added to the header in V5
        , iccIntent         :: !Word32
        , iccProfileData    :: !Word32
        , iccProfileSize    :: !Word32
        }
        deriving Show

    -- | Size of the Windows BITMAPV4INFOHEADER color space information.
    sizeofColorProfile :: Int
    sizeofColorProfile = 48

    -- | Sizes of basic BMP headers.
    sizeofBmpHeader, sizeofBmpCoreHeader, sizeofBmpInfoHeader :: Word32
    sizeofBmpHeader = 2 + 4 + 2 + 2 + 4
    sizeofBmpCoreHeader = 12
    sizeofBmpInfoHeader = 40

    -- | Sizes of extended BMP headers.
    sizeofBmpV2Header, sizeofBmpV3Header, sizeofBmpV4Header, sizeofBmpV5Header :: Word32
    sizeofBmpV2Header = 52
    sizeofBmpV3Header = 56
    sizeofBmpV4Header = 108
    sizeofBmpV5Header = 124

    instance Binary ColorSpaceType where
        put CalibratedRGB         = putWord32le 0
        put DeviceDependentRGB    = putWord32le 1
        put DeviceDependentCMYK   = putWord32le 2
        put ProfileEmbedded       = putWord32le 0x4D424544
        put ProfileLinked         = putWord32le 0x4C494E4B
        put SRGB                  = putWord32le 0x73524742
        put WindowsColorSpace     = putWord32le 0x57696E20
        put (UnknownColorSpace x) = putWord32le x
        get = do
          w <- getWord32le
          return $ case w of
            0          -> CalibratedRGB
            1          -> DeviceDependentRGB
            2          -> DeviceDependentCMYK
            0x4D424544 -> ProfileEmbedded
            0x4C494E4B -> ProfileLinked
            0x73524742 -> SRGB
            0x57696E20 -> WindowsColorSpace
            _          -> UnknownColorSpace w

    instance Binary BmpV5Header where
        put hdr = do
            putWord32le $ size hdr

            if (size hdr == sizeofBmpCoreHeader) then do
              putWord16le . fromIntegral $ width hdr
              putWord16le . fromIntegral $ height hdr
              putWord16le $ planes hdr
              putWord16le $ bitPerPixel hdr
            else do
              putInt32le $ width hdr
              putInt32le $ height hdr
              putWord16le $ planes hdr
              putWord16le $ bitPerPixel hdr

            when (size hdr > sizeofBmpCoreHeader) $ do
              putWord32le $ bitmapCompression hdr
              putWord32le $ byteImageSize hdr
              putInt32le $ xResolution hdr
              putInt32le $ yResolution hdr
              putWord32le $ colorCount hdr
              putWord32le $ importantColours hdr

            when (size hdr > sizeofBmpInfoHeader || bitmapCompression hdr == 3) $ do
              putWord32le $ redMask hdr
              putWord32le $ greenMask hdr
              putWord32le $ blueMask hdr

            when (size hdr > sizeofBmpV2Header) $
              putWord32le $ alphaMask hdr

            when (size hdr > sizeofBmpV3Header) $ do
              put $ colorSpaceType hdr
              putByteString $ colorSpace hdr

            when (size hdr > sizeofBmpV4Header) $ do
              put $ iccIntent hdr
              putWord32le $ iccProfileData hdr
              putWord32le $ iccProfileSize hdr
              putWord32le 0 -- reserved field

        get = do
          readSize <- getWord32le
          if readSize == sizeofBmpCoreHeader
            then getBitmapCoreHeader readSize
            else getBitmapInfoHeader readSize

          where
            getBitmapCoreHeader readSize = do
              readWidth <- getWord16le
              readHeight <- getWord16le
              readPlanes <- getWord16le
              readBitPerPixel <- getWord16le
              return BmpV5Header {
                  size = readSize,
                  width = fromIntegral readWidth,
                  height = fromIntegral readHeight,
                  planes = readPlanes,
                  bitPerPixel = readBitPerPixel,
                  bitmapCompression = 0,
                  byteImageSize = 0,
                  xResolution = 2835,
                  yResolution = 2835,
                  colorCount = 2 ^ readBitPerPixel,
                  importantColours = 0,
                  redMask = 0,
                  greenMask = 0,
                  blueMask = 0,
                  alphaMask = 0,
                  colorSpaceType = DeviceDependentRGB,
                  colorSpace = B.empty,
                  iccIntent = 0,
                  iccProfileData = 0,
                  iccProfileSize = 0
              }

            getBitmapInfoHeader readSize = do
              readWidth <- getInt32le
              readHeight <- getInt32le
              readPlanes <- getWord16le
              readBitPerPixel <- getWord16le
              readBitmapCompression <- getWord32le
              readByteImageSize <- getWord32le
              readXResolution <- getInt32le
              readYResolution <- getInt32le
              readColorCount <- getWord32le
              readImportantColours <- getWord32le

              (readRedMask, readGreenMask, readBlueMask) <-
                if readSize == sizeofBmpInfoHeader && readBitmapCompression /= 3
                  then return (0, 0, 0)
                  else do
                    -- fields added to the header in V2, but sometimes present
                    -- immediately after a plain BITMAPINFOHEADER
                    innerReadRedMask <- getWord32le
                    innerReadGreenMask <- getWord32le
                    innerReadBlueMask <- getWord32le
                    return (innerReadRedMask, innerReadGreenMask, innerReadBlueMask)

              -- field added in V3 (undocumented)
              readAlphaMask <- if readSize < sizeofBmpV3Header then return 0 else getWord32le

              (readColorSpaceType, readColorSpace) <-
                if readSize < sizeofBmpV4Header
                  then return (DeviceDependentRGB, B.empty)
                  else do
                    -- fields added in V4 (Windows 95)
                    csType <- get
                    cs <- getByteString sizeofColorProfile
                    return (csType, cs)

              (readIccIntent, readIccProfileData, readIccProfileSize) <-
                if readSize < sizeofBmpV5Header
                  then return (0, 0, 0)
                  else do
                    -- fields added in V5 (Windows 98)
                    innerIccIntent <- getWord32le
                    innerIccProfileData <- getWord32le
                    innerIccProfileSize <- getWord32le
                    void getWord32le -- reserved field
                    return (innerIccIntent, innerIccProfileData, innerIccProfileSize)

              return BmpV5Header {
                  size = readSize,
                  width = readWidth,
                  height = readHeight,
                  planes = readPlanes,
                  bitPerPixel = readBitPerPixel,
                  bitmapCompression = readBitmapCompression,
                  byteImageSize = readByteImageSize,
                  xResolution = readXResolution,
                  yResolution = readYResolution,
                  colorCount = readColorCount,
                  importantColours = readImportantColours,
                  redMask = readRedMask,
                  greenMask = readGreenMask,
                  blueMask = readBlueMask,
                  alphaMask = readAlphaMask,
                  colorSpaceType = readColorSpaceType,
                  colorSpace = readColorSpace,
                  iccIntent = readIccIntent,
                  iccProfileData = readIccProfileData,
                  iccProfileSize = readIccProfileSize
              }

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

    putPalette :: BmpPalette -> Put
    putPalette (BmpPalette p) = mapM_ (\(r, g, b, a) -> put r >> put g >> put b >> put a) p

    putICCProfile :: Maybe B.ByteString -> Put
    putICCProfile Nothing = return ()
    putICCProfile (Just bytes) = put 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 _ = BmpPalette []

    stridePut :: M.STVector s Word8 -> Int -> Int -> ST s ()
    {-# INLINE stridePut #-}
    stridePut vec = inner
     where inner  _ 0 = return ()
           inner ix n = do
               (vec `M.unsafeWrite` ix) 0
               inner (ix + 1) (n - 1)

    instance BmpEncodable Pixel8 where
        hasAlpha _ = False
        defaultPalette _ = BmpPalette [(x,x,x, 255) | x <- [0 .. 255]]
        bitsPerPixel _ = 8
        bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) =
          forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ encodeLine l
            where stride = fromIntegral $ linePadding 8 w
                  putVector vec = putByteString $ blitVector vec 0 lineWidth
                  lineWidth = w + stride

                  encodeLine :: forall s. Int -> ST s (VS.Vector Word8)
                  encodeLine line = do
                      buff <- M.new lineWidth

                      let lineIdx = line * w
                          inner col | col >= w = return ()
                          inner col = do
                              let v = arr `VS.unsafeIndex` (lineIdx + col)
                              (buff `M.unsafeWrite` col) v
                              inner (col + 1)

                      inner 0

                      stridePut buff w stride
                      VS.unsafeFreeze buff

    instance BmpEncodable PixelRGBA8 where
        hasAlpha _ = True
        bitsPerPixel _ = 32
        bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) =
          forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ putLine l
          where
            putVector vec = putByteString . blitVector vec 0 $ w * 4

            putLine :: forall s. Int -> ST s (VS.Vector Word8)
            putLine line = do
                buff <- M.new $ 4 * w
                let initialIndex = line * w * 4
                    inner col _ _ | col >= w = return ()
                    inner col writeIdx readIdx = do
                        let r = arr `VS.unsafeIndex` readIdx
                            g = arr `VS.unsafeIndex` (readIdx + 1)
                            b = arr `VS.unsafeIndex` (readIdx + 2)
                            a = arr `VS.unsafeIndex` (readIdx + 3)

                        (buff `M.unsafeWrite` writeIdx) b
                        (buff `M.unsafeWrite` (writeIdx + 1)) g
                        (buff `M.unsafeWrite` (writeIdx + 2)) r
                        (buff `M.unsafeWrite` (writeIdx + 3)) a

                        inner (col + 1) (writeIdx + 4) (readIdx + 4)

                inner 0 0 initialIndex
                VS.unsafeFreeze buff

    instance BmpEncodable PixelRGB8 where
        hasAlpha _ = False
        bitsPerPixel _ = 24
        bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) =
           forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ putLine l
            where
              stride = fromIntegral . linePadding 24 $ w

              putVector vec = putByteString $ blitVector vec 0 (w * 3 + stride)

              putLine :: forall s. Int -> ST s (VS.Vector Word8)
              putLine line = do
                  buff <- M.new $ w * 3 + stride
                  let initialIndex = line * w * 3
                      inner col _ _ | col >= w = return ()
                      inner col writeIdx readIdx = do
                          let r = arr `VS.unsafeIndex` readIdx
                              g = arr `VS.unsafeIndex` (readIdx + 1)
                              b = arr `VS.unsafeIndex` (readIdx + 2)

                          (buff `M.unsafeWrite` writeIdx) b
                          (buff `M.unsafeWrite` (writeIdx + 1)) g
                          (buff `M.unsafeWrite` (writeIdx + 2)) r

                          inner (col + 1) (writeIdx + 3) (readIdx + 3)

                  inner 0 0 initialIndex
                  VS.unsafeFreeze buff

    -- | Information required to extract data from a bitfield.
    data Bitfield t = Bitfield
        { bfMask :: !t            -- ^ The original bitmask.
        , bfShift :: !Int         -- ^ The computed number of bits to shift right.
        , bfScale :: !Float       -- ^ The scale factor to fit the data into 8 bits.
        } deriving (Eq, Show)

    -- | Four bitfields (red, green, blue, alpha)
    data Bitfields4 t = Bitfields4 !(Bitfield t)
                                   !(Bitfield t)
                                   !(Bitfield t)
                                   !(Bitfield t)
                                   deriving (Eq, Show)

    -- | Default bitfields 32 bit bitmaps.
    defaultBitfieldsRGB32 :: Bitfields3 Word32
    defaultBitfieldsRGB32 = Bitfields3 (makeBitfield 0x00FF0000)
                                       (makeBitfield 0x0000FF00)
                                       (makeBitfield 0x000000FF)

    -- | Default bitfields for 16 bit bitmaps.
    defaultBitfieldsRGB16 :: Bitfields3 Word16
    defaultBitfieldsRGB16 = Bitfields3 (makeBitfield 0x7C00)
                                       (makeBitfield 0x03E0)
                                       (makeBitfield 0x001F)

    -- | Three bitfields (red, gree, blue).
    data Bitfields3 t = Bitfields3 !(Bitfield t)
                                   !(Bitfield t)
                                   !(Bitfield t)
                                   deriving (Eq, Show)

    -- | Pixel formats used to encode RGBA image data.
    data RGBABmpFormat = RGBA32 !(Bitfields4 Word32)
                       | RGBA16 !(Bitfields4 Word16)
                       deriving (Eq, Show)

    -- | Pixel formats used to encode RGB image data.
    data RGBBmpFormat = RGB32 !(Bitfields3 Word32)
                      | RGB24
                      | RGB16 !(Bitfields3 Word16)
                      deriving (Eq, Show)

    -- | Pixel formats used to encode indexed or grayscale images.
    data IndexedBmpFormat = OneBPP | FourBPP | EightBPP deriving Show

    -- | Extract pixel data from a bitfield.
    extractBitfield :: (FiniteBits t, Integral t) => Bitfield t -> t -> Word8
    extractBitfield bf t = if bfScale bf == 1
                            then fromIntegral field
                            else round $ bfScale bf * fromIntegral field
      where field = (t .&. bfMask bf) `unsafeShiftR` bfShift bf

    -- | Convert a bit mask into a 'BitField'.
    makeBitfield :: (FiniteBits t, Integral t) => t -> Bitfield t
    makeBitfield mask = Bitfield mask shiftBits scale
      where
        shiftBits = countTrailingZeros mask
        scale = 255 / fromIntegral (mask `unsafeShiftR` shiftBits)

    -- | Helper method to cast a 'B.ByteString' to a 'VS.Vector' of some type.
    castByteString :: VS.Storable a => B.ByteString -> VS.Vector a
    castByteString (BI.PS fp offset len) = VS.unsafeCast $ VS.unsafeFromForeignPtr fp offset len

    decodeImageRGBA8 :: RGBABmpFormat -> BmpV5Header -> B.ByteString -> Image PixelRGBA8
    decodeImageRGBA8 pixelFormat (BmpV5Header { width = w, height = h, bitPerPixel = bpp }) str = Image wi hi stArray where
      wi = fromIntegral w
      hi = abs $ fromIntegral h
      stArray = runST $ do
          arr <- M.new (fromIntegral $ w * abs h * 4)
          if h > 0 then
            foldM_ (readLine arr) 0 [0 .. hi - 1]
          else
            foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0]
          VS.unsafeFreeze arr

      paddingWords = (8 * linePadding intBPP wi) `div` intBPP
      intBPP = fromIntegral bpp

      readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int
      readLine arr readIndex line = case pixelFormat of
          RGBA32 bitfields -> inner bitfields (castByteString str) readIndex writeIndex
          RGBA16 bitfields -> inner bitfields (castByteString str) readIndex writeIndex
        where
          lastIndex = wi * (hi - 1 - line + 1) * 4
          writeIndex = wi * (hi - 1 - line) * 4

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

    decodeImageRGB8 :: RGBBmpFormat -> BmpV5Header -> B.ByteString -> Image PixelRGB8
    decodeImageRGB8 pixelFormat (BmpV5Header { width = w, height = h, bitPerPixel = bpp }) str = Image wi hi stArray where
      wi = fromIntegral w
      hi = abs $ fromIntegral h
      stArray = runST $ do
          arr <- M.new (fromIntegral $ w * abs h * 3)
          if h > 0 then
            foldM_ (readLine arr) 0 [0 .. hi - 1]
          else
            foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0]
          VS.unsafeFreeze arr

      paddingBytes = linePadding intBPP wi
      paddingWords = (linePadding intBPP wi * 8) `div` intBPP
      intBPP = fromIntegral bpp

      readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int
      readLine arr readIndex line = case pixelFormat of
          RGB16 bitfields -> innerBF bitfields (castByteString str) readIndex writeIndex
          RGB32 bitfields -> innerBF bitfields (castByteString str) readIndex writeIndex
          RGB24 -> inner24 readIndex writeIndex
        where
          lastIndex = wi * (hi - 1 - line + 1) * 3
          writeIndex = wi * (hi - 1 - line) * 3

          inner24 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + paddingBytes
          inner24 readIdx writeIdx = do
              (arr `M.unsafeWrite`  writeIdx     ) (str `B.index` (readIdx + 2))
              (arr `M.unsafeWrite` (writeIdx + 1)) (str `B.index` (readIdx + 1))
              (arr `M.unsafeWrite` (writeIdx + 2)) (str `B.index`  readIdx)
              inner24 (readIdx + 3) (writeIdx + 3)

          innerBF
            :: (FiniteBits t, Integral t, M.Storable t, Show t)
            => Bitfields3 t
            -> VS.Vector t
            -> Int
            -> Int
            -> ST s Int
          innerBF (Bitfields3 r g b) inStr = innerBF0
            where
              innerBF0 :: Int -> Int -> ST s Int
              innerBF0 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + paddingWords
              innerBF0 readIdx writeIdx = do
                let word = inStr VS.! readIdx
                (arr `M.unsafeWrite`  writeIdx     ) (extractBitfield r word)
                (arr `M.unsafeWrite` (writeIdx + 1)) (extractBitfield g word)
                (arr `M.unsafeWrite` (writeIdx + 2)) (extractBitfield b word)
                innerBF0 (readIdx + 1) (writeIdx + 3)

    decodeImageY8 :: IndexedBmpFormat -> BmpV5Header -> B.ByteString -> Image Pixel8
    decodeImageY8 lowBPP (BmpV5Header { width = w, height = h, bitPerPixel = bpp }) str = Image wi hi stArray where
      wi = fromIntegral w
      hi = abs $ fromIntegral h
      stArray = runST $ do
          arr <- M.new . fromIntegral $ w * abs h
          if h > 0 then
            foldM_ (readLine arr) 0 [0 .. hi - 1]
          else
            foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0]
          VS.unsafeFreeze arr

      padding = linePadding (fromIntegral bpp) wi

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

          inner8 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + padding
          inner8 readIdx writeIdx = do
            (arr `M.unsafeWrite` writeIdx) (str `B.index` readIdx)
            inner8 (readIdx + 1) (writeIdx + 1)

          inner4 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + padding
          inner4 readIdx writeIdx = do
            let byte = str `B.index` readIdx
            if writeIdx >= lastIndex - 1 then do
              (arr `M.unsafeWrite` writeIdx) (byte `unsafeShiftR` 4)
              inner4 (readIdx + 1) (writeIdx + 1)
            else do
              (arr `M.unsafeWrite` writeIdx) (byte `unsafeShiftR` 4)
              (arr `M.unsafeWrite` (writeIdx + 1)) (byte .&. 0x0F)
              inner4 (readIdx + 1) (writeIdx + 2)

          inner1 readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + padding
          inner1 readIdx writeIdx = do
            let byte = str `B.index` readIdx
            let toWrite = (lastIndex - writeIdx) `min` 8
            forM_ [0 .. (toWrite - 1)] $ \i ->
              when (byte `testBit` (7 - i)) $ (arr `M.unsafeWrite` (writeIdx + i)) 1
            inner1 (readIdx + 1) (writeIdx + toWrite)

    decodeImageY8RLE :: Bool -> BmpV5Header -> B.ByteString -> Image Pixel8
    decodeImageY8RLE is4bpp (BmpV5Header { width = w, height = h, byteImageSize = sz }) str = Image wi hi stArray where
      wi = fromIntegral w
      hi = abs $ fromIntegral h
      xOffsetMax = wi - 1

      stArray = runST $ do
        arr <- M.new . fromIntegral $ w * abs h
        decodeRLE arr (B.unpack (B.take (fromIntegral sz) str)) ((hi - 1) * wi, 0)
        VS.unsafeFreeze arr

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

          -- | Write n copies of a byte to the output array.
          writeN :: Int -> Word8 -> [Word8] -> (Int, Int) -> ST s ()
          writeN 0 _ rest writePos = inner rest writePos
          writeN n b rest writePos =
            case (is4bpp, n) of
              (True, 1) ->
                writeByte (b `unsafeShiftR` 4) writePos >>= writeN (n - 1) b rest
              (True, _) ->
                writeByte (b `unsafeShiftR` 4) writePos
                  >>= writeByte (b .&. 0x0F) >>= writeN (n - 2) b rest
              (False, _) ->
                writeByte b writePos >>= writeN (n - 1) b 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 _ _ [] _ = return ()
          copyN False 0 rest writePos = inner rest writePos
          copyN True 0 (_:rest) writePos = inner rest writePos
          copyN isPadded n (b : rest) writePos =
            case (is4bpp, n) of
              (True, 1) ->
                writeByte (b `unsafeShiftR` 4) writePos >>= copyN isPadded (n - 1) rest
              (True, _) ->
                writeByte (b `unsafeShiftR` 4) writePos
                  >>= writeByte (b .&. 0x0F) >>= copyN isPadded (n - 2) rest
              (False, _) ->
                writeByte b writePos >>= copyN isPadded (n - 1) rest

          -- | Write the next byte to the output array.
          writeByte :: Word8 -> (Int, Int) -> ST s (Int, Int)
          writeByte byte (yOffset, xOffset) = do
            (arr `M.unsafeWrite` (yOffset + xOffset)) byte
            return (yOffset, (xOffset + 1) `min` xOffsetMax)

    pixel4Get :: Get [Word8]
    pixel4Get = do
        b <- getWord8
        g <- getWord8
        r <- getWord8
        _ <- getWord8
        return [r, g, b]

    pixel3Get :: Get [Word8]
    pixel3Get = do
        b <- getWord8
        g <- getWord8
        r <- getWord8
        return [r, g, b]

    metadataOfHeader :: BmpV5Header -> Maybe B.ByteString -> Metadatas
    metadataOfHeader hdr iccProfile =
        cs `mappend` Met.simpleMetadata Met.SourceBitmap (width hdr) (abs $ height hdr) dpiX dpiY
      where
        dpiX = Met.dotsPerMeterToDotPerInch . fromIntegral $ xResolution hdr
        dpiY = Met.dotsPerMeterToDotPerInch . fromIntegral $ yResolution hdr
        cs = case colorSpaceType hdr of
              CalibratedRGB -> Met.singleton
                Met.ColorSpace (Met.WindowsBitmapColorSpace $ colorSpace hdr)
              SRGB -> Met.singleton Met.ColorSpace Met.SRGB
              ProfileEmbedded -> case iccProfile of
                                  Nothing -> Met.empty
                                  Just profile -> Met.singleton Met.ColorSpace
                                                    (Met.ICCProfile profile)
              _ -> 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 = fmap fst . decodeBitmapWithMetadata

    -- | Same as 'decodeBitmap' but also extracts metadata.
    decodeBitmapWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
    decodeBitmapWithMetadata byte =
      first palettedToTrueColor <$> decodeBitmapWithPaletteAndMetadata byte

    -- | Same as 'decodeBitmap' but also extracts metadata and provide separated palette.
    decodeBitmapWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)
    decodeBitmapWithPaletteAndMetadata str = flip runGetStrict str $ do
      fileHeader <- get :: Get BmpHeader
      bmpHeader  <- get :: Get BmpV5Header

      readed <- bytesRead
      when (readed > fromIntegral (dataOffset fileHeader))
           (fail "Invalid bmp image, data in header")

      when (width bmpHeader <= 0)
           (fail $ "Invalid bmp width, " ++ show (width bmpHeader))

      when (height bmpHeader == 0)
           (fail $ "Invalid bmp height (0) ")

      decodeBitmapWithHeaders fileHeader bmpHeader

    -- | Decode the rest of a bitmap, after the headers have been decoded.
    decodeBitmapWithHeaders :: BmpHeader -> BmpV5Header -> Get (PalettedImage, Metadatas)
    decodeBitmapWithHeaders fileHdr hdr = do
        img <- bitmapData
        profile <- getICCProfile
        return $ addMetadata profile img

      where
        bpp = fromIntegral $ bitPerPixel hdr :: Int
        paletteColorCount
          | colorCount hdr == 0 = 2 ^ bpp
          | otherwise = fromIntegral $ colorCount hdr

        addMetadata profile i = (i, metadataOfHeader hdr profile)

        getData = do
          readed <- bytesRead
          label "Start of pixel data" $
            skip . fromIntegral $ dataOffset fileHdr - fromIntegral readed
          let pixelBytes = if bitmapCompression hdr == 1 || bitmapCompression hdr == 2
                              then fromIntegral $ byteImageSize hdr
                              else sizeofPixelData bpp (fromIntegral $ width hdr)
                                                       (fromIntegral $ height hdr)
          label "Pixel data" $ getByteString pixelBytes

        getICCProfile =
          if size hdr >= sizeofBmpV5Header
              && colorSpaceType hdr == ProfileLinked
              && iccProfileData hdr > 0
              && iccProfileSize hdr > 0
          then do
            readSoFar <- bytesRead
            label "Start of embedded ICC color profile" $
              skip $ fromIntegral (iccProfileData hdr) - fromIntegral readSoFar
            profile <- label "Embedded ICC color profile" $
                          getByteString . fromIntegral $ iccProfileSize hdr
            return (Just profile)
          else return Nothing

        bitmapData = case (bitPerPixel hdr, planes hdr, bitmapCompression hdr) of
          (32, 1, 0) -> do
            rest <- getData
            return . TrueColorImage . ImageRGB8 $
              decodeImageRGB8 (RGB32 defaultBitfieldsRGB32) hdr rest
            -- (2, 1, 0, 3) means BGRA pixel order
          (32, 1, 3) -> do
            r <- getBitfield $ redMask hdr
            g <- getBitfield $ greenMask hdr
            b <- getBitfield $ blueMask hdr
            rest     <- getData
            if alphaMask hdr == 0
              then return . TrueColorImage . ImageRGB8 $
                decodeImageRGB8 (RGB32 $ Bitfields3 r g b) hdr rest
              else do
                a <- getBitfield $ alphaMask hdr
                return . TrueColorImage . ImageRGBA8 $
                  decodeImageRGBA8 (RGBA32 $ Bitfields4 r g b a) hdr rest
          (24, 1, 0) -> do
            rest <- getData
            return . TrueColorImage . ImageRGB8 $
              decodeImageRGB8 RGB24 hdr rest
          (16, 1, 0) -> do
            rest <- getData
            return . TrueColorImage . ImageRGB8 $
              decodeImageRGB8 (RGB16 defaultBitfieldsRGB16) hdr rest
          (16, 1, 3) -> do
            r <- getBitfield . fromIntegral $ 0xFFFF .&. redMask hdr
            g <- getBitfield . fromIntegral $ 0xFFFF .&. greenMask hdr
            b <- getBitfield . fromIntegral $ 0xFFFF .&. blueMask hdr
            rest     <- getData
            if alphaMask hdr == 0
              then return . TrueColorImage . ImageRGB8 $
                decodeImageRGB8 (RGB16 $ Bitfields3 r g b) hdr rest
              else do
                a <- getBitfield . fromIntegral $ 0xFFFF .&. alphaMask hdr
                return . TrueColorImage . ImageRGBA8 $
                  decodeImageRGBA8 (RGBA16 $ Bitfields4 r g b a) hdr rest
          ( _, 1, compression) -> do
            table <- if size hdr == sizeofBmpCoreHeader
                        then replicateM paletteColorCount pixel3Get
                        else replicateM paletteColorCount pixel4Get
            rest <- getData
            let palette = Palette'
                  { _paletteSize = paletteColorCount
                  , _paletteData = VS.fromListN (paletteColorCount * 3) $ concat table
                  }
            image <-
              case (bpp, compression) of
                (8, 0) -> return $ decodeImageY8 EightBPP hdr rest
                (4, 0) -> return $ decodeImageY8 FourBPP hdr rest
                (1, 0) -> return $ decodeImageY8 OneBPP hdr rest
                (8, 1) -> return $ decodeImageY8RLE False hdr rest
                (4, 2) -> return $ decodeImageY8RLE True hdr rest
                (a, b) -> fail $ "Can't handle BMP file " ++ show (a, 1 :: Int, b)

            return $ PalettedRGB8 image palette

          a          -> fail $ "Can't handle BMP file " ++ show 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 0 = fail $
      "Codec.Picture.Bitmap.getBitfield: bitfield cannot be 0"
    getBitfield w = return (makeBitfield w)

    -- | Compute the size of the pixel data
    sizeofPixelData :: Int -> Int -> Int -> Int
    sizeofPixelData bpp lineWidth nLines = ((bpp * (abs lineWidth) + 31) `div` 32) * 4 * abs nLines

    -- | Write an image in a file use the bitmap format.
    writeBitmap :: (BmpEncodable pixel)
                => FilePath -> Image pixel -> IO ()
    writeBitmap filename img = L.writeFile filename $ encodeBitmap img

    linePadding :: Int -> Int -> Int
    linePadding bpp imgWidth = (4 - (bytesPerLine `mod` 4)) `mod` 4
      where bytesPerLine = (bpp * imgWidth + 7) `div` 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 = encodeBitmapWithPalette (defaultPalette (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 metas =
      encodeBitmapWithPaletteAndMetadata metas (defaultPalette (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 path img = case encodeDynamicBitmap img of
            Left err -> return $ Left err
            Right b  -> L.writeFile path b >> return (Right True)

    -- | Encode a dynamic image in BMP if possible, supported images are:
    --
    --   - 'ImageY8'
    --
    --   - 'ImageRGB8'
    --
    --   - 'ImageRGBA8'
    --
    encodeDynamicBitmap :: DynamicImage -> Either String L.ByteString
    encodeDynamicBitmap (ImageRGB8 img) = Right $ encodeBitmap img
    encodeDynamicBitmap (ImageRGBA8 img) = Right $ encodeBitmap img
    encodeDynamicBitmap (ImageY8 img) = Right $ encodeBitmap img
    encodeDynamicBitmap _ = Left "Unsupported image format for bitmap export"

    extractDpiOfMetadata :: Metadatas -> (Word32, Word32)
    extractDpiOfMetadata metas = (fetch Met.DpiX, fetch Met.DpiY) where
      fetch k = maybe 0 (fromIntegral . Met.dotPerInchToDotsPerMeter) $ Met.lookup k metas

    -- | Convert an image to a bytestring ready to be serialized.
    encodeBitmapWithPalette :: forall pixel. (BmpEncodable pixel)
                            => BmpPalette -> Image pixel -> L.ByteString
    encodeBitmapWithPalette = encodeBitmapWithPaletteAndMetadata 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 metas pal@(BmpPalette palette) img =
      runPut $ put hdr >> put info >> putPalette pal >> bmpEncode img
                       >> putICCProfile colorProfileData

        where imgWidth = fromIntegral $ imageWidth img
              imgHeight = fromIntegral $ imageHeight img
              (dpiX, dpiY) = extractDpiOfMetadata metas
              cs = Met.lookup Met.ColorSpace metas
              colorType = case cs of
                            Just Met.SRGB -> SRGB
                            Just (Met.WindowsBitmapColorSpace _) -> CalibratedRGB
                            Just (Met.ICCProfile _) -> ProfileEmbedded
                            Nothing -> DeviceDependentRGB

              colorSpaceInfo = case cs of
                                Just (Met.WindowsBitmapColorSpace bytes) -> bytes
                                _ -> B.pack $ replicate sizeofColorProfile 0

              colorProfileData = case cs of
                                  Just (Met.ICCProfile bytes) -> Just bytes
                                  _ -> Nothing

              headerSize | colorType == ProfileEmbedded                = sizeofBmpV5Header
                         | colorType == CalibratedRGB || hasAlpha img  = sizeofBmpV4Header
                         | otherwise                                   = sizeofBmpInfoHeader

              paletteSize = fromIntegral $ length palette
              bpp = bitsPerPixel (undefined :: pixel)

              profileSize = fromIntegral $ maybe 0 B.length colorProfileData
              imagePixelSize = fromIntegral $ sizeofPixelData bpp imgWidth imgHeight
              offsetToData = sizeofBmpHeader + headerSize + 4 * paletteSize
              offsetToICCProfile = offsetToData + imagePixelSize <$ colorProfileData
              sizeOfFile = sizeofBmpHeader + headerSize + 4 * paletteSize
                            + imagePixelSize + profileSize

              hdr = BmpHeader {
                  magicIdentifier = bitmapMagicIdentifier,
                  fileSize = sizeOfFile,
                  reserved1 = 0,
                  reserved2 = 0,
                  dataOffset = offsetToData
              }

              info = BmpV5Header {
                  size = headerSize,
                  width = fromIntegral imgWidth,
                  height = fromIntegral imgHeight,
                  planes = 1,
                  bitPerPixel = fromIntegral bpp,
                  bitmapCompression = if hasAlpha img then 3 else 0,
                  byteImageSize = imagePixelSize,
                  xResolution = fromIntegral dpiX,
                  yResolution = fromIntegral dpiY,
                  colorCount = paletteSize,
                  importantColours = 0,
                  redMask   = if hasAlpha img then 0x00FF0000 else 0,
                  greenMask = if hasAlpha img then 0x0000FF00 else 0,
                  blueMask  = if hasAlpha img then 0x000000FF else 0,
                  alphaMask = if hasAlpha img then 0xFF000000 else 0,
                  colorSpaceType = colorType,
                  colorSpace = colorSpaceInfo,
                  iccIntent = 0,
                  iccProfileData = fromMaybe 0 offsetToICCProfile,
                  iccProfileSize = profileSize
              }

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