diff --git a/src/PDF/Body.hs b/src/PDF/Body.hs index 5b0063a..c5cccaa 100644 --- a/src/PDF/Body.hs +++ b/src/PDF/Body.hs @@ -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 diff --git a/src/PDF/Object.hs b/src/PDF/Object.hs index 1828718..1a4ed06 100644 --- a/src/PDF/Object.hs +++ b/src/PDF/Object.hs @@ -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" -- diff --git a/src/PDF/Parser.hs b/src/PDF/Parser.hs index f8cd7af..0aba5da 100644 --- a/src/PDF/Parser.hs +++ b/src/PDF/Parser.hs @@ -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