module Graphics.PDF.Pages(
standardViewerPrefs
, findPage
, recordPage
, noPages
, addPages
, getCurrentPage
, addObject
, supply
, updateObject
, addOutlines
, insertDown
, insertRight
, up
, createContent
, recordBound
, setPageResource
, setPageAnnotations
) where
import qualified Data.IntMap as IM
import Control.Monad.State
import Graphics.PDF.LowLevel.Types
import Graphics.PDF.Draw
import qualified Graphics.PDF.Data.PDFTree as PT hiding(PDFTree,Key)
import Graphics.PDF.Resources
import Data.List(zip4)
import Graphics.PDF.Data.PDFTree(PDFTree,Key)
setPageAnnotations :: [AnyAnnotation] -> PDFReference PDFPage -> PDF ()
setPageAnnotations an page = do
lPages <- gets pages
let thePage = findPage page lPages
case thePage of
Nothing -> return ()
Just (PDFPage a b c d e f _) -> do
refs <- mapM (\x -> addAnnotation x >>= return . AnyPdfObject) an
modifyStrict $ \s -> s {pages = recordPage page (PDFPage a b c d e f refs) lPages}
setPageResource :: PDFReference PDFResource -> PDFReference PDFPage -> PDF ()
setPageResource newr page = do
lPages <- gets pages
let thePage = findPage page lPages
case thePage of
Nothing -> return ()
Just (PDFPage a b c _ e f g) -> modifyStrict $ \s -> s {pages = recordPage page (PDFPage a b c (Just newr) e f g) lPages}
createContent :: Draw a
-> Maybe (PDFReference PDFPage)
-> PDF (PDFReference PDFStream)
createContent d page = do
streamref <- supply
myBounds <- gets xobjectBound
let (_,state',w') = runDrawing d (emptyEnvironment {streamId = streamref, xobjectBoundD = myBounds}) (emptyDrawState streamref)
modifyStrict $ \s -> s {streams = IM.insert streamref (page,(state',w')) (streams s)}
return (PDFReference streamref)
supply :: PDF Int
supply = do
r <- gets supplySrc
modifyStrict $ \s -> s {supplySrc = r+1}
return r
addObject :: (PdfObject a) => a -> PDF (PDFReference a)
addObject a = do
r <- supply
modifyStrict $ \s -> s {objects = IM.insert r (AnyPdfObject a) (objects s)}
return (PDFReference r)
updateObject :: (PdfObject a) => PDFReference a
-> a
-> PDF ()
updateObject (PDFReference i) obj = do
modifyStrict $ \s -> s {objects = IM.insert i (AnyPdfObject obj) (objects s)}
standardViewerPrefs :: PDFViewerPreferences
standardViewerPrefs = PDFViewerPreferences False False False False False False UseNone
recordPage :: PDFReference PDFPage
-> PDFPage
-> Pages
-> Pages
recordPage pageref page (Pages lPages) = Pages (PT.insert pageref page lPages)
findPage :: PDFReference PDFPage
-> Pages
-> Maybe PDFPage
findPage page (Pages lPages) = PT.lookup page lPages
nodePage :: Maybe (PDFReference PDFPages)
-> PDFTree PDFPage
-> PDFTree PDFPage
-> PDF (Int,PDFReference PDFPages)
nodePage ref l r = do
n <- supply
let pRef = (PDFReference n) :: PDFReference PDFPages
(sl,lr) <- PT.fold2 (Just pRef) nodePage leafPage l
(sr,rr) <- PT.fold2 (Just pRef) nodePage leafPage r
let len = sl + sr
case (PT.isLeaf l,PT.isLeaf r) of
(False,False) -> updateObject pRef $ PDFPages len ref [Left lr,Left rr]
(True,False) -> updateObject pRef $ PDFPages len ref [Right (PT.keyOf l),Left rr]
(False,True) -> updateObject pRef $ PDFPages len ref [Left lr,Right (PT.keyOf r)]
(True,True) -> updateObject pRef $ PDFPages len ref [Right (PT.keyOf l),Right (PT.keyOf r)]
return (len,pRef)
leafPage :: Maybe (PDFReference PDFPages)
-> Key PDFPage
-> PDFPage
-> PDF (Int,PDFReference PDFPages)
leafPage (Just ref) (PDFReference objectnb) (PDFPage _ a b c d e f) = do
modifyStrict $ \s -> s {objects = IM.insert objectnb (AnyPdfObject $ PDFPage (Just ref) a b c d e f) (objects s) }
return (1,ref)
leafPage Nothing p@(PDFReference objectnb) (PDFPage _ a b c d e f) = do
n <- supply
let pRef = (PDFReference n) :: PDFReference PDFPages
updateObject pRef $ PDFPages 1 Nothing [Right p]
modifyStrict $ \s -> s {objects = IM.insert objectnb (AnyPdfObject $ PDFPage (Just pRef) a b c d e f) (objects s) }
return (1,pRef)
addPages :: PDF (PDFReference PDFPages)
addPages = do
Pages lPages <- gets pages
(_,r) <- PT.fold2 Nothing nodePage leafPage lPages
return r
noPages :: Pages
noPages = Pages (PT.empty)
insertRight :: a -> OutlineLoc a -> OutlineLoc a
insertRight _ (OutlineLoc _ Top) = error "Cannot insert right of the top node"
insertRight t' (OutlineLoc t c ) = let c' = Child { value = value c
, parent = parent c
, rights = rights c
, lefts = lefts c ++ [t] }
in OutlineLoc (Node t' []) c'
insertDown :: a -> OutlineLoc a -> OutlineLoc a
insertDown t' (OutlineLoc (Node v cs) c) = let c' = Child { value = v
, parent = c
, rights = []
, lefts = cs
}
in OutlineLoc (Node t' []) c'
up :: OutlineLoc a -> OutlineLoc a
up (OutlineLoc _ Top ) = error "Cannot go up from the top node"
up (OutlineLoc t (Child v c ls rs)) = let t' = Node v (ls ++ [t] ++ rs)
in OutlineLoc t' c
addOutlines :: Maybe Outline -> PDF (Maybe (PDFReference PDFOutline))
addOutlines Nothing = return Nothing
addOutlines (Just r) = do
let (Node _ l) = toTree r
if null l
then return Nothing
else do
rootRef <- supply
(first,end) <- createOutline (PDFReference rootRef) l
let outlineCatalog = PDFOutline first end
updateObject (PDFReference rootRef) outlineCatalog
return (Just (PDFReference rootRef))
createOutline :: PDFReference PDFOutlineEntry -> [Tree OutlineData] -> PDF (PDFReference PDFOutlineEntry,PDFReference PDFOutlineEntry)
createOutline r children = do
refs' <- mapM (const (supply >>= return . Just . PDFReference)) children
let refs = zip4 (Nothing : init refs') refs' children (tail refs' ++ [Nothing])
current (_,c,_,_) = c
Just first = current (head refs)
Just end = current (last refs)
mapM_ (addEntry first end) refs
return (first,end)
where
addEntry _ _ (_,Nothing,_,_) = error "This pattern match in addEntry should never occur !"
addEntry _ _ (prev,Just current,Node (title,col,style,dest) c,next) = do
(f,e) <- if (null c)
then
return (Nothing,Nothing)
else
createOutline current c >>= \(x,y) -> return (Just x,Just y)
let o = PDFOutlineEntry title
r
prev
next
f
e
((length c))
dest
(maybe (Rgb 0 0 0) id col)
(maybe NormalOutline id style)
updateObject current o
toTree :: OutlineLoc a -> Tree a
toTree (OutlineLoc a Top) = a
toTree a = toTree (up a)
getCurrentPage :: PDF (Maybe (PDFReference PDFPage))
getCurrentPage = gets currentPage
recordBound :: Int
-> PDFFloat
-> PDFFloat
-> PDF ()
recordBound ref width height = modifyStrict $ \s -> s {xobjectBound = IM.insert ref (width,height) (xobjectBound s)}