bspack 0.0.2 → 0.0.3

raw patch · 6 files changed

+356/−69 lines, 6 filesdep +blaze-builderdep +criteriondep +ghc-primPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: blaze-builder, criterion, ghc-prim

API changes (from Hackage documentation)

Files

• Data/ByteString/Pack.hs +20/−62
• Data/ByteString/Pack/Base32.hs +140/−0
• Data/ByteString/Pack/Internal.hs +83/−0
• Tests/Bench.hs +86/−0
• Tests/Tests.hs +9/−0
• bspack.cabal +18/−7

@@ -8,25 +8,30 @@ -- Portability : unknown -- -- Simple ByteString packer+--+-- > > either error id $ flip pack 20 $ putWord8 0x41 >> putByteString "BCD" >> putWord8 0x20 >> putStorable (42 :: Word32)+-- > ABCD *\NUL\NUL\NUL" module Data.ByteString.Pack     ( Packer     , Result(..)     , pack       -- * Operations       -- ** put+    , putWord8+    , putWord16+    , putWord32     , putStorable     , putByteString     , fillList     , fillUpWith-    , putWord8-    , putWord16-    , putWord32+      -- *** Encoding+    , putByteStringBase32+    , guessEncodedLength       -- ** skip     , skip     , skipStorable     ) where -import Control.Applicative import Data.ByteString.Internal (ByteString(..)) import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B@@ -36,55 +41,8 @@ import Foreign.Storable import System.IO.Unsafe (unsafePerformIO) --- A little cache to update the data-data Cache = Cache {-# UNPACK #-} !(Ptr Word8) -- pointer in the bytestring-                   {-# UNPACK #-} !Int         -- remaining size--instance Show Cache where-    show (Cache _ l) = show l---- | Packing result:------ * PackerOK a -> means the bytestring has been filled with the given data--- * PackerMore a cache -> a temporary -data Result a =-      PackerMore a Cache-    | PackerFail String-  deriving (Show)---- | Simple Bytestring Packer-newtype Packer a = Packer { runPacker_ :: Cache -> IO (Result a) }--instance Functor Packer where-    fmap = fmapPacker--instance Applicative Packer where-    pure = returnPacker-    (<*>) = appendPacker--instance Monad Packer where-    return = returnPacker-    (>>=) = bindPacker--fmapPacker :: (a -> b) -> Packer a -> Packer b-fmapPacker f p = Packer $ \cache -> do-    rv <- runPacker_ p cache-    return $ case rv of-        PackerMore v cache' -> PackerMore (f v) cache'-        PackerFail err      -> PackerFail err--returnPacker :: a -> Packer a-returnPacker v = Packer $ \cache -> return $ PackerMore v cache--bindPacker :: Packer a -> (a -> Packer b) -> Packer b-bindPacker p fp = Packer $ \cache -> do-    rv <- runPacker_ p cache-    case rv of-        PackerMore v cache' -> runPacker_ (fp v) cache'-        PackerFail err      -> return $ PackerFail err--appendPacker :: Packer (a -> b) -> Packer a -> Packer b-appendPacker p1f p2 = p1f >>= \p1 -> p2 >>= \v -> return (p1 v)+import Data.ByteString.Pack.Internal+import Data.ByteString.Pack.Base32  -- | pack the given packer into the given bytestring pack :: Packer a -> Int -> Either String ByteString@@ -97,20 +55,15 @@             PackerMore _ (Cache _ r) -> Right (PS fptr 0 (len - r))             PackerFail err           -> Left err --- run a sized action-actionPacker :: Int -> (Ptr Word8 -> IO a) -> Packer a-actionPacker s action = Packer $ \(Cache ptr size) ->-    case compare size s of-        LT -> return $ PackerFail "Not enough space in destination"-        _  -> do-            v <- action ptr-            return $ PackerMore v (Cache (ptr `plusPtr` s) (size - s))+fillUpWithWord8' :: Word8 -> Packer ()+fillUpWithWord8' w = Packer $ \(Cache ptr size) -> do+    _ <- B.memset ptr w (fromIntegral size)+    return $ PackerMore () (Cache (ptr `plusPtr` size) (0))  -- | put a storable from the current position in the stream putStorable :: Storable storable => storable -> Packer () putStorable s = actionPacker (sizeOf s) (\ptr -> poke (castPtr ptr) s) - -- | put a Bytestring from the current position in the stream -- -- If the ByteString ins null, then do nothing@@ -141,6 +94,8 @@ -- > fillUpWith s == fillList (repeat s) fillUpWith :: Storable storable => storable -> Packer () fillUpWith s = fillList $ repeat s+{-# RULES "fillUpWithWord8" forall s . fillUpWith s = fillUpWithWord8' s #-}+{-# NOINLINE fillUpWith #-}  -- | Will put the given storable list from the current position in the stream -- to the end.@@ -165,13 +120,16 @@ -- | put Word8 in the current position in the stream putWord8 :: Word8 -> Packer () putWord8 = putStorable+{-# INLINE putWord8 #-}  -- | put Word16 in the current position in the stream -- /!\ use Host Endianness putWord16 :: Word16 -> Packer () putWord16 = putStorable+{-# INLINE putWord16 #-}  -- | put Word32 in the current position in the stream -- /!\ use Host Endianness putWord32 :: Word32 -> Packer () putWord32 = putStorable+{-# INLINE putWord32 #-}

@@ -0,0 +1,140 @@+-- |+-- Module      : Data.ByteString.Pack.Base32+-- License     : BSD-Style+-- Copyright   : Copyright © 2014 Nicolas DI PRIMA+--+-- Maintainer  : Nicolas DI PRIMA <nicolas@di-prima.fr>+-- Stability   : experimental+-- Portability : unknown+--+-- Base32 converstion (see RFC4648)+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+module Data.ByteString.Pack.Base32+    ( putByteStringBase32+    , guessEncodedLength+    ) where++import           Control.Monad (void)+import           Data.Bits+import qualified Data.ByteString          as B+import           Data.ByteString.Internal as B+import           Data.ByteString.Pack.Internal+import           Foreign.ForeignPtr (withForeignPtr)+import           Foreign.Ptr+import           Foreign.Storable+import           GHC.Prim+import           GHC.Types+import           GHC.Word++-- | convert the given bytestring in base 32+putByteStringBase32 :: ByteString -> Packer ()+putByteStringBase32 bs+    | neededLength == 0 = return ()+    | otherwise         = actionPacker neededLength (actionPackerEncode32 bs)+  where+    sourceLength :: Int+    sourceLength = B.length bs+    neededLength :: Int+    neededLength = guessEncodedLength sourceLength++    actionPackerEncode32 :: ByteString -> Ptr Word8 -> IO ()+    actionPackerEncode32 (PS srcfptr off _) dstptr = do+        withForeignPtr srcfptr $ \srcptr ->+            encode32Ptr (srcptr `plusPtr` off) dstptr sourceLength neededLength (0x00, 0)++encode32Ptr :: Ptr Word8 -> Ptr Word8 -> Int -> Int -> (Word8, Int) -> IO ()+-- OK: all the bytes have been consumned, the Cache has been flushed+encode32Ptr _       !dstptr  0  0 (!bits, !size) = void $ flush dstptr (bits, size)+encode32Ptr _       !dstptr  0 !k (!bits, !size) = do+    _ <- flush dstptr (bits, size)+    _ <- B.memset (dstptr `plusPtr` 1) 0x3d (fromIntegral $ k - 1)+    return ()+-- OK: consume the byte and iterate+encode32Ptr !srcptr !dstptr !n !k (!bits, !size) = do+    w <- peek srcptr+    case size of+        0 -> flush dstptr (bufferize w 1 5 (bits, size)) >>= encodeNext 1 1 . bufferize w 6 8+        1 -> flush dstptr (bufferize w 1 4 (bits, size)) >>= encodeNext 1 1 . bufferize w 5 8+        2 -> flush dstptr (bufferize w 1 3 (bits, size)) >>= flush (dstptr `plusPtr` 1) . bufferize w 4 8 >>= encodeNext 1 2+        3 -> flush dstptr (bufferize w 1 2 (bits, size)) >>= flush (dstptr `plusPtr` 1) . bufferize w 3 7 >>= encodeNext 1 2 . bufferize w 8 8+        4 -> flush dstptr (bufferize w 1 1 (bits, size)) >>= flush (dstptr `plusPtr` 1) . bufferize w 2 6 >>= encodeNext 1 2 . bufferize w 7 8+        _ -> undefined+  where+    encodeNext :: Int -> Int -> (Word8, Int) -> IO ()+    encodeNext !srcoff !dstoff = encode32Ptr (srcptr `plusPtr` srcoff) (dstptr `plusPtr` dstoff) (n - srcoff) (k - dstoff)+    {-# INLINE encodeNext #-}+                 +flush :: Ptr Word8 -> (Word8, Int) -> IO (Word8, Int)+flush !ptr (!w, _) = do+    poke ptr (toBase32 $ fromIntegral w)+    return (0, 0)+{-# INLINE flush #-}++bufferize :: Word8+          -> Int+          -> Int+          -> (Word8, Int)+          -> (Word8, Int)+bufferize !w !from !to (!bits, !nbRead) = (newBits, newNbRead)+  where+    newBits :: Word8+    newBits = bits .|. (((w `shiftR` shifterR) .&. mask) `shiftL` shifterL)+    newNbRead :: Int+    newNbRead = nbRead + size++    shifterR :: Int+    shifterR = 8 - to+    shifterL :: Int+    shifterL = 5 - size - nbRead++    size :: Int+    size = to - from + 1+    mask :: Word8+    mask = getMask size+{-# INLINE bufferize #-}++-- | return the maximum needed length to convert in Base32+guessEncodedLength :: Int -- ^ the lenght of the Bytestring to convert into base32+                   -> Int+guessEncodedLength 0 = 0+guessEncodedLength l+  | modulo == 0 = 8 * l `div` 5+  | otherwise   = 8 * (l + 5 - modulo) `div` 5+  where+    modulo :: Int+    modulo = l `mod` 5++------------------------------------------------------------------------------+--                                Helpers                                   --+------------------------------------------------------------------------------++getMask :: Int -> Word8+getMask !n =+  case n of+    0 -> 0x00 -- 0000 0000+    1 -> 0x01 -- 0000 0001+    2 -> 0x03 -- 0000 0011+    3 -> 0x07 -- 0000 0111+    4 -> 0x0F -- 0000 1111+    5 -> 0x1F -- 0001 1111+    6 -> 0x3F -- 0011 1111+    7 -> 0x7F -- 0111 1111+    _ -> 0xFF -- 1111 1111++toBase32 :: Word8 -> Word8+toBase32 !w+  | index < 32 = W8# (indexWord8OffAddr# addr i)+  | otherwise  = error $ "toWord8: bad input: cannot convert '" ++ (show index) ++ "'"+  where+    index :: Int+    index = fromIntegral w++    !(I# i) = index+    !(Table addr) = alphabet++data Table = Table !Addr#++alphabet :: Table+alphabet = Table "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"#

@@ -0,0 +1,83 @@+-- |+-- Module      : Data.ByteString.Pack.Internal+-- License     : BSD-Style+-- Copyright   : Copyright © 2014 Nicolas DI PRIMA+--+-- Maintainer  : Nicolas DI PRIMA <nicolas@di-prima.fr>+-- Stability   : experimental+-- Portability : unknown+--+module Data.ByteString.Pack.Internal+    ( Result(..)+    , Packer(..)+    , Cache(..)+    , actionPacker+    ) where++import Control.Applicative+import Data.Word+import Foreign.Ptr++-- A little cache to update the data+data Cache = Cache {-# UNPACK #-} !(Ptr Word8) -- pointer in the bytestring+                   {-# UNPACK #-} !Int         -- remaining size++instance Show Cache where+    show (Cache _ l) = show l++-- | Packing result:+--+-- * PackerOK a -> means the bytestring has been filled with the given data+-- * PackerMore a cache -> a temporary +data Result a =+      PackerMore a Cache+    | PackerFail String+  deriving (Show)++-- | Simple Bytestring Packer+newtype Packer a = Packer { runPacker_ :: Cache -> IO (Result a) }++instance Functor Packer where+    fmap = fmapPacker++instance Applicative Packer where+    pure = returnPacker+    (<*>) = appendPacker++instance Monad Packer where+    return = returnPacker+    (>>=) = bindPacker++fmapPacker :: (a -> b) -> Packer a -> Packer b+fmapPacker f p = Packer $ \cache -> do+    rv <- runPacker_ p cache+    return $ case rv of+        PackerMore v cache' -> PackerMore (f v) cache'+        PackerFail err      -> PackerFail err+{-# INLINE fmapPacker #-}++returnPacker :: a -> Packer a+returnPacker v = Packer $ \cache -> return $ PackerMore v cache+{-# INLINE returnPacker #-}++bindPacker :: Packer a -> (a -> Packer b) -> Packer b+bindPacker p fp = Packer $ \cache -> do+    rv <- runPacker_ p cache+    case rv of+        PackerMore v cache' -> runPacker_ (fp v) cache'+        PackerFail err      -> return $ PackerFail err+{-# INLINE bindPacker #-}++appendPacker :: Packer (a -> b) -> Packer a -> Packer b+appendPacker p1f p2 = p1f >>= \p1 -> p2 >>= \v -> return (p1 v)+{-# INLINE appendPacker #-}++-- run a sized action+actionPacker :: Int -> (Ptr Word8 -> IO a) -> Packer a+actionPacker s action = Packer $ \(Cache ptr size) ->+    case compare size s of+        LT -> return $ PackerFail "Not enough space in destination"+        _  -> do+            v <- action ptr+            return $ PackerMore v (Cache (ptr `plusPtr` s) (size - s))+{-# INLINE actionPacker #-}

@@ -0,0 +1,86 @@+-- |+-- Module      : Tests.Bench+-- License     : BSD-Style+-- Copyright   : Copyright © 2014 Nicolas DI PRIMA+--+-- Maintainer  : Nicolas DI PRIMA <nicolas@di-prima.fr>+-- Stability   : experimental+-- Portability : unknown+--+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Criterion.Main++import Data.ByteString.Pack+import Data.ByteString.Pack.Base32+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as B+import Data.Word++import Data.Monoid+import qualified Blaze.ByteString.Builder as Blaze+import qualified Blaze.ByteString.Builder.Char8 as Blaze++main :: IO ()+main = defaultMain+    [ bgroup "just fill up with the same char" benchFillUpWith+    , bgroup "write a bytestring" benchWriteByteString+    , bgroup "write byte and bytestring" benchConcatBytes+    , bgroup "base32" benchBase32+    ]++benchFillUpWith =+    [ bench "bytestring: replicate" $ whnf (flip B.replicate 0x41) 2048+    , bench "bspack: fillUpWith" $ whnf (pack (fillUpWith (0x41 :: Word8))) 2048+    ]++exampleByteString :: B.ByteString+exampleByteString = B.replicate 1024 0x42++benchWriteByteString =+    [ bench "blaze" $ whnf (Blaze.toByteString) (Blaze.copyByteString exampleByteString)+    , bench "bytestring" $ nf (B.toLazyByteString) (B.byteString exampleByteString)+    , bench "bspack" $ whnf (flip pack 1024) (putByteString exampleByteString)+    ]++exampleShortByteString :: B.ByteString+exampleShortByteString = "Haskell rocks!"++concatPacker :: Packer ()+concatPacker = do+    putByteString exampleShortByteString+    putWord8 0x20++concatBlaze :: Blaze.Builder+concatBlaze =+      Blaze.copyByteString exampleShortByteString+   <> Blaze.fromChar ' '++concatBlazeShort :: Blaze.Builder+concatBlazeShort = mconcat $ replicate 5 concatBlaze++concatPackerShort :: Packer ()+concatPackerShort = sequence_ $ replicate 5 concatPacker++concatBlazeLong :: Blaze.Builder+concatBlazeLong = mconcat $ replicate 30 concatBlaze++concatPackerLong :: Packer ()+concatPackerLong = sequence_ $ replicate 30 concatPacker++benchConcatBytes =+    [ bench "blaze"       $ whnf (Blaze.toByteString) concatBlazeShort+    , bench "bspack"      $ whnf (flip pack 1024)     concatPackerShort+    , bench "blaze lazy"  $ nf (Blaze.toLazyByteString) concatBlazeLong+    , bench "blaze long"  $ whnf (Blaze.toByteString) concatBlazeLong+    , bench "bspack long" $ whnf (flip pack 2048)     concatPackerLong+    ]++benchBase32 =+    [ bench "bspack 512B" $ whnf (\bs -> pack (putByteStringBase32 bs) 824)      $! B.replicate 512      0x42+    , bench "bspack 10KB" $ whnf (\bs -> pack (putByteStringBase32 bs) 16000)    $! B.replicate 10000    0x42+    , bench "bspack 1MB"  $ whnf (\bs -> pack (putByteStringBase32 bs) 1600000)  $! B.replicate 1000000  0x42+    , bench "bspack 10MB" $ whnf (\bs -> pack (putByteStringBase32 bs) 16000000) $! B.replicate 10000000 0x42+    ]

@@ -14,6 +14,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.ByteString.Pack+import Data.ByteString.Pack.Base32 import Data.Char  ------------------------------------------------------------------------------@@ -51,11 +52,19 @@ longByteString =     "Evolution is the change in the inherited characteristics of biological populations over successive generations. Evolutionary processes give rise to diversity at every level of biological organisation, including species, individual organisms and molecules such as DNA and proteins.[1] All life on Earth is descended from a last universal ancestor that lived approximately 3.8 billion years ago. Repeated speciation and the divergence of life can be inferred from shared sets of biochemical and morphological traits, or by shared DNA sequences.[2] These homologous traits and sequences are more similar among species that share a more recent common ancestor, and can be used to reconstruct evolutionary histories, using both existing species and the fossil record. Existing patterns of biodiversity have been shaped both by speciation and by extinction.[3]" +longBase32 :: ByteString+longBase32 = "JBQXG23FNRWCA2LTEBQW4IDBMR3GC3TDMVSCA4DVOJSWY6JNMZ2W4Y3UNFXW4YLMEBYHE33HOJQW23LJNZTSA3DBNZTXKYLHMUXCAQLOEBXXAZLOFVZW65LSMNSSA4DSN5SHKY3UEBXWMIDNN5ZGKIDUNBQW4IDUO5SW45DZEB4WKYLSOMQG6ZRAMN2XI5DJNZTS2ZLEM5SSA4TFONSWC4TDNAWCA2LUEBQWY3DPO5ZSA4TBOBUWIIDEMV3GK3DPOBWWK3TUEBXWMIDSN5RHK43UFQQGG33OMNUXGZJMEBRW64TSMVRXIIDTN5THI53BOJSS4ICXNF2GQIDTORZG63THEBZXK4DQN5ZHIIDGN5ZCA2LOORSWO4TBORUW63RAO5UXI2BAN52GQZLSEBWGC3THOVQWOZLTFQQGE5LJNR2C22LOEBRW63TDOVZHEZLOMN4SAYLOMQQHAYLSMFWGYZLMNFZW2LBAMRSWE5LHM5SXE4ZMEBYHE33GNFWGK4TTFQQHE2LDNAQGY2LCOJQXE2LFOMQGC3TEEBQW4IDBMN2GS5TFEBRW63LNOVXGS5DZFQQEQYLTNNSWY3BANVQWWZLTEBUXIIDFMFZWSZLSEB2G6IDQOJXWI5LDMUQGM3DFPBUWE3DFFQQG2YLJNZ2GC2LOMFRGYZJMEBUGSZ3IFVYXKYLMNF2HSIDTN5THI53BOJSS4==="++longForBase32 :: ByteString+longForBase32 = "Haskell is an advanced purely-functional programming language. An open-source product of more than twenty years of cutting-edge research, it allows rapid development of robust, concise, correct software. With strong support for integration with other languages, built-in concurrency and parallelism, debuggers, profilers, rich libraries and an active community, Haskell makes it easier to produce flexible, maintainable, high-quality software."+ refTestsOk = testGroup "All these tests must always pass"     [ testCaseOk "put a byte"    "B"  1  (putWord8 $ fromChar 'B')     , testCaseOk "write string"  "Haskell rocks!" 42 (putByteString "Haskell" >> putWord8 0x20 >> putByteString "rocks!")     , testCaseOk "put a 2 bytes" "XY" 2 (putWord16 0x5958)     , testCaseOk "write long stuff" longByteString (B.length longByteString) (putByteString longByteString)+    , testCaseOk "write base 32 short" "JBQXG23FNRWA====" 20 (putByteStringBase32 "Haskell")+    , testCaseOk "write base 32 long" longBase32 (B.length longBase32 + 10) (putByteStringBase32 longForBase32)     ]  refTestsFail = testGroup "Try to see that pack fails properly"

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                bspack-version:             0.0.2+version:             0.0.3 synopsis:            A simple and fast bytestring packer description:         A simple and fast bytestring packer homepage:            https://github.com/NicolasDP/hs-bspack@@ -10,21 +10,32 @@ license-file:        LICENSE author:              Nicolas DI PRIMA maintainer:          nicolas@di-prima.fr--- copyright:           +copyright:           Copyright © 2014 Nicolas DI PRIMA category:            Data build-type:          Simple--- extra-source-files:   cabal-version:       >=1.10  library   exposed-modules:     Data.ByteString.Pack-  -- other-modules:       +                     , Data.ByteString.Pack.Base32+  other-modules:       Data.ByteString.Pack.Internal   -- other-extensions:       build-depends:       base == 4.*-                     , bytestring -  -- hs-source-dirs:      +                     , bytestring+                     , ghc-prim   default-language:    Haskell2010-  ghc-options:         -Wall -fno-warn-orphans+  ghc-options:         -Wall -fno-warn-orphans -O2++Benchmark bench-bspack+    hs-source-dirs:    Tests+    Main-Is:           Bench.hs+    type:              exitcode-stdio-1.0+    Default-Language:  Haskell2010+    Build-depends:     base >= 4 && < 5+                     , bytestring+                     , criterion+                     , bspack+                     , blaze-builder  Test-Suite  tests   type:                exitcode-stdio-1.0