bitmap parser. for study，so ugly yet...

BMP.hs

{-# LANGUAGE TypeSynonymInstances #-}

import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.ByteString.Lazy as L
import qualified Data.Binary.Get as G
import Data.Char (isSpace)
import Data.Int
import Data.Maybe
import Control.Monad
import Control.Monad.Trans.State

--
-- ghciでの実行方法
--
-- ghci> byteStr <- L8.readFile "picture.bmp"
-- ghci> evalState parseBitmapFile (ParseState byteStr 0)
--

data BitmapFile = BitmapFile {
    fileSize :: Int
  , width :: Int
  , height :: Int
  , count :: Int
  , imgData :: L.ByteString
  } deriving (Eq)

instance Show BitmapFile  where
  show (BitmapFile s w h c i) =
    "BitmapFile "
      ++ show s ++ "bytes"
      ++ " size:" ++ show w ++ "x" ++ show h
      ++ " " ++ "count:" ++ show c

data ParseState = ParseState {
   string :: L.ByteString
  ,offset :: Int64
} deriving (Show)

type Parser = State ParseState

matchHeader :: L.ByteString -> Parser (Maybe ())
matchHeader prefix = get >>= \(ParseState s offset) ->
  case prefix `L8.isPrefixOf` s of
    False -> return Nothing
    True -> put (ParseState
                 (L8.dropWhile isSpace (L.drop (L.length prefix) s))
                 (offset + (L.length prefix)))
                  >> return (Just ())

get32Int :: Parser (Maybe Int)
get32Int = get >>= \(ParseState s offset) ->
    case (L.length s < 4) of
      True -> return Nothing
      False -> let n = G.runGet G.getWord32le s in
         put (ParseState (L.drop 4 s) (offset + 4)) >> return (Just (fromIntegral n))

get16Int' :: Parser (Maybe Int)
get16Int' = get >>= \(ParseState s offset) ->
    case (L.length s < 2) of
      True -> return Nothing
      False -> let n = G.runGet G.getWord16le s in
         put (ParseState (L.drop 2 s) (offset + 2)) >> return (Just (fromIntegral n))

getBytes :: Int -> Parser (Maybe L.ByteString)
getBytes n = get >>= \(ParseState s offset) ->
    case (L.length s) < (fromIntegral n) of
      True -> return Nothing
      False -> let bytes = G.runGet (G.getLazyByteString (fromIntegral n)) s in
         put (ParseState (L.drop (fromIntegral n) s) (offset + (fromIntegral n))) >> return (Just bytes)

getBytes' :: Maybe Int -> Parser (Maybe L.ByteString)
getBytes' Nothing = return Nothing
getBytes' jn = let n = fromJust jn
                in getBytes n

maybeMinus :: Maybe Int -> Maybe Int -> Maybe Int
maybeMinus x y = liftM2 (\x y -> x -y) x y

imageSize :: Int -> Int -> Int -> Int
imageSize width height bitCount = width * height * bitCount `div` 8

maybeImageSize :: Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int
maybeImageSize w h c = liftM3 imageSize w h c

parseBitmapFile :: Parser (Maybe BitmapFile)
parseBitmapFile = get >>= \(ParseState s offset) ->
  matchHeader (L8.pack "BM")  >>
  get32Int                    >>=
  \fileSize -> getBytes 4     >>
  get32Int                    >>=
  \offset -> get32Int         >>=
  \headerSize -> get32Int     >>=
  \width -> get32Int          >>=
  \height -> getBytes 2       >>
  get16Int'                    >>=
  \count -> getBytes' (headerSize `maybeMinus` (Just 16)) >>
  getBytes' (maybeImageSize width  height count) >>=
  \img -> return (liftM5 BitmapFile fileSize width height count img)