70 lines
2.1 KiB
Haskell
70 lines
2.1 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module PDF.Content (
|
|
Content(..)
|
|
, ContentUnit(..)
|
|
, GraphicContextUnit(..)
|
|
, TextContext
|
|
, content
|
|
, parse
|
|
) where
|
|
|
|
import Control.Applicative ((<|>))
|
|
import Control.Monad.State (evalStateT, modify)
|
|
import Data.Attoparsec.ByteString.Char8 (sepBy)
|
|
import Data.ByteString (ByteString)
|
|
import PDF.Content.Operator (Instruction, operator)
|
|
import PDF.Object (blank, directObject)
|
|
import PDF.Output (Output(..), line)
|
|
import PDF.Parser (MonadParser, evalParser, string)
|
|
|
|
data GraphicContextUnit =
|
|
GraphicInstruction Instruction
|
|
| ContentUnit ContentUnit
|
|
deriving Show
|
|
type TextContext = [Instruction]
|
|
data ContentUnit =
|
|
GraphicContext [GraphicContextUnit]
|
|
| TextContext TextContext
|
|
deriving Show
|
|
newtype Content = Content [ContentUnit] deriving Show
|
|
|
|
content :: MonadParser m => m Content
|
|
content = Content <$> contentUnit `sepBy` blank
|
|
|
|
contentUnit :: MonadParser m => m ContentUnit
|
|
contentUnit =
|
|
(GraphicContext <$> graphicContext)
|
|
<|> (TextContext <$> textContext)
|
|
where
|
|
graphicContext =
|
|
string "q" *> blank *> graphicContextUnit `sepBy` blank <* blank <* string "Q"
|
|
|
|
graphicContextUnit :: MonadParser m => m GraphicContextUnit
|
|
graphicContextUnit =
|
|
(GraphicInstruction <$> instruction)
|
|
<|> (ContentUnit <$> contentUnit)
|
|
|
|
instruction :: MonadParser m => m Instruction
|
|
instruction = evalStateT stackParser []
|
|
where
|
|
stackParser = ((directObject <* blank) >>= push) <|> operator
|
|
push arg = modify (arg:) *> stackParser
|
|
|
|
parse :: ByteString -> Either String Content
|
|
parse = evalParser content ()
|
|
|
|
textContext :: MonadParser m => m TextContext
|
|
textContext =
|
|
string "BT" *> blank *> instruction `sepBy` blank <* blank <* string "ET"
|
|
|
|
instance Output Content where
|
|
output (Content contentUnits) = output contentUnits
|
|
|
|
instance Output ContentUnit where
|
|
output (GraphicContext gc) = line "q" `mappend` output gc `mappend` line "Q"
|
|
output (TextContext tc) = line "BT" `mappend` output tc `mappend` line "ET"
|
|
|
|
instance Output GraphicContextUnit where
|
|
output (GraphicInstruction gi) = output gi
|
|
output (ContentUnit cu) = output cu
|