{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} module PDF.Pages ( Contents(..) , FontCache , Page(..) , PageNumber(..) , Pages(..) , cacheFonts , withResources ) where import Control.Applicative (Alternative, (<|>)) import Control.Monad (foldM) import Control.Monad.Fail (MonadFail(..)) import Control.Monad.Reader (ReaderT, runReaderT) import Control.Monad.State (StateT(..), evalStateT, gets, modify) import Control.Monad.Trans (lift) import Data.OrderedMap (OrderedMap, build) import Data.Map (Map) import qualified Data.Map as Map (empty, fromList, insert, lookup, toList) import PDF.Box (Box(..)) import PDF.CMap (cMap) import PDF.Content (Content(..)) import qualified PDF.Content as Content (parse) import PDF.Encoding (encoding) import PDF.Font (Font, FontSet) import PDF.Layer (Layer(..)) import PDF.Object ( Dictionary, DirectObject(..), IndirectObjCoordinates(..) , Name(..), Object(..) ,) import PDF.Object.Navigation ( Clear(..), PDFContent, (//), (>./), (>//), getDictionary , getKey, objectById, origin ) import PDF.Output (ObjectId(..)) import Prelude hiding (fail) import Text.Printf (printf) type Except m = (Alternative m, MonadFail m) type InLayer m = ReaderT Layer m type CachedFonts = Map ObjectId Font type FontCache m = StateT CachedFonts (InLayer m) data Page = Page { contents :: OrderedMap ObjectId Content , resources :: Dictionary , source :: ObjectId } loadContents :: Except m => DirectObject -> InLayer m (OrderedMap ObjectId Content) loadContents directObject = sequenceA . build loadContent $ objectIds directObject where loadContent :: Except m => ObjectId -> InLayer m Content loadContent objectId = objectById objectId >>= r Clear >>= Content.parse objectIds (Array l) = l >>= getReference objectIds dirObj = getReference dirObj getFontDictionary :: Except m => Object -> InLayer m Dictionary getFontDictionary pageObj = (pageObj >// ["Resources", "Font"] >>= getDictionary) <|> return Map.empty cache :: Except m => (ObjectId -> FontCache m Font) -> ObjectId -> FontCache m Font cache loader objectId = gets (Map.lookup objectId) >>= maybe load return where load = do value <- loader objectId modify $ Map.insert objectId value return value loadFont :: Except m => ObjectId -> FontCache m Font loadFont objectId = lift $ objectById objectId >>= tryMappings where tryMappings object = (object >./ "ToUnicode" >>= r Clear >>= cMap) <|> (object >./ "Encoding" >>= loadEncoding) <|> (fail $ unknownFormat (show objectId) (show object)) unknownFormat = printf "Unknown font format for object #%s : %s" loadEncoding :: MonadFail m => Object -> m Font loadEncoding (Direct (NameObject (Name name))) = encoding name loadEncoding object = fail $ printf "Encoding must be a name, not that : %s" $ show object loadResources :: Except m => Dictionary -> FontCache m FontSet loadResources = foldM addFont Map.empty . Map.toList where addFont output (name, Reference (IndirectObjCoordinates {objectId})) = flip (Map.insert name) output <$> cache loadFont objectId addFont output _ = return output getReference :: DirectObject -> [ObjectId] getReference (Reference (IndirectObjCoordinates {objectId})) = [objectId] getReference _ = [] loadPage :: Except m => ObjectId -> InLayer m Page loadPage source = do page <- objectById source contents <- getKey "Contents" page >>= loadContents resources <- getFontDictionary page return $ Page {contents, resources, source} pagesList :: Except m => InLayer m [ObjectId] pagesList = (origin // ["Root", "Pages"] >>= getKey "Kids" >>= return . getReferences) <|> return [] where getReferences (Array kids) = kids >>= getReference getReferences _ = fail "Not a pages array" data Pages = Pages newtype PageNumber = P Int data Contents = Contents instance (Alternative m, MonadFail m) => Box m Pages Layer (Map Int Page) where r Pages layer = runReaderT (numbered <$> (mapM loadPage =<< pagesList)) layer where numbered :: [Page] -> Map Int Page numbered = Map.fromList . zip [1..] instance (Alternative m, MonadFail m) => Box m PageNumber Layer Page where r (P i) layer | i < 1 = fail "Pages start at 1" | otherwise = runReaderT (drop (i - 1) <$> pagesList >>= firstPage) layer where firstPage [] = fail "Page is out of bounds" firstPage (p:_) = loadPage p instance Monad m => Box m Contents Page (OrderedMap ObjectId Content) where r Contents = return . contents cacheFonts :: Monad m => StateT CachedFonts m a -> m a cacheFonts = flip evalStateT Map.empty withResources :: Except m => (Page -> ReaderT FontSet m b) -> Page -> FontCache m b withResources f p = loadResources (resources p) >>= lift . lift . runReaderT (f p)