Tissevert/Hufflepdf
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Simplify Content abstracting over MonadParser for no reason and provide instead an parse that's in MonadFail to avoid having to handle Either outside

Browse source
This commit is contained in:
Tissevert 2020-03-08 22:16:23 +01:00
parent 673321bf0a
commit f2986da96d
1 changed files with 13 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
src/PDF/Content.hs
View file

@ -12,13 +12,13 @@ module PDF.Content (
, Id(..)
, Indexed
, TextContext
, content
, parse
) where
import Control.Applicative ((<|>))
import Control.Monad.Fail (MonadFail)
import Control.Monad.Reader (asks, runReader)
import Control.Monad.State (MonadState, evalStateT, gets, modify, runStateT)
import Control.Monad.State (evalStateT, gets, modify)
import Data.Attoparsec.ByteString.Char8 (sepBy)
import Data.ByteString (ByteString)
import Data.Map (Map, (!))
@ -27,7 +27,7 @@ import PDF.Box (Box(..))
import PDF.Content.Operator (Instruction, operator)
import PDF.Object (blank, directObject)
import PDF.Output (Output(..), line)
import PDF.Parser (MonadParser, evalParser, string)
import PDF.Parser (Parser, runParser, string)
newtype Id a = Id Int deriving (Eq, Ord, Show)
data Instructions = Instructions
@ -47,27 +47,26 @@ data Content = Content {
, indexedInstructions :: Indexed Instruction
} deriving Show
type InstructionParser m = (MonadParser m, MonadState (Indexed Instruction) m)
type InstructionParser = Parser (Indexed Instruction)
instance Monad m => Box m Instructions Content (Indexed Instruction) where
r Instructions = return . indexedInstructions
w Instructions indexedInstructions someContent =
return $ someContent {indexedInstructions}
register :: MonadState (Indexed Instruction) m => Instruction -> m (Id Instruction)
register :: Instruction -> InstructionParser (Id Instruction)
register newInstruction = do
newInstructionID <- gets (Id . Map.size)
modify (Map.insert newInstructionID newInstruction)
return newInstructionID
content :: MonadParser m => m Content
content = do
(contentUnits, indexedInstructions) <- runInstructionParser
return $ Content {contentUnits, indexedInstructions}
parse :: MonadFail m => ByteString -> m Content
parse =
either fail (return . uncurry Content) . runParser contentUnits Map.empty
where
runInstructionParser = runStateT (contentUnit `sepBy` blank) Map.empty
contentUnits = contentUnit `sepBy` blank
contentUnit :: InstructionParser m => m ContentUnit
contentUnit :: InstructionParser ContentUnit
contentUnit =
(GraphicContext <$> graphicContext)
<|> (TextContext <$> textContext)
@ -75,21 +74,18 @@ contentUnit =
graphicContext =
string "q" *> blank *> graphicContextUnit `sepBy` blank <* blank <* string "Q"
graphicContextUnit :: InstructionParser m => m GraphicContextUnit
graphicContextUnit :: InstructionParser GraphicContextUnit
graphicContextUnit =
(GraphicInstruction <$> instruction)
<|> (ContentUnit <$> contentUnit)
instruction :: InstructionParser m => m (Id Instruction)
instruction :: InstructionParser (Id Instruction)
instruction = evalStateT stackParser [] >>= register
where
stackParser = ((directObject <* blank) >>= push) <|> operator
push arg = modify (arg:) *> stackParser
parse :: ByteString -> Either String Content
parse = evalParser content ()
textContext :: InstructionParser m => m TextContext
textContext :: InstructionParser TextContext
textContext =
string "BT" *> blank *> instruction `sepBy` blank <* blank <* string "ET"