DVI のパース

dvi.hs

import Control.Applicative ((<$>), (<*>), pure, some)
import Control.Monad (replicateM)
import Data.Binary (get, Binary(..), Get)
import Data.Binary.Get (bytesRead, runGet, getWord8, getWord16be, getWord32be, getByteString)
import Data.Int (Int8, Int32)
import Data.Word (Word, Word8, Word16, Word32)
import qualified Data.ByteString as SB (ByteString)
import qualified Data.ByteString.Lazy as LB (readFile)

data DviOp
    = Set      Word
    | SetRule  Int32 Int32
    | Put      Word
    | PutRule  Int32 Int32
    | Nop
    | Bop      [Int32] Int32
    | Eop
    | Push
    | Pop
    | Rgt      Int
    | W        (Maybe Int)
    | X        (Maybe Int)
    | Dwn      Int
    | Y        (Maybe Int)
    | Z        (Maybe Int)
    | Fnt      Word
    | Xxx      Int
    | FntDef   Word Word32 Int32 Int32 SB.ByteString SB.ByteString
    | Pre      Word8 Word32 Word32 Word32 SB.ByteString
    | Post     Int32 Word32 Word32 Word32 Int32 Int32 Word16 Word16
    | PostPost Int32 Word8 Bool
    | Reserved
    | Dir      Bool
    deriving (Show)

parseDvi :: Get [(Int32, DviOp)]
parseDvi = some parseDviOp

parseDviOp :: Get (Int32, DviOp)
parseDviOp = do
    p <- fromIntegral <$> bytesRead
    t <- getWord8
    (,) p <$> case t of
      _ | t  <      128       -> Set <$> pure (fromIntegral t)
        | t `elem` [128..131] -> Set <$> readuint (t - 127)
        | t ==      132       -> SetRule <$> getInt32be <*> getInt32be
        | t `elem` [133..136] -> Put <$> readuint (t - 132)
        | t ==      137       -> PutRule <$> getInt32be <*> getInt32be
        | t ==      138       -> pure Nop
        | t ==      139       -> Bop <$> replicateM 10 getInt32be <*> getInt32be
        | t ==      140       -> pure Eop
        | t ==      141       -> pure Push
        | t ==      142       -> pure Pop
        | t `elem` [143..146] -> Rgt      <$> readint (t - 142)
        | t ==      147       -> W        <$> pure Nothing
        | t `elem` [148..151] -> W . Just <$> readint (t - 147)
        | t ==      152       -> X        <$> pure Nothing
        | t `elem` [153..156] -> X . Just <$> readint (t - 152)
        | t `elem` [157..160] -> Dwn      <$> readint (t - 156)
        | t ==      161       -> Y        <$> pure Nothing
        | t `elem` [162..165] -> Y . Just <$> readint (t - 161)
        | t ==      166       -> Z        <$> pure Nothing
        | t `elem` [167..170] -> Z . Just <$> readint (t - 166)
        | t `elem` [171..234] -> Fnt <$> pure (fromIntegral t - 171)
        | t `elem` [235..238] -> Fnt <$> readuint (t - 234)
        | t `elem` [243..246] -> fontdef t
        | t ==      247       -> pre
        | t ==      248       -> post
        | t ==      249       -> PostPost <$> getInt32be <*> getWord8 <*> postcheck
        | t `elem` [250..254] -> pure Reserved
        | t ==      255       -> Dir . (/= 0) <$> getWord8
        | otherwise -> undefined
    where
        fontdef t = FntDef
            <$> readuint (t - 242) <*> getWord32be <*> getInt32be <*> getInt32be
            <*> (getWord8 >>= readstring) <*> (getWord8 >>= readstring)
        pre = Pre
            <$> getWord8 <*> getWord32be <*> getWord32be <*> getWord32be
            <*> (getWord8 >>= readstring)
        post = Post
            <$> getInt32be <*> getWord32be <*> getWord32be <*> getWord32be
            <*> getInt32be <*> getInt32be  <*> getWord16be <*> getWord16be
        postcheck = all (== 223) <$> some getWord8
        readstring = getByteString . fromIntegral

readuint :: Integral a => a -> Get Word
readuint cnt = foldl f 0 <$> map fromIntegral <$> replicateM (fromIntegral cnt) getWord8
    where f o n = o*256 + n

readint :: Integral a => a -> Get Int
readint cnt = do
    x <- get :: Get Int8
    foldl f (fromIntegral x) <$> map fromIntegral <$> replicateM (fromIntegral cnt - 1) getWord8
    where f o n = o*256 + n

getInt32be :: Get Int32
getInt32be = fromIntegral <$> getWord32be

main :: IO ()
main = do
    r <- LB.readFile "genfunc.dvi"
    mapM_ print (runGet parseDvi r)