    {-# OPTIONS_HADDOCK hide #-}
    module Codec.BMP.Unpack
            (unpackBMPToRGBA32)
    where
    import Codec.BMP.Base
    import Codec.BMP.BitmapInfo
    import Codec.BMP.BitmapInfoV3
    import Foreign.Ptr
    import Foreign.Marshal.Alloc
    import Foreign.Storable
    import System.IO.Unsafe
    import Data.Word
    import Data.ByteString          as BS
    import Data.ByteString.Unsafe   as BS
    import Prelude                  as P

    -- | Unpack a BMP image to a string of RGBA component values.
    unpackBMPToRGBA32 :: BMP -> ByteString
    unpackBMPToRGBA32 :: BMP -> ByteString
    unpackBMPToRGBA32 BMP
    bmp
     = let  info :: BitmapInfoV3
    info            = BitmapInfo -> BitmapInfoV3
    getBitmapInfoV3 (BitmapInfo -> BitmapInfoV3) -> BitmapInfo -> BitmapInfoV3
    forall a b. (a -> b) -> a -> b
    $ BMP -> BitmapInfo
    bmpBitmapInfo BMP
    bmp
            width :: Int
    width           = Word32 -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word32 -> Int) -> Word32 -> Int
    forall a b. (a -> b) -> a -> b
    $ BitmapInfoV3 -> Word32
    dib3Width  BitmapInfoV3
    info
            height :: Int
    height          = Word32 -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word32 -> Int) -> Word32 -> Int
    forall a b. (a -> b) -> a -> b
    $ BitmapInfoV3 -> Word32
    dib3Height BitmapInfoV3
    info
            flipX :: Bool
    flipX           = BitmapInfoV3 -> Bool
    dib3HeightFlipped BitmapInfoV3
    info
            bitCount :: Word16
    bitCount        = BitmapInfoV3 -> Word16
    dib3BitCount BitmapInfoV3
    info
       in   case Word16
    bitCount of
             Word16
    24     -> Int -> Int -> Bool -> ByteString -> ByteString
    packRGB24ToRGBA32 Int
    width Int
    height Bool
    flipX (BMP -> ByteString
    bmpRawImageData BMP
    bmp)
             Word16
    32     -> Int -> Int -> Bool -> ByteString -> ByteString
    packRGB32ToRGBA32 Int
    width Int
    height Bool
    flipX (BMP -> ByteString
    bmpRawImageData BMP
    bmp)
             Word16
    _      -> [Char] -> ByteString
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Codec.BMP: Unhandled bitcount."

    -- | Unpack raw, uncompressed 24 bit BMP image data to a string of
    --   RGBA component values.
    --
    --   The alpha component is set to 255 for every pixel.
    packRGB24ToRGBA32
            :: Int                  -- ^ Width of image.
            -> Int                  -- ^ Height of image.
            -> Bool                 -- ^ Image data is flipped along the X axis.
            -> ByteString           -- ^ Input string.
            -> ByteString

    packRGB24ToRGBA32 :: Int -> Int -> Bool -> ByteString -> ByteString
    packRGB24ToRGBA32 Int
    width Int
    height Bool
    flipX ByteString
    str
     = let  -- Number of bytes per line in the source file,
            -- including padding bytes.
            srcBytesPerLine :: Int
    srcBytesPerLine = ByteString -> Int
    BS.length ByteString
    str Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    height
            sizeDest :: Int
    sizeDest        = Int
    width Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    height Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    4

            -- We allow padding bytes on the end of the image data.
       in   if ByteString -> Int
    BS.length ByteString
    str Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    height Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    srcBytesPerLine
             then [Char] -> ByteString
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Codec.BMP: Image data is truncated."
             else IO ByteString -> ByteString
    forall a. IO a -> a
    unsafePerformIO
                    (IO ByteString -> ByteString) -> IO ByteString -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
    forall a b. Int -> (Ptr a -> IO b) -> IO b
    allocaBytes Int
    sizeDest      ((Ptr CChar -> IO ByteString) -> IO ByteString)
    -> (Ptr CChar -> IO ByteString) -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ \Ptr CChar
    bufDest ->
                      ByteString -> (Ptr CChar -> IO ByteString) -> IO ByteString
    forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
    BS.unsafeUseAsCString ByteString
    str ((Ptr CChar -> IO ByteString) -> IO ByteString)
    -> (Ptr CChar -> IO ByteString) -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ \Ptr CChar
    bufSrc  ->
                       do   Int
    -> Int
    -> Bool
    -> Int
    -> Ptr (ZonkAny 3)
    -> Ptr (ZonkAny 2)
    -> IO ()
    forall {b} {b}.
    Int -> Int -> Bool -> Int -> Ptr b -> Ptr b -> IO ()
    packRGB24ToRGBA32'
                                    Int
    width Int
    height Bool
    flipX
                                    Int
    srcBytesPerLine
                                    (Ptr CChar -> Ptr (ZonkAny 3)
    forall a b. Ptr a -> Ptr b
    castPtr Ptr CChar
    bufSrc) (Ptr CChar -> Ptr (ZonkAny 2)
    forall a b. Ptr a -> Ptr b
    castPtr Ptr CChar
    bufDest)
                            CStringLen -> IO ByteString
    packCStringLen (Ptr CChar
    bufDest, Int
    sizeDest)

    -- We're doing this via Ptrs because we don't want to take the
    -- overhead of doing the bounds checks in ByteString.index.
    packRGB24ToRGBA32' :: Int -> Int -> Bool -> Int -> Ptr b -> Ptr b -> IO ()
    packRGB24ToRGBA32' Int
    width Int
    height Bool
    flipX Int
    srcBytesPerLine Ptr b
    ptrSrc Ptr b
    ptrDst
     = Int -> IO ()
    go Int
    0
     where
            go :: Int -> IO ()
    go Int
    posY
             -- we've finished the image.
             | Int
    posY Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    height
             = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

             -- Image source data is flipped along the X axis.
             | Bool
    flipX
             = let  !oSrc :: Int
    oSrc   = Int
    srcBytesPerLine Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * (Int
    height Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    posY)
                    !oDst :: Int
    oDst   = Int
    width Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    4 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    posY
               in   Int -> Int -> Int -> Int -> IO ()
    go_line Int
    0 Int
    posY Int
    oSrc Int
    oDst

             -- Image source data is in the natural order.
             | Bool
    otherwise
             = let  !oSrc :: Int
    oSrc   = Int
    srcBytesPerLine Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    posY
                    !oDst :: Int
    oDst   = Int
    width Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    4 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    posY
               in   Int -> Int -> Int -> Int -> IO ()
    go_line Int
    0 Int
    posY Int
    oSrc Int
    oDst

            go_line :: Int -> Int -> Int -> Int -> IO ()
    go_line Int
    posX Int
    posY Int
    oSrc Int
    oDst
             -- move to the next line.
             | Int
    posX Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    width
             = Int -> IO ()
    go (Int
    posY Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1)

             -- process a pixel.
             | Bool
    otherwise
             = do   blue  :: Word8  <- Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptrSrc (Int
    oSrc Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    0)
                    green :: Word8  <- peekByteOff ptrSrc (oSrc + 1)
                    red   :: Word8  <- peekByteOff ptrSrc (oSrc + 2)

                    pokeByteOff ptrDst (oDst + 0) red
                    pokeByteOff ptrDst (oDst + 1) green
                    pokeByteOff ptrDst (oDst + 2) blue
                    pokeByteOff ptrDst (oDst + 3) (255 :: Word8)

                    go_line (posX + 1) posY (oSrc + 3) (oDst + 4)

    -- | Unpack raw, uncompressed 32 bit BMP image data to a string of
    --   RGBA component values.
    --   Note in the BMP file the components are arse-around ABGR instead of RGBA.
    --   The 'unpacking' here is really just flipping the components around.
    packRGB32ToRGBA32
            :: Int                  -- ^ Width of image.
            -> Int                  -- ^ Height of image.
            -> Bool                 -- ^ Image data is flipped along the X axis.
            -> ByteString           -- ^ Input string.
            -> ByteString

    packRGB32ToRGBA32 :: Int -> Int -> Bool -> ByteString -> ByteString
    packRGB32ToRGBA32 Int
    width Int
    height Bool
    flipX ByteString
    str
      = let sizeDest :: Int
    sizeDest = Int
    height Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    width Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    4
        in  if  ByteString -> Int
    BS.length ByteString
    str Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    sizeDest
             then [Char] -> ByteString
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Codec.BMP: Image data is truncated."
             else IO ByteString -> ByteString
    forall a. IO a -> a
    unsafePerformIO
                    (IO ByteString -> ByteString) -> IO ByteString -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Int -> (Ptr CChar -> IO ByteString) -> IO ByteString
    forall a b. Int -> (Ptr a -> IO b) -> IO b
    allocaBytes Int
    sizeDest      ((Ptr CChar -> IO ByteString) -> IO ByteString)
    -> (Ptr CChar -> IO ByteString) -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ \Ptr CChar
    bufDest ->
                      ByteString -> (Ptr CChar -> IO ByteString) -> IO ByteString
    forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
    BS.unsafeUseAsCString ByteString
    str ((Ptr CChar -> IO ByteString) -> IO ByteString)
    -> (Ptr CChar -> IO ByteString) -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ \Ptr CChar
    bufSrc  ->
                       do   Int -> Int -> Bool -> Ptr (ZonkAny 1) -> Ptr (ZonkAny 0) -> IO ()
    forall {b} {b}. Int -> Int -> Bool -> Ptr b -> Ptr b -> IO ()
    packRGB32ToRGBA32' Int
    width Int
    height
                                    Bool
    flipX
                                    (Ptr CChar -> Ptr (ZonkAny 1)
    forall a b. Ptr a -> Ptr b
    castPtr Ptr CChar
    bufSrc) (Ptr CChar -> Ptr (ZonkAny 0)
    forall a b. Ptr a -> Ptr b
    castPtr Ptr CChar
    bufDest)
                            CStringLen -> IO ByteString
    packCStringLen (Ptr CChar
    bufDest, Int
    sizeDest)

    -- We're doing this via Ptrs because we don't want to take the
    -- overhead of doing the bounds checks in ByteString.index.
    packRGB32ToRGBA32' :: Int -> Int -> Bool -> Ptr b -> Ptr b -> IO ()
    packRGB32ToRGBA32' Int
    width Int
    height Bool
    flipX Ptr b
    ptrSrc Ptr b
    ptrDst
     = Int -> IO ()
    go Int
    0
     where
            go :: Int -> IO ()
    go Int
    posY
             -- we've finished the image.
             | Int
    posY Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    height
             = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

             -- Image source data is flipped along the X axis.
             | Bool
    flipX
             = let  !oSrc :: Int
    oSrc   = Int
    width Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    4 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * (Int
    height Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    posY)
                    !oDst :: Int
    oDst   = Int
    width Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    4 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    posY
               in   Int -> Int -> Int -> Int -> IO ()
    go_line Int
    0 Int
    posY Int
    oSrc Int
    oDst

             -- Image source data is in the natural order.
             | Bool
    otherwise
             = let  !oSrc :: Int
    oSrc   = Int
    width Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    4 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    posY
                    !oDst :: Int
    oDst   = Int
    width Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    4 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    posY
               in   Int -> Int -> Int -> Int -> IO ()
    go_line Int
    0 Int
    posY Int
    oSrc Int
    oDst

            go_line :: Int -> Int -> Int -> Int -> IO ()
    go_line Int
    posX Int
    posY Int
    oSrc Int
    oDst
             -- move to the next line.
             | Int
    posX Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    width
             = Int -> IO ()
    go (Int
    posY Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1)

             -- process a pixel.
             | Bool
    otherwise
             = do   blue   :: Word8 <- Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptrSrc (Int
    oSrc Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    0)
                    green  :: Word8 <- peekByteOff ptrSrc (oSrc + 1)
                    red    :: Word8 <- peekByteOff ptrSrc (oSrc + 2)
                    alpha  :: Word8 <- peekByteOff ptrSrc (oSrc + 3)

                    pokeByteOff ptrDst (oDst + 0) red
                    pokeByteOff ptrDst (oDst + 1) green
                    pokeByteOff ptrDst (oDst + 2) blue
                    pokeByteOff ptrDst (oDst + 3) alpha

                    go_line (posX + 1) posY (oSrc + 4) (oDst + 4)