packages feed

binary-strict 0.3.0 → 0.3.1

raw patch · 4 files changed

+187/−57 lines, 4 files

Files

binary-strict.cabal view
@@ -1,5 +1,5 @@ name:            binary-strict-version:         0.3.0+version:         0.3.1 license:         BSD3 license-file:    LICENSE author:          Lennart Kolmodin <kolmodin@dtek.chalmers.se>@@ -9,7 +9,9 @@                  package. It's pretty much just a copy and paste job from the                  original source code. The binary team are currently unsure                  about their future plans w.r.t. strictness, so this is just a-                 stop gap measure.+                 stop gap measure. See+		 http://www.haskell.org/haskellwiki/DealingWithBinaryData for+		 documentation. synopsis:        Binary deserialisation using strict ByteStrings category:        Data, Parsing build-depends:   base, containers, array, bytestring>=0.9@@ -18,9 +20,11 @@ exposed-modules: Data.Binary.Strict.Get,                  Data.Binary.Strict.IncrementalGet,                  Data.Binary.Strict.BitGet,+                 Data.Binary.Strict.BitPut                  Data.Binary.Strict.Util                  Data.Binary.Strict.ByteSet                  Data.Binary.Strict.Class+other-modules:   Data.Binary.Strict.BitUtil extensions:      CPP, FlexibleContexts hs-source-dirs:  src extra-source-files: tests/BitGetTest.hs, src/Data/Binary/Strict/Common.h
src/Data/Binary/Strict/BitGet.hs view
@@ -60,7 +60,8 @@ #include "Common.h"  import qualified Data.ByteString as B-import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Internal as BI+import Data.Binary.Strict.BitUtil import Foreign import Data.Bits @@ -95,58 +96,6 @@ put :: S -> BitGet () put s = BitGet (const (Right (), s)) --- | This is used for masking the last byte of a ByteString so that extra---   bits don't leak in-topNBits :: Int -> Word8-topNBits 0 = 0-topNBits 1 = 0x80-topNBits 2 = 0xc0-topNBits 3 = 0xe0-topNBits 4 = 0xf0-topNBits 5 = 0xf8-topNBits 6 = 0xfc-topNBits 7 = 0xfe-topNBits x = error ("topNBits undefined for " ++ show x)--bottomNBits :: Int -> Word8-bottomNBits 0 = 0-bottomNBits 1 = 0x01-bottomNBits 2 = 0x03-bottomNBits 3 = 0x07-bottomNBits 4 = 0x0f-bottomNBits 5 = 0x1f-bottomNBits 6 = 0x3f-bottomNBits 7 = 0x7f-bottomNBits x = error ("bottomNBits undefined for " ++ show x)---- | Truncate a ByteString to a given number of bits (counting from the left)---   by masking out extra bits in the last byte-leftTruncateBits :: Int -> B.ByteString -> B.ByteString-leftTruncateBits n = B.take ((n + 7) `div` 8) . snd . B.mapAccumL f n where-  f bits w | bits >= 8 = (bits - 8, w)-           | bits == 0 = (0, 0)-           | otherwise = (0, w .&. topNBits bits)---- | Truncate a ByteString to a given number of bits (counting from the right)---   by masking out extra bits in the first byte-rightTruncateBits :: Int -> B.ByteString -> B.ByteString-rightTruncateBits n bs = B.drop (B.length bs - ((n + 7) `div` 8)) $ snd $ B.mapAccumR f n bs where-  f bits w | bits >= 8 = (bits - 8, w)-           | bits == 0 = (0, 0)-           | otherwise = (0, w .&. bottomNBits bits)---- | Shift the whole ByteString some number of bits left where 0 <= @n@ < 8-leftShift :: Int -> B.ByteString -> B.ByteString-leftShift 0 = id-leftShift n = snd . B.mapAccumR f 0 where-  f acc b = (b `shiftR` (8 - n), (b `shiftL` n) .|. acc)---- | Shift the whole ByteString some number of bits right where 0 <= @n@ < 8-rightShift :: Int -> B.ByteString -> B.ByteString-rightShift 0 = id-rightShift n = snd . B.mapAccumL f 0 where-  f acc b = (b .&. (bottomNBits n), (b `shiftR` n) .|. (acc `shiftL` (8 - n)))- -- | Same as the standard splitAt, but in this version both parts share a byte --   so that splitting [1,2,3,4] at 2 results in ([1,2], [2, 3, 4]). splitAtWithDupByte :: Int -> B.ByteString -> (B.ByteString, B.ByteString)@@ -196,8 +145,8 @@  getPtr :: Storable a => Int -> BitGet a getPtr n = do-    (fp, o, _) <- readN BRight (n * 8) B.toForeignPtr-    return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)+    (fp, o, _) <- readN BRight (n * 8) BI.toForeignPtr+    return . BI.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o) {-# INLINE getPtr #-}  -- | Get a single bit from the input@@ -266,3 +215,4 @@ shiftl_w32 = shiftL shiftl_w64 = shiftL #endif+
+ src/Data/Binary/Strict/BitPut.hs view
@@ -0,0 +1,109 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Data.Binary.Strict.BitPut+-- Copyright   : Dominic Steinitz+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Dominic Steinitz <dominic.steinitz@blueyonder.co.uk>+-- Stability   : experimental+--+-- This is the writer dual to BitGet. It allows one to append bits in a monad+-- and get a strict ByteString as a result. Bits are appended from the MSB of+-- the first byte towards the LSB of the last byte.+--+-- This is best suited to small bit-fields because it accumulates bytes using+-- snoc, so large results will cause a lot of copying. It would be possible+-- to switch to using something similar to the Builder monad if need arises.+-- However, since most protocols only have small bit fields, this should+-- suffice for many cases.+-----------------------------------------------------------------------------+module Data.Binary.Strict.BitPut+  ( BitPut+  , runBitPut+  , putBit+  , putNBits+  , putBits+  , putLeftByteString+  ) where++import Control.Monad+import Data.Word (Word8)+import Data.Bits (shiftL, shiftR, (.&.), (.|.), bitSize, Bits)+import qualified Data.ByteString as B++import Data.Binary.Strict.BitUtil++-- | The state of the BitPut.+--   The current offset is in [0..7]. The current byte is packed from MSB, downwards+data S = S {-# UNPACK #-} !B.ByteString  -- ^ output+           {-# UNPACK #-} !Word8  -- ^ bit offset in current byte+           {-# UNPACK #-} !Word8  -- ^ current byte+           deriving (Show)++newtype BitPut' a = BitPut' { unPut :: S -> (a,S) }+type BitPut = BitPut' ()++instance Functor BitPut' where+   fmap f m = BitPut' (\s -> let (a,s') = unPut m s in (f a,s'))++instance Monad BitPut' where+   return a = BitPut' (\s -> (a,s))+   m >>= k = BitPut' (\s -> let (a,s')  = unPut m s in unPut (k a) s')++get :: BitPut' S+get = BitPut' (\s -> (s,s))++put :: S -> BitPut+put s = BitPut' (const ((), s))++-- | Append a single bit+putBit :: Bool -> BitPut+putBit bit = do+  S bytes boff curr <- get+  let v = if bit then 1 else 0+      newCurr = curr .|. (shiftL (fromIntegral v) (fromIntegral (7 - boff)))+      newBoff = boff + 1+  if newBoff == 8+     then put (S (bytes `B.snoc` (curr .|. v)) 0 0)+     else put (S bytes newBoff newCurr)++-- | Append the bottom n bits of the given bits value. In the case that more+--   bits are requested than the value provides, this acts as if the value+--   has as unlimited number of leading 0 bits.+putNBits :: (Integral a, Bits a) => Int -> a -> BitPut+putNBits n v+  | n == 0 = return ()+  | otherwise = do+      S bytes boff curr <- get+      let space = 8 - boff+      if n < fromIntegral space+         then do+           let boff'   = boff + fromIntegral n+               shifted = (fromIntegral v .&. bottomNBits n) `shiftL` (8 - (fromIntegral boff + n))+               curr'  = curr .|. shifted+           put $ S bytes boff' curr'+         else do+           let bits = v `shiftR` remainingBits+               remainingBits = n - fromIntegral space+               mask = bottomNBits $ fromIntegral space+               bytes' = bytes `B.snoc` (curr .|. (mask .&. fromIntegral bits))+           put $ S bytes' 0 0+           putNBits remainingBits v++-- | Append a value. Note that this function is undefined for instances of Bits+--   which have no fixed bitsize (like Integer)+putBits :: (Integral a, Bits a) => a -> BitPut+putBits v = putNBits (bitSize v) v++-- | Append the first n bits of a left aligned ByteString.+putLeftByteString :: Int -> B.ByteString -> BitPut+putLeftByteString bits bs+  | bits < 8 = putNBits bits $ B.head bs+  | otherwise = putBits (B.head bs) >> putLeftByteString (bits - 8) (B.tail bs)++runBitPut :: BitPut -> B.ByteString+runBitPut m = r where+   (_, (S bytes boff curr)) = unPut m (S B.empty 0 0)+   r = if boff > 0+          then bytes `B.snoc` (topNBits (fromIntegral boff) .&. curr)+          else bytes
+ src/Data/Binary/Strict/BitUtil.hs view
@@ -0,0 +1,67 @@+module Data.Binary.Strict.BitUtil+  ( topNBits+  , bottomNBits+  , leftShift+  , rightShift+  , leftTruncateBits+  , rightTruncateBits+  ) where++import Data.Word (Word8)+import qualified Data.ByteString as B+import Data.Bits (shiftL, shiftR, (.|.), (.&.))++-- | This is used for masking the last byte of a ByteString so that extra+--   bits don't leak in+topNBits :: Int -> Word8+topNBits 0 = 0+topNBits 1 = 0x80+topNBits 2 = 0xc0+topNBits 3 = 0xe0+topNBits 4 = 0xf0+topNBits 5 = 0xf8+topNBits 6 = 0xfc+topNBits 7 = 0xfe+topNBits 8 = 0xff+topNBits x = error ("topNBits undefined for " ++ show x)++-- | Return a Word8 with the bottom n bits set+bottomNBits :: Int -> Word8+bottomNBits 0 = 0+bottomNBits 1 = 0x01+bottomNBits 2 = 0x03+bottomNBits 3 = 0x07+bottomNBits 4 = 0x0f+bottomNBits 5 = 0x1f+bottomNBits 6 = 0x3f+bottomNBits 7 = 0x7f+bottomNBits 8 = 0xff+bottomNBits x = error ("bottomNBits undefined for " ++ show x)++-- | Shift the whole ByteString some number of bits left where 0 <= @n@ < 8+leftShift :: Int -> B.ByteString -> B.ByteString+leftShift 0 = id+leftShift n = snd . B.mapAccumR f 0 where+  f acc b = (b `shiftR` (8 - n), (b `shiftL` n) .|. acc)++-- | Shift the whole ByteString some number of bits right where 0 <= @n@ < 8+rightShift :: Int -> B.ByteString -> B.ByteString+rightShift 0 = id+rightShift n = snd . B.mapAccumL f 0 where+  f acc b = (b .&. (bottomNBits n), (b `shiftR` n) .|. (acc `shiftL` (8 - n)))++-- | Truncate a ByteString to a given number of bits (counting from the left)+--   by masking out extra bits in the last byte+leftTruncateBits :: Int -> B.ByteString -> B.ByteString+leftTruncateBits n = B.take ((n + 7) `div` 8) . snd . B.mapAccumL f n where+  f bits w | bits >= 8 = (bits - 8, w)+           | bits == 0 = (0, 0)+           | otherwise = (0, w .&. topNBits bits)++-- | Truncate a ByteString to a given number of bits (counting from the right)+--   by masking out extra bits in the first byte+rightTruncateBits :: Int -> B.ByteString -> B.ByteString+rightTruncateBits n bs = B.drop (B.length bs - ((n + 7) `div` 8)) $ snd $ B.mapAccumR f n bs where+  f bits w | bits >= 8 = (bits - 8, w)+           | bits == 0 = (0, 0)+           | otherwise = (0, w .&. bottomNBits bits)