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