packages feed

fast-builder (empty) → 0.0.0.0

raw patch · 13 files changed

+1492/−0 lines, 13 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, bytestring, criterion, deepseq, fast-builder, ghc-prim, process, scientific, stm, template-haskell, text, true-name, unordered-containers, vector

Files

+ Data/ByteString/FastBuilder.hs view
@@ -0,0 +1,129 @@+-- | An efficient implementation of ByteString builder.+--+-- In many cases, this module works as a drop-in replacement for+-- Data.ByteString.Builder, and should improve speed. However, one caveat+-- applies: when using 'toLazyByteString', if you consume the result+-- in a bound thread, performance degrades significantly. See the+-- documentation for 'toLazyByteString' for details.+--+-- Sometimes performance can be greatly improved by inserting calls to+-- 'rebuild' to your program. See the documentation for 'rebuild' for+-- details.+module Data.ByteString.FastBuilder+  (+  -- * The type++  Builder++  -- * Running a builder+  , toLazyByteString+  , toLazyByteStringWith+  , toStrictByteString+  , hPutBuilder++  -- * Performance tuning+  , rebuild++  -- * Basic builders+  , primBounded+  , primFixed+  , byteString+  , byteStringInsert+  , byteStringCopy+  , byteStringThreshold++  -- * Single byte+  , int8+  , word8++  -- * Little endian+  , int16LE+  , int32LE+  , int64LE++  , word16LE+  , word32LE+  , word64LE++  , floatLE+  , doubleLE++  -- * Big endian+  , int16BE+  , int32BE+  , int64BE++  , word16BE+  , word32BE+  , word64BE++  , floatBE+  , doubleBE++  -- * Host-dependent size and byte order, non-portable+  , intHost+  , int16Host+  , int32Host+  , int64Host++  , wordHost+  , word16Host+  , word32Host+  , word64Host++  , floatHost+  , doubleHost++  -- * Decimal+  , intDec+  , int8Dec+  , int16Dec+  , int32Dec+  , int64Dec++  , wordDec+  , word8Dec+  , word16Dec+  , word32Dec+  , word64Dec++  , integerDec+  , floatDec+  , doubleDec++  -- * Hexadecimal+  , wordHex+  , word8Hex+  , word16Hex+  , word32Hex+  , word64Hex++  -- * Fixed-width hexadecimal+  , int8HexFixed+  , int16HexFixed+  , int32HexFixed+  , int64HexFixed++  , word8HexFixed+  , word16HexFixed+  , word32HexFixed+  , word64HexFixed++  , floatHexFixed+  , doubleHexFixed++  -- * UTF-8+  , charUtf8+  , stringUtf8++  -- * ASCII+  , char7+  , string7++  -- * ISO-8859-1+  , char8+  , string8+  ) where++import Data.ByteString.FastBuilder.Internal+import Data.ByteString.FastBuilder.Internal.Prim
+ Data/ByteString/FastBuilder/Internal.hs view
@@ -0,0 +1,731 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RankNTypes #-}++-- | This is an internal module; its interface is unstable.+module Data.ByteString.FastBuilder.Internal+  (+  -- * Builder and related types+    Builder(..)+  , BuilderArg(..)+  , DataSink(..)+  , DynamicSink(..)+  , Queue(..)+  , Request(..)+  , Response(..)++  -- * Internally used exceptions+  , SuspendBuilderException(..)+  , ChunkOverflowException(..)++  -- * Builder building blocks+  , Builder_+  , BuildM(..)+  , toBuilder_+  , fromBuilder_+  , mkBuilder+  , useBuilder+  , getSink+  , getCur+  , getEnd+  , setCur+  , setEnd++  -- * Running builders+  , runBuilder+  , toLazyByteString+  , toLazyByteStringWith+  , toStrictByteString+  , hPutBuilder++  -- * Basic builders+  , primBounded+  , primFixed+  , primMapListBounded+  , primMapListFixed+  , byteString+  , byteStringThreshold+  , byteStringCopy+  , byteStringCopyNoCheck+  , byteStringInsert+  , unsafeCString+  , ensureBytes+  , getBytes++  -- * Performance tuning+  , rebuild+  ) where++import Control.Concurrent (forkIOWithUnmask, myThreadId)+import Control.Concurrent.MVar+import qualified Control.Exception as E+import Control.Monad+import qualified Data.ByteString as S+import qualified Data.ByteString.Internal as S+import qualified Data.ByteString.Unsafe as S+import qualified Data.ByteString.Lazy as L+import Data.IORef+import Data.Monoid+import Data.String+import Data.Word+import Foreign.C.String+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.ForeignPtr.Unsafe+import Foreign.Marshal.Utils+import Foreign.Ptr+import qualified System.IO as IO+import System.IO.Unsafe++import GHC.Exts (Addr#, State#, RealWorld, Ptr(..), Int(..), Int#)+import GHC.Magic (oneShot)+import GHC.IO (IO(..))+import GHC.CString (unpackCString#)++import qualified Data.ByteString.Builder.Prim as P+import qualified Data.ByteString.Builder.Prim.Internal as PI+import qualified Data.ByteString.Builder.Extra as X++-- | 'Builder' is an auxiliary type for efficiently generating a long+-- 'L.ByteString'. It is isomorphic to lazy 'L.ByteString', but offers+-- constant-time concatanation via '<>'.+--+-- Use 'toLazyByteString' to turn a 'Builder' into a 'L.ByteString'+newtype Builder = Builder+  { unBuilder+      :: BuilderArg -> State# RealWorld -> (# Addr#, Addr#, State# RealWorld #)+  }+  -- It takes and returns two pointers, "cur" and "end". "cur" points to+  -- the next location to put bytes to, and "end" points to the end of the+  -- buffer.++-- | This datatype exists only to work around the limitation that 'oneShot'+-- cannot work with unboxed argument types.+data BuilderArg = BuilderArg+  DataSink+  {-# UNPACK #-} !(Ptr Word8) -- "cur" pointer+  {-# UNPACK #-} !(Ptr Word8) -- "end" pointer++instance Monoid Builder where+  mempty = Builder $ \(BuilderArg _ (Ptr cur) (Ptr end)) s -> (# cur, end, s #)+  {-# INLINE mempty #-}+  mappend (Builder a) (Builder b) = Builder $ \(BuilderArg dex (Ptr cur) (Ptr end)) s ->+    case a (BuilderArg dex (Ptr cur) (Ptr end)) s of+      (# cur', end', s' #) -> b (BuilderArg dex (Ptr cur') (Ptr end')) s'+  {-# INLINE mappend #-}+  mconcat xs = foldr mappend mempty xs+  {-# INLINE mconcat #-}++-- | 'fromString' = 'stringUtf8'+instance IsString Builder where+  fromString = builderFromString+  {-# INLINE fromString #-}++-- | Specifies where bytes generated by a builder go.+data DataSink+  = DynamicSink !(IORef DynamicSink)+    -- ^ The destination of data changes while the builder is running.+  | GrowingBuffer !(IORef (ForeignPtr Word8))+    -- ^ Bytes are accumulated in a contiguous buffer.+  | HandleSink !IO.Handle !(IORef Queue)+    -- ^ Bytes are first accumulated in the 'Queue', then flushed to the+    -- 'IO.Handle'.++-- | Variable-destination cases.+data DynamicSink+  = ThreadedSink !(MVar Request) !(MVar Response)+      -- ^ Bytes are sent to another thread.+  | BoundedGrowingBuffer {-# UNPACK #-} !(ForeignPtr Word8) !Int{-bound-}+      -- ^ Bytes are accumulated in a contiguous buffer until the+      -- size limit is reached. After that, the destination switches+      -- to a 'ThreadedSink'.++-- | A mutable buffer. The 'Int' specifies where the data start.+data Queue = Queue !(ForeignPtr Word8) !Int{-start-}++-- | A request from the driver thread to the builder thread.+data Request+  = Request {-# UNPACK #-} !(Ptr Word8) {-# UNPACK #-} !(Ptr Word8)++-- | A response from the builder thread to the driver thread.+data Response+  = Error E.SomeException+      -- ^ A synchronous exception was thrown by the builder+  | Done !(Ptr Word8)+      -- ^ The builder thread has completed.+  | MoreBuffer !(Ptr Word8) !Int+      -- ^ The builder thread has finished generating one chunk,+      -- and waits for another request with the specified minimum size.+  | InsertByteString !(Ptr Word8) !S.ByteString+      -- ^ The builder thread has partially filled the current chunk,+      -- and wants to emit the bytestring to be included in the final+      -- output.+  deriving (Show)++----------------------------------------------------------------+-- Internally used exceptions++-- | Used in the implementation of 'toLazyByteString'. This is an exception+-- thrown by the consumer thread to itself when it has finished filling the+-- first chunk of the output. After this, a thread will be forked, and the+-- execution of the builder will be resumed in the new thread, using+-- 'ThreadedSink'.+data ChunkOverflowException+  = ChunkOverflowException+      !S.ByteString !(MVar Request) !(MVar Response) !Int++instance Show ChunkOverflowException where+  show (ChunkOverflowException buf _ _ req) =+    "ChunkOverflowException " ++ show buf ++ " _ _ " ++ show req++instance E.Exception ChunkOverflowException++-- | Used in the implementation of 'toLazyByteString'. This is a message sent+-- from the consumer thread to the builder thread, requesting the builder+-- thread to temporarily pause execution. Later, the consumer thread may+-- request resumption by filling the 'MVar'.+data SuspendBuilderException = SuspendBuilderException !(MVar ())++instance Show SuspendBuilderException where+  show _ = "SuspendBuilderException"++instance E.Exception SuspendBuilderException++----------------------------------------------------------------+-- Builder building blocks++-- | An internal type that is isomorphic to 'Builder'. This is a+-- maximaly efficient representation for NOINLINE functions.+type Builder_+  = DataSink -> Addr# -> Addr# -> State# RealWorld+  -> (# Addr#, Addr#, State# RealWorld #)++-- | Convert a 'Builder' into a 'Builder_'.+toBuilder_ :: Builder -> Builder_+toBuilder_ (Builder f) dex cur end s = f (BuilderArg dex (Ptr cur) (Ptr end)) s++-- | Convert a 'Builder_' into a 'Builder'.+fromBuilder_ :: Builder_ -> Builder+fromBuilder_ f = Builder $ \(BuilderArg dex (Ptr cur) (Ptr end)) s -> f dex cur end s++-- | An internal type for making it easier to define builders. A value of+-- @'BuildM' a@ can do everything a 'Builder' can do, and in addition,+-- returns a value of type @a@ upon completion.+newtype BuildM a = BuildM { runBuildM :: (a -> Builder) -> Builder }+  deriving (Functor)++instance Applicative BuildM where+  pure = return+  (<*>) = ap++instance Monad BuildM where+  return x = BuildM $ \k -> k x+  {-# INLINE return #-}+  BuildM b >>= f = BuildM $ \k -> b $ \r -> runBuildM (f r) k+  {-# INLINE (>>=) #-}++-- | Create a builder from a BuildM.+mkBuilder :: BuildM () -> Builder+mkBuilder (BuildM bb) = bb $ \_ -> mempty+{-# INLINE mkBuilder #-}++-- | Embed a builder in the BuildM context.+useBuilder :: Builder -> BuildM ()+useBuilder b = BuildM $ \k -> b <> k ()+{-# INLINE useBuilder #-}++-- | Get the 'DataSink'.+getSink :: BuildM DataSink+getSink = BuildM $ \k -> Builder $ \(BuilderArg dex cur end) s ->+  unBuilder (k dex) (BuilderArg dex cur end) s++-- | Get the current pointer.+getCur :: BuildM (Ptr Word8)+getCur = BuildM $ \k -> Builder $ \(BuilderArg dex cur end) s ->+  unBuilder (k cur) (BuilderArg dex cur end) s++-- | Get the end-of-buffer pointer.+getEnd :: BuildM (Ptr Word8)+getEnd = BuildM $ \k -> Builder $ \(BuilderArg dex cur end) s ->+  unBuilder (k end) (BuilderArg dex cur end) s++-- | Set the current pointer.+setCur :: Ptr Word8 -> BuildM ()+setCur p = BuildM $ \k -> Builder $ \(BuilderArg dex _ end) s ->+  unBuilder (k ()) (BuilderArg dex p end) s++-- | Set the end-of-buffer pointer.+setEnd :: Ptr Word8 -> BuildM ()+setEnd p = BuildM $ \k -> Builder $ \(BuilderArg dex cur _) s ->+  unBuilder (k ()) (BuilderArg dex cur p) s++-- | Perform IO.+io :: IO a -> BuildM a+io (IO x) = BuildM $ \k -> Builder $ \ba s -> case x s of+  (# s', val #) -> unBuilder (k val) ba s'++----------------------------------------------------------------+--+-- Running builders.++-- | Run a builder.+runBuilder :: Builder -> DataSink -> Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8)+runBuilder (Builder f) sink !cur !end = IO $ \s ->+  case f (BuilderArg sink cur end) s of+    (# cur', _, s' #) -> (# s', Ptr cur' #)++-- | Turn a 'Builder' into a lazy 'L.ByteString'.+--+-- __Performance hint__: when the resulting 'L.ByteString' does not fit+-- in one chunk, this function forks a thread. Due to this, the performance+-- degrades sharply if you use this function from a bound thread. Note in+-- particular that the main thread is a bound thread when you use @ghc+-- -threaded@.+--+-- To avoid this problem, do one of these:+--+-- * Make sure the resulting 'L.ByteString' is consumed in an unbound+--    thread. Consider using 'runInUnboundThread' for this.+-- * Use other function to run the 'Builder' instead. Functions that don't+--    return a lazy 'L.ByteString' do not have this issue.+-- * Link your program without @-threaded@.+toLazyByteString :: Builder -> L.ByteString+toLazyByteString = toLazyByteStringWith 100 32768++-- | Like 'toLazyByteString', but allows the user to specify the initial+-- and the subsequent desired buffer sizes.+toLazyByteStringWith :: Int -> Int -> Builder -> L.ByteString++-- The implementation employs a two-phase strategy to minimize the overhead:+--+-- 0. Fill the first chunk in a single-threaded way. Start from 'initialSize'-+--    sized buffer and double the size whenever the buffer is full. This uses a+--    'BoundedGrowingBuffer' sink.+--+-- 1. If the first chunk is big enough and the builder still hasn't finished,+--    suspend the execution of the builder, fork a new thread and resume+--    execution of the builder in the new thread, using a 'ThreadedSink'.+toLazyByteStringWith !initialSize !maxSize builder = unsafePerformIO $ do+  fptr <- mallocForeignPtrBytes initialSize+  sink <- newIORef $ BoundedGrowingBuffer fptr maxSize+  let !base = unsafeForeignPtrToPtr fptr+  let+    finalPtr = unsafeDupablePerformIO $+      -- The use of unsafeDupablePerformIO is safe here, because at any given+      -- time, at most one thread can be attempting to evaluate this finalPtr+      -- thunk.+      runBuilder builder (DynamicSink sink) base (base `plusPtr` initialSize)+    {-# NOINLINE finalPtr #-}++    loop thunk = do+      -- Pass around `thunk` as an argument, otherwise GHC 7.10.1 inlines it+      -- despite the NOINLINE pragma.+      r <- E.try $ E.evaluate thunk+      case r of+        Right p -> do+          BoundedGrowingBuffer finalFptr _ <- readIORef sink+          let !finalBase = unsafeForeignPtrToPtr finalFptr+          return $! L.fromStrict $+            S.fromForeignPtr finalFptr 0 (p `minusPtr` finalBase)+        Left ex+          | Just (ChunkOverflowException chunk reqV respV minSize)+              <- E.fromException ex+            -> do+              let rest = continueBuilderThreaded reqV respV minSize maxSize thunk+              return $ L.fromChunks $+                if S.null chunk then rest else chunk : rest+          | otherwise -> do+              -- Here, there is no way to tell whether 'ex' is an asynchronous+              -- exception or not. We re-throw is as if it were async. This is+              -- a safe assumption, because if it is actually a synchronous+              -- exception, it will be re-thrown when we try to resume+              -- the evaluation of 'thunk'.+              myTid <- myThreadId+              E.throwTo myTid ex++              loop thunk++  loop finalPtr++-- | Continue a suspended builder using threads.+continueBuilderThreaded+  :: MVar Request -> MVar Response -> Int -> Int -> Ptr Word8+  -> [S.ByteString]+continueBuilderThreaded !reqV !respV !initialSize !maxSize thunk =+  makeChunks (max maxSize initialSize) maxSize $ toBufferWriter reqV respV thunk++-- | Run the given suspended builder using a new thread.+toBufferWriter :: MVar Request -> MVar Response -> Ptr Word8 -> X.BufferWriter+toBufferWriter !reqV !respV thunk buf0 sz0 = E.mask_ $ do+  writer Nothing buf0 sz0+  where+    writer !maybeBuilderTid !buf !sz = do+      putMVar reqV $ Request buf (buf `plusPtr` sz)+      -- Fork after putMVar, in order to minimize the chance that+      -- the new thread is scheduled on a different CPU.+      builderTid <- case maybeBuilderTid of+        Just t -> return t+        Nothing -> forkIOWithUnmask $ \u ->+          builderThreadWithUnmask u respV thunk+      resp <- wait builderTid+      let go cur next = return(written, next)+            where !written = cur `minusPtr` buf+      case resp of+        Error ex -> E.throwIO ex+        Done cur -> go cur X.Done+        MoreBuffer cur k -> go cur $ X.More k $ writer (Just builderTid)+        InsertByteString cur str -> go cur $ X.Chunk str $ writer (Just builderTid)++    wait !builderTid = do+      r <- E.try $ takeMVar respV+      case r of+        Right resp -> return resp+        Left exn -> do+          -- exn must be an async exception, because takeMVar throws no+          -- synchronous exceptions.+          resumeVar <- newEmptyMVar+          E.throwTo builderTid $ SuspendBuilderException resumeVar+          thisTid <- myThreadId+          E.throwTo thisTid (exn :: E.SomeException)++          -- A thunk containing this computation has been resumed.+          -- Resume the builder thread, and retry.+          putMVar resumeVar ()+          wait builderTid++-- | The body of the builder thread.+builderThreadWithUnmask+  :: (forall a. IO a -> IO a) -> MVar Response -> Ptr Word8+  -> IO ()+builderThreadWithUnmask unmask !respV thunk = loop+  where+    loop = do+      r <- E.try $ unmask $ E.evaluate thunk+      case r of+        Right p -> putMVar respV $ Done p+        Left ex+          | Just (SuspendBuilderException lock) <- E.fromException ex+            -> do takeMVar lock; loop+          | otherwise -> putMVar respV $ Error ex++-- | Run a 'X.BufferWriter'.+makeChunks :: Int -> Int -> X.BufferWriter -> [S.ByteString]+makeChunks !initialBufSize maxBufSize = go initialBufSize+  where+    go !bufSize w = unsafePerformIO $ do+      fptr <- S.mallocByteString bufSize+      (written, next) <- withForeignPtr fptr $ \buf -> w buf bufSize+      let rest = case next of+            X.Done -> []+            X.More reqSize w' -> go (max reqSize maxBufSize) w'+            X.Chunk chunk w' -> chunk : go maxBufSize w'+              -- TODO: don't throw away the remaining part of the buffer+      return $ if written == 0+        then rest+        else S.fromForeignPtr fptr 0 written : rest++-- | Turn a 'Builder' into a strict 'S.ByteString'.+toStrictByteString :: Builder -> S.ByteString+toStrictByteString builder = unsafePerformIO $ do+  let cap = 100+  fptr <- mallocForeignPtrBytes cap+  bufferRef <- newIORef fptr+  let !base = unsafeForeignPtrToPtr fptr+  cur <- runBuilder builder (GrowingBuffer bufferRef) base (base `plusPtr` cap)+  endFptr <- readIORef bufferRef+  let !written = cur `minusPtr` unsafeForeignPtrToPtr endFptr+  return $ S.fromForeignPtr endFptr 0 written++-- | Output a 'Builder' to a 'IO.Handle'.+hPutBuilder :: IO.Handle -> Builder -> IO ()+hPutBuilder !h builder = do+  let cap = 100+  fptr <- mallocForeignPtrBytes cap+  qRef <- newIORef $ Queue fptr 0+  let !base = unsafeForeignPtrToPtr fptr+  cur <- runBuilder builder (HandleSink h qRef) base (base `plusPtr` cap)+  flushQueue h qRef cur++----------------------------------------------------------------+-- builders++-- | Turn a 'String' into a 'Builder', using UTF-8,+builderFromString :: String -> Builder+builderFromString = primMapListBounded P.charUtf8+{-# NOINLINE[0] builderFromString #-}++{-# RULES "FastBuilder: builderFromString/unpackCString#"+  forall addr.+    builderFromString (unpackCString# addr) = unsafeCString (Ptr addr)+  #-}++-- | Turn a value of type @a@ into a 'Builder', using the given 'PI.BoundedPrim'.+primBounded :: PI.BoundedPrim a -> a -> Builder+primBounded prim !x = mappend (ensureBytes $ PI.sizeBound prim) $ mkBuilder $ do+  cur <- getCur+  cur' <- io $ PI.runB prim x cur+  setCur cur'+{-# INLINE primBounded #-}++-- | Turn a value of type @a@ into a 'Builder', using the given 'PI.FixedPrim'.+primFixed :: PI.FixedPrim a -> a -> Builder+primFixed prim x = primBounded (PI.toB prim) x+{-# INLINE primFixed #-}++-- | Turn a list of values of type @a@ into a 'Builder', using the given+-- 'PI.BoundedPrim'.+primMapListBounded :: PI.BoundedPrim a -> [a] -> Builder+primMapListBounded prim = \xs -> mconcat $ map (primBounded prim) xs+{-# INLINE primMapListBounded #-}++-- | Turn a list of values of type @a@ into a 'Builder', using the given+-- 'PI.FixedPrim'.+primMapListFixed :: PI.FixedPrim a -> [a] -> Builder+primMapListFixed prim = \xs -> primMapListBounded (PI.toB prim) xs+{-# INLINE primMapListFixed #-}++-- | Turn a 'S.ByteString' to a 'Builder'.+byteString :: S.ByteString -> Builder+byteString = byteStringThreshold maximalCopySize+{-# INLINE byteString #-}++maximalCopySize :: Int+maximalCopySize = 2 * X.smallChunkSize++-- | Turn a 'S.ByteString' to a 'Builder'. If the size of the 'S.ByteString'+-- is larger than the given threshold, avoid copying it as much+-- as possible.+byteStringThreshold :: Int -> S.ByteString -> Builder+byteStringThreshold th bstr = rebuild $+  if S.length bstr >= th+    then byteStringInsert bstr+    else byteStringCopy bstr++-- | Turn a 'S.ByteString' to a 'Builder'. The 'S.ByteString' will be copied+-- to the buffer, regardless of the size.+byteStringCopy :: S.ByteString -> Builder+byteStringCopy !bstr =+  -- TODO: this is suboptimal; should keep using the same buffer size.+  ensureBytes (S.length bstr) <> byteStringCopyNoCheck bstr++-- | Like 'byteStringCopy', but assumes that the current buffer is large enough.+byteStringCopyNoCheck :: S.ByteString -> Builder+byteStringCopyNoCheck !bstr = mkBuilder $ do+  cur <- getCur+  io $ S.unsafeUseAsCString bstr $ \ptr ->+    copyBytes cur (castPtr ptr) len+  setCur $ cur `plusPtr` len+  where+    !len = S.length bstr++-- | Turn a 'S.ByteString' to a 'Builder'. When possible, the given+-- 'S.ByteString' will not be copied, and inserted directly into the output+-- instead.+byteStringInsert :: S.ByteString -> Builder+byteStringInsert !bstr = fromBuilder_ $ byteStringInsert_ bstr++-- | The body of the 'byteStringInsert', worker-wrappered manually.+byteStringInsert_ :: S.ByteString -> Builder_+byteStringInsert_ bstr = toBuilder_ $ mkBuilder $ do+  sink <- getSink+  case sink of+    DynamicSink dRef -> do+      dyn <- io $ readIORef dRef+      case dyn of+        ThreadedSink reqV respV -> do+          cur <- getCur+          io $ putMVar respV $ InsertByteString cur bstr+          handleRequest reqV+        BoundedGrowingBuffer fptr bound -> do+          r <- remainingBytes+          when (r < S.length bstr) $+            growBufferBounded dRef fptr bound (S.length bstr)+          -- TODO: insert rather than copy if the first chunk+          -- is full.+          useBuilder $ byteStringCopyNoCheck bstr+    GrowingBuffer bufRef -> do+      r <- remainingBytes+      when (r < S.length bstr) $+        growBuffer bufRef (S.length bstr)+      useBuilder $ byteStringCopyNoCheck bstr+    HandleSink h queueRef -> do+      cur <- getCur+      io $ flushQueue h queueRef cur+      io $ S.hPut h bstr+{-# NOINLINE byteStringInsert_ #-}++-- | Turn a C String into a 'Builder'. The behavior is undefined if the given+-- 'CString' does not point to a constant null-terminated string.+unsafeCString :: CString -> Builder+unsafeCString cstr = rebuild $ let+    !len = fromIntegral $ c_pure_strlen cstr+  in+  mappend (ensureBytes len) $ mkBuilder $ do+  cur <- getCur+  io $ copyBytes cur (castPtr cstr) len+  setCur $ cur `plusPtr` len++foreign import ccall unsafe "strlen" c_pure_strlen :: CString -> CSize++-- | @'ensureBytes' n@ ensures that at least @n@ bytes of free space is+-- available in the current buffer, by allocating a new buffer when+-- necessary.+ensureBytes :: Int -> Builder+ensureBytes !n = mkBuilder $ do+  r <- remainingBytes+  when (r < n) $ useBuilder $ getBytes n+{-# INLINE ensureBytes #-}++-- | @'getBytes' n@ allocates a new buffer, containing at least @n@ bytes.+getBytes :: Int -> Builder+getBytes (I# n) = fromBuilder_ (getBytes_ n)++-- | The body of the 'getBytes' function, worker-wrappered manually.+getBytes_ :: Int# -> Builder_+getBytes_ n = toBuilder_ $ mkBuilder $ do+  sink <- getSink+  case sink of+    DynamicSink dRef -> do+      dyn <- io $ readIORef dRef+      case dyn of+        ThreadedSink reqV respV -> do+          cur <- getCur+          io $ putMVar respV $ MoreBuffer cur $ I# n+          handleRequest reqV+        BoundedGrowingBuffer fptr bound ->+          growBufferBounded dRef fptr bound (I# n)+    GrowingBuffer bufRef -> growBuffer bufRef (I# n)+    HandleSink h queueRef -> do+      cur <- getCur+      io $ flushQueue h queueRef cur+      switchQueue queueRef $ max 4096 (I# n)+{-# NOINLINE getBytes_ #-}++-- | Return the remaining size of the current buffer, in bytes.+remainingBytes :: BuildM Int+remainingBytes = minusPtr <$> getEnd <*> getCur+{-# INLINE remainingBytes #-}++----------------------------------------------------------------+-- Performance tuning++-- | @'rebuild' b@ is equivalent to @b@, but it allows GHC to assume+-- that @b@ will be run at most once. This can enable various+-- optimizations that greately improves performance.+--+-- There are two types of typical situations where a use of 'rebuild'+-- is often a win:+--+-- * When constructing a builder using a recursive function. e.g.+--  @rebuild $ foldr ...@.+-- * When constructing a builder using a conditional expression. e.g.+--  @rebuild $ case x of ... @+rebuild :: Builder -> Builder+rebuild (Builder f) = Builder $ oneShot (\ !arg s -> f arg s)++----------------------------------------------------------------+-- ThreadedSink++-- | Wait for a request, and switch to a new buffer.+handleRequest :: MVar Request -> BuildM ()+handleRequest reqV = do+  Request newCur newEnd <- io $ takeMVar reqV+  setCur newCur+  setEnd newEnd++----------------------------------------------------------------+-- GrowingBuffer++-- | @growBuffer bufRef req@ reallocates the buffer, growing it+-- by at least @req@.+growBuffer :: IORef (ForeignPtr Word8) -> Int -> BuildM ()+growBuffer !bufRef !req = do+  cur <- getCur+  end <- getCur+  fptr <- io $ readIORef bufRef+  let !base = unsafeForeignPtrToPtr fptr+  let !size = cur `minusPtr` base+  let !cap = end `minusPtr` base+  let !newCap = cap + max cap req+  newFptr <- io $ mallocForeignPtrBytes newCap+  let !newBase = unsafeForeignPtrToPtr newFptr+  setCur $ newBase `plusPtr` size+  setEnd $ newBase `plusPtr` newCap+  io $ do+    copyBytes newBase base size+    touchForeignPtr fptr+    touchForeignPtr newFptr+    writeIORef bufRef newFptr+{-# INLINE growBuffer #-}++----------------------------------------------------------------+-- HandleSink++-- | Put the content of the 'Queue' to the 'IO.Handle', and empty+-- the 'Queue'.+flushQueue :: IO.Handle -> IORef Queue -> Ptr Word8 -> IO ()+flushQueue !h !qRef !cur = do+  Queue fptr start <- readIORef qRef+  let !end = cur `minusPtr` unsafeForeignPtrToPtr fptr+  when (end > start) $ do+    S.hPut h $ S.fromForeignPtr fptr start (end - start)+    writeIORef qRef $ Queue fptr end++-- | @switchQueue qRef minSize@ discards the old 'Queue' and sets up+-- a new empty 'Queue' of at least @minSize@ large. If the old 'Queue'+-- is large enough, it is re-used.+switchQueue :: IORef Queue -> Int -> BuildM ()+switchQueue !qRef !minSize = do+  end <- getCur+  Queue fptr _ <- io $ readIORef qRef+  let !base = unsafeForeignPtrToPtr fptr+  let !cap = end `minusPtr` base+  newFptr <- if minSize <= cap+    then return fptr+    else io $ mallocForeignPtrBytes minSize+  let !newBase = unsafeForeignPtrToPtr newFptr+  io $ writeIORef qRef $ Queue newFptr 0+  setCur newBase+  setEnd $ newBase `plusPtr` max minSize cap++----------------------------------------------------------------+-- BoundedGrowingBuffer++-- | @growBufferBounded dRef fptr bound req@ reallocates the buffer, growing it+-- by at least @req@. If the buffer size would exceed @bound@, it instead+-- interrupts execution by throwing a 'ChunkOverflowException', and switches+-- to a 'ThreadedSink'.+growBufferBounded+  :: IORef DynamicSink -> ForeignPtr Word8 -> Int -> Int -> BuildM ()+growBufferBounded !dRef !fptr !bound !req = do+  cur <- getCur+  end <- getCur+  let !base = unsafeForeignPtrToPtr fptr+  let !size = cur `minusPtr` base+  let !cap = end `minusPtr` base+  let !newCap = cap + max cap req+  if bound < newCap+    then chunkOverflow dRef req $ S.fromForeignPtr fptr 0 size+    else do+      newFptr <- io $ mallocForeignPtrBytes newCap+      let !newBase = unsafeForeignPtrToPtr newFptr+      setCur $ newBase `plusPtr` size+      setEnd $ newBase `plusPtr` newCap+      io $ do+        copyBytes newBase base size+        touchForeignPtr fptr+        touchForeignPtr newFptr+        writeIORef dRef $ BoundedGrowingBuffer newFptr bound+{-# INLINE growBufferBounded #-}++-- | Throw a 'ChunkOverflowException' and switches to a 'ThreadedSink'.+chunkOverflow :: IORef DynamicSink -> Int -> S.ByteString -> BuildM ()+chunkOverflow !dRef !minSize !chunk = do+  myTid <- io $ myThreadId+  reqV <- io $ newEmptyMVar+  respV <- io $ newEmptyMVar+  io $ E.throwTo myTid $ ChunkOverflowException chunk reqV respV minSize+  io $ writeIORef dRef $ ThreadedSink reqV respV+  handleRequest reqV
+ Data/ByteString/FastBuilder/Internal/Prim.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE CPP #-}++-- | This is an internal module; its interface is unstable.+module Data.ByteString.FastBuilder.Internal.Prim where++import Data.ByteString.FastBuilder.Internal+import qualified Data.ByteString.Builder.Prim as P+import Data.Int+import Data.Word++# define WRAP_WITH(typ, name, def) name :: typ -> Builder; name = def; {-# INLINE name #-}+# define WRAP_F(type,name) WRAP_WITH(type,name,primFixed P.name)+# define WRAP_B(type,name) WRAP_WITH(type,name,primBounded P.name)+# define WRAP_SHOW7(type,name) WRAP_WITH(type,name,string7 . show)++WRAP_F(Int,intHost)+WRAP_F(Int8,int8)+WRAP_F(Int16,int16LE)+WRAP_F(Int16,int16BE)+WRAP_F(Int16,int16Host)+WRAP_F(Int32,int32LE)+WRAP_F(Int32,int32BE)+WRAP_F(Int32,int32Host)+WRAP_F(Int64,int64LE)+WRAP_F(Int64,int64BE)+WRAP_F(Int64,int64Host)++WRAP_F(Word,wordHost)+WRAP_F(Word8,word8)+WRAP_F(Word16,word16LE)+WRAP_F(Word16,word16BE)+WRAP_F(Word16,word16Host)+WRAP_F(Word32,word32LE)+WRAP_F(Word32,word32BE)+WRAP_F(Word32,word32Host)+WRAP_F(Word64,word64LE)+WRAP_F(Word64,word64BE)+WRAP_F(Word64,word64Host)++WRAP_F(Float,floatLE)+WRAP_F(Float,floatBE)+WRAP_F(Float,floatHost)+WRAP_F(Double,doubleLE)+WRAP_F(Double,doubleBE)+WRAP_F(Double,doubleHost)++WRAP_B(Int,intDec)+WRAP_B(Int8,int8Dec)+WRAP_B(Int16,int16Dec)+WRAP_B(Int32,int32Dec)+WRAP_B(Int64,int64Dec)++WRAP_B(Word,wordDec)+WRAP_B(Word8,word8Dec)+WRAP_B(Word16,word16Dec)+WRAP_B(Word32,word32Dec)+WRAP_B(Word64,word64Dec)++WRAP_B(Word,wordHex)+WRAP_B(Word8,word8Hex)+WRAP_B(Word16,word16Hex)+WRAP_B(Word32,word32Hex)+WRAP_B(Word64,word64Hex)++WRAP_F(Int8,int8HexFixed)+WRAP_F(Int16,int16HexFixed)+WRAP_F(Int32,int32HexFixed)+WRAP_F(Int64,int64HexFixed)++WRAP_F(Word8,word8HexFixed)+WRAP_F(Word16,word16HexFixed)+WRAP_F(Word32,word32HexFixed)+WRAP_F(Word64,word64HexFixed)++WRAP_F(Float,floatHexFixed)+WRAP_F(Double,doubleHexFixed)++WRAP_F(Char,char7)+WRAP_WITH(String,string7,primMapListFixed P.char7)++WRAP_F(Char,char8)+WRAP_WITH(String,string8,primMapListFixed P.char8)++WRAP_B(Char,charUtf8)+WRAP_WITH(String,stringUtf8,primMapListBounded P.charUtf8)++WRAP_SHOW7(Integer,integerDec)+WRAP_SHOW7(Double,floatDec)+WRAP_SHOW7(Double,doubleDec)
+ LICENSE view
@@ -0,0 +1,121 @@+Creative Commons Legal Code++CC0 1.0 Universal++    CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE+    LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN+    ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS+    INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES+    REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS+    PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM+    THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED+    HEREUNDER.++Statement of Purpose++The laws of most jurisdictions throughout the world automatically confer+exclusive Copyright and Related Rights (defined below) upon the creator+and subsequent owner(s) (each and all, an "owner") of an original work of+authorship and/or a database (each, a "Work").++Certain owners wish to permanently relinquish those rights to a Work for+the purpose of contributing to a commons of creative, cultural and+scientific works ("Commons") that the public can reliably and without fear+of later claims of infringement build upon, modify, incorporate in other+works, reuse and redistribute as freely as possible in any form whatsoever+and for any purposes, including without limitation commercial purposes.+These owners may contribute to the Commons to promote the ideal of a free+culture and the further production of creative, cultural and scientific+works, or to gain reputation or greater distribution for their Work in+part through the use and efforts of others.++For these and/or other purposes and motivations, and without any+expectation of additional consideration or compensation, the person+associating CC0 with a Work (the "Affirmer"), to the extent that he or she+is an owner of Copyright and Related Rights in the Work, voluntarily+elects to apply CC0 to the Work and publicly distribute the Work under its+terms, with knowledge of his or her Copyright and Related Rights in the+Work and the meaning and intended legal effect of CC0 on those rights.++1. Copyright and Related Rights. A Work made available under CC0 may be+protected by copyright and related or neighboring rights ("Copyright and+Related Rights"). Copyright and Related Rights include, but are not+limited to, the following:++  i. the right to reproduce, adapt, distribute, perform, display,+     communicate, and translate a Work;+ ii. moral rights retained by the original author(s) and/or performer(s);+iii. publicity and privacy rights pertaining to a person's image or+     likeness depicted in a Work;+ iv. rights protecting against unfair competition in regards to a Work,+     subject to the limitations in paragraph 4(a), below;+  v. rights protecting the extraction, dissemination, use and reuse of data+     in a Work;+ vi. database rights (such as those arising under Directive 96/9/EC of the+     European Parliament and of the Council of 11 March 1996 on the legal+     protection of databases, and under any national implementation+     thereof, including any amended or successor version of such+     directive); and+vii. other similar, equivalent or corresponding rights throughout the+     world based on applicable law or treaty, and any national+     implementations thereof.++2. Waiver. To the greatest extent permitted by, but not in contravention+of, applicable law, Affirmer hereby overtly, fully, permanently,+irrevocably and unconditionally waives, abandons, and surrenders all of+Affirmer's Copyright and Related Rights and associated claims and causes+of action, whether now known or unknown (including existing as well as+future claims and causes of action), in the Work (i) in all territories+worldwide, (ii) for the maximum duration provided by applicable law or+treaty (including future time extensions), (iii) in any current or future+medium and for any number of copies, and (iv) for any purpose whatsoever,+including without limitation commercial, advertising or promotional+purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each+member of the public at large and to the detriment of Affirmer's heirs and+successors, fully intending that such Waiver shall not be subject to+revocation, rescission, cancellation, termination, or any other legal or+equitable action to disrupt the quiet enjoyment of the Work by the public+as contemplated by Affirmer's express Statement of Purpose.++3. Public License Fallback. Should any part of the Waiver for any reason+be judged legally invalid or ineffective under applicable law, then the+Waiver shall be preserved to the maximum extent permitted taking into+account Affirmer's express Statement of Purpose. In addition, to the+extent the Waiver is so judged Affirmer hereby grants to each affected+person a royalty-free, non transferable, non sublicensable, non exclusive,+irrevocable and unconditional license to exercise Affirmer's Copyright and+Related Rights in the Work (i) in all territories worldwide, (ii) for the+maximum duration provided by applicable law or treaty (including future+time extensions), (iii) in any current or future medium and for any number+of copies, and (iv) for any purpose whatsoever, including without+limitation commercial, advertising or promotional purposes (the+"License"). The License shall be deemed effective as of the date CC0 was+applied by Affirmer to the Work. Should any part of the License for any+reason be judged legally invalid or ineffective under applicable law, such+partial invalidity or ineffectiveness shall not invalidate the remainder+of the License, and in such case Affirmer hereby affirms that he or she+will not (i) exercise any of his or her remaining Copyright and Related+Rights in the Work or (ii) assert any associated claims and causes of+action with respect to the Work, in either case contrary to Affirmer's+express Statement of Purpose.++4. Limitations and Disclaimers.++ a. No trademark or patent rights held by Affirmer are waived, abandoned,+    surrendered, licensed or otherwise affected by this document.+ b. Affirmer offers the Work as-is and makes no representations or+    warranties of any kind concerning the Work, express, implied,+    statutory or otherwise, including without limitation warranties of+    title, merchantability, fitness for a particular purpose, non+    infringement, or the absence of latent or other defects, accuracy, or+    the present or absence of errors, whether or not discoverable, all to+    the greatest extent permissible under applicable law.+ c. Affirmer disclaims responsibility for clearing rights of other persons+    that may apply to the Work or any use thereof, including without+    limitation any person's Copyright and Related Rights in the Work.+    Further, Affirmer disclaims responsibility for obtaining any necessary+    consents, permissions or other rights required for any use of the+    Work.+ d. Affirmer understands and acknowledges that Creative Commons is not a+    party to this document and has no duty or obligation with respect to+    this CC0 or use of the Work.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmarks/aeson/Bstr.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE CPP #-}+#define LIB Data.ByteString.Builder+#define NAME Bstr+#include "template.hs"++rebuild :: Builder -> Builder+rebuild = id
+ benchmarks/aeson/Fast.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE CPP #-}+#define LIB Data.ByteString.FastBuilder+#define NAME Fast+#include "template.hs"
+ benchmarks/aeson/HashMapExts.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+module HashMapExts where++import qualified Data.HashMap.Strict as H+import Data.Monoid+import GHC.Exts (Array#, sizeofArray#, indexArray#, Int(..))+import Unsafe.TrueName (quasiName)++import HashMapNames++foldMapWithKey :: (Monoid m) => (k -> a -> m) -> H.HashMap k a -> m+foldMapWithKey f = go+  where+    go hm = case hm of+      [quasiName|Empty ''H.HashMap|] -> mempty+      [quasiName|BitmapIndexed ''H.HashMap _ ary|] -> foldMapArray go ary+      [quasiName|Full ''H.HashMap ary|] -> foldMapArray go ary+      [quasiName|Collision ''H.HashMap _ ary|] -> foldMapArray leaf ary+      [quasiName|Leaf ''H.HashMap _ l|] -> leaf l++    leaf $(lPat "k" "v")  = f k v+{-# INLINE foldMapWithKey #-}++foldMapArray :: (Monoid m) => (a -> m) -> $(arrayType) a -> m+foldMapArray f $(arrayPat "arr") = foldMapArray' f arr++foldMapArray' :: (Monoid m) => (a -> m) -> Array# a -> m+foldMapArray' f arr = go 0+  where+    go k@(I# k#)+      | k >= I# (sizeofArray# arr) = mempty+      | otherwise = case indexArray# arr k# of+        (# v #) -> f v <> go (k + 1)+{-# INLINE foldMapArray' #-}
+ benchmarks/aeson/HashMapNames.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE TemplateHaskell #-}+module HashMapNames where++import qualified Data.HashMap.Strict as H+import Language.Haskell.TH+import Unsafe.TrueName (trueName)++lPat :: String -> String -> Q Pat+lPat a b = do+  leafConName <- trueName "Leaf" ''H.HashMap+  leafTyName <- trueName "Leaf" leafConName+  lName <- trueName "L" leafTyName+  conP lName [varP (mkName a), varP (mkName b)]++arrayTypeName :: Q Name+arrayTypeName = do+  fullConName <- trueName "Full" ''H.HashMap+  trueName "Array" fullConName++arrayType :: Q Type+arrayType = conT =<< arrayTypeName++arrayPat :: String -> Q Pat+arrayPat a = do+  arrayTyName <- arrayTypeName+  arrayConName <- trueName "Array" arrayTyName+  conP arrayConName [varP (mkName a)]
+ benchmarks/aeson/main.hs view
@@ -0,0 +1,17 @@+import qualified Fast as F+import qualified Bstr as B+import Control.Concurrent+import Control.DeepSeq+import Criterion.Main+import Data.Aeson (decode', encode)+import qualified Data.ByteString.Lazy as L++main :: IO ()+main = runInUnboundThread $ do+  Just json <- decode' <$> L.readFile "../aeson/benchmarks/json-data/twitter100.json"+  rnf json `seq` return ()+  defaultMain+    [ bench "fast" $ nf F.valueToLazyByteString json+    , bench "bstr" $ nf B.valueToLazyByteString json+    , bench "aeson" $ nf encode json+    ]
+ benchmarks/vector.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DeriveFunctor #-}+import Control.Concurrent+import Control.Monad+import Criterion.Main+import Data.Monoid+import qualified Data.Vector.Unboxed as U+import Data.Word+import qualified System.IO as IO++import qualified Data.ByteString.Builder as Bstr+import qualified Data.ByteString.FastBuilder as Fast++main :: IO ()+main = runInUnboundThread $ do+  h <- IO.openFile "/dev/null" IO.WriteMode+  let+    size sz vec = bgroup sz+      [ bench "lazy/fast" $ nf (Fast.toLazyByteString . fastVector) vec+      , bench "lazy/bstr" $ nf (Bstr.toLazyByteString . bstrVector) vec+      , bench "strict/fast" $ nf (Fast.toStrictByteString . fastVector) vec+      , bench "io/fast" $ whnfIO $ Fast.hPutBuilder h $ fastVector vec+      , bench "io/bstr" $ whnfIO $ Bstr.hPutBuilder h $ bstrVector vec+      ]+  vec10 `seq` vec100 `seq` vec1000 `seq` vec10000 `seq` defaultMain+    [ size "10" vec10+    , size "100" vec100+    , size "1000" vec1000+    , size "10000" vec10000+    ]++type Item = (Bool, Word32)++fastVector :: U.Vector Item -> Fast.Builder+fastVector = Fast.rebuild . my_foldr step mempty+  where+    step (b, w) rest = Fast.word8 (if b then 1 else 0) <> Fast.word32LE w <> rest++bstrVector :: U.Vector Item -> Bstr.Builder+bstrVector = my_foldr step mempty+  where+    step (b, w) rest = Bstr.word8 (if b then 1 else 0) <> Bstr.word32LE w <> rest++vec10 :: U.Vector Item+vec10 = makeItems 10++vec100 :: U.Vector Item+vec100 = makeItems 100++vec1000 :: U.Vector Item+vec1000 = makeItems 1000++vec10000 :: U.Vector Item+vec10000 = makeItems 10000++makeItems :: Int -> U.Vector Item+makeItems n = U.generate n $ \i ->+  (mod i 3 == 0, fromIntegral i + 100)++data Box a = Box a+  deriving Functor+instance Applicative Box where+  pure = return+  (<*>) = ap+instance Monad Box where+  return = Box+  Box a >>= f = f a++my_foldr :: (U.Unbox a) => (a -> r -> r) -> r -> U.Vector a -> r+my_foldr f z = go+  where+    go v+      | U.null v = z+      | otherwise = f (U.unsafeHead v) $ go (U.unsafeTail v)
+ fast-builder.cabal view
@@ -0,0 +1,53 @@+name:                fast-builder+version:             0.0.0.0+synopsis:            Fast ByteString Builder+description:         An efficient implementation of ByteString builder. It should be faster than+                     the standard implementation in most cases.+homepage:            http://github.com/takano-akio/fast-builder+license:             PublicDomain+license-file:        LICENSE+author:              Takano Akio+maintainer:          aljee@hyper.cx+-- copyright:           +category:            Data+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++library+  exposed-modules:     Data.ByteString.FastBuilder,+                       Data.ByteString.FastBuilder.Internal+  other-modules:       Data.ByteString.FastBuilder.Internal.Prim++  -- other-extensions:    +  build-depends:       base ==4.8.0.0, bytestring >= 0.10.6.0, ghc-prim+  -- hs-source-dirs:      +  default-language:    Haskell2010+  ghc-options:         -Wall -g++benchmark aeson+  type:                exitcode-stdio-1.0+  main-is:             main.hs+  hs-source-dirs:      benchmarks/aeson+  other-modules:       Fast, Bstr, HashMapExts, HashMapNames+  build-depends:       base, fast-builder, aeson, criterion, bytestring, scientific, text, vector, deepseq, unordered-containers, ghc-prim, true-name, template-haskell+  ghc-options:         -fsimpl-tick-factor=120+  ghc-options:         -Wall -threaded -g -rtsopts++benchmark vector+  type:                exitcode-stdio-1.0+  main-is:             vector.hs+  hs-source-dirs:      benchmarks+  build-depends:       base, fast-builder, criterion, bytestring, vector, deepseq+  ghc-options:         -Wall -threaded -g -rtsopts -eventlog++test-suite prop+  type:                exitcode-stdio-1.0+  main-is:             prop.hs+  hs-source-dirs:      tests+  build-depends:       base, fast-builder, bytestring, QuickCheck, stm, process+  ghc-options:         -Wall -g -rtsopts++source-repository head+  type:                git+  location:            https://github.com/takano-akio/fast-builder.git
+ tests/prop.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Main where++import Control.Concurrent+import Control.Concurrent.STM+import qualified Control.Exception as E+import Control.Monad+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.Monoid+import Data.Typeable+import Data.Word+import qualified System.IO as IO+import System.IO.Unsafe+import qualified System.Process as Process+import System.Timeout+import qualified Test.QuickCheck as QC++import Data.ByteString.FastBuilder++data BuilderTree+  = Leaf BuilderPrim+  | Mappend BuilderTree BuilderTree+  deriving (Show)++data BuilderPrim+  = BP_Word8 !Word8+  | BP_Word64le !Word64+  | BP_ByteString !BS.ByteString+  | BP_Empty+  deriving (Show)++instance QC.Arbitrary BuilderTree where+  arbitrary = QC.sized $ \size ->+    if size == 0+      then return (Leaf BP_Empty)+      else QC.oneof+        [ Leaf <$> QC.arbitrary+        , QC.scale (`div` 2) $ Mappend <$> QC.arbitrary <*> QC.arbitrary+        ]++instance QC.Arbitrary BuilderPrim where+  arbitrary = QC.oneof+    [ BP_Word8 <$> QC.arbitrary+    , BP_Word64le <$> QC.arbitrary+    , BP_ByteString . BS.pack <$> QC.arbitrary+    , pure BP_Empty+    ]++data Driver+  = ToLazyByteString+  | ToLazyByteStringWith_10+  | ToStrictByteString+  | HPutBuilder+  deriving (Show, Enum, Bounded)++instance QC.Arbitrary Driver where+  arbitrary = QC.arbitraryBoundedEnum++newtype TestException = TextException Int+  deriving (Show, Eq, Typeable, QC.Arbitrary)++instance E.Exception TestException++runBuilder :: Driver -> Builder -> BS.ByteString+runBuilder ToLazyByteString = BSL.toStrict . toLazyByteString+runBuilder ToLazyByteStringWith_10 =+  BSL.toStrict . toLazyByteStringWith 10 10+runBuilder ToStrictByteString = toStrictByteString+runBuilder HPutBuilder = \b -> unsafePerformIO $ do+  (readH, writeH) <- Process.createPipe+  hPutBuilder writeH b+  IO.hClose writeH+  BS.hGetContents readH++mkBuilder :: BuilderTree -> Builder+mkBuilder = go+  where+    go (Leaf p) = prim p+    go (Mappend a b) = go a <> go b++    prim (BP_Word8 w) = word8 w+    prim (BP_Word64le w) = word64LE w+    prim (BP_ByteString bs) = byteString bs+    prim BP_Empty = mempty++buildWithBuilder :: Driver -> BuilderTree -> BS.ByteString+buildWithBuilder drv = runBuilder drv . mkBuilder++buildWithList :: BuilderTree -> BS.ByteString+buildWithList = BS.pack . ($[]) . go+  where+    go (Leaf p) = prim p+    go (Mappend a b) = go a . go b++    prim (BP_Word8 w) = (w:)+    prim (BP_Word64le w) = (list++)+      where+        list = take 8 $ map fromIntegral $ iterate (`div` 256) w+    prim (BP_ByteString bs) = (BS.unpack bs ++)+    prim BP_Empty = id++errorBuilder :: TestException -> Builder+errorBuilder ex = mempty <> E.throw ex+{-# NOINLINE errorBuilder #-}++asyncExnBuilder :: ThreadId -> TestException -> Builder+asyncExnBuilder tid ex = mempty <> unsafePerformIO act+  where+    act = do+      E.throwTo tid ex+      return mempty+{-# NOINLINE asyncExnBuilder #-}++nonterminatingBuilder :: TVar Bool -> Builder+nonterminatingBuilder inBlock = mempty <> unsafePerformIO act+  where+    act = do+      atomically $ writeTVar inBlock True+      loop 0+      `E.finally` atomically (writeTVar inBlock False)++    loop k+      | k < (0::Integer) = return mempty+      | otherwise = loop $ k + 1+{-# NOINLINE nonterminatingBuilder #-}++tryEvaluate :: a -> IO (Either TestException a)+tryEvaluate = E.try . E.evaluate++-- | Builder's semantics matches the reference implementation.+prop_builderTree :: Driver -> BuilderTree -> Bool+prop_builderTree drv tree = buildWithBuilder drv tree == buildWithList tree++-- | When a Builder throws a synchronous exception, the exception should come+-- out unchanged from the driver. Evaluating the result again should repeat+-- the same exception.+prop_syncException+    :: TestException+    -> Driver+    -> BuilderTree+    -> BuilderTree+    -> QC.Property+prop_syncException ex drv before after = QC.ioProperty $ do+  r <- tryEvaluate bstr+  r1 <- tryEvaluate bstr+  return $ (r, r1) == (Left ex, Left ex)+  where+    bstr = runBuilder drv $+      mkBuilder before <> errorBuilder ex <> mkBuilder after++-- | When a Builder is interrupted by an asynchronous exception, the exception+-- should come out unchanged from the driver. Evaluating the result again+-- should then succeed.+prop_asyncException+    :: TestException+    -> Driver+    -> BuilderTree+    -> BuilderTree+    -> QC.Property+prop_asyncException ex drv before after = QC.ioProperty $ do+  tid <- myThreadId+  let+    bstr = runBuilder drv $+      mkBuilder before <> asyncExnBuilder tid ex <> mkBuilder after+  r <- tryEvaluate bstr+  r1 <- tryEvaluate bstr+  return $ (r, r1) == (Left ex, Right $ buildWithList (Mappend before after))++-- | When a non-terminating Builder is interrupted by an asynchronous exception,+-- it should be killed, rather than keep running forever.+prop_asyncExceptionInterrupts+    :: TestException+    -> Driver+    -> BuilderTree+    -> BuilderTree+    -> QC.Property+prop_asyncExceptionInterrupts ex drv before after = QC.ioProperty $ do+  inNontermV <- newTVarIO False+  tid <- myThreadId+  let+    bstr = runBuilder drv $+      mkBuilder before <> nonterminatingBuilder inNontermV <> mkBuilder after+  _ <- forkIO $ do+    atomically $ guard =<< readTVar inNontermV+    E.throwTo tid ex+  r <- tryEvaluate bstr+  r1 <- timeout 100000 $ atomically $ guard . not =<< readTVar inNontermV+  return $ (r, r1) == (Left ex, Just ())++return []++main :: IO ()+main = do+  True <- $(QC.forAllProperties) $ \prop -> do+    r <- QC.quickCheckWithResult QC.stdArgs{ QC.chatty = False } prop+    print r+    return r+  return ()