118 lines
3.2 KiB
Haskell
118 lines
3.2 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
module PDF.Output (
|
|
OBuilder
|
|
, OContext(..)
|
|
, Offset(..)
|
|
, Output(..)
|
|
, byteString
|
|
, char
|
|
, getOffsets
|
|
, join
|
|
, lift
|
|
, newLine
|
|
, nextLine
|
|
, saveOffset
|
|
, string
|
|
, render
|
|
) where
|
|
|
|
import Data.ByteString.Builder (Builder, char8, lazyByteString, string8, toLazyByteString)
|
|
import Data.ByteString.Lazy.Char8 (ByteString)
|
|
import qualified Data.ByteString.Lazy.Char8 as BS (length)
|
|
import Data.Int (Int64)
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map (singleton)
|
|
import Data.String (IsString(..))
|
|
import Control.Monad.RWS (RWS, runRWS, ask, get, listen, modify, tell)
|
|
import qualified PDF.EOL as EOL (Style(..))
|
|
|
|
data Offset = StartXRef | ObjectId Int deriving (Eq, Ord)
|
|
|
|
newtype OContext a = OContext (RWS EOL.Style (Map Offset Int64) Int64 a)
|
|
type OBuilder = OContext Builder
|
|
|
|
instance Functor OContext where
|
|
fmap f (OContext oc) = OContext $ fmap f oc
|
|
|
|
instance Applicative OContext where
|
|
pure = OContext . pure
|
|
(<*>) (OContext f) (OContext a) = OContext (f <*> a)
|
|
|
|
instance Monad OContext where
|
|
(>>=) (OContext a) f = OContext (a >>= (\x -> let OContext y = f x in y))
|
|
|
|
saveOffset :: Offset -> OContext ()
|
|
saveOffset offset = OContext $
|
|
get >>= tell . Map.singleton offset
|
|
|
|
lift :: (a -> Builder) -> a -> OBuilder
|
|
lift f a = return (f a)
|
|
|
|
getOffsets :: OBuilder -> OContext (OBuilder, Map Offset Int64)
|
|
getOffsets (OContext builder) =
|
|
OContext (listen builder >>= \(a, w) -> return (return a, w))
|
|
|
|
append :: OBuilder -> OBuilder -> OBuilder
|
|
append (OContext a) (OContext b) = OContext (mappend <$> a <*> b)
|
|
|
|
#if MIN_VERSION_base(4,11,0)
|
|
instance Semigroup OBuilder where
|
|
(<>) = append
|
|
#endif
|
|
|
|
instance Monoid OBuilder where
|
|
mempty = OContext (return mempty)
|
|
#if !(MIN_VERSION_base(4,11,0))
|
|
mappend = append
|
|
#endif
|
|
|
|
instance IsString OBuilder where
|
|
fromString = string
|
|
|
|
class Output a where
|
|
output :: a -> OBuilder
|
|
|
|
instance Output OBuilder where
|
|
output = id
|
|
|
|
instance Output Bool where
|
|
output False = string "false"
|
|
output True = string "true"
|
|
|
|
instance Output a => Output [a] where
|
|
output = foldl mappend mempty . fmap output
|
|
|
|
join :: Output a => String -> [a] -> OBuilder
|
|
join _ [] = mempty
|
|
join _ [a] = output a
|
|
join separator (a:as) =
|
|
output a `mappend` string separator `mappend` (join separator as)
|
|
|
|
newLine :: OBuilder
|
|
newLine = OContext $ buildEOL =<< ask
|
|
where
|
|
buildEOL EOL.CR = return (char8 '\r') <* modify (+1)
|
|
buildEOL EOL.LF = return (char8 '\n') <* modify (+1)
|
|
buildEOL EOL.CRLF = return (string8 "\r\n") <* modify (+2)
|
|
|
|
nextLine :: OBuilder -> OBuilder -> OBuilder
|
|
nextLine a b = a `mappend` newLine `mappend` b
|
|
|
|
char :: Char -> OBuilder
|
|
char c = lift char8 c <* OContext (modify (+1))
|
|
|
|
string :: String -> OBuilder
|
|
string s = lift string8 s <* OContext (modify (+ toEnum (length s)))
|
|
|
|
byteString :: ByteString -> OBuilder
|
|
byteString bs = lift lazyByteString bs <* OContext (modify (+ BS.length bs))
|
|
|
|
render :: Output a => EOL.Style -> a -> ByteString
|
|
render eolStyle a =
|
|
let OContext builder = output a in
|
|
let (outputByteString, _, _) = runRWS builder eolStyle 0 in
|
|
toLazyByteString outputByteString
|