module Pdf.Toolbox.Core.Writer
(
PdfWriter,
runPdfWriter,
writePdfHeader,
writeObject,
deleteObject,
writeXRefTable
)
where
import Data.Int
import Data.Set (Set)
import qualified Data.Set as Set
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BSL
import Data.ByteString.Lazy.Builder
import Data.ByteString.Lazy.Builder.ASCII
import Data.Function
import Data.Monoid
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Control.Monad.IO.Class
import System.IO.Streams (OutputStream)
import qualified System.IO.Streams as Streams
import Pdf.Toolbox.Core.Object.Types
import Pdf.Toolbox.Core.Object.Builder
newtype PdfWriter m a = PdfWriter (StateT PdfState m a)
deriving (Monad, MonadIO, MonadTrans)
runPdfWriter :: MonadIO m
=> OutputStream ByteString
-> PdfWriter m a
-> m a
runPdfWriter output (PdfWriter action) = do
(out, count) <- liftIO $ Streams.countOutput output
let emptyState = PdfState {
stOutput = out,
stObjects = Set.empty,
stCount = count,
stOffset = 0
}
evalStateT action emptyState
data Elem = Elem {
elemIndex :: !Int,
elemGen :: !Int,
elemOffset :: !Int64,
elemFree :: !Bool
}
instance Eq Elem where
(==) = (==) `on` elemIndex
instance Ord Elem where
compare = compare `on` elemIndex
data PdfState = PdfState {
stOutput :: OutputStream ByteString,
stObjects :: !(Set Elem),
stCount :: IO Int64,
stOffset :: !Int64
}
writePdfHeader :: MonadIO m => PdfWriter m ()
writePdfHeader = do
output <- PdfWriter $ gets stOutput
liftIO $ Streams.write (Just "%PDF-1.7\n") output
writeObject :: MonadIO m => Ref -> Object BSL.ByteString -> PdfWriter m ()
writeObject ref@(Ref index gen) obj = do
st <- PdfWriter get
pos <- countWritten
addElem $ Elem index gen pos False
dumpObject (stOutput st) ref obj
return ()
deleteObject :: MonadIO m => Ref -> Int64 -> PdfWriter m ()
deleteObject (Ref index gen) nextFree =
addElem $ Elem index gen nextFree True
writeXRefTable :: MonadIO m
=> Int64
-> Dict
-> PdfWriter m ()
writeXRefTable offset tr = do
st <- PdfWriter get
off <- (+ offset) `liftM` countWritten
let elems = Set.mapMonotonic (\e -> e {elemOffset = elemOffset e + offset}) $ stObjects st
content = byteString "xref\n" `mappend`
buildXRefTable (Set.toAscList elems) `mappend`
byteString "trailer\n" `mappend`
buildDict tr `mappend`
byteString "\nstartxref\n" `mappend`
int64Dec off `mappend`
byteString "\n%%EOF\n"
liftIO $ Streams.writeLazyByteString (toLazyByteString content) (stOutput st)
countWritten :: MonadIO m => PdfWriter m Int64
countWritten = do
st <- PdfWriter get
c <- (stOffset st +) `liftM` liftIO (stCount st)
PdfWriter $ put $ st {stOffset = c}
return $! c
addElem :: Monad m => Elem -> PdfWriter m ()
addElem e = do
st <- PdfWriter get
when (Set.member e $ stObjects st) $ error $ "PdfWriter: attempt to write object with the same index: " ++ show (elemIndex e)
PdfWriter $ put st {stObjects = Set.insert e $ stObjects st}
dumpObject :: MonadIO m => OutputStream ByteString -> Ref -> Object BSL.ByteString -> m ()
dumpObject out ref o = liftIO $ Streams.writeLazyByteString (toLazyByteString $ buildIndirectObject ref o) out
buildXRefTable :: [Elem] -> Builder
buildXRefTable entries =
mconcat (map buildXRefSection $ sections entries)
where
sections :: [Elem] -> [[Elem]]
sections [] = []
sections xs = let (s, rest) = section xs in s : sections rest
section [] = error "impossible"
section (x:xs) = go (elemIndex x + 1) [x] xs
where
go _ res [] = (reverse res, [])
go i res (y:ys) =
if i == elemIndex y
then go (i + 1) (y : res) ys
else (reverse res, y:ys)
buildXRefSection :: [Elem] -> Builder
buildXRefSection [] = error "impossible"
buildXRefSection s@(e:_) =
intDec (elemIndex e) `mappend`
char7 ' ' `mappend`
intDec (length s) `mappend`
char7 '\n' `mappend`
loop s
where
loop (x:xs) =
buildFixed 10 '0' (elemOffset x) `mappend`
char7 ' ' `mappend`
buildFixed 5 '0' (elemGen x) `mappend`
char7 ' ' `mappend`
char7 (if elemFree x then 'f' else 'n') `mappend`
string7 "\r\n" `mappend`
loop xs
loop [] = mempty
buildFixed :: Show a => Int -> Char -> a -> Builder
buildFixed len c i =
let v = take len $ show i
l = length v
in string7 $ replicate (len l) c ++ v