HPDF-1.0: Graphics/PDF.hs

---------------------------------------------------------
-- |
-- Copyright   : (c) alpheccar 2007
-- License     : BSD-style
--
-- Maintainer  : misc@NOSPAMalpheccar.org
-- Stability   : experimental
-- Portability : portable
--
-- Generation of PDF documents
---------------------------------------------------------
module Graphics.PDF
  (
  -- * HPDF
  -- ** PDF Monad
    PDF 
  , runPdf
  -- ** PDF Common Types
  , PDFRect(..)
  , PDFFloat(..)
  , PDFReference
  , PDFString
  , PDFPage
  , Pages
  -- ** Document management
  , module Graphics.PDF.Document
  -- ** Drawing
  , module Graphics.PDF.Shapes
  -- ** Colors
  , module Graphics.PDF.Colors
  -- ** Geometry
  , module Graphics.PDF.Coordinates
  -- ** Text
  , module Graphics.PDF.Text
  -- ** Navigation
  , module Graphics.PDF.Navigation
  -- ** Annotations
  , module Graphics.PDF.Annotation
  -- ** Actions
  , module Graphics.PDF.Action
  -- ** Images
  , module Graphics.PDF.Image
  -- ** Patterns
  , module Graphics.PDF.Pattern
  -- ** Shading
  , module Graphics.PDF.Shading
  ) where
 
import Graphics.PDF.Shading
import Graphics.PDF.Pattern
import Graphics.PDF.Navigation
import Graphics.PDF.Text
import qualified Data.IntMap as IM
import qualified Data.Map as M
import qualified Data.ByteString.Lazy as B
import Data.Int
import System.IO
import Control.Exception(bracket)
import Text.Printf(printf)
import Control.Monad.State
import Graphics.PDF.Annotation
import Graphics.PDF.LowLevel.Types
import Graphics.PDF.Draw
import Graphics.PDF.Colors
import Graphics.PDF.Shapes
import Graphics.PDF.Coordinates
import Graphics.PDF.Pages
import Graphics.PDF.Document
import Codec.Compression.Zlib
import Graphics.PDF.Action
import Graphics.PDF.Image
import Graphics.PDF.Resources(emptyResource)

-- | Create a new PDF document and return a first page
-- The page is using the document size by default
createPDF :: PDF ()
createPDF  = do
  -- Create the Proc structure
  --proc <- addObject PDFProc
  -- Create an empty resource
  --addObject $ PDFResource proc
  return ()
  
-- Create the PDF stream objects from the draw monads
createStreams :: [(Int, (Maybe (PDFReference PDFPage),Draw ()))] -> PDF ()
createStreams l = mapM_ addStream l
 where
    addStream (k,(p,d)) = do
     -- New reference for the stream
     r <- supply
     -- Run the drawing and get the new state (resource, annotation)
     myBounds <- gets xobjectBound
     cp <- gets currentPage
     let (_,state',w') = runDrawing d (emptyEnvironment {streamId = r, xobjectb = myBounds, currentp = maybe Nothing (\(PDFReference x) -> Just x) cp })
         ref = PDFReference r :: PDFReference PDFLength
         
     -- Pattern NEEDS a resource entry even if empty otherwise don't work with acrobat reader
     -- Image DON'T want a resource entry if empty otherwise don't work with apple reader
     resources <- if (emptyResource (rsrc state')) && (not (pdfDictMember (PDFName "PatternType") (otherRsrcs state')))
       then do
         case p of
            -- Not linked to a page
            -- otherResource are entries specific to a special stream (like an XObject) so we return empty for a page
            Nothing -> return (otherRsrcs state') 
            -- Linked to a page
            Just pageRef -> do
                 setPageAnnotations (annots state') pageRef
                 return emptyDictionary
       -- Some resource are needed by the stream
       else do
         rsrcRef <- addObject (rsrc state')
         case p of
             -- Not linked to a page
             Nothing -> do                  
                  return $ (otherRsrcs state') `pdfDictUnion` (PDFDictionary . M.fromList  $ [(PDFName "Resources",AnyPdfObject rsrcRef)])
             -- Linked to a page
             Just pageRef -> do
                  setPageAnnotations (annots state') pageRef
                  setPageResource rsrcRef pageRef
                  return emptyDictionary
              
     infos <- gets docInfo
     -- Resources to add to the stream
     -- We compress only if the stream is not using its own filter
     if (compressed infos) && (not (pdfDictMember (PDFName "Filter") resources))
       then do
         let w'' = compress w'
         updateObject (PDFReference k :: PDFReference PDFStream) (PDFStream w'' True ref resources)
         updateObject ref (PDFLength (B.length w''))
       else do
         updateObject (PDFReference k :: PDFReference PDFStream) (PDFStream w' False ref resources)
         updateObject ref (PDFLength (B.length w'))

-- | Save all the pages and streams in the main object dictionary
saveObjects :: PDF (PDFReference PDFCatalog)
saveObjects  = do
  ls <- gets streams
  createStreams . IM.toList $ ls
  infos <- gets docInfo
  -- Save pages and streams to the object dictionary so that they are saved in the PDF document
  pRef <- addPages
  -- Create outlines object
  o <- gets outline
  oref <- addOutlines o
  -- Create the catalog
  cat <- addObject $ PDFCatalog oref pRef (pageMode infos) (pageLayout infos) (viewerPreferences infos)
  modify $ \s -> s {catalog = cat}
  gets catalog
  
-- | Write PDF objects in the TOC
writeObjectsAndCreateToc :: Handle -- ^ File handle
                         -> [B.ByteString] -- ^ List of objects each object being already converted to a bytestring
                         -> IO (Int,Int64,[B.ByteString])
writeObjectsAndCreateToc h l = foldM writeObject (0,0::Int64,[]) l where
  writeObject (nb,len,toc) obj = do
    -- Write the object to the file
    B.hPut h obj
    -- Remember the position
    return (nb+1,len + B.length obj,(toByteString (printf "%010d 00000 n \n" ((fromIntegral len)::Integer))) : toc)

withFile :: FilePath -> (Handle -> IO c) -> IO c
withFile name = bracket (openBinaryFile name WriteMode) hClose

-- | The PDFTrailer
#ifndef __HADDOCK__
data PDFTrailer = PDFTrailer 
  !Int -- ^ Number of PDF objects in the document
  !(PDFReference PDFCatalog) -- ^ Reference to the PDf catalog
  !(PDFDocumentInfo)
#else
data PDFTrailer
#endif
    
instance PdfObject PDFTrailer where
   toPDF (PDFTrailer size root infos) = toPDF $ PDFDictionary. M.fromList $ 
     [ (PDFName "Size",AnyPdfObject . PDFInteger $ size)
     , (PDFName "Root",AnyPdfObject root)
     , (PDFName "Info",AnyPdfObject . PDFDictionary . M.fromList $ allInfos)
     ]
     where
      allInfos = [ (PDFName "Author",AnyPdfObject . author $ infos)
                 , (PDFName "Subject",AnyPdfObject . subject $ infos)
                 ]
    
-- | Generates a PDF document
runPdf :: String -- ^ Name of the PDF document
       -> PDFDocumentInfo
       -> PDFRect -- ^ Default size for a page
       -> PDF a  -- ^ PDF action 
       -> IO ()
runPdf filename infos rect m = do
  (root,s) <- flip runStateT vars  . unPDF $ createPDF >> m >> saveObjects
  let header = toByteString "%PDF-1.5\n"
      objs = objects s
  withFile filename $ \h -> do
    (nb,len,toc) <- writeObjectsAndCreateToc h $ header : (map (toPDF . pointer) . IM.toAscList $ objs)
    B.hPut h . toByteString $ "xref\n"
    B.hPut h . toByteString $ "0 " ++ show nb ++ "\n"
    B.hPut h . toByteString $ "0000000000 65535 f \n"
    B.hPut h . B.concat . tail . reverse $ toc
    B.hPut h . toByteString $ "\ntrailer\n"
    B.hPut h . toPDF $ PDFTrailer nb root infos
    B.hPut h . toByteString $ "\nstartxref\n"
    B.hPut h . toByteString $ (show len)
    B.hPut h . toByteString $ "\n%%EOF"
 where
  pointer (x,a) = PDFReferencedObject (fromIntegral x) a
  vars = PdfState {
           supplySrc = 1
         , objects = IM.empty
         , pages = noPages
         , streams = IM.empty
         , catalog = PDFReference 0
         , defaultRect = rect
         , docInfo = infos
         , outline = Nothing
         , currentPage = Nothing
         , xobjectBound = IM.empty
         , firstOutline = [True]
         }