Generalize the Parser type into a MonadParser class to use with MonadTrans and remove redundant code already defined in Applicative or Attoparsec

This commit is contained in:
Tissevert 2019-09-24 18:36:17 +02:00
parent 66d315b7fe
commit b8eb9e6856
3 changed files with 52 additions and 61 deletions

View file

@ -6,6 +6,7 @@ module PDF.Body (
import Control.Applicative ((<|>))
import Control.Monad.State (get, gets, modify)
import Data.Attoparsec.ByteString.Char8 (option)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS (cons, drop, unpack)
import Data.Map ((!))
@ -18,7 +19,7 @@ import PDF.Object (
, blank, dictionary, directObject, integer, line
)
import PDF.Output (ObjectId(..), Offset(..))
import PDF.Parser (Parser, (<?>), block, char, evalParser, on, option, takeAll)
import PDF.Parser (Parser, (<?>), block, char, evalParser, on, takeAll)
data UserState = UserState {
input :: ByteString

View file

@ -28,7 +28,8 @@ module PDF.Object (
, structure
) where
import Control.Applicative ((<|>))
import Control.Applicative ((<|>), many)
import Data.Attoparsec.ByteString.Char8 (choice, count, option, sepBy)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS (
concat, cons, pack, singleton, unpack
@ -44,11 +45,7 @@ import PDF.Output (
, byteString, getObjectId, getOffset, getOffsets, join, newLine
, saveOffset
)
import PDF.Parser (
Parser, (<?>)
, char, choice, count, decNumber, hexNumber, many, octDigit, oneOf, option
, sepBy, string, takeAll, takeAll1
)
import PDF.Parser (MonadParser(..), Parser, (<?>), octDigit, oneOf)
import Text.Printf (printf)
line :: String -> Parser u ()
@ -63,8 +60,8 @@ eofMarker = "%%EOF"
whiteSpaceCharset :: String
whiteSpaceCharset = "\0\t\12 "
blank :: Parser u ()
blank = takeAll (`elem` (EOL.charset ++ whiteSpaceCharset)) *> return ()
blank :: MonadParser m => m ()
blank = takeAll (`elem` (EOL.charset ++ whiteSpaceCharset)) *> pure ()
delimiterCharset :: String
delimiterCharset = "()<>[]{}/%"
@ -140,7 +137,7 @@ newtype Name = Name String deriving (Eq, Ord, Show)
instance Output Name where
output (Name n) = Output.string ('/':n)
name :: Parser u Name
name :: MonadParser m => m Name
name = Name . BS.unpack <$> (char '/' *> takeAll regular) <?> "name"
--

View file

@ -1,28 +1,29 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-}
module PDF.Parser (
Parser
MonadParser
, Parser
, (<?>)
, block
, char
, choice
, count
, decNumber
, hexNumber
, many
, octDigit
, on
, oneOf
, option
, runParser
, evalParser
, sepBy
, string
, takeAll
, takeAll1
) where
import Control.Applicative ((<|>), empty)
import Control.Applicative (Alternative, (<|>))
import Control.Monad (MonadPlus)
import Control.Monad.Fail (MonadFail(..))
import Control.Monad.State (StateT(..), evalStateT)
import Control.Monad.Trans (lift)
import Control.Monad.Trans (MonadTrans(..))
import qualified Data.Attoparsec.ByteString.Char8 as Atto (
Parser, char, parseOnly, satisfy, string, take, takeWhile, takeWhile1
)
@ -30,28 +31,45 @@ 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 = Atto.string
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
type Parser s = StateT s Atto.Parser
(<?>) :: Parser s a -> String -> Parser s a
(<?>) :: (Alternative m, MonadFail m) => m a -> String -> m a
(<?>) parser debugMessage = parser <|> fail debugMessage
block :: Int -> Parser s ByteString
block = lift . Atto.take
char :: Char -> Parser s Char
char = lift . Atto.char
choice :: [Parser s a] -> Parser s a
choice = foldr (<|>) empty
count :: Int -> Parser s a -> Parser s [a]
count 0 _ = return []
count n p = (:) <$> p <*> count (n-1) p
decNumber :: Parser s ByteString
decNumber = lift $ Atto.takeWhile1 (`Set.member` digits)
digits :: Set Char
digits = Set.fromList ['0'..'9']
@ -60,13 +78,7 @@ hexDigits = Set.unions [digits, Set.fromList af, Set.fromList $ toLower <$> af]
where
af = ['A'..'F']
hexNumber :: Parser s ByteString
hexNumber = lift $ Atto.takeWhile1 (`Set.member` hexDigits)
many :: Parser s a -> Parser s [a]
many parser = (:) <$> parser <*> many parser <|> return []
octDigit :: Parser s Char
octDigit :: MonadParser m => m Char
octDigit = oneOf ['0'..'7']
on :: Parser s a -> ByteString -> Parser s (Either String a)
@ -75,27 +87,8 @@ on (StateT parserF) input = StateT $ \state ->
Left errorMsg -> return (Left errorMsg, state)
Right (result, newState) -> return (Right result, newState)
oneOf :: String -> Parser s Char
oneOf charSet = lift $ Atto.satisfy (`elem` charSet)
option :: a -> Parser s a -> Parser s a
option defaultValue p = p <|> pure defaultValue
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)
sepBy :: Parser s a -> Parser s b -> Parser s [a]
sepBy parser separator =
option [] $ (:) <$> parser <*> many (separator *> parser)
string :: ByteString -> Parser s ByteString
string = lift . Atto.string
takeAll :: (Char -> Bool) -> Parser s ByteString
takeAll = lift . Atto.takeWhile
takeAll1 :: (Char -> Bool) -> Parser s ByteString
takeAll1 = lift . Atto.takeWhile1