git.iko.soy/binary-bits
on 2cb8908 help sign in
binary-bits/BitsQC.hs
516 lines 20 kB history raw
1{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts, TupleSections #-}
3module Main ( main ) where
5import Data.Binary ( Binary(..) )
6import Data.Binary.Get ( runGet, runGetIncremental, pushChunks, Decoder(..) )
7import Data.Binary.Put ( runPut )
9import Data.Binary.Bits
10import Data.Binary.Bits.Get
11import Data.Binary.Bits.Put
13import qualified Data.ByteString as B
14import qualified Data.ByteString.Lazy as L
16import Control.Applicative
17import Data.Bits
18import Data.Word
19import Foreign.Storable
20import System.Random
22import Test.Framework.Providers.QuickCheck2 ( testProperty )
23import Test.Framework.Runners.Console ( defaultMain )
24import Test.Framework ( Test, testGroup )
25import Test.QuickCheck
27main :: IO ()
28main = defaultMain tests
30tests :: [Test]
31tests =
32 [ testGroup "Internal test functions"
33 [ testProperty "prop_bitreq" prop_bitreq ]
35 , testGroup "Custom test cases"
36 [ testProperty "prop_composite_case" prop_composite_case ]
38 , testGroup "getByteString"
39 [ testProperty "prop_getByteString_negative" prop_getByteString_negative ]
41 , testGroup "getLazyByteString"
42 [ testProperty "getLazyByteString == getByteString"
43 prop_getLazyByteString_equal_to_ByteString
44 , testProperty "getLazyByteString == getByteString (with shift)"
45 prop_getLazyByteString_equal_to_ByteString2
46 ]
48 , testGroup "isEmpty"
49 [ testProperty "prop_isEmptyOfEmptyEmpty" prop_isEmptyOfEmptyEmpty
50 , testProperty "prop_isEmptyOfNonEmptyEmpty" prop_isEmptyOfNonEmptyEmpty
51 , testProperty "prop_isEmptyOfConsumedEmpty" prop_isEmptyOfConsumedEmpty
52 , testProperty "prop_isEmptyOfNotConsumedNotEmpty" prop_isEmptyOfNotConsumedNotEmpty
53 ]
55 , testGroup "Fail"
56 [ testProperty "monadic fail" prop_fail ]
58 , testGroup "prop_bitput_with_get_from_binary"
59 [ testProperty "Word8" (prop_bitput_with_get_from_binary :: W [Word8] -> Property)
60 , testProperty "Word16" (prop_bitput_with_get_from_binary :: W [Word16] -> Property)
61 , testProperty "Word32" (prop_bitput_with_get_from_binary :: W [Word32] -> Property)
62 , testProperty "Word64" (prop_bitput_with_get_from_binary :: W [Word64] -> Property)
63 ]
65 , testGroup "prop_bitget_with_put_from_binary"
66 [ testProperty "Word8" (prop_bitget_with_put_from_binary :: W [Word8] -> Property)
67 , testProperty "Word16" (prop_bitget_with_put_from_binary :: W [Word16] -> Property)
68 , testProperty "Word32" (prop_bitget_with_put_from_binary :: W [Word32] -> Property)
69 , testProperty "Word64" (prop_bitget_with_put_from_binary :: W [Word64] -> Property)
70 ]
72 , testGroup "prop_compare_put_with_naive"
73 [ testProperty "Word8" (prop_compare_put_with_naive :: W [Word8] -> Property)
74 , testProperty "Word16" (prop_compare_put_with_naive :: W [Word16] -> Property)
75 , testProperty "Word32" (prop_compare_put_with_naive :: W [Word32] -> Property)
76 , testProperty "Word64" (prop_compare_put_with_naive :: W [Word64] -> Property)
77 ]
79 , testGroup "prop_compare_get_with_naive"
80 [ testProperty "Word8" (prop_compare_get_with_naive:: W [Word8] -> Property)
81 , testProperty "Word16" (prop_compare_get_with_naive:: W [Word16] -> Property)
82 , testProperty "Word32" (prop_compare_get_with_naive:: W [Word32] -> Property)
83 , testProperty "Word64" (prop_compare_get_with_naive:: W [Word64] -> Property)
84 ]
86 , testGroup "prop_put_with_bitreq"
87 [ testProperty "Word8" (prop_putget_with_bitreq :: W Word8 -> Property)
88 , testProperty "Word16" (prop_putget_with_bitreq :: W Word16 -> Property)
89 , testProperty "Word32" (prop_putget_with_bitreq :: W Word32 -> Property)
90 , testProperty "Word64" (prop_putget_with_bitreq :: W Word64 -> Property)
91 ]
93 , testGroup "prop_putget_list_simple"
94 [ testProperty "Bool" (prop_putget_list_simple :: W [Bool] -> Property)
95 , testProperty "Word8" (prop_putget_list_simple :: W [Word8] -> Property)
96 , testProperty "Word16" (prop_putget_list_simple :: W [Word16] -> Property)
97 , testProperty "Word32" (prop_putget_list_simple :: W [Word32] -> Property)
98 , testProperty "Word64" (prop_putget_list_simple :: W [Word64] -> Property)
99 ]
101 , testGroup "prop_putget_applicative_with_bitreq"
102 [ testProperty "Word8" (prop_putget_applicative_with_bitreq :: W [(Word8,Word8,Word8)] -> Property)
103 , testProperty "Word16" (prop_putget_applicative_with_bitreq :: W [(Word16,Word16,Word16)] -> Property)
104 , testProperty "Word32" (prop_putget_applicative_with_bitreq :: W [(Word32,Word32,Word32)] -> Property)
105 , testProperty "Word64" (prop_putget_applicative_with_bitreq :: W [(Word64,Word64,Word64)] -> Property)
106 ]
108 , testGroup "prop_putget_list_with_bitreq"
109 [ testProperty "Word8" (prop_putget_list_with_bitreq :: W [Word8] -> Property)
110 , testProperty "Word16" (prop_putget_list_with_bitreq :: W [Word16] -> Property)
111 , testProperty "Word32" (prop_putget_list_with_bitreq :: W [Word32] -> Property)
112 , testProperty "Word64" (prop_putget_list_with_bitreq :: W [Word64] -> Property)
113 ]
114 , testGroup "prop_bitget_bytestring_interspersed"
115 [ testProperty "Word8" (prop_bitget_bytestring_interspersed :: W Word8 -> [B.ByteString] -> Property)
116 , testProperty "Word16" (prop_bitget_bytestring_interspersed :: W Word16 -> [B.ByteString] -> Property)
117 , testProperty "Word32" (prop_bitget_bytestring_interspersed :: W Word32 -> [B.ByteString] -> Property)
118 , testProperty "Word64" (prop_bitget_bytestring_interspersed :: W Word64 -> [B.ByteString] -> Property)
119 ]
120 , testGroup "Simulate programs"
121 [ testProperty "primitive" prop_primitive
122 , testProperty "many primitives in sequence" prop_program
123 ]
124 ]
126prop_isEmptyOfEmptyEmpty :: Bool
127prop_isEmptyOfEmptyEmpty = runGet (runBitGet isEmpty) L.empty
129prop_isEmptyOfNonEmptyEmpty :: L.ByteString -> Property
130prop_isEmptyOfNonEmptyEmpty bs =
131 not (L.null bs) ==> not (runGet (runBitGet isEmpty) bs)
133prop_isEmptyOfConsumedEmpty :: L.ByteString -> Property
134prop_isEmptyOfConsumedEmpty bs =
135 not (L.null bs) ==>
136 runGet (runBitGet (getByteString n >> isEmpty)) bs
137 where n = fromIntegral $ L.length bs
139prop_isEmptyOfNotConsumedNotEmpty :: L.ByteString -> Int -> Property
140prop_isEmptyOfNotConsumedNotEmpty bs n =
141 (fromIntegral n) < L.length bs && not (L.null bs) ==>
142 not (runGet (runBitGet (getByteString n >> isEmpty)) bs)
144prop_getLazyByteString_equal_to_ByteString :: L.ByteString -> Int -> Property
145prop_getLazyByteString_equal_to_ByteString bs n =
146 (fromIntegral n) <= L.length bs ==>
147 runGet (runBitGet (getLazyByteString (fromIntegral n))) bs ==
148 (L.fromChunks . (:[]) $ runGet (runBitGet (getByteString n)) bs)
150prop_getLazyByteString_equal_to_ByteString2 :: L.ByteString -> Int -> Property
151prop_getLazyByteString_equal_to_ByteString2 bs n =
152 (L.length bs > 1) && (fromIntegral n) < L.length bs ==>
153 runGet (runBitGet (getWord8 2 >> getLazyByteString (fromIntegral n))) bs ==
154 (L.fromChunks . (:[]) $ runGet (runBitGet (getWord8 2 >> getByteString n)) bs)
156prop_getByteString_negative :: Int -> Property
157prop_getByteString_negative n =
158 n < 1 ==>
159 runGet (runBitGet (getByteString n)) L.empty == B.empty
161prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W a -> Property
162prop_putget_with_bitreq (W w) = property $
163 -- write all words with as many bits as it's required
164 let p = putBits (bitreq w) w
165 g = getBits (bitreq w)
166 lbs = runPut (runBitPut p)
167 w' = runGet (runBitGet g) lbs
168 in w == w'
170-- | Write a list of items. Each item is written with the maximum amount of
171-- bits, i.e. 8 for Word8, 16 for Word16, etc.
172prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => W [a] -> Property
173prop_putget_list_simple (W ws) = property $
174 let s = sizeOf (head ws) * 8
175 p = mapM_ (putBits s) ws
176 g = mapM (const (getBits s)) ws
177 lbs = runPut (runBitPut p)
178 ws' = runGet (runBitGet g) lbs
179 in ws == ws'
181-- | Write a list of items. Each item is written with exactly as many bits
182-- as required. Then read it back.
183prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [a] -> Property
184prop_putget_list_with_bitreq (W ws) = property $
185 -- write all words with as many bits as it's required
186 let p = mapM_ (\v -> putBits (bitreq v) v) ws
187 g = mapM getBits bitlist
188 lbs = runPut (runBitPut p)
189 ws' = runGet (runBitGet g) lbs
190 in ws == ws'
191 where
192 bitlist = map bitreq ws
194prop_putget_applicative_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [(a,a,a)] -> Property
195prop_putget_applicative_with_bitreq (W ts) = property $
196 let p = mapM_ (\(a,b,c) -> do putBits (bitreq a) a
197 putBits (bitreq b) b
198 putBits (bitreq c) c) ts
199 g = mapM (\(a,b,c) -> (,,) <$> getBits a <*> getBits b <*> getBits c) bitlist
200 lbs = runPut (runBitPut p)
201 ts' = runGet (runBitGet g) lbs
202 in ts == ts'
203 where
204 bitlist = map (\(a,b,c) -> (bitreq a, bitreq b, bitreq c)) ts
206-- | Write bits using this library, and read them back using the binary
207-- library.
208prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
209prop_bitput_with_get_from_binary (W ws) = property $
210 let s = sizeOf (head ws) * 8
211 p = mapM_ (putBits s) ws
212 g = mapM (const get) ws
213 lbs = runPut (runBitPut p)
214 ws' = runGet g lbs
215 in ws == ws'
217-- | Write bits using the binary library, and read them back using this
218-- library.
219prop_bitget_with_put_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
220prop_bitget_with_put_from_binary (W ws) = property $
221 let s = sizeOf (head ws) * 8
222 p = mapM_ put ws
223 g = mapM (const (getBits s)) ws
224 lbs = runPut p
225 ws' = runGet (runBitGet g) lbs
226 in ws == ws'
228-- | Write each 'ByteString' with a variable sized value as a separator.
229prop_bitget_bytestring_interspersed :: (BinaryBit a, Binary a, Num a, Ord a, Bits a) => W a -> [B.ByteString] -> Property
230prop_bitget_bytestring_interspersed (W ws) bss = property $
231 let p = mapM_ (\bs -> putBits (bitreq ws) ws >> putByteString bs) bss
232 g = mapM (\bs -> (,) <$> getBits (bitreq ws) <*> getByteString (B.length bs)) bss
233 lbs = runPut (runBitPut p)
234 r = runGet (runBitGet g) lbs
235 in map (ws,) bss == r
237-- | Test failing.
238prop_fail :: L.ByteString -> String -> Property
239prop_fail lbs errMsg0 = forAll (choose (0, 8 * L.length lbs)) $ \len ->
240 let (bytes,bits) = len `divMod` 8
241 expectedBytesConsumed
242 | bits == 0 = bytes
243 | otherwise = bytes + 1
244 p = do getByteString (fromIntegral bytes)
245 getBits (fromIntegral bits) :: BitGet Word8
246 fail errMsg0
247 r = runGetIncremental (runBitGet p) `pushChunks` lbs
248 in case r of
249 Fail remainingBS pos errMsg ->
250 and [ L.fromChunks [remainingBS] == L.drop expectedBytesConsumed lbs
251 , pos == expectedBytesConsumed
252 , errMsg == errMsg0
253 ]
254 _ -> False
256-- | number of bits required to write @v@
257bitreq :: (Num b, Num a, Bits a, Ord a) => a -> b
258bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]
260bittable :: (Bits a, Num a) => [(Integer, a)]
261bittable = [ (fromIntegral x, (1 `shiftL` x) - 1) | x <- [1..64] ]
263prop_bitreq :: W Word64 -> Property
264prop_bitreq (W w) = property $
265 ( w == 0 && bitreq w == 1 )
266 || bitreq w == bitreq (w `shiftR` 1) + 1
268prop_composite_case :: Bool -> W Word16 -> Property
269prop_composite_case b (W w) = w < 0x8000 ==>
270 let p = do putBool b
271 putWord16be 15 w
272 g = do v <- getBool
273 case v of
274 True -> getWord16be 15
275 False -> do
276 msb <- getWord8 7
277 lsb <- getWord8 8
278 return ((fromIntegral msb `shiftL` 8) .|. fromIntegral lsb)
279 lbs = runPut (runBitPut p)
280 w' = runGet (runBitGet g) lbs
281 in w == w'
283prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => W [a] -> Property
284prop_compare_put_with_naive (W ws) = property $
285 let pn = mapM_ (\v -> naive_put (bitreq v) v) ws
286 p = mapM_ (\v -> putBits (bitreq v) v) ws
287 lbs_n = runPut (runBitPut pn)
288 lbs = runPut (runBitPut p)
289 in lbs_n == lbs
291prop_compare_get_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => W [a] -> Property
292prop_compare_get_with_naive (W ws) = property $
293 let gn = mapM (\v -> naive_get (bitreq v)) ws
294 g = mapM (\v -> getBits (bitreq v)) ws
295 p = mapM_ (\v -> naive_put (bitreq v) v) ws
296 lbs = runPut (runBitPut p)
297 rn = runGet (runBitGet gn) lbs
298 r = runGet (runBitGet g ) lbs
299 -- we must help our compiler to resolve the types of 'gn' and 'g'
300 _types = rn == ws && r == ws
301 in rn == r
303-- | Write one bit at a time until the full word has been written
304naive_put :: (Bits a) => Int -> a -> BitPut ()
305naive_put n w = mapM_ (\b -> putBool (testBit w b)) [n-1,n-2..0]
307-- | Read one bit at a time until we've reconstructed the whole word
308naive_get :: (Bits a, Num a) => Int -> BitGet a
309naive_get n0 =
310 let loop 0 acc = return acc
311 loop n acc = do
312 b <- getBool
313 case b of
314 False -> loop (n-1) (acc `shiftL` 1)
315 True -> loop (n-1) ((acc `shiftL` 1) + 1)
316 in loop n0 0
318shrinker :: (Num a, Ord a, Bits a) => a -> [a]
319shrinker 0 = []
320shrinker w = [ w `shiftR` 1 -- try to make everything roughly half size
321 ] ++ [ w' -- flip bits to zero, left->right
322 | m <- [n, n-1..1]
323 , let w' = w `clearBit` m
324 , w /= w'
325 ] ++ [w-1] -- just make it a little smaller
326 where
327 n = bitreq w
329data W a = W { unW :: a } deriving (Show, Eq, Ord)
331arbitraryW :: (Arbitrary (W a)) => Gen a
332arbitraryW = unW <$> arbitrary
334shrinkW :: (Arbitrary (W a)) => a -> [a]
335shrinkW x = unW <$> shrink (W x)
337instance Arbitrary (W Bool) where
338 arbitrary = W <$> arbitrary
339 shrink = map W <$> shrink . unW
341instance Arbitrary (W Word8) where
342 arbitrary = W <$> choose (minBound, maxBound)
343 shrink = map W . shrinker . unW
345instance Arbitrary (W Word16) where
346 arbitrary = W <$> choose (minBound, maxBound)
347 shrink = map W . shrinker . unW
349instance Arbitrary (W Word32) where
350 arbitrary = W <$> choose (minBound, maxBound)
351 shrink = map W . shrinker . unW
353instance Arbitrary (W Word64) where
354 arbitrary = W <$> choose (minBound, maxBound)
355 shrink = map W . shrinker . unW
357instance Arbitrary B.ByteString where
358 arbitrary = B.pack <$> arbitrary
359 shrink bs = B.pack <$> shrink (B.unpack bs)
361instance Arbitrary L.ByteString where
362 arbitrary = L.fromChunks <$> arbitrary
363 shrink bs = L.fromChunks <$> shrink (L.toChunks bs)
365instance (Arbitrary (W a)) => Arbitrary (W [a]) where
366 arbitrary = W . map unW <$> arbitrary
367 shrink = map (W . map unW) <$> mapM shrink . map W . unW
369instance (Arbitrary (W a), Arbitrary (W b)) => Arbitrary (W (a,b)) where
370 arbitrary = (W .) . (,) <$> arbitraryW <*> arbitraryW
371 shrink (W (a,b)) = (W .) . (,) <$> shrinkW a <*> shrinkW b
373instance (Arbitrary (W a), Arbitrary (W b), Arbitrary (W c)) => Arbitrary (W (a,b,c)) where
374 arbitrary = ((W .) .) . (,,) <$> arbitraryW <*> arbitraryW <*> arbitraryW
375 shrink (W (a,b,c)) = ((W .) .) . (,,) <$> shrinkW a <*> shrinkW b <*> shrinkW c
377integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
378integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
379 fromIntegral b :: Integer) g of
380 (x,g) -> (fromIntegral x, g)
382data Primitive
383 = Bool Bool
384 | W8 Int Word8
385 | W16 Int Word16
386 | W32 Int Word32
387 | W64 Int Word64
388 | BS Int B.ByteString
389 | LBS Int L.ByteString
390 | IsEmpty
391 deriving (Eq, Show)
393type Program = [Primitive]
395instance Arbitrary Primitive where
396 arbitrary = do
397 let gen c = do
398 let (maxBits, _) = (\w -> (bitSize w, c undefined w)) undefined
399 bits <- choose (0, maxBits)
400 n <- choose (0, fromIntegral (2^bits-1))
401 return (c bits n)
402 oneof
403 [ Bool <$> arbitrary
404 , gen W8
405 , gen W16
406 , gen W32
407 , gen W64
408 , do n <- choose (0,10)
409 cs <- vector n
410 return (BS n (B.pack cs))
411 , do n <- choose (0,10)
412 cs <- vector n
413 return (LBS n (L.pack cs))
414 , return IsEmpty
415 ]
416 shrink p =
417 let snk c x = map (\x' -> c (bitreq x') x') (shrinker x) in
418 case p of
419 Bool b -> if b then [Bool False] else []
420 W8 _ x -> snk W8 x
421 W16 _ x -> snk W16 x
422 W32 _ x -> snk W32 x
423 W64 _ x -> snk W64 x
424 BS _ bs -> let ws = B.unpack bs in map (\ws' -> BS (length ws') (B.pack ws')) (shrink ws)
425 LBS _ lbs -> let ws = L.unpack lbs in map (\ws' -> LBS (length ws') (L.pack ws')) (shrink ws)
426 IsEmpty -> []
428prop_primitive :: Primitive -> Property
429prop_primitive prim = property $
430 let p = putPrimitive prim
431 g = getPrimitive prim
432 lbs = runPut (runBitPut p)
433 r = runGet (runBitGet g) lbs
434 in r == prim
436prop_program :: Program -> Property
437prop_program program = property $
438 let p = mapM_ putPrimitive program
439 g = verifyProgram (8 * fromIntegral (L.length lbs)) program
440 lbs = runPut (runBitPut p)
441 r = runGet (runBitGet g) lbs
442 in r
444putPrimitive :: Primitive -> BitPut ()
445putPrimitive p =
446 case p of
447 Bool b -> putBool b
448 W8 n x -> putWord8 n x
449 W16 n x -> putWord16be n x
450 W32 n x -> putWord32be n x
451 W64 n x -> putWord64be n x
452 BS _ bs -> putByteString bs
453 LBS _ lbs -> mapM_ putByteString (L.toChunks lbs)
454 IsEmpty -> return ()
456getPrimitive :: Primitive -> BitGet Primitive
457getPrimitive p =
458 case p of
459 Bool _ -> Bool <$> getBool
460 W8 n _ -> W8 n <$> getWord8 n
461 W16 n _ -> W16 n <$> getWord16be n
462 W32 n _ -> W32 n <$> getWord32be n
463 W64 n _ -> W64 n <$> getWord64be n
464 BS n _ -> BS n <$> getByteString n
465 LBS n _ -> LBS n <$> getLazyByteString n
466 IsEmpty -> isEmpty >> return IsEmpty
469verifyProgram :: Int -> Program -> BitGet Bool
470verifyProgram totalLength ps0 = go 0 ps0
471 where
472 go _ [] = return True
473 go pos (p:ps) =
474 case p of
475 Bool x -> check x getBool >> go (pos+1) ps
476 W8 n x -> check x (getWord8 n) >> go (pos+n) ps
477 W16 n x -> check x (getWord16be n) >> go (pos+n) ps
478 W32 n x -> check x (getWord32be n) >> go (pos+n) ps
479 W64 n x -> check x (getWord64be n) >> go (pos+n) ps
480 BS n x -> check x (getByteString n) >> go (pos+(8*n)) ps
481 LBS n x -> check x (getLazyByteString n) >> go (pos+(8*n)) ps
482 IsEmpty -> do
483 let expected = pos == totalLength
484 actual <- isEmpty
485 if expected == actual
486 then go pos ps
487 else error $ "isEmpty returned wrong value, expected "
488 ++ show expected ++ " but got " ++ show actual
489 check x g = do
490 y <- g
491 if x == y
492 then return ()
493 else error $ "Roundtrip error: Expected "
494 ++ show x ++ " but got " ++ show y
496{-
497instance Random Word where
498 randomR = integralRandomR
499 random = randomR (minBound,maxBound)
501instance Random Word8 where
502 randomR = integralRandomR
503 random = randomR (minBound,maxBound)
505instance Random Word16 where
506 randomR = integralRandomR
507 random = randomR (minBound,maxBound)
509instance Random Word32 where
510 randomR = integralRandomR
511 random = randomR (minBound,maxBound)
513instance Random Word64 where
514 randomR = integralRandomR
515 random = randomR (minBound,maxBound)
516-}