binary-bits 0.1 → 0.2
raw patch · 3 files changed
+397/−19 lines, 3 filesdep ~basedep ~binaryPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, binary
API changes (from Hackage documentation)
Files
- BitsQC.hs +360/−0
- Data/Binary/Bits/Get.hs +32/−14
- binary-bits.cabal +5/−5
+ BitsQC.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts, TupleSections #-}++module Main where++import Data.Binary ( encode, Binary(..) )+import Data.Binary.Get ( runGet, runGetIncremental, pushChunks, Decoder(..) )+import Data.Binary.Put ( runPut )++import qualified Data.Binary.Get as BG ( getWord8, getWord16be, getWord32be, getWord64be )+import qualified Data.Binary.Put as BP ( putWord8, putWord16be, putWord32be, putWord64be )++import Data.Binary.Bits+import Data.Binary.Bits.Get+import Data.Binary.Bits.Put++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++import Control.Applicative+import Data.Bits+import Data.Monoid+import Data.Word+import Foreign.Storable+import System.Random++import Test.Framework.Options ( TestOptions'(..) )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.Framework.Runners.Console ( defaultMain )+import Test.Framework.Runners.Options ( RunnerOptions'(..) )+import Test.Framework ( Test, testGroup )+import Test.QuickCheck++main = defaultMain tests++tests :: [Test]+tests =+ [ testGroup "Internal test functions"+ [ testProperty "prop_bitreq" prop_bitreq ]++ , testGroup "Custom test cases"+ [ testProperty "prop_composite_case" prop_composite_case ]++ , testGroup "getByteString"+ [ testProperty "prop_getByteString_negative" prop_getByteString_negative ]++ , testGroup "Fail"+ [ testProperty "monadic fail" prop_fail ]++ , testGroup "prop_bitput_with_get_from_binary"+ [ testProperty "Word8" (prop_bitput_with_get_from_binary :: W [Word8] -> Property)+ , testProperty "Word16" (prop_bitput_with_get_from_binary :: W [Word16] -> Property)+ , testProperty "Word32" (prop_bitput_with_get_from_binary :: W [Word32] -> Property)+ , testProperty "Word64" (prop_bitput_with_get_from_binary :: W [Word64] -> Property)+ ]++ , testGroup "prop_bitget_with_put_from_binary"+ [ testProperty "Word8" (prop_bitget_with_put_from_binary :: W [Word8] -> Property)+ , testProperty "Word16" (prop_bitget_with_put_from_binary :: W [Word16] -> Property)+ , testProperty "Word32" (prop_bitget_with_put_from_binary :: W [Word32] -> Property)+ , testProperty "Word64" (prop_bitget_with_put_from_binary :: W [Word64] -> Property)+ ]++ , testGroup "prop_compare_put_with_naive"+ [ testProperty "Word8" (prop_compare_put_with_naive :: W [Word8] -> Property)+ , testProperty "Word16" (prop_compare_put_with_naive :: W [Word16] -> Property)+ , testProperty "Word32" (prop_compare_put_with_naive :: W [Word32] -> Property)+ , testProperty "Word64" (prop_compare_put_with_naive :: W [Word64] -> Property)+ ]++ , testGroup "prop_compare_get_with_naive"+ [ testProperty "Word8" (prop_compare_get_with_naive:: W [Word8] -> Property)+ , testProperty "Word16" (prop_compare_get_with_naive:: W [Word16] -> Property)+ , testProperty "Word32" (prop_compare_get_with_naive:: W [Word32] -> Property)+ , testProperty "Word64" (prop_compare_get_with_naive:: W [Word64] -> Property)+ ]++ , testGroup "prop_put_with_bitreq"+ [ testProperty "Word8" (prop_putget_with_bitreq :: W Word8 -> Property)+ , testProperty "Word16" (prop_putget_with_bitreq :: W Word16 -> Property)+ , testProperty "Word32" (prop_putget_with_bitreq :: W Word32 -> Property)+ , testProperty "Word64" (prop_putget_with_bitreq :: W Word64 -> Property)+ ]++ , testGroup "prop_putget_list_simple"+ [ testProperty "Bool" (prop_putget_list_simple :: W [Bool] -> Property)+ , testProperty "Word8" (prop_putget_list_simple :: W [Word8] -> Property)+ , testProperty "Word16" (prop_putget_list_simple :: W [Word16] -> Property)+ , testProperty "Word32" (prop_putget_list_simple :: W [Word32] -> Property)+ , testProperty "Word64" (prop_putget_list_simple :: W [Word64] -> Property)+ ]++ , testGroup "prop_putget_applicative_with_bitreq"+ [ testProperty "Word8" (prop_putget_applicative_with_bitreq :: W [(Word8,Word8,Word8)] -> Property)+ , testProperty "Word16" (prop_putget_applicative_with_bitreq :: W [(Word16,Word16,Word16)] -> Property)+ , testProperty "Word32" (prop_putget_applicative_with_bitreq :: W [(Word32,Word32,Word32)] -> Property)+ , testProperty "Word64" (prop_putget_applicative_with_bitreq :: W [(Word64,Word64,Word64)] -> Property)+ ]++ , testGroup "prop_putget_list_with_bitreq"+ [ testProperty "Word8" (prop_putget_list_with_bitreq :: W [Word8] -> Property)+ , testProperty "Word16" (prop_putget_list_with_bitreq :: W [Word16] -> Property)+ , testProperty "Word32" (prop_putget_list_with_bitreq :: W [Word32] -> Property)+ , testProperty "Word64" (prop_putget_list_with_bitreq :: W [Word64] -> Property)+ ]+ , testGroup "prop_bitget_bytestring_interspersed"+ [ testProperty "Word8" (prop_bitget_bytestring_interspersed :: W Word8 -> [B.ByteString] -> Property)+ , testProperty "Word16" (prop_bitget_bytestring_interspersed :: W Word16 -> [B.ByteString] -> Property)+ , testProperty "Word32" (prop_bitget_bytestring_interspersed :: W Word32 -> [B.ByteString] -> Property)+ , testProperty "Word64" (prop_bitget_bytestring_interspersed :: W Word64 -> [B.ByteString] -> Property)+ ]+ ]+++prop_getByteString_negative :: Int -> Property+prop_getByteString_negative n =+ n < 1 ==>+ runGet (runBitGet (getByteString n)) L.empty == B.empty++prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W a -> Property+prop_putget_with_bitreq (W w) = property $+ -- write all words with as many bits as it's required+ let p = putBits (bitreq w) w+ g = getBits (bitreq w)+ lbs = runPut (runBitPut p)+ w' = runGet (runBitGet g) lbs+ in w == w'++-- | Write a list of items. Each item is written with the maximum amount of+-- bits, i.e. 8 for Word8, 16 for Word16, etc.+prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => W [a] -> Property+prop_putget_list_simple (W ws) = property $+ let s = sizeOf (head ws) * 8+ p = mapM_ (\v -> putBits s v) ws+ g = mapM (const (getBits s)) ws+ lbs = runPut (runBitPut p)+ ws' = runGet (runBitGet g) lbs+ in ws == ws'++-- | Write a list of items. Each item is written with exactly as many bits+-- as required. Then read it back.+prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [a] -> Property+prop_putget_list_with_bitreq (W ws) = property $+ -- write all words with as many bits as it's required+ let p = mapM_ (\v -> putBits (bitreq v) v) ws+ g = mapM getBits bitlist+ lbs = runPut (runBitPut p)+ ws' = runGet (runBitGet g) lbs+ in ws == ws'+ where+ bitlist = map bitreq ws++prop_putget_applicative_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [(a,a,a)] -> Property+prop_putget_applicative_with_bitreq (W ts) = property $+ let p = mapM_ (\(a,b,c) -> do putBits (bitreq a) a+ putBits (bitreq b) b+ putBits (bitreq c) c) ts+ g = mapM (\(a,b,c) -> (,,) <$> getBits a <*> getBits b <*> getBits c) bitlist+ lbs = runPut (runBitPut p)+ ts' = runGet (runBitGet g) lbs+ in ts == ts'+ where+ bitlist = map (\(a,b,c) -> (bitreq a, bitreq b, bitreq c)) ts++-- | Write bits using this library, and read them back using the binary+-- library.+prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property+prop_bitput_with_get_from_binary (W ws) = property $+ let s = sizeOf (head ws) * 8+ p = mapM_ (putBits s) ws+ g = mapM (const get) ws+ lbs = runPut (runBitPut p)+ ws' = runGet g lbs+ in ws == ws'++-- | Write bits using the binary library, and read them back using this+-- library.+prop_bitget_with_put_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property+prop_bitget_with_put_from_binary (W ws) = property $+ let s = sizeOf (head ws) * 8+ p = mapM_ put ws+ g = mapM (const (getBits s)) ws+ lbs = runPut p+ ws' = runGet (runBitGet g) lbs+ in ws == ws'++-- | Write each 'ByteString' with a variable sized value as a separator.+prop_bitget_bytestring_interspersed :: (BinaryBit a, Binary a, Num a, Ord a, Bits a) => W a -> [B.ByteString] -> Property+prop_bitget_bytestring_interspersed (W ws) bss = property $+ let p = mapM_ (\bs -> putBits (bitreq ws) ws >> putByteString bs) bss+ g = mapM (\bs -> (,) <$> (getBits (bitreq ws)) <*> (getByteString (B.length bs))) bss+ lbs = runPut (runBitPut p)+ r = runGet (runBitGet g) lbs+ in map (ws,) bss == r++-- | Test failing.+prop_fail :: L.ByteString -> String -> Property+prop_fail lbs errMsg0 = forAll (choose (0, 8 * L.length lbs)) $ \len ->+ let (bytes,bits) = len `divMod` 8+ expectedBytesConsumed+ | bits == 0 = bytes+ | otherwise = bytes + 1+ p = do getByteString (fromIntegral bytes)+ getBits (fromIntegral bits) :: BitGet Word8+ fail errMsg0+ r = runGetIncremental (runBitGet p) `pushChunks` lbs+ in case r of+ Fail remainingBS pos errMsg ->+ and [ L.fromChunks [remainingBS] == L.drop expectedBytesConsumed lbs+ , pos == expectedBytesConsumed+ , errMsg == errMsg0+ ]+ _ -> False++-- | number of bits required to write @v@+bitreq :: (Num b, Num a, Bits a, Ord a) => a -> b+bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]++bittable :: (Bits a, Num a) => [(Integer, a)]+bittable = [ (fromIntegral x, (1 `shiftL` x) - 1) | x <- [1..64] ]++prop_bitreq :: W Word64 -> Property+prop_bitreq (W w) = property $+ ( w == 0 && bitreq w == 1 )+ || bitreq w == (bitreq (w `shiftR` 1)) + 1++prop_composite_case :: Bool -> W Word16 -> Property+prop_composite_case b (W w) = w < 0x8000 ==>+ let p = do putBool b+ putWord16be 15 w+ g = do v <- getBool+ case v of+ True -> getWord16be 15+ False -> do+ msb <- getWord8 7+ lsb <- getWord8 8+ return ((fromIntegral msb `shiftL` 8) .|. fromIntegral lsb)+ lbs = runPut (runBitPut p)+ w' = runGet (runBitGet g) lbs+ in w == w'++prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => W [a] -> Property+prop_compare_put_with_naive (W ws) = property $+ let pn = mapM_ (\v -> naive_put (bitreq v) v) ws+ p = mapM_ (\v -> putBits (bitreq v) v) ws+ lbs_n = runPut (runBitPut pn)+ lbs = runPut (runBitPut p)+ in lbs_n == lbs++prop_compare_get_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => W [a] -> Property+prop_compare_get_with_naive (W ws) = property $+ let gn = mapM (\v -> naive_get (bitreq v)) ws+ g = mapM (\v -> getBits (bitreq v)) ws+ p = mapM_ (\v -> naive_put (bitreq v) v) ws+ lbs = runPut (runBitPut p)+ rn = runGet (runBitGet gn) lbs+ r = runGet (runBitGet g ) lbs+ -- we must help our compiler to resolve the types of 'gn' and 'g'+ types = rn == ws && r == ws+ in rn == r++-- | Write one bit at a time until the full word has been written+naive_put :: (Bits a) => Int -> a -> BitPut ()+naive_put n w = mapM_ (\b -> putBool (testBit w b)) [n-1,n-2..0]++-- | Read one bit at a time until we've reconstructed the whole word+naive_get :: (Bits a, Num a) => Int -> BitGet a+naive_get n0 =+ let loop 0 acc = return acc+ loop n acc = do+ b <- getBool+ case b of+ False -> loop (n-1) (acc `shiftL` 1)+ True -> loop (n-1) ((acc `shiftL` 1) + 1)+ in loop n0 0++shrinker :: (Num a, Ord a, Bits a) => a -> [a]+shrinker 0 = []+shrinker w = [ w `shiftR` 1 -- try to make everything roughly half size+ ] ++ [ w' -- flip bits to zero, left->right+ | m <- [n, n-1..1]+ , let w' = w `clearBit` m+ , w /= w'+ ] ++ [w-1] -- just make it a little smaller+ where+ n = bitreq w++data W a = W { unW :: a } deriving (Show, Eq, Ord)++arbitraryW :: (Arbitrary (W a)) => Gen a+arbitraryW = unW <$> arbitrary++shrinkW :: (Arbitrary (W a)) => a -> [a]+shrinkW x = unW <$> shrink (W x)++instance Arbitrary (W Bool) where+ arbitrary = W <$> arbitrary+ shrink = map W <$> shrink . unW++instance Arbitrary (W Word8) where+ arbitrary = W <$> choose (minBound, maxBound)+ shrink = map W . shrinker . unW++instance Arbitrary (W Word16) where+ arbitrary = W <$> choose (minBound, maxBound)+ shrink = map W . shrinker . unW++instance Arbitrary (W Word32) where+ arbitrary = W <$> choose (minBound, maxBound)+ shrink = map W . shrinker . unW++instance Arbitrary (W Word64) where+ arbitrary = W <$> choose (minBound, maxBound)+ shrink = map W . shrinker . unW++instance Arbitrary B.ByteString where+ arbitrary = B.pack <$> arbitrary+ shrink bs = B.pack <$> shrink (B.unpack bs)++instance Arbitrary L.ByteString where+ arbitrary = L.fromChunks <$> arbitrary+ shrink bs = L.fromChunks <$> shrink (L.toChunks bs)++instance (Arbitrary (W a)) => Arbitrary (W [a]) where+ arbitrary = W . map unW <$> arbitrary+ shrink = map (W . map unW) <$> mapM shrink . map W . unW++instance (Arbitrary (W a), Arbitrary (W b)) => Arbitrary (W (a,b)) where+ arbitrary = (W .) . (,) <$> arbitraryW <*> arbitraryW+ shrink (W (a,b)) = (W .) . (,) <$> shrinkW a <*> shrinkW b++instance (Arbitrary (W a), Arbitrary (W b), Arbitrary (W c)) => Arbitrary (W (a,b,c)) where+ arbitrary = ((W .) .) . (,,) <$> arbitraryW <*> arbitraryW <*> arbitraryW+ shrink (W (a,b,c)) = ((W .) .) . (,,) <$> shrinkW a <*> shrinkW b <*> shrinkW c++integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)+integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,+ fromIntegral b :: Integer) g of+ (x,g) -> (fromIntegral x, g)++{-+instance Random Word where+ randomR = integralRandomR+ random = randomR (minBound,maxBound)++instance Random Word8 where+ randomR = integralRandomR+ random = randomR (minBound,maxBound)++instance Random Word16 where+ randomR = integralRandomR+ random = randomR (minBound,maxBound)++instance Random Word32 where+ randomR = integralRandomR+ random = randomR (minBound,maxBound)++instance Random Word64 where+ randomR = integralRandomR+ random = randomR (minBound,maxBound)+-}
Data/Binary/Bits/Get.hs view
@@ -82,6 +82,7 @@ ) where import Data.Binary.Get as B ( runGet, Get, getByteString )+import Data.Binary.Get.Internal as B ( get, put, ensureN ) import Data.ByteString as B import Data.ByteString.Unsafe@@ -145,13 +146,13 @@ --ipv6Header = 'runBitGet' ('block' ipv6headerblock) -- @ -data S = S !ByteString -- Input- !Int -- Bit offset (0-7)+data S = S {-# UNPACK #-} !ByteString -- Input+ {-# UNPACK #-} !Int -- Bit offset (0-7) deriving (Show) -- | A block that will be read with only one boundry check. Needs to know the -- number of bits in advance.-data Block a = Block !Int (S -> a)+data Block a = Block Int (S -> a) instance Functor Block where fmap f (Block i p) = Block i (\s -> f (p s))@@ -169,8 +170,9 @@ block :: Block a -> BitGet a block (Block i p) = do ensureBits i- modifyState (\s -> (incS i s, p s))-+ s <- getState+ putState $! (incS i s)+ return $! p s incS :: Int -> S -> S incS o (S bs n) =@@ -180,7 +182,7 @@ in S (unsafeDrop d bs) n' -- | make_mask 3 = 00000111-make_mask :: Bits a => Int -> a+make_mask :: (Bits a, Num a) => Int -> a make_mask n = (1 `shiftL` fromIntegral n) - 1 {-# SPECIALIZE make_mask :: Int -> Int #-} {-# SPECIALIZE make_mask :: Int -> Word #-}@@ -198,6 +200,7 @@ readBool :: S -> Bool readBool (S bs n) = testBit (unsafeHead bs) (7-n) +{-# INLINE readWord8 #-} readWord8 :: Int -> S -> Word8 readWord8 n (S bs o) -- no bits at all, return 0@@ -218,7 +221,7 @@ w' = (w `shiftr_w16` (16 - o - n)) .&. m in fromIntegral w' -+{-# INLINE readWord16be #-} readWord16be :: Int -> S -> Word16 readWord16be n s@(S bs o) @@ -244,6 +247,7 @@ | otherwise = error "readWord16be: tried to read more than 16 bits" +{-# INLINE readWord32be #-} readWord32be :: Int -> S -> Word32 readWord32be n s@(S _ o) -- 8 or fewer bits, use readWord8@@ -259,6 +263,7 @@ | otherwise = error "readWord32be: tried to read more than 32 bits" +{-# INLINE readWord64be #-} readWord64be :: Int -> S -> Word64 readWord64be n s@(S _ o) -- 8 or fewer bits, use readWord8@@ -335,7 +340,7 @@ instance Monad BitGet where return x = B $ \s -> return (s,x)- fail str = B $ \_s -> fail str+ fail str = B $ \(S inp n) -> putBackState inp n >> fail str (B f) >>= g = B $ \s -> do (s',a) <- f s runState (g a) s' @@ -350,18 +355,28 @@ -- been partially consumed it will be discarded once 'runBitGet' is finished. runBitGet :: BitGet a -> Get a runBitGet bg = do- (_,a) <- runState bg (S B.empty 0)+ s <- mkInitState+ ((S str' n),a) <- runState bg s+ putBackState str' n return a +mkInitState :: Get S+mkInitState = do+ str <- get+ put B.empty+ return (S str 0)++putBackState :: B.ByteString -> Int -> Get ()+putBackState bs n = do+ remaining <- get+ put (B.drop (if n==0 then 0 else 1) bs `B.append` remaining)+ getState :: BitGet S getState = B $ \s -> return (s,s) putState :: S -> BitGet () putState s = B $ \_ -> return (s,()) -modifyState :: (S -> (S,a)) -> BitGet a-modifyState f = B $ \s -> return (f s)- -- | Make sure there are at least @n@ bits. ensureBits :: Int -> BitGet () ensureBits n = do@@ -370,7 +385,9 @@ then return () else do let currentBits = B.length bs * 8 - o let byteCount = (n - currentBits + 7) `div` 8- B $ \_ -> do bs' <- B.getByteString byteCount+ B $ \_ -> do B.ensureN byteCount+ bs' <- B.get+ put B.empty return (S (bs`append`bs') o, ()) -- | Get 1 bit as a 'Bool'.@@ -419,7 +436,8 @@ -- | Read @n@ bytes as a 'ByteString'. byteString :: Int -> Block ByteString-byteString n = Block (n*8) (readByteString n)+byteString n | n > 0 = Block (n*8) (readByteString n)+ | otherwise = Block 0 (\_ -> B.empty) ------------------------------------------------------------------------ -- Unchecked shifts, from the package binary
binary-bits.cabal view
@@ -1,6 +1,6 @@ -- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/ name: binary-bits-version: 0.1+version: 0.2 synopsis: Bit parsing/writing on top of binary. description: Bit parsing/writing on top of binary. Provides functions to read and write bits to and from 8\/16\/32\/64 words.@@ -14,11 +14,11 @@ cabal-version: >=1.10 source-repository head- type: darcs- location: http://code.haskell.org/binary-bits+ type: git+ location: git://github.com/kolmodin/binary-bits.git library- build-depends: base==4.*, binary, bytestring+ build-depends: base==4.*, binary >= 0.6.0.0, bytestring other-extensions: RankNTypes, MagicHash, BangPatterns, CPP @@ -35,7 +35,7 @@ main-is: BitsQC.hs default-language: Haskell98 - build-depends: base==4.*, binary, bytestring,+ build-depends: base==4.*, binary >= 0.6.0.0, bytestring, QuickCheck>=2, random, test-framework, test-framework-quickcheck2