Hufflepdf/src/PDF/Parser.hs

97 lines
2.9 KiB
Haskell

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-}
module PDF.Parser (
MonadParser(..)
, Parser
, (<?>)
, octDigit
, on
, runParser
, evalParser
) where
import Control.Applicative (Alternative, (<|>))
import Control.Monad (MonadPlus)
import Control.Monad.Fail (MonadFail(..))
import Control.Monad.State (StateT(..), evalStateT)
import Control.Monad.Trans (MonadTrans(..))
import qualified Data.Attoparsec.ByteString.Char8 as Atto (
Parser, char, decimal, double, endOfInput, parseOnly, peekChar', satisfy, string, take
, takeWhile, takeWhile1
)
import Data.ByteString (ByteString)
import Data.ByteString.Char8.Util (B16Int(..))
import Data.Char (toLower)
import Data.Set (Set)
import qualified Data.Set as Set (fromList, member, unions)
import Prelude hiding (fail)
type MonadDeps m = (MonadFail m, MonadPlus m)
class MonadDeps m => MonadParser m where
block :: Int -> m ByteString
char :: Char -> m Char
decNumber :: m Int
floatNumber :: m Double
endOfInput :: m ()
hexNumber :: m B16Int
oneOf :: String -> m Char
peek :: m Char
string :: ByteString -> m ByteString
takeAll :: (Char -> Bool) -> m ByteString
takeAll1 :: (Char -> Bool) -> m ByteString
instance MonadParser Atto.Parser where
block = Atto.take
char = Atto.char
endOfInput = Atto.endOfInput
decNumber = Atto.decimal
floatNumber = Atto.double
hexNumber = B16Int <$> Atto.takeWhile1 (`Set.member` hexDigits)
oneOf charSet = Atto.satisfy (`elem` charSet)
peek = Atto.peekChar'
string s = Atto.string s <?> show s
takeAll = Atto.takeWhile
takeAll1 = Atto.takeWhile1
instance (MonadParser m, MonadTrans t, MonadDeps (t m)) => MonadParser (t m) where
block = lift . block
char = lift . char
endOfInput = lift $ endOfInput
decNumber = lift $ decNumber
floatNumber = lift $ floatNumber
hexNumber = lift $ hexNumber
oneOf = lift . oneOf
peek = lift $ peek
string = lift . string
takeAll = lift . takeAll
takeAll1 = lift . takeAll1
type Parser s = StateT s Atto.Parser
(<?>) :: (Alternative m, MonadFail m) => m a -> String -> m a
(<?>) parser debugMessage = parser <|> fail debugMessage
digits :: Set Char
digits = Set.fromList ['0'..'9']
hexDigits :: Set Char
hexDigits = Set.unions [digits, Set.fromList af, Set.fromList $ toLower <$> af]
where
af = ['A'..'F']
octDigit :: MonadParser m => m Char
octDigit = oneOf ['0'..'7']
on :: Parser s a -> ByteString -> Parser s (Either String a)
on (StateT parserF) input = StateT $ \state ->
case Atto.parseOnly (parserF state) input of
Left errorMsg -> return (Left errorMsg, state)
Right (result, newState) -> return (Right result, newState)
runParser :: Parser s a -> s -> ByteString -> Either String (a, s)
runParser parser initState = Atto.parseOnly (runStateT parser initState)
evalParser :: Parser s a -> s -> ByteString -> Either String a
evalParser parser initState = Atto.parseOnly (evalStateT parser initState)