2020-02-10 10:54:44 +01:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module PDF.Content.Text (
|
|
|
|
renderText
|
|
|
|
) where
|
|
|
|
|
|
|
|
import Control.Monad (foldM)
|
|
|
|
import Control.Monad.Reader (ReaderT, asks, runReaderT)
|
|
|
|
import Control.Monad.State (MonadState(..), StateT, evalStateT)
|
|
|
|
import Data.Map ((!))
|
|
|
|
import Data.Text (Text)
|
|
|
|
import PDF.Content (Content(..), ContentUnit(..), GraphicContextUnit(..))
|
|
|
|
import PDF.Content.Operator (Instruction, Operator(..))
|
|
|
|
import PDF.Content.Operator.Text (Operator(..))
|
|
|
|
import PDF.Font (Font, FontSet, emptyFont)
|
|
|
|
import PDF.Object (DirectObject(..), StringObject, toByteString)
|
|
|
|
|
|
|
|
type RenderingContext = ReaderT FontSet (Either String)
|
|
|
|
type TextRenderingContext = StateT Font RenderingContext
|
|
|
|
|
|
|
|
decodeString :: StringObject -> TextRenderingContext Text
|
|
|
|
decodeString input = do
|
|
|
|
font <- get
|
|
|
|
either fail return . font $ toByteString input
|
|
|
|
|
|
|
|
renderText :: FontSet -> Content -> Either String [Text]
|
|
|
|
renderText fontSet (Content contentUnits) =
|
|
|
|
runReaderT (concat <$> mapM renderContentUnit contentUnits) fontSet
|
|
|
|
|
|
|
|
renderContentUnit :: ContentUnit -> RenderingContext [Text]
|
|
|
|
renderContentUnit (GraphicContext graphicContextUnits) =
|
|
|
|
concat <$> mapM renderGraphicContextUnit graphicContextUnits
|
|
|
|
renderContentUnit (TextContext instructions) =
|
|
|
|
evalStateT (concat <$> mapM renderInstruction instructions) emptyFont
|
|
|
|
|
|
|
|
renderGraphicContextUnit :: GraphicContextUnit -> RenderingContext [Text]
|
|
|
|
renderGraphicContextUnit (GraphicInstruction _) = return []
|
|
|
|
renderGraphicContextUnit (ContentUnit contentUnit) =
|
|
|
|
renderContentUnit contentUnit
|
|
|
|
|
|
|
|
renderInstruction :: Instruction -> StateT Font RenderingContext [Text]
|
|
|
|
renderInstruction (Text Tf, [NameObject fontName, _]) =
|
|
|
|
asks (! fontName) >>= put >> return []
|
|
|
|
|
|
|
|
renderInstruction (Text Tstar, []) = return ["\n"]
|
|
|
|
|
|
|
|
renderInstruction (Text TJ, [Array arrayObject]) =
|
|
|
|
replicate 1 <$> foldM appendText "" arrayObject
|
|
|
|
where
|
|
|
|
appendText t (StringObject outputString) =
|
|
|
|
mappend t <$> decodeString outputString
|
|
|
|
appendText t _ = return t
|
|
|
|
|
|
|
|
renderInstruction (Text Tj, [StringObject outputString]) =
|
|
|
|
replicate 1 <$> decodeString outputString
|
|
|
|
|
|
|
|
renderInstruction (Text Quote, [StringObject outputString]) =
|
|
|
|
(\t -> ["\n", t]) <$> decodeString outputString
|
|
|
|
|
|
|
|
renderInstruction (Text DQuote, [StringObject outputString]) =
|
|
|
|
(\t -> ["\n", t]) <$> decodeString outputString
|
|
|
|
|
|
|
|
renderInstruction _ = return []
|