223 lines
7.8 KiB
Haskell
223 lines
7.8 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ConstraintKinds #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module PDF.Text {-(
|
|
pageContents
|
|
)-} where
|
|
|
|
import Control.Applicative ((<|>))
|
|
import Control.Monad (foldM)
|
|
import Control.Monad.Fail (MonadFail)
|
|
import Control.Monad.Reader (ReaderT, runReaderT, asks)
|
|
import Control.Monad.State (MonadState, evalStateT, get, modify, put)
|
|
import Data.Attoparsec.ByteString.Char8 (choice, sepBy)
|
|
import Data.ByteString (ByteString)
|
|
import Data.ByteString.Char8 (pack)
|
|
import Data.Map ((!), (!?), Map)
|
|
import qualified Data.Map as Map (fromList)
|
|
import PDF.Font (Font, FontSet, emptyFont)
|
|
import PDF.Object (
|
|
DirectObject(..), StringObject(..)
|
|
, array, blank, name, regular, stringObject, toByteString
|
|
)
|
|
import PDF.Parser (MonadParser, (<?>), Parser, evalParser, string, takeAll1)
|
|
|
|
data StateOperator =
|
|
Cm | W | J | J_ | M | D | Ri | I | Gs -- general graphic state
|
|
deriving (Bounded, Enum)
|
|
data TextOperator =
|
|
Td | TD | Tm | Tstar -- text positioning
|
|
| TJ | Tj | Quote | DQuote -- text showing
|
|
| Tc | Tw | Tz | TL | Tf | Tr | Ts -- text state
|
|
deriving (Bounded, Enum)
|
|
data Argument = Raw ByteString | Typed DirectObject deriving Show
|
|
type Call a = (a, [Argument])
|
|
|
|
instance Show StateOperator where
|
|
show Cm = "cm"
|
|
show W = "w"
|
|
show J = "J"
|
|
show J_ = "j"
|
|
show M = "M"
|
|
show D = "d"
|
|
show Ri = "ri"
|
|
show I = "i"
|
|
show Gs = "gs"
|
|
|
|
instance Show TextOperator where
|
|
show Td = "Td"
|
|
show TD = "TD"
|
|
show Tm = "Tm"
|
|
show Tstar = "T*"
|
|
show TJ = "TJ"
|
|
show Tj = "Tj"
|
|
show Quote = "'"
|
|
show DQuote = "\""
|
|
show Tc = "Tc"
|
|
show Tw = "Tw"
|
|
show Tz = "Tz"
|
|
show TL = "TL"
|
|
show Tf = "Tf"
|
|
show Tr = "Tr"
|
|
show Ts = "Ts"
|
|
|
|
stateOperator :: OperatorTable StateOperator
|
|
stateOperator = Map.fromList [
|
|
("cm", (Cm, \l -> case l of [Raw _, Raw _, Raw _, Raw _, Raw _, Raw _] -> True ; _ -> False))
|
|
, ("w", (W, \l -> case l of [Raw _] -> True ; _ -> False))
|
|
, ("J", (J, \l -> case l of [Raw _] -> True ; _ -> False))
|
|
, ("j", (J_, \l -> case l of [Raw _] -> True ; _ -> False))
|
|
, ("M", (M, \l -> case l of [Raw _] -> True ; _ -> False))
|
|
, ("d", (D, \l -> case l of [Raw _, Raw _] -> True ; _ -> False))
|
|
, ("ri", (Ri, \l -> case l of [Raw _] -> True ; _ -> False))
|
|
, ("i", (I, \l -> case l of [Raw _] -> True ; _ -> False))
|
|
, ("gs", (Gs, \l -> case l of [Typed (NameObject _)] -> True ; _ -> False))
|
|
]
|
|
|
|
{-
|
|
stateOperator (Cm, [Raw _, Raw _, Raw _, Raw _, Raw _, Raw _]) = True
|
|
stateOperator (W, [Raw _]) = True
|
|
stateOperator (J, [Raw _]) = True
|
|
stateOperator (J_, [Raw _]) = True
|
|
stateOperator (M, [Raw _]) = True
|
|
stateOperator (D, [Raw _, Raw _]) = True
|
|
stateOperator (Ri, [Raw _]) = True
|
|
stateOperator (I, [Raw _]) = True
|
|
stateOperator (Gs, [Typed (NameObject _)]) = True
|
|
stateOperator _ = False
|
|
-}
|
|
|
|
textOperator :: OperatorTable TextOperator
|
|
textOperator = Map.fromList $ (\(op, checker) -> (pack $ show op, (op, checker))) <$> [
|
|
(Td, \l -> case l of [Raw _, Raw _] -> True ; _ -> False)
|
|
, (TD, \l -> case l of [Raw _, Raw _] -> True ; _ -> False)
|
|
, (Tm, \l -> case l of [Raw _, Raw _, Raw _, Raw _, Raw _, Raw _] -> True ; _ -> False)
|
|
, (Tstar, \l -> case l of [] -> True ; _ -> False)
|
|
, (TJ, \l -> case l of [Typed (Array _)] -> True ; _ -> False)
|
|
, (Tj, \l -> case l of [Typed (StringObject _)] -> True ; _ -> False)
|
|
, (Quote, \l -> case l of [Typed (StringObject _)] -> True ; _ -> False)
|
|
, (DQuote, \l -> case l of [Typed (StringObject _)] -> True ; _ -> False)
|
|
, (Tc, \l -> case l of [Raw _] -> True ; _ -> False)
|
|
, (Tw, \l -> case l of [Raw _] -> True ; _ -> False)
|
|
, (Tz, \l -> case l of [Raw _] -> True ; _ -> False)
|
|
, (TL, \l -> case l of [Raw _] -> True ; _ -> False)
|
|
, (Tf, \l -> case l of [Typed (NameObject _), Raw _] -> True ; _ -> False)
|
|
, (Tr, \l -> case l of [Raw _] -> True ; _ -> False)
|
|
, (Ts, \l -> case l of [Raw _] -> True ; _ -> False)
|
|
]
|
|
|
|
{-
|
|
textOperator (Td, [Raw _, Raw _]) = True
|
|
textOperator (TD, [Raw _, Raw _]) = True
|
|
textOperator (Tm, [Raw _, Raw _, Raw _, Raw _, Raw _, Raw _]) = True
|
|
textOperator (Tstar, []) = True
|
|
textOperator (TJ, [Typed (Array _)]) = True
|
|
textOperator (Tj, [Typed (StringObject _)]) = True
|
|
textOperator (Quote, [Typed (StringObject _)]) = True
|
|
textOperator (DQuote, [Typed (StringObject _)]) = True
|
|
textOperator (Tc, [Raw _]) = True
|
|
textOperator (Tw, [Raw _]) = True
|
|
textOperator (Tz, [Raw _]) = True
|
|
textOperator (TL, [Raw _]) = True
|
|
textOperator (Tf, [Typed (NameObject _), Raw _]) = True
|
|
textOperator (Tr, [Raw _]) = True
|
|
textOperator (Ts, [Raw _]) = True
|
|
textOperator _ = False
|
|
-}
|
|
|
|
type ArgumentStackParser m = (MonadState [Argument] m, MonadParser m)
|
|
type Operator a = (Bounded a, Enum a, Show a)
|
|
type OperatorTable a = Map ByteString (TypeChecker a)
|
|
type TypeChecker a = (a, [Argument] -> Bool)
|
|
|
|
parseShowable :: (Show a, MonadParser m) => a -> m a
|
|
parseShowable textOp = string (pack $ show textOp) *> return textOp
|
|
|
|
callChunk :: MonadParser m => OperatorTable a -> m (Either (TypeChecker a) Argument)
|
|
callChunk table =
|
|
(Right <$> choice [stringArg, nameArg, arrayArg])
|
|
<|> operatorOrRawArg
|
|
<?> "call chunk"
|
|
where
|
|
operatorOrRawArg = do
|
|
chunk <- takeAll1 regular <* blank
|
|
case table !? chunk of
|
|
Nothing -> return . Right $ Raw chunk
|
|
Just typeChecker -> return $ Left typeChecker
|
|
|
|
stackParser :: (ArgumentStackParser m, Show a) => OperatorTable a -> m (Call a)
|
|
stackParser table = either popCall push =<< (callChunk table)
|
|
where
|
|
push arg = modify (arg:) >> stackParser table
|
|
popCall (operator, predicate) = do
|
|
arguments <- reverse <$> get
|
|
let call = (operator, arguments)
|
|
if predicate arguments then return call else fail (show call)
|
|
|
|
a :: (Operator a, MonadParser m) => OperatorTable a -> m (Call a)
|
|
a table = evalStateT (stackParser table) []
|
|
|
|
argument :: MonadParser m => m Argument
|
|
argument = Raw <$> takeAll1 regular <* blank
|
|
|
|
arrayArg :: MonadParser m => m Argument
|
|
arrayArg = Typed . Array <$> array <* blank
|
|
|
|
nameArg :: MonadParser m => m Argument
|
|
nameArg = Typed . NameObject <$> name <* blank
|
|
|
|
stringArg :: MonadParser m => m Argument
|
|
stringArg = Typed . StringObject <$> stringObject <* blank
|
|
|
|
type ParserWithFont = ReaderT FontSet (Parser Font)
|
|
|
|
pageContents :: FontSet -> ByteString -> Either String [ByteString]
|
|
pageContents font input =
|
|
evalParser (runReaderT page font) emptyFont input
|
|
|
|
page :: ParserWithFont [ByteString]
|
|
page = graphicState <|> text <?> "Text page contents"
|
|
|
|
graphicState :: ParserWithFont [ByteString]
|
|
graphicState =
|
|
(string "q" *> blank *> insideQ <* blank <* string "Q") <?> "Graphic state"
|
|
where
|
|
insideQ = concat <$> ((command <|> page) `sepBy` blank )
|
|
command = a stateOperator *> return []
|
|
|
|
text :: ParserWithFont [ByteString]
|
|
text =
|
|
string "BT" *> blank *> commands <* blank <* string "ET" <?> "Text operators"
|
|
where
|
|
commands = concat <$> (a textOperator >>= runOperator) `sepBy` blank
|
|
|
|
runOperator :: Call TextOperator -> ParserWithFont [ByteString]
|
|
runOperator (Tf, [Typed (NameObject fontName), _]) =
|
|
asks (! fontName) >>= put >> return []
|
|
|
|
runOperator (Tstar, []) = return ["\n"]
|
|
|
|
runOperator (TJ, [Typed (Array arrayObject)]) =
|
|
replicate 1 <$> foldM appendText "" arrayObject
|
|
where
|
|
appendText bs (StringObject outputString) =
|
|
mappend bs <$> decodeString outputString
|
|
appendText bs _ = return bs
|
|
|
|
runOperator (Tj, [Typed (StringObject outputString)]) =
|
|
replicate 1 <$> decodeString outputString
|
|
|
|
runOperator (Quote, [Typed (StringObject outputString)]) =
|
|
(\bs -> ["\n", bs]) <$> decodeString outputString
|
|
|
|
runOperator (DQuote, [Typed (StringObject outputString)]) =
|
|
(\bs -> ["\n", bs]) <$> decodeString outputString
|
|
|
|
runOperator _ = return []
|
|
|
|
decodeString :: (MonadFail m, MonadState Font m) => StringObject -> m ByteString
|
|
decodeString input = do
|
|
font <- get
|
|
either fail return . font $ toByteString input
|