132 lines
3.6 KiB
Haskell
132 lines
3.6 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
module PDF.Output (
|
|
OBuilder
|
|
, ObjectId(..)
|
|
, OContext(..)
|
|
, Offset(..)
|
|
, Output(..)
|
|
, Resource(..)
|
|
, byteString
|
|
, char
|
|
, concat
|
|
, getOffsets
|
|
, join
|
|
, line
|
|
, newLine
|
|
, saveOffset
|
|
, string
|
|
, render
|
|
) where
|
|
|
|
import Data.ByteString.Builder (Builder, char8, string8, toLazyByteString)
|
|
import qualified Data.ByteString.Builder as B (byteString)
|
|
import Data.ByteString (ByteString)
|
|
import qualified Data.ByteString as BS (length)
|
|
import qualified Data.ByteString.Lazy as Lazy (ByteString)
|
|
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(..))
|
|
import Prelude hiding (concat)
|
|
|
|
newtype ObjectId = ObjectId {getObjectId :: Int} deriving (Enum, Eq, Ord, Show)
|
|
newtype Offset = Offset {getOffset :: Int} deriving (Show)
|
|
|
|
data Resource = StartXRef | Object ObjectId deriving (Eq, Ord)
|
|
|
|
newtype OContext a = OContext (RWS EOL.Style (Map Resource Offset) Offset 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 :: Resource -> OContext ()
|
|
saveOffset resource = OContext $
|
|
get >>= tell . Map.singleton resource
|
|
|
|
lift :: (a -> Builder) -> a -> OBuilder
|
|
lift f a = return (f a)
|
|
|
|
getOffsets :: OBuilder -> OContext (OBuilder, Map Resource Offset)
|
|
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)
|
|
|
|
concat :: [OBuilder] -> OBuilder
|
|
concat = foldl mappend mempty
|
|
|
|
#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 = concat . 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)
|
|
|
|
offset :: (Int -> Int) -> OContext ()
|
|
offset f = OContext $ modify $ \(Offset o) -> Offset (f o)
|
|
|
|
newLine :: OBuilder
|
|
newLine = buildEOL =<< OContext ask
|
|
where
|
|
buildEOL EOL.CR = return (char8 '\r') <* offset (+1)
|
|
buildEOL EOL.LF = return (char8 '\n') <* offset (+1)
|
|
buildEOL EOL.CRLF = return (string8 "\r\n") <* offset (+2)
|
|
|
|
char :: Char -> OBuilder
|
|
char c = lift char8 c <* offset (+1)
|
|
|
|
string :: String -> OBuilder
|
|
string s = lift string8 s <* offset (+ length s)
|
|
|
|
line :: String -> OBuilder
|
|
line l = string l `mappend` newLine
|
|
|
|
byteString :: ByteString -> OBuilder
|
|
byteString bs = lift B.byteString bs <* offset (+ BS.length bs)
|
|
|
|
render :: Output a => EOL.Style -> a -> Lazy.ByteString
|
|
render eolStyle a =
|
|
let OContext builder = output a in
|
|
let (outputByteString, _, _) = runRWS builder eolStyle (Offset 0) in
|
|
toLazyByteString outputByteString
|