diff --git a/src/PDF.hs b/src/PDF.hs index d2fad68..9cfb05b 100644 --- a/src/PDF.hs +++ b/src/PDF.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MultiParamTypeClasses #-} module PDF ( Document(..) - , Content(..) , DirectObject(..) , parseDocument , render @@ -17,7 +17,10 @@ import Data.Int (Int64) import qualified Data.Map as Map (lookup) import PDF.Body (populate) import qualified PDF.EOL as EOL (Style(..), charset, parser) -import PDF.Object (Content(..), DirectObject(..), content, eofMarker, magicNumber) +import PDF.Object ( + Content(..), DirectObject(..), Name(..), Number(..), Structure(..) + , eofMarker, magicNumber, structure + ) import qualified PDF.Output as Output (render, string) import PDF.Output (Output(..), nextLine) import Text.Parsec @@ -86,23 +89,23 @@ findNextSection offset input = then newOffset + findNextLine newInput else findNextSection (newOffset + 1) (BS.drop 1 newInput) -iterateContents :: Int64 -> ByteString -> Either ParseError [Content] -iterateContents startXref input = - parse content ('@':show startXref) (BS.drop startXref input) >>= stopOrFollow +readStructures :: Int64 -> ByteString -> Either ParseError [Structure] +readStructures startXref input = + parse structure ('@':show startXref) (BS.drop startXref input) >>= stopOrFollow where - stopOrFollow c@(Content {trailer}) = - case Map.lookup "Prev" trailer of + stopOrFollow c@(Structure {inputTrailer}) = + case Map.lookup (Name "Prev") inputTrailer of Nothing -> Right [c {startOffset = findNextLine input}] - Just (Number newStartXref) -> + Just (NumberObject (Number newStartXref)) -> let offset = truncate newStartXref in let startOffset = findNextSection offset (BS.drop offset input) in - (c {startOffset}:) <$> (iterateContents offset input) + (c {startOffset}:) <$> (readStructures offset input) Just v -> parseError $ "Bad value for Prev entry in trailer: " ++ show v parseDocument :: ByteString -> Either ParseError Document parseDocument input = do (pdfVersion, eolStyle) <- parse ((,) <$> version <*> EOL.parser) "" input startXref <- readStartXref eolStyle input - structures <- iterateContents startXref input - let contents = populate input <$> structures + structuresRead <- readStructures startXref input + let contents = populate input <$> structuresRead return $ Document {pdfVersion, eolStyle, contents} diff --git a/src/PDF/Body.hs b/src/PDF/Body.hs index 46da7b8..d898cdc 100644 --- a/src/PDF/Body.hs +++ b/src/PDF/Body.hs @@ -7,33 +7,35 @@ import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as BS (drop, pack) import Data.Int (Int64) import Data.Map ((!)) -import qualified Data.Map as Map (insert, lookup) +import qualified Data.Map as Map (empty, insert, lookup) import qualified PDF.EOL as EOL (charset, parser) import PDF.Object ( - Content(..), DirectObject(..), IndirectObjCoordinates(..), Object(..) - , Occurrence(..), Parser, XRefEntry(..), XRefSection, XRefSubSection(..) + Content(..), DirectObject(..), Flow(..), IndirectObjCoordinates(..), Name(..) + , Number(..), Object(..), Occurrence(..), Parser, Structure(..) + , XRefEntry(..), XRefSection, XRefSubSection(..) , blank, dictionary, directObject, integer, line ) import Text.Parsec data UserState = UserState { input :: ByteString - , content :: Content + , structure :: Structure + , flow :: Flow } type SParser = Parser UserState -modifyContent :: (Content -> Content) -> SParser () -modifyContent f = modifyState $ \state -> state {content = f $ content state} +modifyFlow :: (Flow -> Flow) -> SParser () +modifyFlow f = modifyState $ \state -> state {flow = f $ flow state} addObject :: Int -> Object -> SParser () -addObject objectId newObject = modifyContent $ \content -> content { - objects = Map.insert objectId newObject $ objects content +addObject objectId newObject = modifyFlow $ \flow -> flow { + tmpObjects = Map.insert objectId newObject $ tmpObjects flow } pushOccurrence :: Occurrence -> SParser () -pushOccurrence newOccurrence = modifyContent $ \content -> content { - body = newOccurrence : (body content) +pushOccurrence newOccurrence = modifyFlow $ \flow -> flow { + occurrencesStack = newOccurrence : (occurrencesStack flow) } comment :: Parser u String @@ -53,7 +55,7 @@ lookupOffset objectId (xrefSubSection:others) = getOffset :: Int -> SParser Int64 getOffset objectId = do - Content {xrefSection} <- content <$> getState + Structure {xrefSection} <- structure <$> getState case lookupOffset objectId xrefSection of Nothing -> fail $ "obj " ++ show objectId ++ " is referenced but missing in XRef table" @@ -69,9 +71,9 @@ loadNumber objectId = do offset <- getOffset objectId objectStart <- BS.drop offset . input <$> getState indirectObjCoordinates `on` objectStart >> return () - objectValue <- (!objectId) . objects . content <$> getState + objectValue <- (!objectId) . tmpObjects . flow <$> getState case objectValue of - Direct (Number n) -> return n + Direct (NumberObject (Number n)) -> return n obj -> fail $ "Expected obj@" ++ show offset ++ " (" ++ show obj ++ ") to be a Number" invalidValue :: Object -> String @@ -79,12 +81,12 @@ invalidValue v = "Invalid value " ++ show v getSize :: Maybe DirectObject -> SParser Float getSize Nothing = fail "Missing '/Length' key on stream" -getSize (Just (Number size)) = return size +getSize (Just (NumberObject (Number size))) = return size getSize (Just (Reference (IndirectObjCoordinates {objectId}))) = do - Content {objects} <- content <$> getState - case Map.lookup objectId objects of + Flow {tmpObjects} <- flow <$> getState + case Map.lookup objectId tmpObjects of Nothing -> loadNumber objectId - Just (Direct (Number size)) -> return size + Just (Direct (NumberObject (Number size))) -> return size Just v -> fail $ invalidValue v ++ " for obj " ++ show objectId ++ "used as /Length" getSize (Just v) = fail $ invalidValue (Direct v) ++ " for /Length" @@ -92,7 +94,7 @@ getSize (Just v) = fail $ invalidValue (Direct v) ++ " for /Length" streamObject :: SParser Object streamObject = try $ do header <- dictionary <* blank - size <- getSize (Map.lookup "Length" header) + size <- getSize (Map.lookup (Name "Length") header) streamContent <- BS.pack <$> stream (truncate size) return $ Stream {header, streamContent} where @@ -112,16 +114,20 @@ indirectObjCoordinates = do occurrence :: SParser Occurrence occurrence = Comment <$> comment <|> Indirect <$> indirectObjCoordinates -populate :: ByteString -> Content -> Content -populate input initialContent = - let bodyInput = BS.drop (startOffset initialContent) input in +populate :: ByteString -> Structure -> Content +populate input structure = + let bodyInput = BS.drop (startOffset structure) input in case runParser recurseOnOccurrences initialState "" bodyInput of - Left _ -> initialContent + Left _ -> emptyContent Right finalState -> - let finalContent = content finalState in - finalContent {body = reverse (body finalContent)} + let Flow {occurrencesStack, tmpObjects} = flow finalState in + Content {occurrences = reverse occurrencesStack, objects = tmpObjects, trailer} where - initialState = UserState {input, content = initialContent} + trailer = inputTrailer structure + emptyContent = Content {occurrences = [], objects = Map.empty, trailer} + initialState = UserState { + input, structure, flow = Flow {occurrencesStack = [], tmpObjects = Map.empty} + } recurseOnOccurrences :: SParser UserState recurseOnOccurrences = diff --git a/src/PDF/Object.hs b/src/PDF/Object.hs index 9fa4068..3c8a179 100644 --- a/src/PDF/Object.hs +++ b/src/PDF/Object.hs @@ -1,159 +1,46 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} module PDF.Object ( Content(..) , DirectObject(..) + , Flow(..) , IndirectObjCoordinates(..) + , Name(..) + , Number(..) , Object(..) , Occurrence(..) , Parser + , Structure(..) , XRefEntry(..) , XRefSection , XRefSubSection(..) , blank - , content , dictionary , directObject , eofMarker , integer , line , magicNumber + , structure ) where import Data.ByteString.Lazy.Char8 (ByteString) import Data.Int (Int64) import Data.Map (Map, (!)) -import qualified Data.Map as Map (empty, elems, fromList, toList) +import qualified Data.Map as Map (elems, fromList, toList) import qualified PDF.EOL as EOL (charset, parser) import qualified PDF.Output as Output (string) -import PDF.Output (OBuilder, Output(..), byteString, join, newLine, nextLine) +import PDF.Output ( + OBuilder, Offset(..), Output(..) + , byteString, getOffsets, join, newLine, nextLine, saveOffset + ) import Text.Parsec import Text.Printf (printf) type Parser u = Parsec ByteString u -type Dictionary = Map String DirectObject - -instance Output (Map String DirectObject) where - output dict = - "<<" `mappend` keyValues `mappend` ">>" - where - keyValues = join " " $ outputKeyVal <$> Map.toList dict - outputKeyVal (key, val) = - Output.string (printf "/%s " key) `mappend` output val - -data StringObj = Literal String | Hexadecimal String deriving Show - -instance Output StringObj where - output (Literal s) = Output.string (printf "(%s)" s) - output (Hexadecimal s) = Output.string (printf "<%s>" s) - -data DirectObject = - Boolean Bool - | Number Float - | String StringObj - | Name String - | Array [DirectObject] - | Dictionary Dictionary - | Null - | Reference IndirectObjCoordinates - deriving Show - -outputFloat :: Float -> OBuilder -outputFloat f = Output.string $ - case properFraction f of - (n, 0) -> printf "%d" (n :: Int) - _ -> printf "%f" f - -instance Output DirectObject where - output (Boolean b) = output b - output (Number n) = outputFloat n - output (String s) = output s - output (Name n) = "/" `mappend` Output.string n - output (Array a) = "[" `mappend` join " " a `mappend` "]" - output (Dictionary d) = output d - output (Null) = "null" - output (Reference (IndirectObjCoordinates {objectId, versionNumber})) = - Output.string (printf "%d %d R" objectId versionNumber) - -data Object = - Direct DirectObject - | Stream { - header :: Dictionary - , streamContent :: ByteString - } - deriving Show - -instance Output Object where - output (Direct d) = output d - output (Stream {header, streamContent}) = - output header - `nextLine` "stream" - `nextLine` byteString streamContent - `mappend` "endstream" - -data IndirectObjCoordinates = IndirectObjCoordinates { - objectId :: Int - , versionNumber :: Int - } deriving Show - -data Occurrence = Comment String | Indirect IndirectObjCoordinates deriving Show - -outputOccurrence :: Map Int Object -> Occurrence -> OBuilder -outputOccurrence _ (Comment c) = - Output.string (printf "%%%s" c) `mappend` newLine -outputOccurrence objects (Indirect (IndirectObjCoordinates {objectId, versionNumber})) = - Output.string (printf "%d %d obj" objectId versionNumber) - `nextLine` output (objects ! objectId) - `nextLine` "endobj" `mappend` newLine - -data XRefEntry = InUse { - offset :: Int64 - , generation :: Int - } | Free { - nextFree :: Int64 - , generation :: Int - } deriving Show - -instance Output XRefEntry where - output (InUse {offset, generation}) = - Output.string (printf "%010d %05d n " offset generation) `mappend` newLine - output (Free {nextFree, generation}) = - Output.string (printf "%010d %05d f " nextFree generation) `mappend` newLine - -data XRefSubSection = XRefSubSection { - firstObjectId :: Int - , entriesNumber :: Int - , entries :: Map Int XRefEntry - } deriving Show - -instance Output XRefSubSection where - output (XRefSubSection {firstObjectId, entriesNumber, entries}) = - Output.string (printf "%d %d" firstObjectId entriesNumber) - `nextLine` output (Map.elems entries) - -type XRefSection = [XRefSubSection] - -data Content = Content { - startOffset :: Int64 - , body :: [Occurrence] - , objects :: Map Int Object - , xrefSection :: XRefSection - , trailer :: Dictionary - , startXrefPosition :: Int64 - } deriving Show - -instance Output Content where - output (Content {body, objects, trailer, xrefSection, startXrefPosition}) = - output (outputOccurrence objects <$> body) - `mappend` output xrefSection - `mappend` "trailer" - `nextLine` output trailer - `nextLine` "startxref" - `nextLine` Output.string (printf "%d" startXrefPosition) - `nextLine` byteString eofMarker - line :: String -> Parser u () line l = string l *> EOL.parser *> return () @@ -181,29 +68,46 @@ regular = noneOf $ EOL.charset ++ whiteSpaceCharset ++ delimiterCharset integer :: (Read a, Num a) => Parser u a integer = read <$> many1 digit <* whiteSpace -directObject :: Parser u DirectObject -directObject = - Boolean <$> try boolean - <|> Reference <$> try reference {- defined before Number because Number is a prefix of it -} - <|> Number <$> try number - <|> String <$> try stringObj - <|> Name <$> try name - <|> Array <$> try array - <|> Dictionary <$> try dictionary - <|> const Null <$> try nullObject +------------------------------------- +-- OBJECTS +------------------------------------- +-- +-- Boolean +-- boolean :: Parser u Bool boolean = (string "true" *> return True) <|> (string "false" *> return False) -number :: Parser u Float -number = read <$> (mappend <$> sign <*> (integerPart <|> ('0':) <$> floatPart)) +-- +-- Number +-- +newtype Number = Number Float deriving Show + +instance Output Number where + output (Number f) = Output.string $ + case properFraction f of + (n, 0) -> printf "%d" (n :: Int) + _ -> printf "%f" f + +number :: Parser u Number +number = Number . read <$> + (mappend <$> sign <*> (integerPart <|> ('0':) <$> floatPart)) where sign = string "-" <|> option "" (char '+' >> return "") integerPart = mappend <$> many1 digit <*> option "" floatPart floatPart = (:) <$> char '.' <*> (option "0" $ many1 digit) -stringObj :: Parser u StringObj -stringObj = +-- +-- StringObject +-- +data StringObject = Literal String | Hexadecimal String deriving Show + +instance Output StringObject where + output (Literal s) = Output.string (printf "(%s)" s) + output (Hexadecimal s) = Output.string (printf "<%s>" s) + +stringObject :: Parser u StringObject +stringObject = Literal <$> (char '(' *> (concat <$> many literalStringBlock) <* char ')') <|> Hexadecimal <$> (char '<' *> many hexDigit <* char '>') where @@ -213,12 +117,36 @@ stringObj = escapedChar = (:) <$> char '\\' <*> ((:[]) <$> oneOf "nrtbf()\\" <|> octalCode) octalCode = choice $ (\n -> count n octDigit) <$> [1..3] -name :: Parser u String -name = char '/' *> many regular +-- +-- Name +-- +newtype Name = Name String deriving (Eq, Ord, Show) +instance Output Name where + output (Name n) = "/" `mappend` Output.string n + +name :: Parser u Name +name = Name <$> (char '/' *> many regular) + +-- +-- Array +-- array :: Parser u [DirectObject] array = char '[' *> blank *> directObject `endBy` blank <* char ']' +-- +-- Dictionary +-- +type Dictionary = Map Name DirectObject + +instance Output Dictionary where + output dict = + "<<" `mappend` keyValues `mappend` ">>" + where + keyValues = join " " $ outputKeyVal <$> Map.toList dict + outputKeyVal :: (Name, DirectObject) -> OBuilder + outputKeyVal (key, val) = output key `mappend` " " `mappend` output val + dictionary :: Parser u Dictionary dictionary = try (string "<<" *> blank *> keyValPairs <* string ">>") @@ -226,12 +154,114 @@ dictionary = keyVal = (,) <$> name <* blank <*> directObject keyValPairs = Map.fromList <$> keyVal `endBy` blank +-- +-- Null +-- nullObject :: Parser u () nullObject = string "null" *> return () +-- +-- Reference +-- +data IndirectObjCoordinates = IndirectObjCoordinates { + objectId :: Int + , versionNumber :: Int + } deriving Show + reference :: Parser u IndirectObjCoordinates reference = IndirectObjCoordinates <$> integer <*> integer <* char 'R' +-- +-- DirectObject +-- +data DirectObject = + Boolean Bool + | NumberObject Number + | StringObject StringObject + | NameObject Name + | Array [DirectObject] + | Dictionary Dictionary + | Null + | Reference IndirectObjCoordinates + deriving Show + +instance Output DirectObject where + output (Boolean b) = output b + output (NumberObject n) = output n + output (StringObject s) = output s + output (NameObject n) = output n + output (Array a) = "[" `mappend` join " " a `mappend` "]" + output (Dictionary d) = output d + output (Null) = "null" + output (Reference (IndirectObjCoordinates {objectId, versionNumber})) = + Output.string (printf "%d %d R" objectId versionNumber) + +directObject :: Parser u DirectObject +directObject = + Boolean <$> try boolean + <|> Reference <$> try reference {- defined before Number because Number is a prefix of it -} + <|> NumberObject <$> try number + <|> StringObject <$> try stringObject + <|> NameObject <$> try name + <|> Array <$> try array + <|> Dictionary <$> try dictionary + <|> const Null <$> try nullObject + +-- +-- Object +-- +data Object = + Direct DirectObject + | Stream { + header :: Dictionary + , streamContent :: ByteString + } + deriving Show + +instance Output Object where + output (Direct d) = output d + output (Stream {header, streamContent}) = + output header + `nextLine` "stream" + `nextLine` byteString streamContent + `mappend` "endstream" + + +-- +-- Occurrence +-- +data Occurrence = Comment String | Indirect IndirectObjCoordinates deriving Show + +outputOccurrence :: Map Int Object -> Occurrence -> OBuilder +outputOccurrence _ (Comment c) = + Output.string (printf "%%%s" c) `mappend` newLine +outputOccurrence objects (Indirect (IndirectObjCoordinates {objectId, versionNumber})) = + saveOffset (ObjectId objectId) + >> Output.string (printf "%d %d obj" objectId versionNumber) + `nextLine` output (objects ! objectId) + `nextLine` "endobj" `mappend` newLine + +------------------------------------- +-- XREF TABLE +------------------------------------- + +-- +-- XRefEntry +-- +data XRefEntry = InUse { + offset :: Int64 + , generation :: Int + } | Free { + nextFree :: Int64 + , generation :: Int + } deriving Show + +instance Output XRefEntry where + output (InUse {offset, generation}) = + Output.string (printf "%010d %05d n " offset generation) `mappend` newLine + output (Free {nextFree, generation}) = + Output.string (printf "%010d %05d f " nextFree generation) `mappend` newLine + entry :: Parser u XRefEntry entry = do (big, small) <- (,) <$> integer <*> integer @@ -242,15 +272,83 @@ entry = do free :: Int64 -> Int -> Parser u XRefEntry free nextFree generation = char 'f' *> return (Free {nextFree, generation}) + +-- +-- XRefSubSection +-- +data XRefSubSection = XRefSubSection { + firstObjectId :: Int + , entriesNumber :: Int + , entries :: Map Int XRefEntry + } deriving Show + +instance Output XRefSubSection where + output (XRefSubSection {firstObjectId, entriesNumber, entries}) = + Output.string (printf "%d %d" firstObjectId entriesNumber) + `nextLine` output (Map.elems entries) + xrefSubSection :: Parser u XRefSubSection xrefSubSection = do (firstObjectId, entriesNumber) <- (,) <$> integer <*> integer entries <- Map.fromList . zip [firstObjectId..] <$> count entriesNumber entry return $ XRefSubSection {firstObjectId, entriesNumber, entries} -content :: Parser u Content -content = - Content 0 [] Map.empty +type XRefSection = [XRefSubSection] + +-- +-- Structure +-- +data Structure = Structure { + startOffset :: Int64 + , xrefSection :: XRefSection + , inputTrailer :: Dictionary + --, startXRef :: Int64 + } deriving Show + +structure :: Parser u Structure +structure = + Structure 0 <$> (line "xref" *> xrefSubSection `sepBy` EOL.parser) <*> (line "trailer" *> dictionary <* EOL.parser) - <*> (line "startxref" *> integer) + -- <*> (line "startxref" *> integer) + +xrefFromOffsets :: Map Offset Int64 -> (XRefSection, Int64) +xrefFromOffsets offsets = ( + [] + , offsets ! StartXRef + ) + +-- +-- Flow +-- +data Flow = Flow { + occurrencesStack :: [Occurrence] + , tmpObjects :: Map Int Object + } deriving Show + +-- +-- Content +-- +data Content = Content { + occurrences :: [Occurrence] + , objects :: Map Int Object + , trailer :: Dictionary + } deriving Show + +outputBody :: ([Occurrence], Map Int Object) -> OBuilder +outputBody (occurrences, objects) = + output (outputOccurrence objects <$> occurrences) <* saveOffset StartXRef + +instance Output Content where + output (Content {occurrences, objects, trailer}) = + fmap xrefFromOffsets <$> getOffsets (outputBody (occurrences, objects)) + >>= \(body, (xref, startXRef)) -> + body + `mappend` "xref" + `nextLine` "trailer" + --`nextLine` output xrefSection + --`mappend` "trailer" + `nextLine` output trailer + `nextLine` "startxref" + `nextLine` (Output.string (printf "%d" startXRef)) + `nextLine` byteString eofMarker diff --git a/src/PDF/Output.hs b/src/PDF/Output.hs index a4a3762..f310b89 100644 --- a/src/PDF/Output.hs +++ b/src/PDF/Output.hs @@ -1,42 +1,82 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module PDF.Output ( - OBuilder(..) + OBuilder + , OContext(..) + , Offset(..) , Output(..) , byteString , char + , getOffsets , join , lift , newLine , nextLine + , saveOffset , string , render ) where +--import Data.ByteString.Builder (Builder, char8, lazyByteString, string8) 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) -- #if MIN_VERSION_base(4,9,0) -- import qualified Data.Semigroup as Sem -- #endif import Data.String (IsString(..)) -import Control.Monad.Reader (MonadReader(..), Reader, runReader) +--import Control.Monad.Reader (MonadReader(..), Reader, runReader) +--import Control.Monad.Reader (MonadReader(..), Reader, runReader) +--import Control.Monad.Reader (MonadReader(..), Reader, runReader) +import Control.Monad.RWS (RWS, runRWS, ask, get, listen, modify, tell) import qualified PDF.EOL as EOL (Style(..)) -newtype OBuilder = OBuilder (Reader EOL.Style Builder) +data Offset = StartXRef | ObjectId Int deriving (Eq, Ord) + +{- +incrOffset :: (Int64 -> Int64) -> OutputState +-} + +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 = OBuilder $ return (f a) +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 (OBuilder a) (OBuilder b) = OBuilder (mappend <$> a <*> b) +append (OContext a) (OContext b) = OContext (mappend <$> a <*> b) -#if MIN_VERSION_base(4,9,0) +#if MIN_VERSION_base(4,11,0) instance Semigroup OBuilder where (<>) = append #endif instance Monoid OBuilder where - mempty = OBuilder (return mempty) -#if !(MIN_VERSION_base(4,9,0)) + mempty = OContext (return mempty) +#if !(MIN_VERSION_base(4,11,0)) mappend = append #endif @@ -63,25 +103,26 @@ join separator (a:as) = output a `mappend` string separator `mappend` (join separator as) newLine :: OBuilder -newLine = OBuilder $ buildEOL <$> ask +newLine = OContext $ buildEOL =<< ask where - buildEOL EOL.CR = char8 '\r' - buildEOL EOL.LF = char8 '\n' - buildEOL EOL.CRLF = string8 "\r\n" + 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 = lift char8 +char c = lift char8 c <* OContext (modify (+1)) string :: String -> OBuilder -string = lift string8 +string s = lift string8 s <* OContext (modify (+ toEnum (length s))) byteString :: ByteString -> OBuilder -byteString = lift lazyByteString +byteString bs = lift lazyByteString bs <* OContext (modify (+ BS.length bs)) render :: Output a => EOL.Style -> a -> ByteString render eolStyle a = - let OBuilder r = output a in - toLazyByteString $ runReader r eolStyle + let OContext builder = output a in + let (outputByteString, _, _) = runRWS builder eolStyle 0 in + toLazyByteString outputByteString