From 4c202bbffb21ca4542765d9247976c23b4abdc24 Mon Sep 17 00:00:00 2001 From: Sylvain HENRY Date: Fri, 6 Mar 2015 20:09:32 +0100 Subject: [PATCH] Add tests and fix bugs --- BitsQC.hs | 63 ++++++++++++++++++++++++++++++----------- Data/Binary/Bits/Get.hs | 19 +++++++------ Data/Binary/Bits/Put.hs | 31 ++++++++++---------- 3 files changed, 71 insertions(+), 42 deletions(-) diff --git a/BitsQC.hs b/BitsQC.hs index 1af03a0..67d3bbd 100644 --- a/BitsQC.hs +++ b/BitsQC.hs @@ -9,6 +9,7 @@ import Data.Binary.Put ( runPut ) import Data.Binary.Bits import Data.Binary.Bits.Get import Data.Binary.Bits.Put +import Data.Binary.Bits.BitOrder import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L @@ -18,6 +19,8 @@ import Data.Bits import Data.Word import Foreign.Storable import System.Random +import Data.Traversable (traverse) +import Data.Foldable (traverse_) import Test.Framework.Providers.QuickCheck2 ( testProperty ) import Test.Framework.Runners.Console ( defaultMain ) @@ -36,7 +39,10 @@ tests = [ testProperty "prop_composite_case" prop_composite_case ] , testGroup "getByteString" - [ testProperty "prop_getByteString_negative" prop_getByteString_negative ] + [ testProperty "prop_getByteString_negative" prop_getByteString_negative + , testProperty "prop_putByteString_getByteString" (prop_putByteString_getByteString :: BitOrder -> B.ByteString -> Property) + , testProperty "prop_putByteString_getByteString_many" (prop_putByteString_getByteString_many :: BitOrder -> [B.ByteString] -> Property) + ] , testGroup "getLazyByteString" [ testProperty "getLazyByteString == getByteString" @@ -84,10 +90,10 @@ tests = ] , 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) + [ testProperty "Word8" (prop_putget_with_bitreq :: BitOrder -> W Word8 -> Property) + , testProperty "Word16" (prop_putget_with_bitreq :: BitOrder -> W Word16 -> Property) + , testProperty "Word32" (prop_putget_with_bitreq :: BitOrder -> W Word32 -> Property) + , testProperty "Word64" (prop_putget_with_bitreq :: BitOrder -> W Word64 -> Property) ] , testGroup "prop_putget_list_simple" @@ -112,10 +118,10 @@ tests = , 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) + [ testProperty "Word8" (prop_bitget_bytestring_interspersed :: BitOrder -> W Word8 -> [B.ByteString] -> Property) + , testProperty "Word16" (prop_bitget_bytestring_interspersed :: BitOrder -> W Word16 -> [B.ByteString] -> Property) + , testProperty "Word32" (prop_bitget_bytestring_interspersed :: BitOrder -> W Word32 -> [B.ByteString] -> Property) + , testProperty "Word64" (prop_bitget_bytestring_interspersed :: BitOrder -> W Word64 -> [B.ByteString] -> Property) ] , testGroup "Simulate programs" [ testProperty "primitive" prop_primitive @@ -158,13 +164,28 @@ 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 $ +prop_putByteString_getByteString :: BitOrder -> B.ByteString -> Property +prop_putByteString_getByteString bo bs = property $ bs' == bs + where + n = B.length bs + w = runPut (runBitPut (withBitOrder bo (putByteString bs))) + bs' = runGet (runBitGet (withBitOrder bo (getByteString n))) w + +prop_putByteString_getByteString_many :: BitOrder -> [B.ByteString] -> Property +prop_putByteString_getByteString_many bo bs = property $ bs' == bs + where + n = fmap B.length bs + w = runPut (runBitPut (withBitOrder bo (traverse_ putByteString bs))) + bs' = runGet (runBitGet (withBitOrder bo (traverse getByteString n))) w + + +prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => BitOrder -> W a -> Property +prop_putget_with_bitreq bo (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 + lbs = runPut (runBitPut (withBitOrder bo p)) + w' = runGet (runBitGet (withBitOrder bo g)) lbs in w == w' -- | Write a list of items. Each item is written with the maximum amount of @@ -226,12 +247,12 @@ prop_bitget_with_put_from_binary (W ws) = property $ 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 $ +prop_bitget_bytestring_interspersed :: (BinaryBit a, Binary a, Num a, Ord a, Bits a) => BitOrder -> W a -> [B.ByteString] -> Property +prop_bitget_bytestring_interspersed bo (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 + lbs = runPut (runBitPut (withBitOrder bo p)) + r = runGet (runBitGet (withBitOrder bo g)) lbs in map (ws,) bss == r -- | Test failing. @@ -425,6 +446,14 @@ instance Arbitrary Primitive where LBS _ lbs -> let ws = L.unpack lbs in map (\ws' -> LBS (length ws') (L.pack ws')) (shrink ws) IsEmpty -> [] +instance Arbitrary BitOrder where + arbitrary = elements [BB, LB, LL, BL] + shrink LL = [BB,LB,BL] + shrink BL = [BB,LB] + shrink LB = [BB] + shrink BB = [] + + prop_primitive :: Primitive -> Property prop_primitive prim = property $ let p = putPrimitive prim diff --git a/Data/Binary/Bits/Get.hs b/Data/Binary/Bits/Get.hs index fb38989..302e0ef 100644 --- a/Data/Binary/Bits/Get.hs +++ b/Data/Binary/Bits/Get.hs @@ -239,16 +239,17 @@ readWordChecked m n s readByteString :: Int -> S -> ByteString readByteString n (S bs o bo) = let - bs' = unsafeTake (n+1) bs - rev = B.map (reverseBits 8) + bs' = unsafeTake (n+1) bs + bs'' = unsafeTake n bs + rev = B.map (reverseBits 8) in case (o,bo) of - (0,BB) -> unsafeTake n bs - (0,LB) -> B.reverse (unsafeTake n bs) - (0,BL) -> rev (unsafeTake n bs) - (0,LL) -> rev (B.reverse (unsafeTake n bs)) - (_,BL) -> rev (readByteString n (S (B.reverse bs') o LB)) - (_,LL) -> rev (readByteString n (S (B.reverse bs') o BB)) - (_,LB) -> readByteString n (S (B.reverse bs') o BB) + (0,BB) -> bs'' + (0,LB) -> B.reverse bs'' + (0,LL) -> rev bs'' + (0,BL) -> rev . B.reverse $ bs'' + (_,LB) -> readByteString n (S (B.reverse bs') (8-o) BB) + (_,BL) -> rev . B.reverse $ readByteString n (S bs' o BB) + (_,LL) -> rev . B.reverse $ readByteString n (S bs' o LB) (_,BB) -> unsafePerformIO $ do let len = n+1 ptr <- mallocBytes len diff --git a/Data/Binary/Bits/Put.hs b/Data/Binary/Bits/Put.hs index 72f4a8b..badc864 100644 --- a/Data/Binary/Bits/Put.hs +++ b/Data/Binary/Bits/Put.hs @@ -82,9 +82,9 @@ putWordS n w s@(S builder b o bo) = s' -- Word containing the remaining (n-cn) bits to store in its LSB w' = case bo of BB -> w - BL -> w + BL -> w `fastShiftR` cn LB -> w `fastShiftR` cn - LL -> w `fastShiftR` cn + LL -> w -- Select bits to store in the current byte. -- Put them in the correct order and return them in the least-significant @@ -92,9 +92,9 @@ putWordS n w s@(S builder b o bo) = s' selectBits :: (Num a, FastBits a, Integral a) => a -> Word8 selectBits x = fromIntegral $ case bo of BB -> mask cn $ x `fastShiftR` (n-cn) - BL -> reverseBits cn $ mask cn $ x `fastShiftR` (n-cn) + LL -> reverseBits cn $ mask cn $ x `fastShiftR` (n-cn) LB -> mask cn x - LL -> reverseBits cn $ mask cn x + BL -> reverseBits cn $ mask cn x -- shift left at the correct position shl :: Word8 -> Word8 @@ -148,20 +148,19 @@ putByteString :: ByteString -> BitPut () putByteString bs = BitPut $ \s -> PairS () (putByteStringS bs s) putByteStringS :: ByteString -> S -> S -putByteStringS bs (S builder b 0 BB) = S (builder `mappend` B.fromByteString bs) b 0 BB -putByteStringS bs s@(S _ _ _ BB) +putByteStringS bs s | BS.null bs = s - | otherwise = putByteStringS (BS.unsafeTail bs) (putWordS 8 (BS.unsafeHead bs) s) -putByteStringS bs (S builder b o bo) = putByteStringS bs' (S builder b o BB) + | otherwise = case s of + (S builder b 0 BB) -> S (builder `mappend` B.fromByteString bs) b 0 BB + (S builder b 0 LB) -> S (builder `mappend` B.fromByteString (BS.reverse bs)) b 0 LB + (S builder b 0 LL) -> S (builder `mappend` B.fromByteString (rev bs)) b 0 LL + (S builder b 0 BL) -> S (builder `mappend` B.fromByteString (rev (BS.reverse bs))) b 0 BL + (S _ _ _ BB) -> putByteStringS (BS.unsafeTail bs) (putWordS 8 (BS.unsafeHead bs) s) + (S _ _ _ LB) -> putByteStringS (BS.unsafeInit bs) (putWordS 8 (BS.unsafeLast bs) s) + (S _ _ _ BL) -> putByteStringS (BS.unsafeInit bs) (putWordS 8 (BS.unsafeLast bs) s) + (S _ _ _ LL) -> putByteStringS (BS.unsafeTail bs) (putWordS 8 (BS.unsafeHead bs) s) where - rev = BS.map (reverseBits 8) - - bs' = case bo of - BL -> BS.reverse (rev bs) - LB -> BS.reverse bs - LL -> rev bs - BB -> bs -- should not occur, already matched but the compiler doesn't detect it - + rev = BS.map (reverseBits 8) -- | Run a 'Put' inside 'BitPut'. Any partially written bytes will be flushed