109 lines
3.7 KiB
Haskell
109 lines
3.7 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ConstraintKinds #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
module PDF.Content (
|
|
Content(..)
|
|
, ContentUnit(..)
|
|
, GraphicContextUnit(..)
|
|
, Id(..)
|
|
, Indexed
|
|
, TextContext
|
|
, content
|
|
, parse
|
|
) where
|
|
|
|
import Control.Applicative ((<|>))
|
|
import Control.Monad.Reader (asks, runReader)
|
|
import Control.Monad.State (MonadState, evalStateT, gets, modify, runStateT)
|
|
import Data.Attoparsec.ByteString.Char8 (sepBy)
|
|
import Data.ByteString (ByteString)
|
|
import Data.Map (Map, (!))
|
|
import qualified Data.Map as Map (empty, insert, size)
|
|
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)
|
|
|
|
newtype Id a = Id Int deriving (Eq, Ord, Show)
|
|
data Instructions = Instructions
|
|
type Indexed a = Map (Id a) a
|
|
|
|
data GraphicContextUnit =
|
|
GraphicInstruction (Id Instruction)
|
|
| ContentUnit ContentUnit
|
|
deriving Show
|
|
type TextContext = [Id Instruction]
|
|
data ContentUnit =
|
|
GraphicContext [GraphicContextUnit]
|
|
| TextContext TextContext
|
|
deriving Show
|
|
data Content = Content {
|
|
contentUnits :: [ContentUnit]
|
|
, indexedInstructions :: Indexed Instruction
|
|
} deriving Show
|
|
|
|
type InstructionParser m = (MonadParser m, MonadState (Indexed Instruction) m)
|
|
|
|
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 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}
|
|
where
|
|
runInstructionParser = runStateT (contentUnit `sepBy` blank) Map.empty
|
|
|
|
contentUnit :: InstructionParser m => m ContentUnit
|
|
contentUnit =
|
|
(GraphicContext <$> graphicContext)
|
|
<|> (TextContext <$> textContext)
|
|
where
|
|
graphicContext =
|
|
string "q" *> blank *> graphicContextUnit `sepBy` blank <* blank <* string "Q"
|
|
|
|
graphicContextUnit :: InstructionParser m => m GraphicContextUnit
|
|
graphicContextUnit =
|
|
(GraphicInstruction <$> instruction)
|
|
<|> (ContentUnit <$> contentUnit)
|
|
|
|
instruction :: InstructionParser m => m (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 =
|
|
string "BT" *> blank *> instruction `sepBy` blank <* blank <* string "ET"
|
|
|
|
instance Output Content where
|
|
output (Content {contentUnits, indexedInstructions}) =
|
|
runReader (mconcat <$> mapM outputCU contentUnits) indexedInstructions
|
|
where
|
|
outputCU (GraphicContext gc) = do
|
|
inside <- mconcat <$> mapM outputGCU gc
|
|
return (line "q" `mappend` inside `mappend` line "Q")
|
|
outputCU (TextContext tc) = do
|
|
inside <- mconcat <$> mapM outputIId tc
|
|
return (line "BT" `mappend` inside `mappend` line "ET")
|
|
outputGCU (GraphicInstruction gi) = outputIId gi
|
|
outputGCU (ContentUnit cu) = outputCU cu
|
|
outputIId instructionId = asks (output . (! instructionId))
|