{-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns, RankNTypes #-}#if __GLASGOW_HASKELL__ == 700
-- This is needed as a workaround for an old bug in GHC 7.0.1 (Trac #4498){-# LANGUAGE MonoPatBinds #-}#endif
#if __GLASGOW_HASKELL__ >= 703
{-# LANGUAGE Unsafe #-}#endif
{-# OPTIONS_HADDOCK not-home #-}-- | Copyright : (c) 2010 - 2011 Simon Meier-- License : BSD3-style (see LICENSE)---- Maintainer : Simon Meier <iridcode@gmail.com>-- Stability : unstable, private-- Portability : GHC---- *Warning:* this module is internal. If you find that you need it then please-- contact the maintainers and explain what you are trying to do and discuss-- what you would need in the public API. It is important that you do this as-- the module may not be exposed at all in future releases.---- Core types and functions for the 'Builder' monoid and its generalization,-- the 'Put' monad.---- The design of the 'Builder' monoid is optimized such that---- 1. buffers of arbitrary size can be filled as efficiently as possible and---- 2. sequencing of 'Builder's is as cheap as possible.---- We achieve (1) by completely handing over control over writing to the buffer-- to the 'BuildStep' implementing the 'Builder'. This 'BuildStep' is just told-- the start and the end of the buffer (represented as a 'BufferRange'). Then,-- the 'BuildStep' can write to as big a prefix of this 'BufferRange' in any-- way it desires. If the 'BuildStep' is done, the 'BufferRange' is full, or a-- long sequence of bytes should be inserted directly, then the 'BuildStep'-- signals this to its caller using a 'BuildSignal'.---- We achieve (2) by requiring that every 'Builder' is implemented by a-- 'BuildStep' that takes a continuation 'BuildStep', which it calls with the-- updated 'BufferRange' after it is done. Therefore, only two pointers have-- to be passed in a function call to implement concatenation of 'Builder's.-- Moreover, many 'Builder's are completely inlined, which enables the compiler-- to sequence them without a function call and with no boxing at all.---- This design gives the implementation of a 'Builder' full access to the 'IO'-- monad. Therefore, utmost care has to be taken to not overwrite anything-- outside the given 'BufferRange's. Moreover, further care has to be taken to-- ensure that 'Builder's and 'Put's are referentially transparent. See the-- comments of the 'builder' and 'put' functions for further information.-- Note that there are /no safety belts/ at all, when implementing a 'Builder'-- using an 'IO' action: you are writing code that might enable the next-- buffer-overflow attack on a Haskell server!--moduleData.ByteString.Builder.Internal(-- * Buffer managementBuffer (..),BufferRange (..),newBuffer ,bufferSize ,byteStringFromBuffer ,ChunkIOStream (..),buildStepToCIOS ,ciosUnitToLazyByteString ,ciosToLazyByteString -- * Build signals and steps,BuildSignal ,BuildStep ,finalBuildStep ,done ,bufferFull ,insertChunk ,fillWithBuildStep -- * The Builder monoid,Builder ,builder ,runBuilder ,runBuilderWith -- ** Primitive combinators,empty ,append ,flush ,ensureFree -- , sizedChunksInsert,byteStringCopy ,byteStringInsert ,byteStringThreshold ,lazyByteStringCopy ,lazyByteStringInsert ,lazyByteStringThreshold ,shortByteString ,maximalCopySize ,byteString ,lazyByteString -- ** Execution,toLazyByteStringWith ,AllocationStrategy ,safeStrategy ,untrimmedStrategy ,customStrategy ,L.smallChunkSize ,L.defaultChunkSize ,L.chunkOverhead -- * The Put monad,Put ,put ,runPut -- ** Execution,putToLazyByteString ,putToLazyByteStringWith ,hPut -- ** Conversion to and from Builders,putBuilder ,fromPut -- -- ** Lifting IO actions-- , putLiftIO)whereimportControl.Arrow(second)#if !(MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0)
importData.Semigroup(Semigroup((<>)))#endif
#if !(MIN_VERSION_base(4,8,0))
importData.MonoidimportControl.Applicative(Applicative(..),(<$>))#endif
importqualifiedData.ByteString asSimportqualifiedData.ByteString.Internal asSimportqualifiedData.ByteString.Lazy.Internal asLimportqualifiedData.ByteString.Short.Internal asSh#if __GLASGOW_HASKELL__ >= 611
importqualifiedGHC.IO.BufferasIO(Buffer(..),newByteBuffer)importGHC.IO.Handle.Internals(wantWritableHandle,flushWriteBuffer)importGHC.IO.Handle.Types(Handle__,haByteBuffer,haBufferMode)importSystem.IO(hFlush,BufferMode(..))importData.IORef#else
importqualifiedData.ByteString.LazyasL#endif
importSystem.IO(Handle)#if MIN_VERSION_base(4,4,0)
#if MIN_VERSION_base(4,7,0)
importForeign#else
importForeignhiding(unsafeForeignPtrToPtr)#endif
importForeign.ForeignPtr.Unsafe(unsafeForeignPtrToPtr)importSystem.IO.Unsafe(unsafeDupablePerformIO)#else
importForeignimportGHC.IO(unsafeDupablePerformIO)#endif
-------------------------------------------------------------------------------- Buffers-------------------------------------------------------------------------------- | A range of bytes in a buffer represented by the pointer to the first byte-- of the range and the pointer to the first byte /after/ the range.dataBufferRange =BufferRange {-# UNPACK#-}!(PtrWord8)-- First byte of range{-# UNPACK#-}!(PtrWord8)-- First byte /after/ range-- | A 'Buffer' together with the 'BufferRange' of free bytes. The filled-- space starts at offset 0 and ends at the first free byte.dataBuffer =Buffer {-# UNPACK#-}!(ForeignPtrWord8){-# UNPACK#-}!BufferRange -- | Combined size of the filled and free space in the buffer.{-# INLINEbufferSize#-}bufferSize::Buffer ->IntbufferSize (Buffer fpbuf (BufferRange _ope ))=ope `minusPtr`unsafeForeignPtrToPtrfpbuf -- | Allocate a new buffer of the given size.{-# INLINEnewBuffer#-}newBuffer::Int->IOBuffer newBuffer size =dofpbuf <-S.mallocByteString size letpbuf =unsafeForeignPtrToPtrfpbuf return$!Buffer fpbuf (BufferRange pbuf (pbuf `plusPtr`size ))-- | Convert the filled part of a 'Buffer' to a strict 'S.ByteString'.{-# INLINEbyteStringFromBuffer#-}byteStringFromBuffer::Buffer ->S.ByteString byteStringFromBuffer (Buffer fpbuf (BufferRange op _))=S.PS fpbuf 0(op `minusPtr`unsafeForeignPtrToPtrfpbuf )-- | Prepend the filled part of a 'Buffer' to a lazy 'L.ByteString'-- trimming it if necessary.{-# INLINEtrimmedChunkFromBuffer#-}trimmedChunkFromBuffer::AllocationStrategy ->Buffer ->L.ByteString ->L.ByteString trimmedChunkFromBuffer (AllocationStrategy __trim )buf k |S.null bs =k |trim (S.length bs )(bufferSize buf )=L.Chunk (S.copy bs )k |otherwise=L.Chunk bs k wherebs =byteStringFromBuffer buf -------------------------------------------------------------------------------- Chunked IO Stream-------------------------------------------------------------------------------- | A stream of chunks that are constructed in the 'IO' monad.---- This datatype serves as the common interface for the buffer-by-buffer-- execution of a 'BuildStep' by 'buildStepToCIOS'. Typical users of this-- interface are 'ciosToLazyByteString' or iteratee-style libraries like-- @enumerator@.dataChunkIOStream a =Finished Buffer a -- ^ The partially filled last buffer together with the result.|Yield1 S.ByteString (IO(ChunkIOStream a ))-- ^ Yield a /non-empty/ strict 'S.ByteString'.-- | A smart constructor for yielding one chunk that ignores the chunk if-- it is empty.{-# INLINEyield1#-}yield1::S.ByteString ->IO(ChunkIOStream a )->IO(ChunkIOStream a )yield1 bs cios |S.null bs =cios |otherwise=return$Yield1 bs cios -- | Convert a @'ChunkIOStream' ()@ to a lazy 'L.ByteString' using-- 'unsafeDupablePerformIO'.{-# INLINEciosUnitToLazyByteString#-}ciosUnitToLazyByteString::AllocationStrategy ->L.ByteString ->ChunkIOStream ()->L.ByteString ciosUnitToLazyByteString strategy k =go wherego (Finished buf _)=trimmedChunkFromBuffer strategy buf k go(Yield1 bs io )=L.Chunk bs $unsafeDupablePerformIO(go <$>io )-- | Convert a 'ChunkIOStream' to a lazy tuple of the result and the written-- 'L.ByteString' using 'unsafeDupablePerformIO'.{-# INLINEciosToLazyByteString#-}ciosToLazyByteString::AllocationStrategy ->(a ->(b ,L.ByteString ))->ChunkIOStream a ->(b ,L.ByteString )ciosToLazyByteString strategy k =go wherego (Finished buf x )=second(trimmedChunkFromBuffer strategy buf )$k x go(Yield1 bs io )=second(L.Chunk bs )$unsafeDupablePerformIO(go <$>io )-------------------------------------------------------------------------------- Build signals-------------------------------------------------------------------------------- | 'BuildStep's may be called *multiple times* and they must not rise an-- async. exception.typeBuildStep a =BufferRange ->IO(BuildSignal a )-- | 'BuildSignal's abstract signals to the caller of a 'BuildStep'. There are-- three signals: 'done', 'bufferFull', or 'insertChunks signalsdataBuildSignal a =Done {-# UNPACK#-}!(PtrWord8)a |BufferFull {-# UNPACK#-}!Int{-# UNPACK#-}!(PtrWord8)(BuildStep a )|InsertChunk {-# UNPACK#-}!(PtrWord8)S.ByteString (BuildStep a )-- | Signal that the current 'BuildStep' is done and has computed a value.{-# INLINEdone#-}done::PtrWord8-- ^ Next free byte in current 'BufferRange'->a -- ^ Computed value->BuildSignal a done =Done -- | Signal that the current buffer is full.{-# INLINEbufferFull#-}bufferFull::Int-- ^ Minimal size of next 'BufferRange'.->PtrWord8-- ^ Next free byte in current 'BufferRange'.->BuildStep a -- ^ 'BuildStep' to run on the next 'BufferRange'. This 'BuildStep'-- may assume that it is called with a 'BufferRange' of at least the-- required minimal size; i.e., the caller of this 'BuildStep' must-- guarantee this.->BuildSignal a bufferFull =BufferFull -- | Signal that a 'S.ByteString' chunk should be inserted directly.{-# INLINEinsertChunk#-}insertChunk::PtrWord8-- ^ Next free byte in current 'BufferRange'->S.ByteString -- ^ Chunk to insert.->BuildStep a -- ^ 'BuildStep' to run on next 'BufferRange'->BuildSignal a insertChunk op bs =InsertChunk op bs -- | Fill a 'BufferRange' using a 'BuildStep'.{-# INLINEfillWithBuildStep#-}fillWithBuildStep::BuildStep a -- ^ Build step to use for filling the 'BufferRange'.->(PtrWord8->a ->IOb )-- ^ Handling the 'done' signal->(PtrWord8->Int->BuildStep a ->IOb )-- ^ Handling the 'bufferFull' signal->(PtrWord8->S.ByteString ->BuildStep a ->IOb )-- ^ Handling the 'insertChunk' signal->BufferRange -- ^ Buffer range to fill.->IOb -- ^ Value computed while filling this 'BufferRange'.fillWithBuildStep step fDone fFull fChunk !br =dosignal <-step br casesignal ofDone op x ->fDone op x BufferFull minSize op nextStep ->fFull op minSize nextStep InsertChunk op bs nextStep ->fChunk op bs nextStep -------------------------------------------------------------------------------- The 'Builder' monoid-------------------------------------------------------------------------------- | 'Builder's denote sequences of bytes.-- They are 'Monoid's where-- 'mempty' is the zero-length sequence and-- 'mappend' is concatenation, which runs in /O(1)/.newtypeBuilder =Builder (forallr .BuildStep r ->BuildStep r )-- | Construct a 'Builder'. In contrast to 'BuildStep's, 'Builder's are-- referentially transparent.{-# INLINEbuilder#-}builder::(forallr .BuildStep r ->BuildStep r )-- ^ A function that fills a 'BufferRange', calls the continuation with-- the updated 'BufferRange' once its done, and signals its caller how-- to proceed using 'done', 'bufferFull', or 'insertChunk'.---- This function must be referentially transparent; i.e., calling it-- multiple times with equally sized 'BufferRange's must result in the-- same sequence of bytes being written. If you need mutable state,-- then you must allocate it anew upon each call of this function.-- Moroever, this function must call the continuation once its done.-- Otherwise, concatenation of 'Builder's does not work. Finally, this-- function must write to all bytes that it claims it has written.-- Otherwise, the resulting 'Builder' is not guaranteed to be-- referentially transparent and sensitive data might leak.->Builder builder =Builder -- | The final build step that returns the 'done' signal.finalBuildStep::BuildStep ()finalBuildStep !(BufferRange op _)=return$Done op ()-- | Run a 'Builder' with the 'finalBuildStep'.{-# INLINErunBuilder#-}runBuilder::Builder -- ^ 'Builder' to run->BuildStep ()-- ^ 'BuildStep' that writes the byte stream of this-- 'Builder' and signals 'done' upon completion.runBuilder b =runBuilderWith b finalBuildStep -- | Run a 'Builder'.{-# INLINErunBuilderWith#-}runBuilderWith::Builder -- ^ 'Builder' to run->BuildStep a -- ^ Continuation 'BuildStep'->BuildStep a runBuilderWith (Builder b )=b -- | The 'Builder' denoting a zero-length sequence of bytes. This function is-- only exported for use in rewriting rules. Use 'mempty' otherwise.{-# INLINE[1]empty#-}empty::Builder empty =Builder (\cont ->(\range ->cont range ))-- This eta expansion (hopefully) allows GHC to worker-wrapper the-- 'BufferRange' in the 'empty' base case of loops (since-- worker-wrapper requires (TODO: verify this) that all paths match-- against the wrapped argument.-- | Concatenate two 'Builder's. This function is only exported for use in rewriting-- rules. Use 'mappend' otherwise.{-# INLINE[1]append#-}append::Builder ->Builder ->Builder append (Builder b1 )(Builder b2 )=Builder $b1 .b2 #if MIN_VERSION_base(4,9,0)
instanceSemigroupBuilder where{-# INLINE(<>)#-}(<> )=append #endif
instanceMonoidBuilder where{-# INLINEmempty#-}mempty =empty {-# INLINEmappend#-}#if MIN_VERSION_base(4,9,0)
mappend =(<>)#else
mappend=append#endif
{-# INLINEmconcat#-}mconcat =foldrmappendmempty-- | Flush the current buffer. This introduces a chunk boundary.{-# INLINEflush#-}flush::Builder flush =builder step wherestep k !(BufferRange op _)=return$insertChunk op S.empty k -------------------------------------------------------------------------------- Put-------------------------------------------------------------------------------- | A 'Put' action denotes a computation of a value that writes a stream of-- bytes as a side-effect. 'Put's are strict in their side-effect; i.e., the-- stream of bytes will always be written before the computed value is-- returned.---- 'Put's are a generalization of 'Builder's. The typical use case is the-- implementation of an encoding that might fail (e.g., an interface to the-- 'zlib' compression library or the conversion from Base64 encoded data to-- 8-bit data). For a 'Builder', the only way to handle and report such a-- failure is ignore it or call 'error'. In contrast, 'Put' actions are-- expressive enough to allow reportng and handling such a failure in a pure-- fashion.---- @'Put' ()@ actions are isomorphic to 'Builder's. The functions 'putBuilder'-- and 'fromPut' convert between these two types. Where possible, you should-- use 'Builder's, as sequencing them is slightly cheaper than sequencing-- 'Put's because they do not carry around a computed value.newtypePut a =Put {unPut ::forallr .(a ->BuildStep r )->BuildStep r }-- | Construct a 'Put' action. In contrast to 'BuildStep's, 'Put's are-- referentially transparent in the sense that sequencing the same 'Put'-- multiple times yields every time the same value with the same side-effect.{-# INLINEput#-}put::(forallr .(a ->BuildStep r )->BuildStep r )-- ^ A function that fills a 'BufferRange', calls the continuation with-- the updated 'BufferRange' and its computed value once its done, and-- signals its caller how to proceed using 'done', 'bufferFull', or-- 'insertChunk' signals.---- This function must be referentially transparent; i.e., calling it-- multiple times with equally sized 'BufferRange's must result in the-- same sequence of bytes being written and the same value being-- computed. If you need mutable state, then you must allocate it anew-- upon each call of this function. Moroever, this function must call-- the continuation once its done. Otherwise, monadic sequencing of-- 'Put's does not work. Finally, this function must write to all bytes-- that it claims it has written. Otherwise, the resulting 'Put' is-- not guaranteed to be referentially transparent and sensitive data-- might leak.->Put a put =Put -- | Run a 'Put'.{-# INLINErunPut#-}runPut::Put a -- ^ Put to run->BuildStep a -- ^ 'BuildStep' that first writes the byte stream of-- this 'Put' and then yields the computed value using-- the 'done' signal.runPut (Put p )=p $\x (BufferRange op _)->return$Done op x instanceFunctorPut wherefmap f p =Put $\k ->unPutp (\x ->k (f x )){-# INLINEfmap#-}-- | Synonym for '<*' from 'Applicative'; used in rewriting rules.{-# INLINE[1]ap_l#-}ap_l::Put a ->Put b ->Put a ap_l (Put a )(Put b )=Put $\k ->a (\a' ->b (\_->k a' ))-- | Synonym for '*>' from 'Applicative' and '>>' from 'Monad'; used in-- rewriting rules.{-# INLINE[1]ap_r#-}ap_r::Put a ->Put b ->Put b ap_r (Put a )(Put b )=Put $\k ->a (\_->b k )instanceApplicativePut where{-# INLINEpure#-}pure x =Put $\k ->k x {-# INLINE(<*>)#-}Put f <*> Put a =Put $\k ->f (\f' ->a (\a' ->k (f' a' ))){-# INLINE(<*)#-}(<* )=ap_l {-# INLINE(*>)#-}(*> )=ap_r instanceMonadPut where{-# INLINEreturn#-}return =pure{-# INLINE(>>=)#-}Put m >>= f =Put $\k ->m (\m' ->unPut(f m' )k ){-# INLINE(>>)#-}(>> )=(*>)-- Conversion between Put and Builder--------------------------------------- | Run a 'Builder' as a side-effect of a @'Put' ()@ action.{-# INLINE[1]putBuilder#-}putBuilder::Builder ->Put ()putBuilder (Builder b )=Put $\k ->b (k ())-- | Convert a @'Put' ()@ action to a 'Builder'.{-# INLINEfromPut#-}fromPut::Put ()->Builder fromPut (Put p )=Builder $\k ->p (\_->k )-- We rewrite consecutive uses of 'putBuilder' such that the append of the-- involved 'Builder's is used. This can significantly improve performance,-- when the bound-checks of the concatenated builders are fused.-- ap_l rules{-# RULES"ap_l/putBuilder"forallb1b2.ap_l(putBuilderb1)(putBuilderb2)=putBuilder(appendb1b2)"ap_l/putBuilder/assoc_r"forallb1b2(p::Puta).ap_l(putBuilderb1)(ap_l(putBuilderb2)p)=ap_l(putBuilder(appendb1b2))p"ap_l/putBuilder/assoc_l"forall(p::Puta)b1b2.ap_l(ap_lp(putBuilderb1))(putBuilderb2)=ap_lp(putBuilder(appendb1b2))#-}-- ap_r rules{-# RULES"ap_r/putBuilder"forallb1b2.ap_r(putBuilderb1)(putBuilderb2)=putBuilder(appendb1b2)"ap_r/putBuilder/assoc_r"forallb1b2(p::Puta).ap_r(putBuilderb1)(ap_r(putBuilderb2)p)=ap_r(putBuilder(appendb1b2))p"ap_r/putBuilder/assoc_l"forall(p::Puta)b1b2.ap_r(ap_rp(putBuilderb1))(putBuilderb2)=ap_rp(putBuilder(appendb1b2))#-}-- combined ap_l/ap_r rules{-# RULES"ap_l/ap_r/putBuilder/assoc_r"forallb1b2(p::Puta).ap_l(putBuilderb1)(ap_r(putBuilderb2)p)=ap_l(putBuilder(appendb1b2))p"ap_r/ap_l/putBuilder/assoc_r"forallb1b2(p::Puta).ap_r(putBuilderb1)(ap_l(putBuilderb2)p)=ap_l(putBuilder(appendb1b2))p"ap_l/ap_r/putBuilder/assoc_l"forall(p::Puta)b1b2.ap_l(ap_rp(putBuilderb1))(putBuilderb2)=ap_rp(putBuilder(appendb1b2))"ap_r/ap_l/putBuilder/assoc_l"forall(p::Puta)b1b2.ap_r(ap_lp(putBuilderb1))(putBuilderb2)=ap_rp(putBuilder(appendb1b2))#-}-- Lifting IO actions---------------------{-
-- | Lift an 'IO' action to a 'Put' action.
{-# INLINE putLiftIO #-}
putLiftIO :: IO a -> Put a
putLiftIO io = put $ \k br -> io >>= (`k` br)
-}-------------------------------------------------------------------------------- Executing a Put directly on a buffered Handle-------------------------------------------------------------------------------- | Run a 'Put' action redirecting the produced output to a 'Handle'.---- The output is buffered using the 'Handle's associated buffer. If this-- buffer is too small to execute one step of the 'Put' action, then-- it is replaced with a large enough buffer.hPut::foralla .Handle->Put a ->IOa #if __GLASGOW_HASKELL__ >= 611
hPut h p =dofillHandle 1(runPut p )wherefillHandle::Int->BuildStep a ->IOa fillHandle !minFree step =donext <-wantWritableHandle"hPut"h fillHandle_ next where-- | We need to return an inner IO action that is executed outside-- the lock taken on the Handle for two reasons:---- 1. GHC.IO.Handle.Internals mentions in "Note [async]" that-- we should never do any side-effecting operations before-- an interuptible operation that may raise an async. exception-- as long as we are inside 'wantWritableHandle' and the like.-- We possibly run the interuptible 'flushWriteBuffer' right at-- the start of 'fillHandle', hence entering it a second time is-- not safe, as it could lead to a 'BuildStep' being run twice.---- FIXME (SM): Adapt this function or at least its documentation,-- as it is OK to run a 'BuildStep' twice. We dropped this-- requirement in favor of being able to use-- 'unsafeDupablePerformIO' and the speed improvement that it-- brings.---- 2. We use the 'S.hPut' function to also write to the handle.-- This function tries to take the same lock taken by-- 'wantWritableHandle'. Therefore, we cannot call 'S.hPut'-- inside 'wantWritableHandle'.--fillHandle_::Handle__->IO(IOa )fillHandle_ h_ =domakeSpace =<<readIORefrefBuf fillBuffer =<<readIORefrefBuf whererefBuf =haByteBufferh_ freeSpace buf =IO.bufSizebuf -IO.bufRbuf makeSpace buf |IO.bufSizebuf <minFree =doflushWriteBufferh_ s <-IO.bufState<$>readIORefrefBuf IO.newByteBufferminFree s >>=writeIORefrefBuf |freeSpace buf <minFree =flushWriteBufferh_ |otherwise=#if __GLASGOW_HASKELL__ >= 613
return()#else
-- required for ghc-6.12flushWriteBufferh_#endif
fillBuffer buf |freeSpace buf <minFree =error$unlines["Data.ByteString.Builder.Internal.hPut: internal error."," Not enough space after flush."," required: "++showminFree ," free: "++show(freeSpace buf )]|otherwise=dolet!br =BufferRange op (pBuf `plusPtr`IO.bufSizebuf )res <-fillWithBuildStep step doneH fullH insertChunkH br touchForeignPtrfpBuf returnres wherefpBuf =IO.bufRawbuf pBuf =unsafeForeignPtrToPtrfpBuf op =pBuf `plusPtr`IO.bufRbuf {-# INLINEupdateBufR#-}updateBufR op' =dolet!off' =op' `minusPtr`pBuf !buf' =buf {IO.bufR=off' }writeIORefrefBuf buf' doneH op' x =doupdateBufR op' -- We must flush if this Handle is set to NoBuffering.-- If it is set to LineBuffering, be conservative and-- flush anyway (we didn't check for newlines in the data).-- Flushing must happen outside this 'wantWriteableHandle'-- due to the possible async. exception.casehaBufferModeh_ ofBlockBuffering_->return$returnx _line_or_no_buffering ->return$hFlushh >>returnx fullH op' minSize nextStep =doupdateBufR op' return$fillHandle minSize nextStep -- 'fillHandle' will flush the buffer (provided there is-- really less than 'minSize' space left) before executing-- the 'nextStep'.insertChunkH op' bs nextStep =doupdateBufR op' return$doS.hPut h bs fillHandle 1nextStep #else
hPuthp=go=<<buildStepToCIOSstrategy(runPutp)wherestrategy=untrimmedStrategyL.smallChunkSizeL.defaultChunkSizego(Finishedbufx)=S.hPuth(byteStringFromBufferbuf)>>returnxgo(Yield1bsio)=S.hPuthbs>>io>>=go#endif
-- | Execute a 'Put' and return the computed result and the bytes-- written during the computation as a lazy 'L.ByteString'.---- This function is strict in the computed result and lazy in the writing of-- the bytes. For example, given---- @--infinitePut = sequence_ (repeat (putBuilder (word8 1))) >> return 0-- @---- evaluating the expression---- @--fst $ putToLazyByteString infinitePut-- @---- does not terminate, while evaluating the expression---- @--L.head $ snd $ putToLazyByteString infinitePut-- @---- does terminate and yields the value @1 :: Word8@.---- An illustrative example for these strictness properties is the-- implementation of Base64 decoding (<http://en.wikipedia.org/wiki/Base64>).---- @--type DecodingState = ...----decodeBase64 :: 'S.ByteString' -> DecodingState -> 'Put' (Maybe DecodingState)--decodeBase64 = ...-- @---- The above function takes a strict 'S.ByteString' supposed to represent-- Base64 encoded data and the current decoding state.-- It writes the decoded bytes as the side-effect of the 'Put' and returns the-- new decoding state, if the decoding of all data in the 'S.ByteString' was-- successful. The checking if the strict 'S.ByteString' represents Base64-- encoded data and the actual decoding are fused. This makes the common case,-- where all data represents Base64 encoded data, more efficient. It also-- implies that all data must be decoded before the final decoding-- state can be returned. 'Put's are intended for implementing such fused-- checking and decoding/encoding, which is reflected in their strictness-- properties.{-# NOINLINEputToLazyByteString#-}putToLazyByteString::Put a -- ^ 'Put' to execute->(a ,L.ByteString )-- ^ Result and lazy 'L.ByteString'-- written as its side-effectputToLazyByteString =putToLazyByteStringWith (safeStrategy L.smallChunkSize L.defaultChunkSize )(\x ->(x ,L.Empty ))-- | Execute a 'Put' with a buffer-allocation strategy and a continuation. For-- example, 'putToLazyByteString' is implemented as follows.---- @--putToLazyByteString = 'putToLazyByteStringWith'-- ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') (\x -> (x, L.empty))-- @--{-# INLINEputToLazyByteStringWith#-}putToLazyByteStringWith::AllocationStrategy -- ^ Buffer allocation strategy to use->(a ->(b ,L.ByteString ))-- ^ Continuation to use for computing the final result and the tail of-- its side-effect (the written bytes).->Put a -- ^ 'Put' to execute->(b ,L.ByteString )-- ^ Resulting lazy 'L.ByteString'putToLazyByteStringWith strategy k p =ciosToLazyByteString strategy k $unsafeDupablePerformIO$buildStepToCIOS strategy (runPut p )-------------------------------------------------------------------------------- ByteString insertion / controlling chunk boundaries-------------------------------------------------------------------------------- Raw memory--------------- | Ensure that there are at least 'n' free bytes for the following 'Builder'.{-# INLINEensureFree#-}ensureFree::Int->Builder ensureFree minFree =builder step wherestep k br @(BufferRange op ope )|ope `minusPtr`op <minFree =return$bufferFull minFree op k |otherwise=k br -- | Copy the bytes from a 'BufferRange' into the output stream.wrappedBytesCopyStep::BufferRange -- ^ Input 'BufferRange'.->BuildStep a ->BuildStep a wrappedBytesCopyStep !(BufferRange ip0 ipe )k =go ip0 wherego !ip !(BufferRange op ope )|inpRemaining <=outRemaining =docopyBytesop ip inpRemaining let!br' =BufferRange (op `plusPtr`inpRemaining )ope k br' |otherwise=docopyBytesop ip outRemaining let!ip' =ip `plusPtr`outRemaining return$bufferFull 1ope (go ip' )whereoutRemaining =ope `minusPtr`op inpRemaining =ipe `minusPtr`ip -- Strict ByteStrings-------------------------------------------------------------------------------- | Construct a 'Builder' that copies the strict 'S.ByteString's, if it is-- smaller than the treshold, and inserts it directly otherwise.---- For example, @byteStringThreshold 1024@ copies strict 'S.ByteString's whose size-- is less or equal to 1kb, and inserts them directly otherwise. This implies-- that the average chunk-size of the generated lazy 'L.ByteString' may be as-- low as 513 bytes, as there could always be just a single byte between the-- directly inserted 1025 byte, strict 'S.ByteString's.--{-# INLINEbyteStringThreshold#-}byteStringThreshold::Int->S.ByteString ->Builder byteStringThreshold maxCopySize =\bs ->builder $step bs wherestep !bs @(S.PS __len )!k br @(BufferRange !op _)|len <=maxCopySize =byteStringCopyStep bs k br |otherwise=return$insertChunk op bs k -- | Construct a 'Builder' that copies the strict 'S.ByteString'.---- Use this function to create 'Builder's from smallish (@<= 4kb@)-- 'S.ByteString's or if you need to guarantee that the 'S.ByteString' is not-- shared with the chunks generated by the 'Builder'.--{-# INLINEbyteStringCopy#-}byteStringCopy::S.ByteString ->Builder byteStringCopy =\bs ->builder $byteStringCopyStep bs {-# INLINEbyteStringCopyStep#-}byteStringCopyStep::S.ByteString ->BuildStep a ->BuildStep a byteStringCopyStep (S.PS ifp ioff isize )!k0 br0 @(BufferRange op ope )-- Ensure that the common case is not recursive and therefore yields-- better code.|op' <=ope =docopyBytesop ip isize touchForeignPtrifp k0 (BufferRange op' ope )|otherwise=dowrappedBytesCopyStep (BufferRange ip ipe )k br0 whereop' =op `plusPtr`isize ip =unsafeForeignPtrToPtrifp `plusPtr`ioff ipe =ip `plusPtr`isize k br =dotouchForeignPtrifp -- input consumed: OK to release herek0 br -- | Construct a 'Builder' that always inserts the strict 'S.ByteString'-- directly as a chunk.---- This implies flushing the output buffer, even if it contains just-- a single byte. You should therefore use 'byteStringInsert' only for large-- (@> 8kb@) 'S.ByteString's. Otherwise, the generated chunks are too-- fragmented to be processed efficiently afterwards.--{-# INLINEbyteStringInsert#-}byteStringInsert::S.ByteString ->Builder byteStringInsert =\bs ->builder $\k (BufferRange op _)->return$insertChunk op bs k -- Short bytestrings-------------------------------------------------------------------------------- | Construct a 'Builder' that copies the 'SH.ShortByteString'.--{-# INLINEshortByteString#-}shortByteString::Sh.ShortByteString ->Builder shortByteString =\sbs ->builder $shortByteStringCopyStep sbs -- | Copy the bytes from a 'SH.ShortByteString' into the output stream.{-# INLINEshortByteStringCopyStep#-}shortByteStringCopyStep::Sh.ShortByteString -- ^ Input 'SH.ShortByteString'.->BuildStep a ->BuildStep a shortByteStringCopyStep !sbs k =go 0(Sh.length sbs )wherego !ip !ipe !(BufferRange op ope )|inpRemaining <=outRemaining =doSh.copyToPtr sbs ip op inpRemaining let!br' =BufferRange (op `plusPtr`inpRemaining )ope k br' |otherwise=doSh.copyToPtr sbs ip op outRemaining let!ip' =ip +outRemaining return$bufferFull 1ope (go ip' ipe )whereoutRemaining =ope `minusPtr`op inpRemaining =ipe -ip -- Lazy bytestrings-------------------------------------------------------------------------------- | Construct a 'Builder' that uses the thresholding strategy of 'byteStringThreshold'-- for each chunk of the lazy 'L.ByteString'.--{-# INLINElazyByteStringThreshold#-}lazyByteStringThreshold::Int->L.ByteString ->Builder lazyByteStringThreshold maxCopySize =L.foldrChunks (\bs b ->byteStringThreshold maxCopySize bs `mappend`b )mempty-- TODO: We could do better here. Currently, Large, Small, Large, leads to-- an unnecessary copy of the 'Small' chunk.-- | Construct a 'Builder' that copies the lazy 'L.ByteString'.--{-# INLINElazyByteStringCopy#-}lazyByteStringCopy::L.ByteString ->Builder lazyByteStringCopy =L.foldrChunks (\bs b ->byteStringCopy bs `mappend`b )mempty-- | Construct a 'Builder' that inserts all chunks of the lazy 'L.ByteString'-- directly.--{-# INLINElazyByteStringInsert#-}lazyByteStringInsert::L.ByteString ->Builder lazyByteStringInsert =L.foldrChunks (\bs b ->byteStringInsert bs `mappend`b )mempty-- | Create a 'Builder' denoting the same sequence of bytes as a strict-- 'S.ByteString'.-- The 'Builder' inserts large 'S.ByteString's directly, but copies small ones-- to ensure that the generated chunks are large on average.--{-# INLINEbyteString#-}byteString::S.ByteString ->Builder byteString =byteStringThreshold maximalCopySize -- | Create a 'Builder' denoting the same sequence of bytes as a lazy-- 'L.ByteString'.-- The 'Builder' inserts large chunks of the lazy 'L.ByteString' directly,-- but copies small ones to ensure that the generated chunks are large on-- average.--{-# INLINElazyByteString#-}lazyByteString::L.ByteString ->Builder lazyByteString =lazyByteStringThreshold maximalCopySize -- FIXME: also insert the small chunk for [large,small,large] directly.-- Perhaps it makes even sense to concatenate the small chunks in-- [large,small,small,small,large] and insert them directly afterwards to avoid-- unnecessary buffer spilling. Hmm, but that uncontrollably increases latency-- => no good!-- | The maximal size of a 'S.ByteString' that is copied.-- @2 * 'L.smallChunkSize'@ to guarantee that on average a chunk is of-- 'L.smallChunkSize'.maximalCopySize::IntmaximalCopySize =2*L.smallChunkSize -------------------------------------------------------------------------------- Builder execution-------------------------------------------------------------------------------- | A buffer allocation strategy for executing 'Builder's.-- The strategy---- > 'AllocationStrategy' firstBufSize bufSize trim---- states that the first buffer is of size @firstBufSize@, all following buffers-- are of size @bufSize@, and a buffer of size @n@ filled with @k@ bytes should-- be trimmed iff @trim k n@ is 'True'.dataAllocationStrategy =AllocationStrategy (Maybe(Buffer ,Int)->IOBuffer ){-# UNPACK#-}!Int(Int->Int->Bool)-- | Create a custom allocation strategy. See the code for 'safeStrategy' and-- 'untrimmedStrategy' for examples.{-# INLINEcustomStrategy#-}customStrategy::(Maybe(Buffer ,Int)->IOBuffer )-- ^ Buffer allocation function. If 'Nothing' is given, then a new first-- buffer should be allocated. If @'Just' (oldBuf, minSize)@ is given,-- then a buffer with minimal size 'minSize' must be returned. The-- strategy may reuse the 'oldBuffer', if it can guarantee that this-- referentially transparent and 'oldBuffer' is large enough.->Int-- ^ Default buffer size.->(Int->Int->Bool)-- ^ A predicate @trim used allocated@ returning 'True', if the buffer-- should be trimmed before it is returned.->AllocationStrategy customStrategy =AllocationStrategy -- | Sanitize a buffer size; i.e., make it at least the size of an 'Int'.{-# INLINEsanitize#-}sanitize::Int->Intsanitize =max(sizeOf(undefined::Int))-- | Use this strategy for generating lazy 'L.ByteString's whose chunks are-- discarded right after they are generated. For example, if you just generate-- them to write them to a network socket.{-# INLINEuntrimmedStrategy#-}untrimmedStrategy::Int-- ^ Size of the first buffer->Int-- ^ Size of successive buffers->AllocationStrategy -- ^ An allocation strategy that does not trim any of the-- filled buffers before converting it to a chunkuntrimmedStrategy firstSize bufSize =AllocationStrategy nextBuffer (sanitize bufSize )(\__->False)where{-# INLINEnextBuffer#-}nextBuffer Nothing=newBuffer $sanitize firstSize nextBuffer(Just(_,minSize ))=newBuffer minSize -- | Use this strategy for generating lazy 'L.ByteString's whose chunks are-- likely to survive one garbage collection. This strategy trims buffers-- that are filled less than half in order to avoid spilling too much memory.{-# INLINEsafeStrategy#-}safeStrategy::Int-- ^ Size of first buffer->Int-- ^ Size of successive buffers->AllocationStrategy -- ^ An allocation strategy that guarantees that at least half-- of the allocated memory is used for live datasafeStrategy firstSize bufSize =AllocationStrategy nextBuffer (sanitize bufSize )trim wheretrim used size =2*used <size {-# INLINEnextBuffer#-}nextBuffer Nothing=newBuffer $sanitize firstSize nextBuffer(Just(_,minSize ))=newBuffer minSize -- | /Heavy inlining./ Execute a 'Builder' with custom execution parameters.---- This function is inlined despite its heavy code-size to allow fusing with-- the allocation strategy. For example, the default 'Builder' execution-- function 'toLazyByteString' is defined as follows.---- @-- {-\# NOINLINE toLazyByteString \#-}-- toLazyByteString =-- toLazyByteStringWith ('safeStrategy' 'L.smallChunkSize' 'L.defaultChunkSize') L.empty-- @---- where @L.empty@ is the zero-length lazy 'L.ByteString'.---- In most cases, the parameters used by 'toLazyByteString' give good-- performance. A sub-performing case of 'toLazyByteString' is executing short-- (<128 bytes) 'Builder's. In this case, the allocation overhead for the first-- 4kb buffer and the trimming cost dominate the cost of executing the-- 'Builder'. You can avoid this problem using---- >toLazyByteStringWith (safeStrategy 128 smallChunkSize) L.empty---- This reduces the allocation and trimming overhead, as all generated-- 'L.ByteString's fit into the first buffer and there is no trimming-- required, if more than 64 bytes and less than 128 bytes are written.--{-# INLINEtoLazyByteStringWith#-}toLazyByteStringWith::AllocationStrategy -- ^ Buffer allocation strategy to use->L.ByteString -- ^ Lazy 'L.ByteString' to use as the tail of the generated lazy-- 'L.ByteString'->Builder -- ^ 'Builder' to execute->L.ByteString -- ^ Resulting lazy 'L.ByteString'toLazyByteStringWith strategy k b =ciosUnitToLazyByteString strategy k $unsafeDupablePerformIO$buildStepToCIOS strategy (runBuilder b )-- | Convert a 'BuildStep' to a 'ChunkIOStream' stream by executing it on-- 'Buffer's allocated according to the given 'AllocationStrategy'.{-# INLINEbuildStepToCIOS#-}buildStepToCIOS::AllocationStrategy -- ^ Buffer allocation strategy to use->BuildStep a -- ^ 'BuildStep' to execute->IO(ChunkIOStream a )buildStepToCIOS !(AllocationStrategy nextBuffer bufSize trim )=\step ->nextBuffer Nothing>>=fill step wherefill !step !buf @(Buffer fpbuf br @(BufferRange _pe ))=dores <-fillWithBuildStep step doneH fullH insertChunkH br touchForeignPtrfpbuf returnres wherepbuf =unsafeForeignPtrToPtrfpbuf doneH op' x =return$Finished (Buffer fpbuf (BufferRange op' pe ))x fullH op' minSize nextStep =wrapChunk op' $const$nextBuffer (Just(buf ,maxminSize bufSize ))>>=fill nextStep insertChunkH op' bs nextStep =wrapChunk op' $\isEmpty ->yield1 bs $-- Checking for empty case avoids allocating 'n-1' empty-- buffers for 'n' insertChunkH right after each other.ifisEmpty thenfill nextStep buf elsedobuf' <-nextBuffer (Just(buf ,bufSize ))fill nextStep buf' -- Wrap and yield a chunk, trimming it if necesary{-# INLINEwrapChunk#-}wrapChunk !op' mkCIOS |chunkSize ==0=mkCIOS True|trim chunkSize size =dobs <-S.create chunkSize $\pbuf' ->copyBytespbuf' pbuf chunkSize -- FIXME: We could reuse the trimmed buffer here.return$Yield1 bs (mkCIOS False)|otherwise=return$Yield1 (S.PS fpbuf 0chunkSize )(mkCIOS False)wherechunkSize =op' `minusPtr`pbuf size =pe `minusPtr`pbuf