git.iko.soy/binary-bits
on master help sign in
Add tests and fix bugs
4c202bbSylvain HENRY
BitsQC.hs+46−17
compare with master
unifiedsplit
@@ -9,6 +9,7 @@ import Data.Binary.Put ( runPut )
9import Data.Binary.Bits
9import Data.Binary.Bits
10import Data.Binary.Bits.Get
10import Data.Binary.Bits.Get
11import Data.Binary.Bits.Put
11import Data.Binary.Bits.Put
12+import Data.Binary.Bits.BitOrder
12
13
13import qualified Data.ByteString as B
14import qualified Data.ByteString as B
14import qualified Data.ByteString.Lazy as L
15import qualified Data.ByteString.Lazy as L
@@ -18,6 +19,8 @@ import Data.Bits
18import Data.Word
19import Data.Word
19import Foreign.Storable
20import Foreign.Storable
20import System.Random
21import System.Random
22+import Data.Traversable (traverse)
23+import Data.Foldable (traverse_)
21
24
22import Test.Framework.Providers.QuickCheck2 ( testProperty )
25import Test.Framework.Providers.QuickCheck2 ( testProperty )
23import Test.Framework.Runners.Console ( defaultMain )
26import Test.Framework.Runners.Console ( defaultMain )
@@ -36,7 +39,10 @@ tests =
36 [ testProperty "prop_composite_case" prop_composite_case ]
39 [ testProperty "prop_composite_case" prop_composite_case ]
37
40
38 , testGroup "getByteString"
41 , testGroup "getByteString"
39− [ testProperty "prop_getByteString_negative" prop_getByteString_negative ]
42+ [ testProperty "prop_getByteString_negative" prop_getByteString_negative
43+ , testProperty "prop_putByteString_getByteString" (prop_putByteString_getByteString :: BitOrder -> B.ByteString -> Property)
44+ , testProperty "prop_putByteString_getByteString_many" (prop_putByteString_getByteString_many :: BitOrder -> [B.ByteString] -> Property)
45+ ]
40
46
41 , testGroup "getLazyByteString"
47 , testGroup "getLazyByteString"
42 [ testProperty "getLazyByteString == getByteString"
48 [ testProperty "getLazyByteString == getByteString"
@@ -84,10 +90,10 @@ tests =
84 ]
90 ]
85
91
86 , testGroup "prop_put_with_bitreq"
92 , testGroup "prop_put_with_bitreq"
87− [ testProperty "Word8" (prop_putget_with_bitreq :: W Word8 -> Property)
93+ [ testProperty "Word8" (prop_putget_with_bitreq :: BitOrder -> W Word8 -> Property)
88− , testProperty "Word16" (prop_putget_with_bitreq :: W Word16 -> Property)
94+ , testProperty "Word16" (prop_putget_with_bitreq :: BitOrder -> W Word16 -> Property)
89− , testProperty "Word32" (prop_putget_with_bitreq :: W Word32 -> Property)
95+ , testProperty "Word32" (prop_putget_with_bitreq :: BitOrder -> W Word32 -> Property)
90− , testProperty "Word64" (prop_putget_with_bitreq :: W Word64 -> Property)
96+ , testProperty "Word64" (prop_putget_with_bitreq :: BitOrder -> W Word64 -> Property)
91 ]
97 ]
92
98
93 , testGroup "prop_putget_list_simple"
99 , testGroup "prop_putget_list_simple"
@@ -112,10 +118,10 @@ tests =
112 , testProperty "Word64" (prop_putget_list_with_bitreq :: W [Word64] -> Property)
118 , testProperty "Word64" (prop_putget_list_with_bitreq :: W [Word64] -> Property)
113 ]
119 ]
114 , testGroup "prop_bitget_bytestring_interspersed"
120 , testGroup "prop_bitget_bytestring_interspersed"
115− [ testProperty "Word8" (prop_bitget_bytestring_interspersed :: W Word8 -> [B.ByteString] -> Property)
121+ [ testProperty "Word8" (prop_bitget_bytestring_interspersed :: BitOrder -> W Word8 -> [B.ByteString] -> Property)
116− , testProperty "Word16" (prop_bitget_bytestring_interspersed :: W Word16 -> [B.ByteString] -> Property)
122+ , testProperty "Word16" (prop_bitget_bytestring_interspersed :: BitOrder -> W Word16 -> [B.ByteString] -> Property)
117− , testProperty "Word32" (prop_bitget_bytestring_interspersed :: W Word32 -> [B.ByteString] -> Property)
123+ , testProperty "Word32" (prop_bitget_bytestring_interspersed :: BitOrder -> W Word32 -> [B.ByteString] -> Property)
118− , testProperty "Word64" (prop_bitget_bytestring_interspersed :: W Word64 -> [B.ByteString] -> Property)
124+ , testProperty "Word64" (prop_bitget_bytestring_interspersed :: BitOrder -> W Word64 -> [B.ByteString] -> Property)
119 ]
125 ]
120 , testGroup "Simulate programs"
126 , testGroup "Simulate programs"
121 [ testProperty "primitive" prop_primitive
127 [ testProperty "primitive" prop_primitive
@@ -158,13 +164,28 @@ prop_getByteString_negative n =
158 n < 1 ==>
164 n < 1 ==>
159 runGet (runBitGet (getByteString n)) L.empty == B.empty
165 runGet (runBitGet (getByteString n)) L.empty == B.empty
160
166
167+prop_putByteString_getByteString :: BitOrder -> B.ByteString -> Property
168+prop_putByteString_getByteString bo bs = property $ bs' == bs
169+ where
170+ n = B.length bs
171+ w = runPut (runBitPut (withBitOrder bo (putByteString bs)))
172+ bs' = runGet (runBitGet (withBitOrder bo (getByteString n))) w
173+
174+prop_putByteString_getByteString_many :: BitOrder -> [B.ByteString] -> Property
175+prop_putByteString_getByteString_many bo bs = property $ bs' == bs
176+ where
177+ n = fmap B.length bs
178+ w = runPut (runBitPut (withBitOrder bo (traverse_ putByteString bs)))
179+ bs' = runGet (runBitGet (withBitOrder bo (traverse getByteString n))) w
180+
181+
161−prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W a -> Property
182+prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => BitOrder -> W a -> Property
162−prop_putget_with_bitreq (W w) = property $
183+prop_putget_with_bitreq bo (W w) = property $
163 -- write all words with as many bits as it's required
184 -- write all words with as many bits as it's required
164 let p = putBits (bitreq w) w
185 let p = putBits (bitreq w) w
165 g = getBits (bitreq w)
186 g = getBits (bitreq w)
166− lbs = runPut (runBitPut p)
187+ lbs = runPut (runBitPut (withBitOrder bo p))
167− w' = runGet (runBitGet g) lbs
188+ w' = runGet (runBitGet (withBitOrder bo g)) lbs
168 in w == w'
189 in w == w'
169
190
170-- | Write a list of items. Each item is written with the maximum amount of
191-- | 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 $
226 in ws == ws'
247 in ws == ws'
227
248
228-- | Write each 'ByteString' with a variable sized value as a separator.
249-- | Write each 'ByteString' with a variable sized value as a separator.
229−prop_bitget_bytestring_interspersed :: (BinaryBit a, Binary a, Num a, Ord a, Bits a) => W a -> [B.ByteString] -> Property
250+prop_bitget_bytestring_interspersed :: (BinaryBit a, Binary a, Num a, Ord a, Bits a) => BitOrder -> W a -> [B.ByteString] -> Property
230−prop_bitget_bytestring_interspersed (W ws) bss = property $
251+prop_bitget_bytestring_interspersed bo (W ws) bss = property $
231 let p = mapM_ (\bs -> putBits (bitreq ws) ws >> putByteString bs) bss
252 let p = mapM_ (\bs -> putBits (bitreq ws) ws >> putByteString bs) bss
232 g = mapM (\bs -> (,) <$> getBits (bitreq ws) <*> getByteString (B.length bs)) bss
253 g = mapM (\bs -> (,) <$> getBits (bitreq ws) <*> getByteString (B.length bs)) bss
233− lbs = runPut (runBitPut p)
254+ lbs = runPut (runBitPut (withBitOrder bo p))
234− r = runGet (runBitGet g) lbs
255+ r = runGet (runBitGet (withBitOrder bo g)) lbs
235 in map (ws,) bss == r
256 in map (ws,) bss == r
236
257
237-- | Test failing.
258-- | Test failing.
@@ -425,6 +446,14 @@ instance Arbitrary Primitive where
425 LBS _ lbs -> let ws = L.unpack lbs in map (\ws' -> LBS (length ws') (L.pack ws')) (shrink ws)
446 LBS _ lbs -> let ws = L.unpack lbs in map (\ws' -> LBS (length ws') (L.pack ws')) (shrink ws)
426 IsEmpty -> []
447 IsEmpty -> []
427
448
449+instance Arbitrary BitOrder where
450+ arbitrary = elements [BB, LB, LL, BL]
451+ shrink LL = [BB,LB,BL]
452+ shrink BL = [BB,LB]
453+ shrink LB = [BB]
454+ shrink BB = []
455+
456+
428prop_primitive :: Primitive -> Property
457prop_primitive :: Primitive -> Property
429prop_primitive prim = property $
458prop_primitive prim = property $
430 let p = putPrimitive prim
459 let p = putPrimitive prim
Data/Binary/Bits/Get.hs+10−9
@@ -239,16 +239,17 @@ readWordChecked m n s
239readByteString :: Int -> S -> ByteString
239readByteString :: Int -> S -> ByteString
240readByteString n (S bs o bo) =
240readByteString n (S bs o bo) =
241 let
241 let
242− bs' = unsafeTake (n+1) bs
242+ bs' = unsafeTake (n+1) bs
243+ bs'' = unsafeTake n bs
243− rev = B.map (reverseBits 8)
244+ rev = B.map (reverseBits 8)
244 in case (o,bo) of
245 in case (o,bo) of
245− (0,BB) -> unsafeTake n bs
246+ (0,BB) -> bs''
246− (0,LB) -> B.reverse (unsafeTake n bs)
247+ (0,LB) -> B.reverse bs''
247− (0,BL) -> rev (unsafeTake n bs)
248+ (0,LL) -> rev bs''
248− (0,LL) -> rev (B.reverse (unsafeTake n bs))
249+ (0,BL) -> rev . B.reverse $ bs''
249− (_,BL) -> rev (readByteString n (S (B.reverse bs') o LB))
250+ (_,LB) -> readByteString n (S (B.reverse bs') (8-o) BB)
250− (_,LL) -> rev (readByteString n (S (B.reverse bs') o BB))
251+ (_,BL) -> rev . B.reverse $ readByteString n (S bs' o BB)
251− (_,LB) -> readByteString n (S (B.reverse bs') o BB)
252+ (_,LL) -> rev . B.reverse $ readByteString n (S bs' o LB)
252 (_,BB) -> unsafePerformIO $ do
253 (_,BB) -> unsafePerformIO $ do
253 let len = n+1
254 let len = n+1
254 ptr <- mallocBytes len
255 ptr <- mallocBytes len
Data/Binary/Bits/Put.hs+15−16
@@ -82,9 +82,9 @@ putWordS n w s@(S builder b o bo) = s'
82 -- Word containing the remaining (n-cn) bits to store in its LSB
82 -- Word containing the remaining (n-cn) bits to store in its LSB
83 w' = case bo of
83 w' = case bo of
84 BB -> w
84 BB -> w
85− BL -> w
85+ BL -> w `fastShiftR` cn
86 LB -> w `fastShiftR` cn
86 LB -> w `fastShiftR` cn
87− LL -> w `fastShiftR` cn
87+ LL -> w
88
88
89 -- Select bits to store in the current byte.
89 -- Select bits to store in the current byte.
90 -- Put them in the correct order and return them in the least-significant
90 -- 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'
92 selectBits :: (Num a, FastBits a, Integral a) => a -> Word8
92 selectBits :: (Num a, FastBits a, Integral a) => a -> Word8
93 selectBits x = fromIntegral $ case bo of
93 selectBits x = fromIntegral $ case bo of
94 BB -> mask cn $ x `fastShiftR` (n-cn)
94 BB -> mask cn $ x `fastShiftR` (n-cn)
95− BL -> reverseBits cn $ mask cn $ x `fastShiftR` (n-cn)
95+ LL -> reverseBits cn $ mask cn $ x `fastShiftR` (n-cn)
96 LB -> mask cn x
96 LB -> mask cn x
97− LL -> reverseBits cn $ mask cn x
97+ BL -> reverseBits cn $ mask cn x
98
98
99 -- shift left at the correct position
99 -- shift left at the correct position
100 shl :: Word8 -> Word8
100 shl :: Word8 -> Word8
@@ -148,20 +148,19 @@ putByteString :: ByteString -> BitPut ()
148putByteString bs = BitPut $ \s -> PairS () (putByteStringS bs s)
148putByteString bs = BitPut $ \s -> PairS () (putByteStringS bs s)
149
149
150putByteStringS :: ByteString -> S -> S
150putByteStringS :: ByteString -> S -> S
151−putByteStringS bs (S builder b 0 BB) = S (builder `mappend` B.fromByteString bs) b 0 BB
151+putByteStringS bs s
152−putByteStringS bs s@(S _ _ _ BB)
153 | BS.null bs = s
152 | BS.null bs = s
153+ | otherwise = case s of
154+ (S builder b 0 BB) -> S (builder `mappend` B.fromByteString bs) b 0 BB
155+ (S builder b 0 LB) -> S (builder `mappend` B.fromByteString (BS.reverse bs)) b 0 LB
156+ (S builder b 0 LL) -> S (builder `mappend` B.fromByteString (rev bs)) b 0 LL
157+ (S builder b 0 BL) -> S (builder `mappend` B.fromByteString (rev (BS.reverse bs))) b 0 BL
154− | otherwise = putByteStringS (BS.unsafeTail bs) (putWordS 8 (BS.unsafeHead bs) s)
158+ (S _ _ _ BB) -> putByteStringS (BS.unsafeTail bs) (putWordS 8 (BS.unsafeHead bs) s)
155−putByteStringS bs (S builder b o bo) = putByteStringS bs' (S builder b o BB)
159+ (S _ _ _ LB) -> putByteStringS (BS.unsafeInit bs) (putWordS 8 (BS.unsafeLast bs) s)
160+ (S _ _ _ BL) -> putByteStringS (BS.unsafeInit bs) (putWordS 8 (BS.unsafeLast bs) s)
161+ (S _ _ _ LL) -> putByteStringS (BS.unsafeTail bs) (putWordS 8 (BS.unsafeHead bs) s)
156 where
162 where
157− rev = BS.map (reverseBits 8)
163+ rev = BS.map (reverseBits 8)
158−
159− bs' = case bo of
160− BL -> BS.reverse (rev bs)
161− LB -> BS.reverse bs
162− LL -> rev bs
163− BB -> bs -- should not occur, already matched but the compiler doesn't detect it
164−
165
164
166
165
167-- | Run a 'Put' inside 'BitPut'. Any partially written bytes will be flushed
166-- | Run a 'Put' inside 'BitPut'. Any partially written bytes will be flushed