module Codec.Picture.Blp.Internal.Parser(
    blpParser
  , blpVersion
  , dword
  , compressionParser
  , flagsParser
  , pictureTypeParser
  , blpJpegParser
  , getPos
  , skipToOffset
  , blpUncompressed1Parser
  , blpUncompressed2Parser
  , parseBlp
  ) where

import Codec.Picture
import Control.Monad
import Data.Attoparsec.ByteString as AT
import Data.Bits
import Data.ByteString (ByteString)
import Data.List (nub)
import Data.Word

import qualified Data.Vector as V
import qualified Data.Attoparsec.Internal.Types as AT
import qualified Data.ByteString as BS

import Codec.Picture.Blp.Internal.Data

blpParser :: Parser BlpStruct
blpParser :: Parser BlpStruct
blpParser = do
  ByteString
_ <- Parser ByteString
blpVersion
  BlpCompression
blpCompression <- Parser BlpCompression
compressionParser
  [BlpFlag]
blpFlags <- Parser [BlpFlag]
flagsParser
  Word32
blpWidth <- Parser Word32
dword Parser Word32 -> String -> Parser Word32
forall i a. Parser i a -> String -> Parser i a
<?> "width"
  Word32
blpHeight <- Parser Word32
dword Parser Word32 -> String -> Parser Word32
forall i a. Parser i a -> String -> Parser i a
<?> "height"
  BlpPictureType
blpPictureType <- Parser BlpPictureType
pictureTypeParser
  Word32
blpPictureSubType <- Parser Word32
dword Parser Word32 -> String -> Parser Word32
forall i a. Parser i a -> String -> Parser i a
<?> "picture subtype"
  [Word32]
blpMipMapOffset <- Int -> Parser Word32 -> Parser ByteString [Word32]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM 16 Parser Word32
dword Parser ByteString [Word32] -> String -> Parser ByteString [Word32]
forall i a. Parser i a -> String -> Parser i a
<?> "mipmaps offsets"
  [Word32]
blpMipMapSize <- Int -> Parser Word32 -> Parser ByteString [Word32]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM 16 Parser Word32
dword Parser ByteString [Word32] -> String -> Parser ByteString [Word32]
forall i a. Parser i a -> String -> Parser i a
<?> "mipmaps sizes"
  let mipMapsInfo :: [(Word32, Word32)]
mipMapsInfo = [(Word32, Word32)] -> [(Word32, Word32)]
forall a. Eq a => [a] -> [a]
nub ([(Word32, Word32)] -> [(Word32, Word32)])
-> ([(Word32, Word32)] -> [(Word32, Word32)])
-> [(Word32, Word32)]
-> [(Word32, Word32)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word32, Word32) -> Bool)
-> [(Word32, Word32)] -> [(Word32, Word32)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Word32 -> Bool)
-> ((Word32, Word32) -> Word32) -> (Word32, Word32) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32, Word32) -> Word32
forall a b. (a, b) -> b
snd) ([(Word32, Word32)] -> [(Word32, Word32)])
-> [(Word32, Word32)] -> [(Word32, Word32)]
forall a b. (a -> b) -> a -> b
$ [Word32]
blpMipMapOffset [Word32] -> [Word32] -> [(Word32, Word32)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Word32]
blpMipMapSize
  BlpExt
blpExt <- case BlpCompression
blpCompression of
    BlpCompressionJPEG -> [(Word32, Word32)] -> Parser BlpExt
blpJpegParser [(Word32, Word32)]
mipMapsInfo
    BlpCompressionUncompressed -> case BlpPictureType
blpPictureType of
      JPEGType -> String -> Parser BlpExt
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "JPEG type with Uncompressed type mix"
      UncompressedWithAlpha -> [(Word32, Word32)] -> Parser BlpExt
blpUncompressed1Parser [(Word32, Word32)]
mipMapsInfo
      UncompressedWithoutAlpha -> [(Word32, Word32)] -> Parser BlpExt
blpUncompressed2Parser [(Word32, Word32)]
mipMapsInfo

  BlpStruct -> Parser BlpStruct
forall (m :: * -> *) a. Monad m => a -> m a
return (BlpStruct -> Parser BlpStruct) -> BlpStruct -> Parser BlpStruct
forall a b. (a -> b) -> a -> b
$ $WBlpStruct :: BlpCompression
-> [BlpFlag]
-> Word32
-> Word32
-> BlpPictureType
-> Word32
-> BlpExt
-> BlpStruct
BlpStruct {..}

blpVersion :: Parser ByteString
blpVersion :: Parser ByteString
blpVersion = ByteString -> Parser ByteString
string "BLP1" Parser ByteString -> String -> Parser ByteString
forall i a. Parser i a -> String -> Parser i a
<?> "BLP1 version tag"

dword :: Parser Word32
dword :: Parser Word32
dword = do
  ByteString
bs <- Int -> Parser ByteString
AT.take 4
  Word32 -> Parser Word32
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Parser Word32)
-> (ByteString -> Word32) -> ByteString -> Parser Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Word32
pack (ByteString -> Word32)
-> (ByteString -> ByteString) -> ByteString -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.reverse (ByteString -> Parser Word32) -> ByteString -> Parser Word32
forall a b. (a -> b) -> a -> b
$ ByteString
bs
  where
  pack :: ByteString -> Word32
pack = (Word32 -> Word8 -> Word32) -> Word32 -> ByteString -> Word32
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\n :: Word32
n h :: Word8
h -> (Word32
n Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` 8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
h) 0

rgba8 :: Parser PixelRGBA8
rgba8 :: Parser PixelRGBA8
rgba8 = Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 (Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8)
-> Parser ByteString Word8
-> Parser ByteString (Word8 -> Word8 -> Word8 -> PixelRGBA8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8 Parser ByteString (Word8 -> Word8 -> Word8 -> PixelRGBA8)
-> Parser ByteString Word8
-> Parser ByteString (Word8 -> Word8 -> PixelRGBA8)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Word8
anyWord8 Parser ByteString (Word8 -> Word8 -> PixelRGBA8)
-> Parser ByteString Word8
-> Parser ByteString (Word8 -> PixelRGBA8)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Word8
anyWord8 Parser ByteString (Word8 -> PixelRGBA8)
-> Parser ByteString Word8 -> Parser PixelRGBA8
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Word8
anyWord8

compressionParser :: Parser BlpCompression
compressionParser :: Parser BlpCompression
compressionParser = (Parser BlpCompression -> String -> Parser BlpCompression
forall i a. Parser i a -> String -> Parser i a
<?> "compression") (Parser BlpCompression -> Parser BlpCompression)
-> Parser BlpCompression -> Parser BlpCompression
forall a b. (a -> b) -> a -> b
$ do
  Word32
i <- Parser Word32
dword
  case Word32
i of
    0 -> BlpCompression -> Parser BlpCompression
forall (m :: * -> *) a. Monad m => a -> m a
return BlpCompression
BlpCompressionJPEG
    1 -> BlpCompression -> Parser BlpCompression
forall (m :: * -> *) a. Monad m => a -> m a
return BlpCompression
BlpCompressionUncompressed
    _ -> String -> Parser BlpCompression
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser BlpCompression)
-> String -> Parser BlpCompression
forall a b. (a -> b) -> a -> b
$ "Unknown compression " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
i

flagsParser :: Parser [BlpFlag]
flagsParser :: Parser [BlpFlag]
flagsParser = (Parser [BlpFlag] -> String -> Parser [BlpFlag]
forall i a. Parser i a -> String -> Parser i a
<?> "flags") (Parser [BlpFlag] -> Parser [BlpFlag])
-> Parser [BlpFlag] -> Parser [BlpFlag]
forall a b. (a -> b) -> a -> b
$ do
  Word32
i <- Parser Word32
dword
  [BlpFlag] -> Parser [BlpFlag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlpFlag] -> Parser [BlpFlag]) -> [BlpFlag] -> Parser [BlpFlag]
forall a b. (a -> b) -> a -> b
$ if Word32
i Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` 3
    then [BlpFlag
BlpFlagAlphaChannel]
    else []

pictureTypeParser :: Parser BlpPictureType
pictureTypeParser :: Parser BlpPictureType
pictureTypeParser = (Parser BlpPictureType -> String -> Parser BlpPictureType
forall i a. Parser i a -> String -> Parser i a
<?> "picture type") (Parser BlpPictureType -> Parser BlpPictureType)
-> Parser BlpPictureType -> Parser BlpPictureType
forall a b. (a -> b) -> a -> b
$ do
  Word32
i <- Parser Word32
dword
  case Word32
i of
    2 -> BlpPictureType -> Parser BlpPictureType
forall (m :: * -> *) a. Monad m => a -> m a
return BlpPictureType
JPEGType
    3 -> BlpPictureType -> Parser BlpPictureType
forall (m :: * -> *) a. Monad m => a -> m a
return BlpPictureType
UncompressedWithAlpha
    4 -> BlpPictureType -> Parser BlpPictureType
forall (m :: * -> *) a. Monad m => a -> m a
return BlpPictureType
UncompressedWithAlpha
    5 -> BlpPictureType -> Parser BlpPictureType
forall (m :: * -> *) a. Monad m => a -> m a
return BlpPictureType
UncompressedWithoutAlpha
    _ -> String -> Parser BlpPictureType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser BlpPictureType)
-> String -> Parser BlpPictureType
forall a b. (a -> b) -> a -> b
$ "Unknown picture type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
i

blpJpegParser :: [(Word32, Word32)] -> Parser BlpExt
blpJpegParser :: [(Word32, Word32)] -> Parser BlpExt
blpJpegParser mps :: [(Word32, Word32)]
mps = (Parser BlpExt -> String -> Parser BlpExt
forall i a. Parser i a -> String -> Parser i a
<?> "blp jpeg") (Parser BlpExt -> Parser BlpExt) -> Parser BlpExt -> Parser BlpExt
forall a b. (a -> b) -> a -> b
$ do
  Word32
headerSize <- Parser Word32
dword Parser Word32 -> String -> Parser Word32
forall i a. Parser i a -> String -> Parser i a
<?> "jpeg header size"
  ByteString
blpJpegHeader <- Int -> Parser ByteString
AT.take (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
headerSize) Parser ByteString -> String -> Parser ByteString
forall i a. Parser i a -> String -> Parser i a
<?> "jpeg header"
  [ByteString]
blpJpegData <- [(Word32, Word32)]
-> ((Word32, Word32) -> Parser ByteString)
-> Parser ByteString [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Word32, Word32)]
mps (((Word32, Word32) -> Parser ByteString)
 -> Parser ByteString [ByteString])
-> ((Word32, Word32) -> Parser ByteString)
-> Parser ByteString [ByteString]
forall a b. (a -> b) -> a -> b
$ \(offset :: Word32
offset, size :: Word32
size) -> do
    Word32 -> Parser ()
skipToOffset Word32
offset
    Int -> Parser ByteString
AT.take (Int -> Parser ByteString) -> Int -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size
  BlpExt -> Parser BlpExt
forall (m :: * -> *) a. Monad m => a -> m a
return (BlpExt -> Parser BlpExt) -> BlpExt -> Parser BlpExt
forall a b. (a -> b) -> a -> b
$ $WBlpJpeg :: ByteString -> [ByteString] -> BlpExt
BlpJpeg {..}

getPos :: Parser Int
getPos :: Parser Int
getPos = (forall r.
 State ByteString
 -> Pos
 -> More
 -> Failure ByteString (State ByteString) r
 -> Success ByteString (State ByteString) Int r
 -> IResult ByteString r)
-> Parser Int
forall i a.
(forall r.
 State i
 -> Pos
 -> More
 -> Failure i (State i) r
 -> Success i (State i) a r
 -> IResult i r)
-> Parser i a
AT.Parser ((forall r.
  State ByteString
  -> Pos
  -> More
  -> Failure ByteString (State ByteString) r
  -> Success ByteString (State ByteString) Int r
  -> IResult ByteString r)
 -> Parser Int)
-> (forall r.
    State ByteString
    -> Pos
    -> More
    -> Failure ByteString (State ByteString) r
    -> Success ByteString (State ByteString) Int r
    -> IResult ByteString r)
-> Parser Int
forall a b. (a -> b) -> a -> b
$ \t :: State ByteString
t pos :: Pos
pos more :: More
more _ succ' :: Success ByteString (State ByteString) Int r
succ' -> Success ByteString (State ByteString) Int r
succ' State ByteString
t Pos
pos More
more (Pos -> Int
AT.fromPos Pos
pos)

skipToOffset :: Word32 -> Parser ()
skipToOffset :: Word32 -> Parser ()
skipToOffset i :: Word32
i = do
  Int
pos <- Parser Int
getPos
  let diff :: Int
diff = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pos
  if Int
diff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 then () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else Parser ByteString -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser ByteString -> Parser ()) -> Parser ByteString -> Parser ()
forall a b. (a -> b) -> a -> b
$ Int -> Parser ByteString
AT.take Int
diff

blpUncompressed1Parser :: [(Word32, Word32)] -> Parser BlpExt
blpUncompressed1Parser :: [(Word32, Word32)] -> Parser BlpExt
blpUncompressed1Parser mps :: [(Word32, Word32)]
mps = do
  Vector PixelRGBA8
blpU1Palette <- Int -> Parser PixelRGBA8 -> Parser ByteString (Vector PixelRGBA8)
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
V.replicateM 256 Parser PixelRGBA8
rgba8
  [(ByteString, ByteString)]
blpU1MipMaps <- [(Word32, Word32)]
-> ((Word32, Word32) -> Parser ByteString (ByteString, ByteString))
-> Parser ByteString [(ByteString, ByteString)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Word32, Word32)]
mps (((Word32, Word32) -> Parser ByteString (ByteString, ByteString))
 -> Parser ByteString [(ByteString, ByteString)])
-> ((Word32, Word32) -> Parser ByteString (ByteString, ByteString))
-> Parser ByteString [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ \(offset :: Word32
offset, size :: Word32
size) -> do
    Word32 -> Parser ()
skipToOffset Word32
offset
    let halfSize :: Int
halfSize = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2
    ByteString
indexList <- Int -> Parser ByteString
AT.take Int
halfSize Parser ByteString -> String -> Parser ByteString
forall i a. Parser i a -> String -> Parser i a
<?> "index list"
    ByteString
alphaList <- Int -> Parser ByteString
AT.take Int
halfSize Parser ByteString -> String -> Parser ByteString
forall i a. Parser i a -> String -> Parser i a
<?> "alpha list"
    (ByteString, ByteString)
-> Parser ByteString (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
indexList, ByteString
alphaList)
  BlpExt -> Parser BlpExt
forall (m :: * -> *) a. Monad m => a -> m a
return (BlpExt -> Parser BlpExt) -> BlpExt -> Parser BlpExt
forall a b. (a -> b) -> a -> b
$ $WBlpUncompressed1 :: Vector PixelRGBA8 -> [(ByteString, ByteString)] -> BlpExt
BlpUncompressed1 {..}

blpUncompressed2Parser :: [(Word32, Word32)] -> Parser BlpExt
blpUncompressed2Parser :: [(Word32, Word32)] -> Parser BlpExt
blpUncompressed2Parser mps :: [(Word32, Word32)]
mps = do
  Vector PixelRGBA8
blpU2Palette <- Int -> Parser PixelRGBA8 -> Parser ByteString (Vector PixelRGBA8)
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
V.replicateM 256 Parser PixelRGBA8
rgba8
  [ByteString]
blpU2MipMaps <- [(Word32, Word32)]
-> ((Word32, Word32) -> Parser ByteString)
-> Parser ByteString [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Word32, Word32)]
mps (((Word32, Word32) -> Parser ByteString)
 -> Parser ByteString [ByteString])
-> ((Word32, Word32) -> Parser ByteString)
-> Parser ByteString [ByteString]
forall a b. (a -> b) -> a -> b
$ \(offset :: Word32
offset, size :: Word32
size) -> do
    Word32 -> Parser ()
skipToOffset Word32
offset
    Int -> Parser ByteString
AT.take (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size) Parser ByteString -> String -> Parser ByteString
forall i a. Parser i a -> String -> Parser i a
<?> "index list"
  BlpExt -> Parser BlpExt
forall (m :: * -> *) a. Monad m => a -> m a
return (BlpExt -> Parser BlpExt) -> BlpExt -> Parser BlpExt
forall a b. (a -> b) -> a -> b
$ $WBlpUncompressed2 :: Vector PixelRGBA8 -> [ByteString] -> BlpExt
BlpUncompressed2 {..}

parseBlp :: ByteString -> Either String BlpStruct
parseBlp :: ByteString -> Either String BlpStruct
parseBlp = Parser BlpStruct -> ByteString -> Either String BlpStruct
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser BlpStruct
blpParser