binary-bits 0.3 → 0.4
raw patch · 4 files changed
+208/−28 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Data.Binary.Bits.Get: isEmpty :: BitGet Bool
Files
- BitsQC.hs +168/−12
- Data/Binary/Bits/Get.hs +18/−6
- Data/Binary/Bits/Put.hs +21/−9
- binary-bits.cabal +1/−1
BitsQC.hs view
@@ -1,14 +1,11 @@ {-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts, TupleSections #-} -module Main where+module Main ( main ) where -import Data.Binary ( encode, Binary(..) )+import Data.Binary ( 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@@ -18,18 +15,16 @@ 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 :: IO () main = defaultMain tests tests :: [Test]@@ -43,6 +38,20 @@ , testGroup "getByteString" [ testProperty "prop_getByteString_negative" prop_getByteString_negative ] + , testGroup "getLazyByteString"+ [ testProperty "getLazyByteString == getByteString"+ prop_getLazyByteString_equal_to_ByteString+ , testProperty "getLazyByteString == getByteString (with shift)"+ prop_getLazyByteString_equal_to_ByteString2+ ]++ , testGroup "isEmpty"+ [ testProperty "prop_isEmptyOfEmptyEmpty" prop_isEmptyOfEmptyEmpty+ , testProperty "prop_isEmptyOfNonEmptyEmpty" prop_isEmptyOfNonEmptyEmpty+ , testProperty "prop_isEmptyOfConsumedEmpty" prop_isEmptyOfConsumedEmpty+ , testProperty "prop_isEmptyOfNotConsumedNotEmpty" prop_isEmptyOfNotConsumedNotEmpty+ ]+ , testGroup "Fail" [ testProperty "monadic fail" prop_fail ] @@ -108,9 +117,42 @@ , testProperty "Word32" (prop_bitget_bytestring_interspersed :: W Word32 -> [B.ByteString] -> Property) , testProperty "Word64" (prop_bitget_bytestring_interspersed :: W Word64 -> [B.ByteString] -> Property) ]+ , testGroup "Simulate programs"+ [ testProperty "primitive" prop_primitive+ , testProperty "many primitives in sequence" prop_program + ] ] +prop_isEmptyOfEmptyEmpty :: Bool+prop_isEmptyOfEmptyEmpty = runGet (runBitGet isEmpty) L.empty +prop_isEmptyOfNonEmptyEmpty :: L.ByteString -> Property+prop_isEmptyOfNonEmptyEmpty bs =+ not (L.null bs) ==> not (runGet (runBitGet isEmpty) bs)++prop_isEmptyOfConsumedEmpty :: L.ByteString -> Property+prop_isEmptyOfConsumedEmpty bs =+ not (L.null bs) ==>+ runGet (runBitGet (getByteString n >> isEmpty)) bs+ where n = fromIntegral $ L.length bs++prop_isEmptyOfNotConsumedNotEmpty :: L.ByteString -> Int -> Property+prop_isEmptyOfNotConsumedNotEmpty bs n =+ (fromIntegral n) < L.length bs && not (L.null bs) ==>+ not (runGet (runBitGet (getByteString n >> isEmpty)) bs)++prop_getLazyByteString_equal_to_ByteString :: L.ByteString -> Int -> Property+prop_getLazyByteString_equal_to_ByteString bs n =+ (fromIntegral n) <= L.length bs ==>+ runGet (runBitGet (getLazyByteString (fromIntegral n))) bs ==+ (L.fromChunks . (:[]) $ runGet (runBitGet (getByteString n)) bs)++prop_getLazyByteString_equal_to_ByteString2 :: L.ByteString -> Int -> Property+prop_getLazyByteString_equal_to_ByteString2 bs n =+ (L.length bs > 1) && (fromIntegral n) < L.length bs ==>+ runGet (runBitGet (getWord8 2 >> getLazyByteString (fromIntegral n))) bs ==+ (L.fromChunks . (:[]) $ runGet (runBitGet (getWord8 2 >> getByteString n)) bs)+ prop_getByteString_negative :: Int -> Property prop_getByteString_negative n = n < 1 ==>@@ -130,7 +172,7 @@ 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+ p = mapM_ (putBits s) ws g = mapM (const (getBits s)) ws lbs = runPut (runBitPut p) ws' = runGet (runBitGet g) lbs@@ -187,7 +229,7 @@ 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+ 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@@ -221,7 +263,7 @@ prop_bitreq :: W Word64 -> Property prop_bitreq (W w) = property $ ( w == 0 && bitreq w == 1 )- || bitreq w == (bitreq (w `shiftR` 1)) + 1+ || bitreq w == bitreq (w `shiftR` 1) + 1 prop_composite_case :: Bool -> W Word16 -> Property prop_composite_case b (W w) = w < 0x8000 ==>@@ -255,7 +297,7 @@ 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+ _types = rn == ws && r == ws in rn == r -- | Write one bit at a time until the full word has been written@@ -336,6 +378,120 @@ integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, fromIntegral b :: Integer) g of (x,g) -> (fromIntegral x, g)++data Primitive+ = Bool Bool+ | W8 Int Word8+ | W16 Int Word16+ | W32 Int Word32+ | W64 Int Word64+ | BS Int B.ByteString+ | LBS Int L.ByteString+ | IsEmpty+ deriving (Eq, Show)++type Program = [Primitive]++instance Arbitrary Primitive where+ arbitrary = do+ let gen c = do+ let (maxBits, _) = (\w -> (bitSize w, c undefined w)) undefined+ bits <- choose (0, maxBits)+ n <- choose (0, fromIntegral (2^bits-1))+ return (c bits n)+ oneof+ [ Bool <$> arbitrary+ , gen W8+ , gen W16+ , gen W32+ , gen W64+ , do n <- choose (0,10)+ cs <- vector n+ return (BS n (B.pack cs))+ , do n <- choose (0,10)+ cs <- vector n+ return (LBS n (L.pack cs))+ , return IsEmpty+ ]+ shrink p =+ let snk c x = map (\x' -> c (bitreq x') x') (shrinker x) in+ case p of+ Bool b -> if b then [Bool False] else []+ W8 _ x -> snk W8 x+ W16 _ x -> snk W16 x+ W32 _ x -> snk W32 x+ W64 _ x -> snk W64 x+ BS _ bs -> let ws = B.unpack bs in map (\ws' -> BS (length ws') (B.pack ws')) (shrink ws)+ LBS _ lbs -> let ws = L.unpack lbs in map (\ws' -> LBS (length ws') (L.pack ws')) (shrink ws)+ IsEmpty -> []++prop_primitive :: Primitive -> Property+prop_primitive prim = property $+ let p = putPrimitive prim+ g = getPrimitive prim+ lbs = runPut (runBitPut p)+ r = runGet (runBitGet g) lbs+ in r == prim++prop_program :: Program -> Property+prop_program program = property $+ let p = mapM_ putPrimitive program+ g = verifyProgram (8 * fromIntegral (L.length lbs)) program+ lbs = runPut (runBitPut p)+ r = runGet (runBitGet g) lbs+ in r++putPrimitive :: Primitive -> BitPut ()+putPrimitive p =+ case p of+ Bool b -> putBool b+ W8 n x -> putWord8 n x+ W16 n x -> putWord16be n x+ W32 n x -> putWord32be n x+ W64 n x -> putWord64be n x+ BS _ bs -> putByteString bs+ LBS _ lbs -> mapM_ putByteString (L.toChunks lbs)+ IsEmpty -> return ()++getPrimitive :: Primitive -> BitGet Primitive+getPrimitive p =+ case p of+ Bool _ -> Bool <$> getBool+ W8 n _ -> W8 n <$> getWord8 n+ W16 n _ -> W16 n <$> getWord16be n+ W32 n _ -> W32 n <$> getWord32be n+ W64 n _ -> W64 n <$> getWord64be n+ BS n _ -> BS n <$> getByteString n+ LBS n _ -> LBS n <$> getLazyByteString n+ IsEmpty -> isEmpty >> return IsEmpty+++verifyProgram :: Int -> Program -> BitGet Bool+verifyProgram totalLength ps0 = go 0 ps0+ where+ go _ [] = return True+ go pos (p:ps) =+ case p of+ Bool x -> check x getBool >> go (pos+1) ps+ W8 n x -> check x (getWord8 n) >> go (pos+n) ps+ W16 n x -> check x (getWord16be n) >> go (pos+n) ps+ W32 n x -> check x (getWord32be n) >> go (pos+n) ps+ W64 n x -> check x (getWord64be n) >> go (pos+n) ps+ BS n x -> check x (getByteString n) >> go (pos+(8*n)) ps+ LBS n x -> check x (getLazyByteString n) >> go (pos+(8*n)) ps+ IsEmpty -> do+ let expected = pos == totalLength+ actual <- isEmpty+ if expected == actual+ then go pos ps+ else error $ "isEmpty returned wrong value, expected "+ ++ show expected ++ " but got " ++ show actual+ check x g = do+ y <- g+ if x == y+ then return ()+ else error $ "Roundtrip error: Expected "+ ++ show x ++ " but got " ++ show y {- instance Random Word where
Data/Binary/Bits/Get.hs view
@@ -79,10 +79,11 @@ , byteString , Data.Binary.Bits.Get.getByteString , Data.Binary.Bits.Get.getLazyByteString+ , Data.Binary.Bits.Get.isEmpty ) where -import Data.Binary.Get as B ( runGet, Get, getByteString, getLazyByteString )+import Data.Binary.Get as B ( runGet, Get, getByteString, getLazyByteString, isEmpty ) import Data.Binary.Get.Internal as B ( get, put, ensureN ) import Data.ByteString as B@@ -91,7 +92,6 @@ import Data.Bits import Data.Word- import Control.Applicative import Prelude as P@@ -416,11 +416,23 @@ getByteString :: Int -> BitGet ByteString getByteString n = block (byteString n) +-- | Get @n@ bytes as a lazy ByteString. getLazyByteString :: Int -> BitGet L.ByteString-getLazyByteString m = B $ \ (S n bs) -> do- putBackState n bs- lbs <- B.getLazyByteString (fromIntegral m)- return (S B.empty 0, lbs)+getLazyByteString n = do+ (S _ o) <- getState+ case o of+ 0 -> B $ \ (S bs o') -> do+ putBackState bs o'+ lbs <- B.getLazyByteString (fromIntegral n)+ return (S B.empty 0, lbs)+ _ -> L.fromChunks . (:[]) <$> Data.Binary.Bits.Get.getByteString n++-- | Test whether all input has been consumed, i.e. there are no remaining+-- undecoded bytes.+isEmpty :: BitGet Bool+isEmpty = B $ \ (S bs o) -> if B.null bs+ then B.isEmpty >>= \e -> return (S bs o, e)+ else return (S bs o, False) -- | Read a 1 bit 'Bool'. bool :: Block Bool
Data/Binary/Bits/Put.hs view
@@ -50,22 +50,33 @@ -- | Put a 1 bit 'Bool'. putBool :: Bool -> BitPut ()-putBool b = putWord8 1 (if b then 1 else 0)+putBool b = putWord8 1 (if b then 0xff else 0x00) +-- | make_mask 3 = 00000111+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 #-}+{-# SPECIALIZE make_mask :: Int -> Word8 #-}+{-# SPECIALIZE make_mask :: Int -> Word16 #-}+{-# SPECIALIZE make_mask :: Int -> Word32 #-}+{-# SPECIALIZE make_mask :: Int -> Word64 #-}+ -- | Put the @n@ lower bits of a 'Word8'. putWord8 :: Int -> Word8 -> BitPut () putWord8 n w = BitPut $ \s -> PairS () $+ let w' = make_mask n .&. w in case s of -- a whole word8, no offset (S b t o) | n == 8 && o == 0 -> flush $ S b w n -- less than a word8, will fit in the current word8- | n <= 8 - o -> flush $ S b (t .|. (w `shiftL` (8 - n - o))) (o+n)+ | n <= 8 - o -> flush $ S b (t .|. (w' `shiftL` (8 - n - o))) (o+n) -- will finish this word8, and spill into the next one | otherwise -> flush $ let o' = o + n - 8- w' = t .|. (w `shiftR` o')+ b' = t .|. (w' `shiftR` o') t' = w `shiftL` (8 - o')- in S (b `mappend` B.singleton w') t' o'+ in S (b `mappend` B.singleton b') t' o' -- | Put the @n@ lower bits of a 'Word16'. putWord16be :: Int -> Word16 -> BitPut ()@@ -73,22 +84,23 @@ | n <= 8 = putWord8 n (fromIntegral w) | otherwise = BitPut $ \s -> PairS () $+ let w' = make_mask n .&. w in case s of -- as n>=9, it's too big to fit into one single byte -- it'll either use 2 or 3 bytes -- it'll fit in 2 bytes (S b t o) | o + n <= 16 -> flush $ let o' = o + n - 8- w' = t .|. fromIntegral (w `shiftR` o')+ b' = t .|. fromIntegral (w' `shiftR` o') t' = fromIntegral (w `shiftL` (8-o'))- in (S (b `mappend` B.singleton w') t' o')+ in (S (b `mappend` B.singleton b') t' o') -- 3 bytes required | otherwise -> flush $ let o' = o + n - 16- w' = t .|. fromIntegral (w `shiftR` (o' + 8))- w'' = fromIntegral ((w `shiftR` o') .&. 0xff)+ b' = t .|. fromIntegral (w' `shiftR` (o' + 8))+ b'' = fromIntegral ((w `shiftR` o') .&. 0xff) t' = fromIntegral (w `shiftL` (8-o'))- in (S (b `mappend` B.singleton w' `mappend` B.singleton w'') t' o')+ in (S (b `mappend` B.singleton b' `mappend` B.singleton b'') t' o') -- | Put the @n@ lower bits of a 'Word32'. putWord32be :: Int -> Word32 -> BitPut ()
binary-bits.cabal view
@@ -1,6 +1,6 @@ -- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/ name: binary-bits-version: 0.3+version: 0.4 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.