Hufflepdf/src/PDF/Parser.hs

95 lines
2.7 KiB
Haskell
Raw Normal View History

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-}
2019-05-24 10:48:09 +02:00
module PDF.Parser (
MonadParser
, Parser
2019-05-24 10:48:09 +02:00
, (<?>)
, block
, char
, decNumber
, hexNumber
, octDigit
, on
, oneOf
, runParser
, evalParser
2019-05-24 10:48:09 +02:00
, string
, takeAll
, takeAll1
) where
import Control.Applicative (Alternative, (<|>))
import Control.Monad (MonadPlus)
import Control.Monad.Fail (MonadFail(..))
2019-05-24 10:48:09 +02:00
import Control.Monad.State (StateT(..), evalStateT)
import Control.Monad.Trans (MonadTrans(..))
2019-05-24 10:48:09 +02:00
import qualified Data.Attoparsec.ByteString.Char8 as Atto (
Parser, char, parseOnly, satisfy, string, take, takeWhile, takeWhile1
)
import Data.ByteString (ByteString)
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 ByteString
hexNumber :: m ByteString
oneOf :: String -> 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
decNumber = Atto.takeWhile1 (`Set.member` digits)
hexNumber = Atto.takeWhile1 (`Set.member` hexDigits)
oneOf charSet = Atto.satisfy (`elem` charSet)
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
decNumber = lift $ decNumber
hexNumber = lift $ hexNumber
oneOf = lift . oneOf
string = lift . string
takeAll = lift . takeAll
takeAll1 = lift . takeAll1
2019-05-24 10:48:09 +02:00
type Parser s = StateT s Atto.Parser
(<?>) :: (Alternative m, MonadFail m) => m a -> String -> m a
2019-05-24 10:48:09 +02:00
(<?>) 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
2019-05-24 10:48:09 +02:00
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)