Move Builder back into its own module. Its useful just as ShowS is
authorDon Stewart <dons@cse.unsw.edu.au>
Tue, 16 Jan 2007 16:46:43 +0000 (17:46 +0100)
committerDon Stewart <dons@cse.unsw.edu.au>
Tue, 16 Jan 2007 16:46:43 +0000 (17:46 +0100)
binary.cabal
src/Data/Binary/Builder.hs [new file with mode: 0644]
src/Data/Binary/Get.hs
src/Data/Binary/Put.hs
tests/Makefile

index fc0b85b..a212fde 100644 (file)
@@ -8,7 +8,8 @@ build-depends:   base, mtl
 -- ghc 6.4 also needs package fps
 exposed-modules: Data.Binary,
                  Data.Binary.Put,
-                 Data.Binary.Get
+                 Data.Binary.Get,
+                 Data.Binary.Builder
 extensions:      ForeignFunctionInterface,CPP,FlexibleInstances
 hs-source-dirs:  src
 ghc-options:     -O2 -optc-O3 -Wall -Werror -fliberate-case-threshold=100
diff --git a/src/Data/Binary/Builder.hs b/src/Data/Binary/Builder.hs
new file mode 100644 (file)
index 0000000..4de1ba8
--- /dev/null
@@ -0,0 +1,257 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      : Data.Binary.Put
+-- Copyright   : Ross Paterson
+-- License     : BSD3-style (see LICENSE)
+-- 
+-- Maintainer  : Lennart Kolmodin <kolmodin@dtek.chalmers.se>
+-- Stability   : stable
+-- Portability : Portable to Hugs and GHC. Requires MPTCs
+--
+-- The Builder monoid for efficiently constructing lazy bytestrings.
+--
+-----------------------------------------------------------------------------
+
+module Data.Binary.Builder (
+
+    -- * The Builder type
+      Builder
+    , runBuilder
+
+    -- * Builder operations
+    , empty
+    , singleton
+    , append
+
+    -- * Support for ByteStrings
+    , putByteString         -- :: S.ByteString -> Builder
+    , putLazyByteString     -- :: L.ByteString -> Builder
+
+    -- * Big-endian primitive writes
+    , putWord16be           -- :: Word16 -> Builder
+    , putWord32be           -- :: Word32 -> Builder
+    , putWord64be           -- :: Word64 -> Builder
+
+    -- * Little-endian primitive writes
+    , putWord16le           -- :: Word16 -> Builder
+    , putWord32le           -- :: Word32 -> Builder
+    , putWord64le           -- :: Word64 -> Builder
+
+    -- * Flushing the buffer state
+    , flush
+
+  ) where
+
+import Foreign
+import Data.Monoid
+import Data.Word
+import Data.ByteString.Base (inlinePerformIO)
+import qualified Data.ByteString.Base as S
+import qualified Data.ByteString.Lazy as L
+
+------------------------------------------------------------------------
+
+-- | The 'Builder' monoid abstracts over the construction of a lazy
+-- bytestring by filling byte arrays piece by piece.  As each buffer is
+-- filled, it is \'popped\' off, to become a new chunk of the resulting
+-- lazy 'L.ByteString'.  All this is hidden from the user of the
+-- 'Builder'.
+--
+-- Properties:
+--
+--  * @'runBuilder' 'empty'                  = 'L.empty'@
+--
+--  * @'runBuilder' ('append' x y)           = 'L.append' ('runBuilder' x) ('runBuilder' y)@
+--
+--  * @'runBuilder' ('singleton' b)          = 'L.singleton' b@
+--
+--  * @'runBuilder' ('putByteString' bs)     = 'L.fromChunks' [bs]@
+--
+--  * @'runBuilder' ('putLazyByteString' bs) = bs@
+--
+newtype Builder = Builder {
+        unBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString]
+    }
+
+instance Monoid Builder where
+    mempty = empty
+    mappend = append
+
+-- | The empty Builder
+empty :: Builder
+empty = Builder id
+
+-- | Write a byte into the Builder's output buffer
+singleton :: Word8 -> Builder
+singleton = writeN 1 . flip poke
+
+-- | Append two Builders
+append :: Builder -> Builder -> Builder
+append (Builder f) (Builder g) = Builder (f . g)
+
+------------------------------------------------------------------------
+
+-- Our internal buffer type
+data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)
+                     {-# UNPACK #-} !Int                -- offset
+                     {-# UNPACK #-} !Int                -- used bytes
+                     {-# UNPACK #-} !Int                -- length left
+
+------------------------------------------------------------------------
+
+--
+-- | Run the builder monoid
+--
+runBuilder :: Builder -> L.ByteString
+runBuilder m = S.LPS $ inlinePerformIO $ do
+    buf <- newBuffer defaultSize
+    return (unBuilder (m `append` flush) (const []) buf)
+
+-- | Pop the ByteString we have constructed so far, if any, yielding a
+-- new chunk in the result ByteString.
+flush :: Builder
+flush = Builder $ \ k buf@(Buffer p o u l) ->
+    if u == 0
+      then k buf
+      else S.PS p o u : k (Buffer p (o+u) 0 l)
+
+------------------------------------------------------------------------
+
+--
+-- copied from Data.ByteString.Lazy
+--
+defaultSize :: Int
+defaultSize = 32 * k - overhead
+    where k = 1024
+          overhead = 2 * sizeOf (undefined :: Int)
+
+------------------------------------------------------------------------
+
+-- | Sequence an IO operation on the buffer
+unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder
+unsafeLiftIO f =  Builder $ \ k buf -> inlinePerformIO $ do
+    buf' <- f buf
+    return (k buf')
+{-# INLINE unsafeLiftIO #-}
+
+-- | Get the size of the buffer
+withSize :: (Int -> Builder) -> Builder
+withSize f = Builder $ \ k buf@(Buffer _ _ _ l) ->
+    unBuilder (f l) k buf
+
+-- | Map the resulting list of bytestrings.
+mapBuilder :: ([S.ByteString] -> [S.ByteString]) -> Builder
+mapBuilder f = Builder (f .)
+
+------------------------------------------------------------------------
+
+-- | Ensure that there are at least @n@ many bytes available.
+ensureFree :: Int -> Builder
+ensureFree n = n `seq` withSize $ \ l ->
+    if n <= l then empty else
+        flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize)))
+{-# INLINE [1] ensureFree #-}
+
+-- | Ensure that @n@ many bytes are available, and then use @f@ to write some
+-- bytes into the memory.
+writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder
+writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f)
+{-# INLINE [1] writeN #-}
+
+writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer
+writeNBuffer n f (Buffer fp o u l) = do
+    withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))
+    return (Buffer fp o (u+n) (l-n))
+
+newBuffer :: Int -> IO Buffer
+newBuffer size = do
+    fp <- S.mallocByteString size
+    return $! Buffer fp 0 0 size
+
+------------------------------------------------------------------------
+
+-- | Write a strict ByteString efficiently
+putByteString :: S.ByteString -> Builder
+putByteString bs = flush `append` mapBuilder (bs :)
+
+-- | Write a lazy ByteString efficiently 
+putLazyByteString :: L.ByteString -> Builder
+putLazyByteString bs = flush `append` mapBuilder (L.toChunks bs ++)
+
+------------------------------------------------------------------------
+
+-- | Write a Word16 in big endian format
+putWord16be :: Word16 -> Builder
+putWord16be w16 =
+    let w1 = shiftR w16 8
+        w2 = w16 .&. 0xff
+    in
+    singleton (fromIntegral w1) `append`
+    singleton (fromIntegral w2)
+{-# INLINE putWord16be #-}
+
+-- | Write a Word16 in little endian format
+putWord16le :: Word16 -> Builder
+-- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16)
+
+putWord16le w16 =
+    let w2 = shiftR w16 8
+        w1 = w16 .&. 0xff
+    in
+    singleton (fromIntegral w1) `append`
+    singleton (fromIntegral w2)
+{-# INLINE putWord16le #-}
+
+-- | Write a Word32 in big endian format
+putWord32be :: Word32 -> Builder
+putWord32be w32 =
+    let w1 = (w32 `shiftR` 24)
+        w2 = (w32 `shiftR` 16) .&. 0xff
+        w3 = (w32 `shiftR`  8) .&. 0xff
+        w4 =  w32              .&. 0xff
+    in
+    singleton (fromIntegral w1) `append`
+    singleton (fromIntegral w2) `append`
+    singleton (fromIntegral w3) `append`
+    singleton (fromIntegral w4)
+{-# INLINE putWord32be #-}
+
+-- | Write a Word32 in little endian format
+putWord32le :: Word32 -> Builder
+putWord32le w32 =
+    let w4 = (w32 `shiftR` 24)
+        w3 = (w32 `shiftR` 16) .&. 0xff
+        w2 = (w32 `shiftR`  8) .&. 0xff
+        w1 =  w32              .&. 0xff
+    in
+    singleton (fromIntegral w1) `append`
+    singleton (fromIntegral w2) `append`
+    singleton (fromIntegral w3) `append`
+    singleton (fromIntegral w4)
+{-# INLINE putWord32le #-}
+
+-- on a little endian machine:
+-- putWord32le w32 = writeN 4 (\p -> poke (castPtr p) w32)
+
+-- | Write a Word64 in big endian format
+putWord64be :: Word64 -> Builder
+putWord64be w64 =
+    let w1 = shiftR w64 32
+        w2 = w64 .&. 0xffffffff
+    in
+    putWord32be (fromIntegral w1) `append`
+    putWord32be (fromIntegral w2)
+{-# INLINE putWord64be #-}
+
+-- | Write a Word64 in little endian format
+putWord64le :: Word64 -> Builder
+putWord64le w64 =
+    let w2 = shiftR w64 32
+        w1 = w64 .&. 0xffffffff
+    in
+    putWord32le (fromIntegral w1) `append`
+    putWord32le (fromIntegral w2)
+{-# INLINE putWord64le #-}
+
+-- on a little endian machine:
+-- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64)
index ad2dd2b..e5dc90c 100644 (file)
@@ -52,6 +52,7 @@ import GHC.Word
 import GHC.Int
 #endif
 
+-- | The parse state
 data S = S {-# UNPACK #-} !L.ByteString  -- the rest of the input
            {-# UNPACK #-} !Int64        -- bytes read
 
@@ -63,7 +64,6 @@ instance Monad Get where
     (Get m) >>= k = Get (m >>= unGet . k)
     fail          = failDesc
 
-
 instance MonadState S Get where
     get         = Get get
     put f       = Get (put f)
@@ -103,7 +103,7 @@ ensureLeft n = do
   where
     worker :: Int -> [B.ByteString] -> Get ()
     worker i _ | i <= 0 = return ()
-    worker i []         = 
+    worker i []         =
         fail $ "Data.Binary.Get.ensureLeft: End of input. Wanted "
                  ++ show n ++ " bytes, found " ++ show (n - i) ++ "."
     worker i (x:xs)     = worker (i - fromIntegral (B.length x)) xs
@@ -239,13 +239,3 @@ unsafeShiftL_W32 (W32# x#) (I# i#) = W32# (narrow32Word# (x# `shiftL#` i#))
 unsafeShiftL_W16 = shiftL
 unsafeShiftL_W32 = shiftL
 #endif
-
-
-------------------------------------------------------------------------
-
-{-# TRICKY RULES
- "ensureLeft/combine" forall a b.
-        ensureLeft a >> ensureLeft b = ensureLeft (max a b)
- #-}
-
-{-# TRICKY RULES "readN/combine" forall s1 s2 f1 f2 k.  readN s1 f1 >>= \w1 -> readN s2 f2 >>= \w2 -> k = readN (s1+s2) (\s -> f1 s >>= \w1 -> f2 (L.drop s1 s)) #-}
index 3bd2565..4dcd73e 100644 (file)
@@ -38,16 +38,19 @@ module Data.Binary.Put (
 
   ) where
 
-import Control.Monad.Writer
+import Data.Binary.Builder (Builder, runBuilder)
+import qualified Data.Binary.Builder as B
 
-import Foreign
+import Control.Monad.Writer
 
-import Data.Monoid
 import Data.Word
-import Data.ByteString.Base (inlinePerformIO)
 import qualified Data.ByteString.Base as S
 import qualified Data.ByteString.Lazy as L
 
+------------------------------------------------------------------------
+
+-- | The Put types. A Writer monad over the efficient Builder monoid
+-- Put merely lifts Builder into a Monad
 type Put = Writer Builder ()
 
 -- | Run the 'Put' monad with a serialiser
@@ -57,259 +60,42 @@ runPut              = runBuilder . execWriter
 -- | Pop the ByteString we have constructed so far, if any, yielding a
 -- new chunk in the result ByteString.
 flush               :: Put
-flush               = tell flushB
+flush               = tell B.flush
 
+-- | Efficiently write a byte into the output buffer
 putWord8            :: Word8 -> Put
-putWord8            = tell . singleton
+putWord8            = tell . B.singleton
 
 -- | An efficient primitive to write a strict ByteString into the output buffer.
 -- It flushes the current buffer, and writes the argument into a new chunk.
 putByteString       :: S.ByteString -> Put
-putByteString       = tell . putByteStringB
+putByteString       = tell . B.putByteString
 
 -- | Write a lazy ByteString efficiently, simply appending the lazy
 -- ByteString chunks to the output buffer
 putLazyByteString   :: L.ByteString -> Put
-putLazyByteString   = tell . putLazyByteStringB
+putLazyByteString   = tell . B.putLazyByteString
 
 -- | Write a Word16 in big endian format
 putWord16be         :: Word16 -> Put
-putWord16be         = tell . putWord16beB
+putWord16be         = tell . B.putWord16be
 
 -- | Write a Word16 in little endian format
 putWord16le         :: Word16 -> Put
-putWord16le         = tell . putWord16leB
+putWord16le         = tell . B.putWord16le
 
 -- | Write a Word32 in big endian format
 putWord32be         :: Word32 -> Put
-putWord32be         = tell . putWord32beB
+putWord32be         = tell . B.putWord32be
 
 -- | Write a Word32 in little endian format
 putWord32le         :: Word32 -> Put
-putWord32le         = tell . putWord32leB
+putWord32le         = tell . B.putWord32le
 
 -- | Write a Word64 in big endian format
 putWord64be         :: Word64 -> Put
-putWord64be         = tell . putWord64beB
+putWord64be         = tell . B.putWord64be
 
 -- | Write a Word64 in little endian format
 putWord64le         :: Word64 -> Put
-putWord64le         = tell . putWord64leB
-
--- ---------------------------------------------------------------------
---
--- | The Builder monoid for efficiently constructing lazy bytestrings.
---
-
-data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)
-                     {-# UNPACK #-} !Int                -- offset
-                     {-# UNPACK #-} !Int                -- used bytes
-                     {-# UNPACK #-} !Int                -- length left
-
--- | The 'Builder' monoid abstracts over the construction of a lazy
--- bytestring by filling byte arrays piece by piece.  As each buffer is
--- filled, it is \'popped\' off, to become a new chunk of the resulting
--- lazy 'L.ByteString'.  All this is hidden from the user of the
--- 'Builder'.
---
--- Properties:
---
---  * @'runBuilder' 'empty' = 'L.empty'@
---
---  * @'runBuilder' ('append' x y) = 'L.append' ('runBuilder' x) ('runBuilder' y)@
---
---  * @'runBuilder' ('singleton' b) = 'L.singleton' b@
---
---  * @'runBuilder' ('putByteStringB' bs) = 'L.fromChunks' [bs]@
---
---  * @'runBuilder' ('putLazyByteStringB' bs) = bs@
---
-newtype Builder = Builder {
-        unBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString]
-    }
-
-instance Monoid Builder where
-    mempty = empty
-    mappend = append
-
-empty :: Builder
-empty = Builder id
-
-append :: Builder -> Builder -> Builder
-append (Builder f) (Builder g) = Builder (f . g)
-
---
--- copied from Data.ByteString.Lazy
---
-defaultSize :: Int
-defaultSize = 32 * k - overhead
-    where k = 1024
-          overhead = 2 * sizeOf (undefined :: Int)
-
---
--- Run the builder monoid
---
-runBuilder :: Builder -> L.ByteString
-runBuilder m = S.LPS $ inlinePerformIO $ do
-    buf <- newBuffer defaultSize
-    return (unBuilder (m `append` flushB) (const []) buf)
-
--- | Sequence an IO operation on the buffer
-unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder
-unsafeLiftIO f =  Builder $ \ k buf -> inlinePerformIO $ do
-    buf' <- f buf
-    return (k buf')
-{-# INLINE unsafeLiftIO #-}
-
--- | Get the size of the buffer
-withSize :: (Int -> Builder) -> Builder
-withSize f = Builder $ \ k buf@(Buffer _ _ _ l) ->
-    unBuilder (f l) k buf
-
--- | Map the resulting list of bytestrings.
-mapBuilder :: ([S.ByteString] -> [S.ByteString]) -> Builder
-mapBuilder f = Builder (f .)
-
--- | Pop the ByteString we have constructed so far, if any, yielding a
--- new chunk in the result ByteString.
-flushB :: Builder
-flushB = Builder $ \ k buf@(Buffer p o u l) ->
-    if u == 0
-      then k buf
-      else S.PS p o u : k (Buffer p (o+u) 0 l)
-
--- | Ensure that there are at least @n@ many bytes available.
-ensureFree :: Int -> Builder
-ensureFree n = n `seq` withSize $ \ l ->
-    if n <= l then empty else
-        flushB `append` unsafeLiftIO (const (newBuffer (max n defaultSize)))
-{-# INLINE [1] ensureFree #-}
-
--- | Ensure that @n@ many bytes are available, and then use @f@ to write some
--- bytes into the memory.
-writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder
-writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f)
-{-# INLINE [1] writeN #-}
-
-writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer
-writeNBuffer n f (Buffer fp o u l) = do
-    withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))
-    return (Buffer fp o (u+n) (l-n))
-
-newBuffer :: Int -> IO Buffer
-newBuffer size = do
-    fp <- S.mallocByteString size
-    return $! Buffer fp 0 0 size
-
-------------------------------------------------------------------------
-
--- | Write a byte into the Builder's output buffer
-singleton :: Word8 -> Builder
-singleton = writeN 1 . flip poke
-{-# INLINE [1] putWord8 #-}
-
--- | Write a strict ByteString efficiently
-putByteStringB :: S.ByteString -> Builder
-putByteStringB bs = flushB `append` mapBuilder (bs :)
-
--- | Write a lazy ByteString efficiently 
-putLazyByteStringB :: L.ByteString -> Builder
-putLazyByteStringB bs = flushB `append` mapBuilder (L.toChunks bs ++)
-
-------------------------------------------------------------------------
-
--- | Write a Word16 in big endian format
-putWord16beB :: Word16 -> Builder
-putWord16beB w16 =
-    let w1 = shiftR w16 8
-        w2 = w16 .&. 0xff
-    in
-    singleton (fromIntegral w1) `append`
-    singleton (fromIntegral w2)
-{-# INLINE putWord16be #-}
-
--- | Write a Word16 in little endian format
-putWord16leB :: Word16 -> Builder
--- putWord16leB w16 = writeN 2 (\p -> poke (castPtr p) w16)
-
-putWord16leB w16 =
-    let w2 = shiftR w16 8
-        w1 = w16 .&. 0xff
-    in
-    singleton (fromIntegral w1) `append`
-    singleton (fromIntegral w2)
-{-# INLINE putWord16le #-}
-
--- | Write a Word32 in big endian format
-putWord32beB :: Word32 -> Builder
-putWord32beB w32 =
-    let w1 = (w32 `shiftR` 24)
-        w2 = (w32 `shiftR` 16) .&. 0xff
-        w3 = (w32 `shiftR`  8) .&. 0xff
-        w4 =  w32              .&. 0xff
-    in
-    singleton (fromIntegral w1) `append`
-    singleton (fromIntegral w2) `append`
-    singleton (fromIntegral w3) `append`
-    singleton (fromIntegral w4)
-{-# INLINE putWord32be #-}
-
--- | Write a Word32 in little endian format
-putWord32leB :: Word32 -> Builder
-putWord32leB w32 =
-
--- on a little endian machine:
--- putWord32leB w32 = writeN 4 (\p -> poke (castPtr p) w32)
-
-    let w4 = (w32 `shiftR` 24)
-        w3 = (w32 `shiftR` 16) .&. 0xff
-        w2 = (w32 `shiftR`  8) .&. 0xff
-        w1 =  w32              .&. 0xff
-    in
-    singleton (fromIntegral w1) `append`
-    singleton (fromIntegral w2) `append`
-    singleton (fromIntegral w3) `append`
-    singleton (fromIntegral w4)
-{-# INLINE putWord32le #-}
-
--- | Write a Word64 in big endian format
-putWord64beB :: Word64 -> Builder
-putWord64beB w64 =
-    let w1 = shiftR w64 32
-        w2 = w64 .&. 0xffffffff
-    in
-    putWord32beB (fromIntegral w1) `append`
-    putWord32beB (fromIntegral w2)
-{-# INLINE putWord64be #-}
-
--- | Write a Word64 in little endian format
-putWord64leB :: Word64 -> Builder
-
--- on a little endian machine:
--- putWord64leB w64 = writeN 8 (\p -> poke (castPtr p) w64)
-
-putWord64leB w64 =
-    let w2 = shiftR w64 32
-        w1 = w64 .&. 0xffffffff
-    in
-    putWord32leB (fromIntegral w1) `append`
-    putWord32leB (fromIntegral w2)
-{-# INLINE putWord64le #-}
-
-------------------------------------------------------------------------
--- Some nice rules for Builder
-
-{-# TRICKY RULES
-
-"writeN/combine" forall s1 s2 f1 f2 .
-        bindP (writeN s1 f1) (writeN s2 f2) =
-        writeN (s1+s2) (\p -> f1 p >> f2 (p `plusPtr` s1))
-
-"ensureFree/combine" forall a b .
-        bindP (ensureFree a) (ensureFree b) =
-        ensureFree (max a b)
-
-"flush/combine"
-        bindP flush flush = flush
-
- #-}
+putWord64le         = tell . B.putWord64le
index 35586af..3d4ae6c 100644 (file)
@@ -4,7 +4,7 @@ interpreted:
        runhaskell QC.hs 1000
 
 compiled:
-       ghc -prof-auto-all --make -O QC.hs -o qc -no-recomp
+       ghc -prof -auto-all --make -O QC.hs -o qc -no-recomp
        time ./qc 1000
 
 bench::