Hufflepdf/src/PDF/Output.hs

126 lines
3.5 KiB
Haskell

{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module PDF.Output (
OBuilder
, ObjectId(..)
, OContext(..)
, Offset(..)
, Output(..)
, Resource(..)
, byteString
, char
, 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(..))
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)
#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 = mconcat . 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