blaze-builder 0.2.1.4 → 0.3.0.0

raw patch · 11 files changed

+697/−103 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Blaze/ByteString/Builder/Char/Utf8.hs +10/−10
• Blaze/ByteString/Builder/HTTP.hs +3/−3
• Blaze/ByteString/Builder/Html/Utf8.hs +6/−6
• Blaze/ByteString/Builder/Internal.hs +1/−0
• Blaze/ByteString/Builder/Internal/Types.hs +6/−0
• Blaze/ByteString/Builder/Internal/Write.hs +139/−40
• LICENSE +1/−1
• Makefile +20/−6
• benchmarks/LazyByteString.hs +408/−36
• benchmarks/Utf8IO.hs +102/−0
• blaze-builder.cabal +1/−1

@@ -42,19 +42,19 @@ writeChar :: Char -> Write writeChar c = boundedWrite 4 (encodeCharUtf8 f1 f2 f3 f4 c)   where-    f1 x1          = writeN 1 $ \op -> do pokeByteOff op 0 x1+    f1 x1          = pokeN 1 $ \op -> do pokeByteOff op 0 x1 -    f2 x1 x2       = writeN 2 $ \op -> do pokeByteOff op 0 x1-                                          pokeByteOff op 1 x2+    f2 x1 x2       = pokeN 2 $ \op -> do pokeByteOff op 0 x1+                                         pokeByteOff op 1 x2                    -    f3 x1 x2 x3    = writeN 3 $ \op -> do pokeByteOff op 0 x1-                                          pokeByteOff op 1 x2-                                          pokeByteOff op 2 x3+    f3 x1 x2 x3    = pokeN 3 $ \op -> do pokeByteOff op 0 x1+                                         pokeByteOff op 1 x2+                                         pokeByteOff op 2 x3 -    f4 x1 x2 x3 x4 = writeN 4 $ \op -> do pokeByteOff op 0 x1-                                          pokeByteOff op 1 x2-                                          pokeByteOff op 2 x3-                                          pokeByteOff op 3 x4+    f4 x1 x2 x3 x4 = pokeN 4 $ \op -> do pokeByteOff op 0 x1+                                         pokeByteOff op 1 x2+                                         pokeByteOff op 2 x3+                                         pokeByteOff op 3 x4  -- | Encode a Unicode character to another datatype, using UTF-8. This function -- acts as an abstract way of encoding characters, as it is unaware of what

@@ -36,7 +36,7 @@ {-# INLINE execWrite #-} execWrite :: Write -> Ptr Word8 -> IO () execWrite w op = do-    _ <- runWriteIO (runWrite w) op+    _ <- runPoke (getPoke w) op     return ()  @@ -95,7 +95,7 @@  writeWord32Hex :: Word32 -> Write writeWord32Hex w = -    boundedWrite (2 * sizeOf w) (writeN len $ pokeWord32HexN len w)+    boundedWrite (2 * sizeOf w) (pokeN len $ pokeWord32HexN len w)   where     len = word32HexLength w {-# INLINE writeWord32Hex #-}@@ -181,7 +181,7 @@                       wrapChunk opInner' $ \op' -> do                         -- add header for inserted bytestring                         -- FIXME: assert(S.length bs < maxBound :: Word32)-                        !op'' <- (`runWriteIO` op') $ runWrite $+                        !op'' <- (`runPoke` op') $ getPoke $                             writeWord32Hex (fromIntegral $ S.length bs)                              `mappend` writeCRLF                         -- insert bytestring and write CRLF in next buildstep

@@ -46,12 +46,12 @@     boundedWrite 6 (io c0)     -- WARNING: Don't forget to change the bound if you change the bytestrings.   where-    io '<'  = runWrite $ writeByteString "&lt;"-    io '>'  = runWrite $ writeByteString "&gt;"-    io '&'  = runWrite $ writeByteString "&amp;"-    io '"'  = runWrite $ writeByteString "&quot;"-    io '\'' = runWrite $ writeByteString "&#39;"-    io c    = runWrite $ writeChar c+    io '<'  = getPoke $ writeByteString "&lt;"+    io '>'  = getPoke $ writeByteString "&gt;"+    io '&'  = getPoke $ writeByteString "&amp;"+    io '"'  = getPoke $ writeByteString "&quot;"+    io '\'' = getPoke $ writeByteString "&#39;"+    io c    = getPoke $ writeChar c {-# INLINE writeHtmlEscapedChar #-}  -- | /O(1)./ Serialize a HTML escaped Unicode character using the UTF-8

@@ -30,6 +30,7 @@   , Put   , putBuilder   , putBuildStepCont+  , putLiftIO    -- * Writes   , module Blaze.ByteString.Builder.Internal.Write

@@ -134,4 +134,10 @@ fromPut :: Put a -> Builder fromPut (Put put) = Builder $ \k -> put (\_ -> k) +-- Lifting IO actions+--------------------- +-- | Lift the given IO action.+{-# INLINE putLiftIO #-}+putLiftIO :: IO a -> Put a+putLiftIO io = putBuildStepCont $ \k br -> io >>= (`k` br)

@@ -1,6 +1,6 @@ {-# LANGUAGE CPP, BangPatterns, MonoPatBinds #-} -- |--- Module      : Blaze.ByteString.Builder.Internal.WriteIO+-- Module      : Blaze.ByteString.Builder.Internal.Poke -- Copyright   : (c) 2010 Simon Meier --               (c) 2010 Jasper van der Jeugt -- License     : BSD3-style (see LICENSE)@@ -12,15 +12,28 @@ -- A general and efficient write type that allows for the easy construction of -- builders for (smallish) bounded size writes to a buffer. --+-- FIXME: Improve documentation.+-- module Blaze.ByteString.Builder.Internal.Write (-  -- * Abstracting writes to a buffer-    Write-  , WriteIO-  , writeN+  -- * Poking a buffer+    Poke+  , runPoke+  , pokeN++  -- * Writing to abuffer+  , Write+  , runWrite+  , getBound+  , getBound'+  , getPoke+   , exactWrite   , boundedWrite-  , runWrite-  , runWriteIO+  , writeLiftIO+  , writeIf+  , writeEq+  , writeOrdering+  , writeOrd    -- * Constructing builders from writes   , fromWrite@@ -44,7 +57,7 @@   --------------------------------------------------------------------------------- The Write WriteIO Type+-- Poking a buffer and writing to a buffer ------------------------------------------------------------------------------  -- Sadly GHC is not smart enough: code where we branch and each branch should@@ -52,80 +65,167 @@ -- least not such that it returns the value of the branches unpacked. -- -- Hmm.. at least he behaves much better for the Monoid instance of Write--- than the one for WriteIO. Serializing UTF-8 chars gets a slowdown of a+-- than the one for Poke. Serializing UTF-8 chars gets a slowdown of a -- factor 2 when 2 chars are composed. Perhaps I should try out the writeList -- instances also, as they may be more sensitive to to much work per Char. -- --- | A write to a buffer.------ FIXME: Find better name: what about 'Poke' ?-newtype WriteIO = -    WriteIO { runWriteIO :: Ptr Word8 -> IO (Ptr Word8) }+-- | Changing a sequence of bytes starting from the given pointer. 'Poke's are+-- the most primitive buffer manipulation. In most cases, you don't use the+-- explicitely but as part of a 'Write', which also tells how many bytes will+-- be changed at most. +newtype Poke = +    Poke { runPoke :: Ptr Word8 -> IO (Ptr Word8) }  -- | A write of a bounded number of bytes.-data Write = Write {-# UNPACK #-} !Int WriteIO+--+-- When defining a function @write :: a -> Write@ for some @a@, then it is+-- important to ensure that the bound on the number of bytes written is+-- data-independent. Formally, +--+--  @ forall x y. getBound (write x) = getBound (write y) @+--+-- The idea is that this data-independent bound is specified such that the+-- compiler can optimize the check, if there are enough free bytes in the buffer,+-- to a single subtraction between the pointer to the next free byte and the+-- pointer to the end of the buffer with this constant bound of the maximal+-- number of bytes to be written.+--+data Write = Write {-# UNPACK #-} !Int Poke --- | Extract the 'WriteIO' action of a write.+-- | Extract the 'Poke' action of a write.+{-# INLINE getPoke #-}+getPoke :: Write -> Poke+getPoke (Write _ wio) = wio++-- | Run the 'Poke' action of a write. {-# INLINE runWrite #-}-runWrite :: Write -> WriteIO-runWrite (Write _ wio) = wio+runWrite :: Write -> Ptr Word8 -> IO (Ptr Word8)+runWrite = runPoke . getPoke -instance Monoid WriteIO where-  mempty = WriteIO $ return+-- | Extract the maximal number of bytes that this write could write.+{-# INLINE getBound #-}+getBound :: Write -> Int+getBound (Write bound _) = bound++-- | Extract the maximal number of bytes that this write could write in any+-- case. Assumes that the bound of the write is data-independent.+{-# INLINE getBound' #-}+getBound' :: String             -- ^ Name of caller: for debugging purposes.+          -> (a -> Write) +          -> Int+getBound' msg write =+    getBound $ write $ error $ +    "getBound' called from " ++ msg ++ ": write bound is not data-independent."++instance Monoid Poke where   {-# INLINE mempty #-}-  (WriteIO w1) `mappend` (WriteIO w2) = WriteIO $ w1 >=> w2+  mempty = Poke $ return+   {-# INLINE mappend #-}-  mconcat = foldr mappend mempty+  (Poke po1) `mappend` (Poke po2) = Poke $ po1 >=> po2+   {-# INLINE mconcat #-}+  mconcat = foldr mappend mempty  instance Monoid Write where-  mempty = Write 0 mempty   {-# INLINE mempty #-}+  mempty = Write 0 mempty++  {-# INLINE mappend #-}   (Write bound1 w1) `mappend` (Write bound2 w2) =     Write (bound1 + bound2) (w1 `mappend` w2)-  {-# INLINE mappend #-}-  mconcat = foldr mappend mempty+     {-# INLINE mconcat #-}+  mconcat = foldr mappend mempty  --- | @writeN size io@ creates a write that denotes the writing of @size@ bytes+-- | @pokeN size io@ creates a write that denotes the writing of @size@ bytes -- to a buffer using the IO action @io@. Note that @io@ MUST write EXACTLY @size@ -- bytes to the buffer!-writeN :: Int -       -> (Ptr Word8 -> IO ()) -> WriteIO-writeN size io = WriteIO $ \op -> io op >> return (op `plusPtr` size)-{-# INLINE writeN #-}+{-# INLINE pokeN #-}+pokeN :: Int +       -> (Ptr Word8 -> IO ()) -> Poke+pokeN size io = Poke $ \op -> io op >> return (op `plusPtr` size)   -- | @exactWrite size io@ creates a bounded write that can later be converted to -- a builder that writes exactly @size@ bytes. Note that @io@ MUST write -- EXACTLY @size@ bytes to the buffer!+{-# INLINE exactWrite #-} exactWrite :: Int             -> (Ptr Word8 -> IO ())             -> Write-exactWrite size io = Write size (writeN size io)-{-# INLINE exactWrite #-}+exactWrite size io = Write size (pokeN size io)  -- | @boundedWrite size write@ creates a bounded write from a @write@ that does -- not write more than @size@ bytes.-boundedWrite :: Int -> WriteIO -> Write-boundedWrite = Write {-# INLINE boundedWrite #-}+boundedWrite :: Int -> Poke -> Write+boundedWrite = Write +-- | @writeLiftIO io write@ creates a write executes the @io@ action to compute+-- the value that is then written.+{-# INLINE writeLiftIO #-}+writeLiftIO :: (a -> Write) -> IO a -> Write+writeLiftIO write io =+    Write (getBound' "writeLiftIO" write) +          (Poke $ \pf -> do x <- io; runWrite (write x) pf)++-- | @writeIf p wTrue wFalse x@ creates a 'Write' with a 'Poke' equal to @wTrue+-- x@, if @p x@ and equal to @wFalse x@ otherwise. The bound of this new+-- 'Write' is the maximum of the bounds for either 'Write'. This yields a data+-- independent bound, if the bound for @wTrue@ and @wFalse@ is already data+-- independent.+{-# INLINE writeIf #-}+writeIf :: (a -> Bool) -> (a -> Write) -> (a -> Write) -> (a -> Write)+writeIf p wTrue wFalse x = +    boundedWrite (max (getBound $ wTrue x) (getBound $ wFalse x)) +                 (if p x then getPoke $ wTrue x else getPoke $ wFalse x)++-- | Compare the value to a test value and use the first write action for the+-- equal case and the second write action for the non-equal case.+{-# INLINE writeEq #-}+writeEq :: Eq a => a -> (a -> Write) -> (a -> Write) -> (a -> Write)+writeEq test = writeIf (test ==)++-- | TODO: Test this. It might well be too difficult to use.+--   FIXME: Better name required!+{-# INLINE writeOrdering #-}+writeOrdering :: (a -> Ordering) +              -> (a -> Write) -> (a -> Write) -> (a -> Write)+              -> (a -> Write)+writeOrdering ord wLT wEQ wGT x = +    boundedWrite bound (case ord x of LT -> getPoke $ wLT x; +                                      EQ -> getPoke $ wEQ x; +                                      GT -> getPoke $ wGT x)+  where+    bound = max (getBound $ wLT x) (max (getBound $ wEQ x) (getBound $ wGT x))++-- | A write combinator useful to build decision trees for deciding what value+-- to write with a constant bound on the maximal number of bytes written.+{-# INLINE writeOrd #-}+writeOrd :: Ord a +       => a+       -> (a -> Write) -> (a -> Write) -> (a -> Write)+       -> (a -> Write)+writeOrd test = writeOrdering (`compare` test)++-- | Create a builder that execute a single 'Write'.+{-# INLINE fromWrite #-} fromWrite :: Write -> Builder fromWrite (Write maxSize wio) =     fromBuildStepCont step   where     step k (BufRange op ope)       | op `plusPtr` maxSize <= ope = do-          op' <- runWriteIO wio op+          op' <- runPoke wio op           let !br' = BufRange op' ope           k br'       | otherwise = return $ bufferFull maxSize op (step k)-{-# INLINE fromWrite #-} -fromWriteSingleton :: (a -> Write) -> a -> Builder+{-# INLINE fromWriteSingleton #-}+fromWriteSingleton :: (a -> Write) -> (a -> Builder) fromWriteSingleton write =      mkBuilder   where@@ -133,13 +233,12 @@       where         step k (BufRange op ope)           | op `plusPtr` maxSize <= ope = do-              op' <- runWriteIO wio op+              op' <- runPoke wio op               let !br' = BufRange op' ope               k br'           | otherwise = return $ bufferFull maxSize op (step k)           where             Write maxSize wio = write x-{-# INLINE fromWriteSingleton #-}  -- | Construct a 'Builder' writing a list of data one element at a time. fromWriteList :: (a -> Write) -> [a] -> Builder@@ -156,7 +255,7 @@              go xs@(x':xs') !op               | op `plusPtr` maxSize <= ope0 = do-                  !op' <- runWriteIO wio op+                  !op' <- runPoke wio op                   go xs' op'               | otherwise = return $ bufferFull maxSize op (step xs k)               where

@@ -1,4 +1,4 @@-Copyright Jasper Van der Jeugt 2010+Copyright Jasper Van der Jeugt 2010, Simon Meier 2010 & 2011  All rights reserved. 

@@ -7,7 +7,7 @@ #########  GHC6 = ghc-6.12.3-GHC7 = ghc-7.0.1+GHC7 = ghc-7.0.2  GHC = $(GHC7) @@ -22,11 +22,12 @@ clean-bench-all: 	rm -f benchmarks/*.o benchmarks/*.hi 	rm -f benchmarks/Throughput/*.o benchmarks/Throughput/*.hi-	rm -f Text/Blaze/Builder.o Text/Blaze/Builder.hi-	rm -f Text/Blaze/Builder/*.o Text/Blaze/Builder/*.hi-	rm -f Text/Blaze/Builder/Char/*.o Text/Blaze/Builder/Char/*.hi-	rm -f Text/Blaze/Builder/Html/*.o Text/Blaze/Builder/Html/*.hi-	rm -f Text/Blaze/Builder/Core/*.o Text/Blaze/Builder/Core/*.hi+	rm -f Blaze/ByteString/Builder.o Blaze/ByteString/Builder.hi+	rm -f Blaze/ByteString/Builder/*.o Blaze/ByteString/Builder/*.hi+	rm -f Blaze/ByteString/Builder/Internal/*.o Blaze/ByteString/Builder/Internal/*.hi+	rm -f Blaze/ByteString/Builder/Char/*.o Blaze/ByteString/Builder/Char/*.hi+	rm -f Blaze/ByteString/Builder/Html/*.o Blaze/ByteString/Builder/Html/*.hi+	rm -f Blaze/ByteString/Builder/Core/*.o Blaze/ByteString/Builder/Core/*.hi 	rm -f benchmarks/Compression benchmarks/StringAndText benchmarks/BenchThroughput benchmarks/ChunkedWrite benchmarks/BlazeVsBinary 	rm -f Criterion/*.o Criterion/*.hi 	rm -f Criterion/ScalingBenchmark@@ -34,6 +35,16 @@ ## Individual benchmarks ######################## +# utf8 writing to a file+utf8-io:+	$(GHC) --make -O2 -fforce-recomp -main-is Utf8IO benchmarks/Utf8IO.hs+	time ./benchmarks/Utf8IO via-text    100000000 /dev/null+	time ./benchmarks/Utf8IO text        100000000 /dev/null+	time ./benchmarks/Utf8IO blaze       100000000 /dev/null+	time ./benchmarks/Utf8IO base        100000000 /dev/null+	time ./benchmarks/Utf8IO utf8-light  100000000 /dev/null+	time ./benchmarks/Utf8IO utf8-string 100000000 /dev/null+ # 'blaze-builder' vs. 'binary' comparision bench-blaze-vs-binary: 	$(GHC) --make -O2 -fforce-recomp -main-is BlazeVsBinary benchmarks/BlazeVsBinary.hs@@ -101,6 +112,9 @@ bench-lazy-bytestring: 	$(GHC) --make -O2 -fforce-recomp -ibenchmarks -main-is LazyByteString LazyByteString 	./benchmarks/LazyByteString --resamples 10000++core-lazy-bytestring:+	ghc-core -- --make -O2 -fforce-recomp -ibenchmarks -main-is LazyByteString LazyByteString  # Benchmark benefit of compaction before compression bench-server:

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns, OverloadedStrings #-} -- | -- Module      : LazyByteString -- Copyright   : (c) 2010 Simon Meier@@ -13,20 +13,25 @@ -- implemented with slicing only. module LazyByteString where -- (main)  where +import Data.Char import Data.Word import Data.Monoid  import Data.List  +import Control.Monad+import Control.Arrow (second) import Criterion.Main  import Foreign  import qualified Data.ByteString               as S+import qualified Data.ByteString.Unsafe        as S import qualified Data.ByteString.Internal      as S import qualified Data.ByteString.Lazy          as L import qualified Data.ByteString.Lazy.Internal as L +import Data.ByteString.Base64+ import Blaze.ByteString.Builder.Internal-import Blaze.ByteString.Builder.Write import Blaze.ByteString.Builder.Word import Blaze.ByteString.Builder.ByteString @@ -37,7 +42,38 @@ main :: IO () main = do     let (chunkInfos, benchmarks) = unzip +          {-           [ lazyVsBlaze+              ( "partitionLazy"+              , (uncurry mappend) . L.partition ((0 <) . sin . fromIntegral)+              , (uncurry mappend) . partitionLazy ((0 <) . sin . fromIntegral)+              , (\i -> L.drop 13 $ L.pack $ take i $ cycle [0..])+              , n)+          -}+          {-+          [ lazyVsBlaze+              ( "base64mime"+              , L.fromChunks . return . joinWith "\r\n" 76 . encode+              , toLazyByteString . encodeBase64MIME+              , (\i -> S.drop 13 $ S.pack $ take i $ cycle [0..])+              , n)+          -}+          {-+          [ lazyVsBlaze+              ( "joinWith"+              , L.fromChunks . return . joinWith "\r\n" 76+              , toLazyByteString . intersperseBlocks 76 "\r\n"+              , (\i -> S.drop 13 $ S.pack $ take i $ cycle [0..])+              , n)+          -}+          [ lazyVsBlaze+              ( "base64"+              , L.fromChunks . return . encode+              , toLazyByteString . encodeBase64+              , (\i -> S.drop 13 $ S.pack $ take i $ cycle [0..])+              , n)+          {-+          , lazyVsBlaze               ( "copy"               , L.copy               , copyBlaze@@ -67,6 +103,7 @@               , unfoldrBlaze countToZero               , id               , n )+          -}           ]     sequence_ (intersperse (putStrLn "") chunkInfos)     putStrLn ""@@ -82,8 +119,8 @@          showChunksize implLazy  lazy          showChunksize implBlaze blaze     , bgroup cmpName -        [ mkBench implLazy  lazy-        , mkBench implBlaze blaze+        [ mkBench implBlaze blaze+        , mkBench implLazy  lazy         ]     )   where@@ -145,27 +182,31 @@ fromWriteUnfoldr write =      makeBuilder   where-    makeBuilder f x0 = Builder $ step x0+    makeBuilder f x0 = fromBuildStepCont $ step x0       where         step x1 !k = fill x1           where-            fill x !pf0 !pe0 = go (f x) pf0+            fill x !(BufRange pf0 pe0) = go (f x) pf0               where-                go !Nothing        !pf = k pf pe0+                go !Nothing        !pf = do+                    let !br' = BufRange pf pe0+                    k br'                 go !(Just (y, x')) !pf-                  | pf `plusPtr` size <= pe0 = do-                      io pf-                      go (f x') (pf `plusPtr` size)-                  | otherwise = return $ BufferFull size pf $ \pfNew peNew -> do -                      io pfNew-                      fill x' (pfNew `plusPtr` size) peNew+                  | pf `plusPtr` bound <= pe0 = do+                      !pf' <- runWrite (write y) pf+                      go (f x') pf'+                  | otherwise = return $ bufferFull bound pf $ +                      \(BufRange pfNew peNew) -> do +                          !pfNew' <- runWrite (write y) pfNew+                          fill x' (BufRange pfNew' peNew)                   where-                    !(Write size io) = write y+                    bound = getBound $ write y {-# INLINE fromWriteUnfoldr #-}  -- Filtering and mapping ------------------------ +test :: Int -> (L.ByteString, L.ByteString) test i =      ((L.filter ((==0) . (`mod` 3)) $ x) ,      (filterBlaze ((==0) . (`mod` 3)) $ x))@@ -199,17 +240,17 @@ mapFilterMapByteString :: (Word8 -> Word8) -> (Word8 -> Bool) -> (Word8 -> Word8)                         -> S.ByteString -> Builder mapFilterMapByteString f p g = -    \bs -> Builder $ step bs+    \bs -> fromBuildStepCont $ step bs   where     step (S.PS ifp ioff isize) !k =          goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff)       where         !ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize)-        goBS !ip0 !op0 !ope+        goBS !ip0 !br@(BufRange op0 ope)           | ip0 >= ipe = do touchForeignPtr ifp -- input buffer consumed-                            k op0 ope+                            k br           | op0 < ope  = goPartial (ip0 `plusPtr` min outRemaining inpRemaining)-          | otherwise  = return $ BufferFull 1 op0 (goBS ip0) +          | otherwise  = return $ bufferFull 1 op0 (goBS ip0)            where             outRemaining = ope `minusPtr` op0             inpRemaining = ipe `minusPtr` ip0@@ -223,7 +264,7 @@                         then poke op (f w') >> go (ip `plusPtr` 1) (op `plusPtr` 1)                         else                   go (ip `plusPtr` 1) op                   | otherwise =-                      goBS ip op ope+                      goBS ip (BufRange op ope) {-# INLINE mapFilterMapByteString #-}  mapFilterMapLazyByteString :: (Word8 -> Word8) -> (Word8 -> Bool) -> (Word8 -> Word8) @@ -257,39 +298,43 @@ fromWriteReplicated write =      makeBuilder   where-    makeBuilder !n0 x = Builder $ step +    makeBuilder !n0 x = fromBuildStepCont $ step        where-        Write size io = write x+        bound = getBound $ write x         step !k = fill n0           where-            fill !n1 !pf0 !pe0 = go n1 pf0+            fill !n1 !(BufRange pf0 pe0) = go n1 pf0               where-                go 0 !pf = k pf pe0+                go 0 !pf = do+                    let !br' = BufRange pf pe0+                    k br'                 go n !pf-                  | pf `plusPtr` size <= pe0 = do-                      io pf-                      go (n-1) (pf `plusPtr` size)-                  | otherwise = return $ BufferFull size pf $ \pfNew peNew -> do -                      io pfNew-                      fill (n-1) (pfNew `plusPtr` size) peNew+                  | pf `plusPtr` bound <= pe0 = do+                      pf' <- runWrite (write x) pf+                      go (n-1) pf'+                  | otherwise = return $ bufferFull bound pf $ +                      \(BufRange pfNew peNew) -> do +                          pfNew' <- runWrite (write x) pfNew+                          fill (n-1) (BufRange pfNew' peNew) {-# INLINE fromWriteReplicated #-}  -- FIXME: Output repeated bytestrings for large replications. fromReplicateWord8 :: Int -> Word8 -> Builder fromReplicateWord8 !n0 x = -    Builder $ step+    fromBuildStepCont $ step   where     step !k = fill n0       where-        fill !n !pf !pe-          | n <= 0    = k pf pe+        fill !n !br@(BufRange pf pe)+          | n <= 0    = k br           | pf' <= pe = do               _ <- S.memset pf x (fromIntegral n) -- FIXME: This conversion looses information for 64 bit systems.-              k pf' pe+              let !br' = BufRange pf' pe+              k br'           | otherwise  = do               let !l = pe `minusPtr` pf               _ <- S.memset pf x (fromIntegral l) -- FIXME: This conversion looses information for 64 bit systems.-              return $ BufferFull 1 pe $ fill (n - l)+              return $ bufferFull 1 pe $ fill (n - l)           where             pf' = pf `plusPtr` n {-# INLINE fromReplicateWord8 #-}@@ -370,7 +415,7 @@ ----------  packBlaze :: [Word8] -> L.ByteString-packBlaze = toLazyByteString . fromWrite1List writeWord8+packBlaze = toLazyByteString . fromWriteList writeWord8   -- Reverse@@ -399,7 +444,6 @@ -- copy ------- --- FIXME: Implement wrapping copyBlaze :: L.ByteString -> L.ByteString copyBlaze = toLazyByteString . copyLazyByteString @@ -407,4 +451,332 @@ -- ?? packCString, packCStringLen --------------------------------- +-- joinWith+-------------------------------------------- +intersperseBlocks :: Int -> S.ByteString -> S.ByteString -> Builder+intersperseBlocks blockSize sep (S.PS ifp ioff isize) = +    fromPut $ do+        lastBS <- go (ip0 `plusPtr` ioff) +        unless (S.null lastBS) (putBuilder $ fromByteString lastBS)+  where+    ip0 = unsafeForeignPtrToPtr ifp+    ipe = ip0 `plusPtr` (ioff + isize)+    go !ip +      | ip `plusPtr` blockSize >= ipe =+          return $ S.PS ifp (ip `minusPtr` ip0) (ipe `minusPtr` ip)+      | otherwise = do+          putBuilder $ fromByteString (S.PS ifp (ip `minusPtr` ip0) blockSize)+                       `mappend` fromByteString sep+          go (ip `plusPtr` blockSize)++intersperseLazyBlocks :: Int -> Builder -> L.ByteString -> Builder+intersperseLazyBlocks blockSize sep bs =+    go (splitLazyAt blockSize bs)+  where+    go (pre, suf)+      | L.null suf = fromLazyByteString pre+      | otherwise  = fromLazyByteString pre `mappend` sep `mappend`+                     go (splitLazyAt blockSize suf)++encodeBase64MIME :: S.ByteString -> Builder+encodeBase64MIME =+  intersperseLazyBlocks 76 (fromByteString "\r\n") . toLazyByteString . encodeBase64+++-- test blockwise mapping on base64 encoding+--------------------------------------------++-- | Encode a bytestring using Base64 encoding according to the specification+-- in RFC 4648, <http://www.apps.ietf.org/rfc/rfc4648.html>.+--+-- Note that you need to insert additional linebreaks every 76 bytes using the+-- function @joinWith "\r\n" 76@ in order to achieve the MIME Base64+-- Content-Transfer-Encoding <specified in http://tools.ietf.org/html/rfc2045>.+--+-- TODO implement encoding of lazy bytestrings, implement joinWith+-- functionality, and convencience function for MIME base-64 encoding.+encodeBase64 :: S.ByteString -> Builder+encodeBase64 = encodeLazyBase64 . L.fromChunks . return++encodeLazyBase64 :: L.ByteString -> Builder+encodeLazyBase64 = +    mkBuilder+  where+    mkBuilder bs = fromPut $ do+        remainder <- putWriteLazyBlocks 3 writeBase64 bs +        putBuilder $ complete remainder++    {-# INLINE writeBase64 #-}+    writeBase64 ip = +        exactWrite 4 $ \op -> do+            b0 <- peekByte 0+            b1 <- peekByte 1+            b2 <- peekByte 2+            let w = (b0 `shiftL` 16) .|. (b1 `shiftL` 8) .|. b2+            poke (castPtr $ op            ) =<< enc (w `shiftR` 12)+            poke (castPtr $ op `plusPtr` 2) =<< enc (w .&.   0xfff)+      where+        peekByte :: Int -> IO Word32+        peekByte off = fmap fromIntegral (peekByteOff ip off :: IO Word8)+        +        enc = peekElemOff (unsafeForeignPtrToPtr encodeTable) . fromIntegral++    {-# INLINE complete #-}+    complete bs+      | S.null bs = mempty+      | otherwise = fromWrite $+          exactWrite 4 $ \op -> do+              let poke6Base64 off sh = pokeByteOff op off+                      (alphabet `S.unsafeIndex` fromIntegral (w `shiftR` sh .&. 63))+                  pad off = pokeByteOff op off (fromIntegral $ ord '=' :: Word8)+              poke6Base64 0 18+              poke6Base64 1 12+              if S.length bs == 1 then pad 2 +                                  else poke6Base64 2 8+              pad 3+      where+        getByte :: Int -> Int -> Word32+        getByte i sh = fromIntegral (bs `S.unsafeIndex` i) `shiftL` sh+        w = getByte 0 16 .|. (if S.length bs == 1 then 0 else getByte 1 8)+            +    -- Lookup table trick from Data.ByteString.Base64 by Bryan O'Sullivan+    {-# NOINLINE alphabet #-}+    alphabet :: S.ByteString+    alphabet = S.pack $ [65..90] ++ [97..122] ++ [48..57] ++ [43,47]++    -- FIXME: Check that the implementation of the lookup table aslo works on+    -- big-endian systems.+    {-# NOINLINE encodeTable #-} +    encodeTable :: ForeignPtr Word16+    encodeTable = unsafePerformIO $ do+        fp <- mallocForeignPtrArray 4096+        let ix = fromIntegral . S.index alphabet+        withForeignPtr fp $ \p ->+          sequence_ [ pokeElemOff p (j*64+k) ((ix k `shiftL` 8) .|. ix j)+                    | j <- [0..63], k <- [0..63] ]+        return fp+++-- | Process a bytestring block-wise using a 'Write' action to produce the+-- output per block.+--+-- TODO: Compare speed with 'mapFilterMapByteString'.+{-# INLINE putWriteBlocks #-}+putWriteBlocks :: Int                  -- ^ Block size.+               -> (Ptr Word8 -> Write) -- ^ 'Write' given a pointer to the+                                       --   beginning of the block.+               -> S.ByteString         -- ^ 'S.ByteString' to consume blockwise.+               -> Put S.ByteString     -- ^ 'Put' returning the remaining+                                       --   bytes, which are guaranteed to be+                                       --   fewer than the block size.+putWriteBlocks blockSize write =+    \bs -> putBuildStepCont $ step bs+  where+    step (S.PS ifp ioff isize) !k = +        goBS (unsafeForeignPtrToPtr ifp `plusPtr` ioff)+      where+        !ipe = unsafeForeignPtrToPtr ifp `plusPtr` (ioff + isize)+        goBS !ip0 !br@(BufRange op0 ope)+          | ip0 `plusPtr` blockSize > ipe = do +              touchForeignPtr ifp -- input buffer consumed+              let !bs' = S.PS ifp (ip0 `minusPtr` unsafeForeignPtrToPtr ifp) +                                  (ipe `minusPtr` ip0)+              k bs' br++          | op0 `plusPtr` writeBound < ope  = +              goPartial (ip0 `plusPtr` (blockSize * min outRemaining inpRemaining))++          | otherwise  = return $ bufferFull writeBound op0 (goBS ip0) +          where+            writeBound   = getBound' "putWriteBlocks" write +            outRemaining = (ope `minusPtr` op0) `div` writeBound+            inpRemaining = (ipe `minusPtr` ip0) `div` blockSize++            goPartial !ipeTmp = go ip0 op0+              where+                go !ip !op+                  | ip < ipeTmp = do+                      op' <- runWrite (write ip) op+                      go (ip `plusPtr` blockSize) op'+                  | otherwise =+                      goBS ip (BufRange op ope)+++{-# INLINE putWriteLazyBlocks #-}+putWriteLazyBlocks :: Int                  -- ^ Block size.+                   -> (Ptr Word8 -> Write) -- ^ 'Write' given a pointer to the+                                           --   beginning of the block.+                   -> L.ByteString         -- ^ 'L.ByteString' to consume blockwise.+                   -> Put S.ByteString     -- ^ 'Put' returning the remaining+                                           --   bytes, which are guaranteed to be+                                           --   fewer than the block size.+putWriteLazyBlocks blockSize write =+    go+  where+    go L.Empty          = return S.empty+    go (L.Chunk bs lbs) = do+      bsRem <- putWriteBlocks blockSize write bs+      case S.length bsRem of+        lRem +          | lRem <= 0 -> go lbs+          | otherwise -> do+              let (lbsPre, lbsSuf) = +                      L.splitAt (fromIntegral $ blockSize - lRem) lbs+              case S.concat $ bsRem : L.toChunks lbsPre of+                block@(S.PS bfp boff bsize)+                  | bsize < blockSize -> return block+                  | otherwise         -> do+                      putBuilder $ fromWrite $ +                        write (unsafeForeignPtrToPtr bfp `plusPtr` boff)+                      putLiftIO $ touchForeignPtr bfp+                      go lbsSuf +                          ++------------------------------------------------------------------------------+-- Testing code+------------------------------------------------------------------------------+++chunks3 :: [Word8] -> [Word32]+chunks3 (b0 : b1 : b2 : bs) = +    ((fromIntegral b0 `shiftL` 16) .|. +     (fromIntegral b1 `shiftL`  8) .|. +     (fromIntegral b2            )+    ) : chunks3 bs+chunks3 _                   = []++cmpWriteToLib :: [Word8] -> (L.ByteString, L.ByteString)+cmpWriteToLib bs = +    -- ( toLazyByteString $ fromWriteList write24bitsBase64 $ chunks3 bs+    ( toLazyByteString $ encodeBase64 $ S.pack bs+    , (`L.Chunk` L.empty) $ encode $ S.pack bs )++test3 :: Bool+test3 = uncurry (==) $ cmpWriteToLib $ [0..]++test2 :: L.ByteString +test2 = toLazyByteString $ encodeBase64 $ S.pack [0..]++{- OLD code+ +{-# INLINE poke8 #-}+poke8 :: Word8 -> Ptr Word8 -> IO ()+poke8 = flip poke++-- | @writeBase64 w@ writes the lower @24@ bits as four times 6 bit in+-- little-endian order encoded using the standard alphabeth of Base 64 encoding+-- as defined in <http://www.apps.ietf.org/rfc/rfc4648.html>.+--+{-# INLINE write6bitsBase64 #-}+write6bitsBase64 :: Word32 -> Write+write6bitsBase64 = exactWrite 1  . poke6bitsBase64++{-# INLINE poke6bitsBase64 #-}+poke6bitsBase64 :: Word32 -> Ptr Word8 -> IO ()+poke6bitsBase64 w = poke8 (alphabet `S.unsafeIndex` fromIntegral (w .&. 63))+    {-+    | i <  26   = withOffsets  0 'A'+    | i <  52   = withOffsets 26 'a'+    | i <  62   = withOffsets 52 '0'+    | i == 62   = poke8 $ fromIntegral $ ord '+'+    | otherwise = poke8 $ fromIntegral $ ord '/'+  where+    i :: Int+    i = fromIntegral (w .&. 63)++    {-# INLINE withOffsets #-}+    withOffsets neg pos = poke8 $ fromIntegral (i + ord pos - neg)+    -}++{-# INLINE writePaddedBitsBase64 #-}+writePaddedBitsBase64 :: Bool             -- ^ Only 8 bits have to be output.+                      -> Word32           -- ^ Input whose lower 8 or 16 bits need to be output.+                      -> Write+writePaddedBitsBase64 only8 w =+    write6bitsBase64 (w `shiftr_w32` 18)                         `mappend`+    write6bitsBase64 (w `shiftr_w32` 12)                         `mappend`+    writeIf (const only8) (const $ C8.writeChar '=')+                          (write6bitsBase64 . (`shiftr_w32`  6)) +                          w                                      `mappend`+    C8.writeChar '='++{-# INLINE write24bitsBase64 #-}+write24bitsBase64 :: Word32 -> Write+write24bitsBase64 w = write6bitsBase64 (w `shiftr_w32` 18) `mappend`+                      write6bitsBase64 (w `shiftr_w32` 12) `mappend`+                      write6bitsBase64 (w `shiftr_w32`  6) `mappend`+                      write6bitsBase64 (w                )++-- ASSUMES bits 25 - 31 are zero.+{-# INLINE write24bitsBase64' #-}+write24bitsBase64' :: Word32 -> Write+write24bitsBase64' w = +    exactWrite 4 $ \p -> do+      poke (castPtr p              ) =<< enc (w `shiftR` 12)+      poke (castPtr $ p `plusPtr` 2) =<< enc (w .&.   0xfff)+  where+    {-# INLINE enc #-}+    enc = peekElemOff (unsafeForeignPtrToPtr encodeTable) . fromIntegral++-}++-------------------------------------------------------------------------------+-- A faster split for lazy bytestrings+-------------------------------------------------------------------------------++-- | /O(n\/c)/ 'splitAt' @n xs@ is equivalent to @('take' n xs, 'drop' n xs)@.+splitLazyAt :: Int -> L.ByteString -> (L.ByteString, L.ByteString)+splitLazyAt n cs0+  | n <= 0    = (L.Empty, cs0)+  | otherwise = split cs0+  where+    split L.Empty        = (L.Empty, L.Empty)+    split (L.Chunk c cs)+      | n < len  = case S.splitAt    n         c  of+          (pre, suf) -> (L.Chunk pre L.Empty, L.Chunk suf cs)+      | otherwise = case splitLazyAt (n - len) cs of+          (pre, suf) -> (L.Chunk c   pre    , suf           )+      where+        len = S.length c+++-------------------------------------------------------------------------------+-- A faster partition for strict and lazy bytestrings+-------------------------------------------------------------------------------++{-# INLINE partitionStrict #-}+partitionStrict :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString)+partitionStrict f (S.PS ifp ioff ilen) = +    second S.reverse $ S.inlinePerformIO $ do+        ofp <- S.mallocByteString ilen+        withForeignPtr ifp $ wrapper ofp+  where+    wrapper !ofp !ip0 = +        go (ip0 `plusPtr` ioff) op0 (op0 `plusPtr` ilen)+      where+        op0 = unsafeForeignPtrToPtr ofp++        go !ip !opl !oph+          | oph == opl = return (S.PS ofp 0 olen, S.PS ofp olen (ilen - olen))+          | otherwise  = do+              x <- peek ip+              if f x +                then do poke opl x +                        go (ip `plusPtr` 1) (opl `plusPtr` 1) oph+                else do let oph' = oph `plusPtr` (-1)+                        poke oph' x+                        go (ip `plusPtr` 1) opl               oph'++          where+            olen = opl `minusPtr` op0++{-# INLINE partitionLazy #-}+partitionLazy :: (Word8 -> Bool) -> L.ByteString -> (L.ByteString, L.ByteString)+partitionLazy f = +    L.foldrChunks partitionOne (L.empty, L.empty)+  where+    partitionOne bs (ls, rs) = +        (L.Chunk l ls, L.Chunk r rs)+      where+        (l, r) = partitionStrict f bs

@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Copyright   : (c) 2011 Simon Meier+-- License     : BSD3-style (see LICENSE)+-- +-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Stability   : experimental+-- Portability : tested on GHC only+--+-- Benchmarking IO output speed of writing a string in Utf8 encoding to a file.+module Utf8IO (main)  where++import           Control.Monad+import           Control.Exception (evaluate)++import qualified Codec.Binary.UTF8.Light as Utf8Light++import           Data.Char (chr)+import           Data.Time.Clock+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.UTF8 as Utf8String+import qualified Data.Text.Lazy          as TL+import qualified Data.Text.Lazy.Encoding as TL++import           System.IO+import           System.Environment++import           Blaze.ByteString.Builder           +import           Blaze.ByteString.Builder.Internal (defaultBufferSize)+import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze+++-- | Write using the standard text utf8 encoding function built into 'base'.+writeUtf8_base :: String -> FilePath -> IO ()+writeUtf8_base cs file = +    withFile file WriteMode $ \h -> do+        hSetEncoding h utf8+        hPutStr h cs++-- | Write using utf8 encoding as provided by the 'blaze-builder' library.+writeUtf8_blaze :: String -> FilePath -> IO ()+writeUtf8_blaze cs file = L.writeFile file $ toLazyByteString $ Blaze.fromString cs++-- | Write using utf8 encoding as provided by the 'text' library.+writeUtf8_text :: TL.Text -> FilePath -> IO ()+writeUtf8_text tx file = L.writeFile file $ TL.encodeUtf8 tx++-- | Write using utf8 encoding as provided by the 'utf8-string' library.+writeUtf8_string :: String -> FilePath -> IO ()+writeUtf8_string cs file = L.writeFile file $ Utf8String.fromString cs++-- | Write using utf8 encoding as provided by the 'utf8-light' library. Note+-- that this library only allows encoding the whole string as a strict+-- bytestring. That might make it unusable in some circumstances.+{-# NOINLINE writeUtf8_light #-}+writeUtf8_light :: String -> FilePath -> IO ()+writeUtf8_light cs file = Utf8Light.writeUTF8File file cs+++main :: IO ()+main = do+    [how, len, file] <- getArgs+    let blocksize = 32000+        block     = map chr [0..blocksize]+        n         = read len+        cs        = take n $ cycle $ block+        tx        = TL.pack cs+    writer <- case how of+        "base"        -> return $ writeUtf8_base cs+        "blaze"       -> return $ writeUtf8_blaze cs+        "utf8-string" -> return $ writeUtf8_string cs++        -- utf8-light is missing support for lazy bytestrings => test 100 times+        -- writing a 100 times smaller string to avoid out-of-memory errors.+        "utf8-light"  -> return $ \f -> sequence_ $ replicate 100 $ +                                        writeUtf8_light (take (n `div` 100) cs) f++        "via-text"    -> do return $ writeUtf8_text tx++        -- Here, we ensure that the text tx is already packed before timing.+        "text"        -> do _ <- evaluate (TL.length tx) +                            return $ writeUtf8_text tx+        _             -> error $ "unknown writer '" ++ how ++ "'"+    t <- timed_ $ writer file+    putStrLn $ how ++ ": " ++ show t++------------------------------------------------------------------------------+-- Timing+------------------------------------------------------------------------------++-- | Execute an IO action and return its result plus the time it took to execute it.+timed :: IO a -> IO (a, NominalDiffTime)+timed io = do+  t0 <- getCurrentTime+  x <- io+  t1 <- getCurrentTime+  return (x, diffUTCTime t1 t0)++-- | Execute an IO action and return the time it took to execute it.+timed_ :: IO a -> IO NominalDiffTime+timed_ = (snd `liftM`) . timed+

@@ -1,5 +1,5 @@ Name:                blaze-builder-Version:             0.2.1.4+Version:             0.3.0.0 Synopsis:            Efficient buffered output.  Description: