git.iko.soy/binary-bits
on 89e4dff help sign in
binary-bits/BitsQC.hs
360 lines 15 kB history raw
1{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts, TupleSections #-}
3module Main where
5import Data.Binary ( encode, Binary(..) )
6import Data.Binary.Get ( runGet, runGetIncremental, pushChunks, Decoder(..) )
7import Data.Binary.Put ( runPut )
9import qualified Data.Binary.Get as BG ( getWord8, getWord16be, getWord32be, getWord64be )
10import qualified Data.Binary.Put as BP ( putWord8, putWord16be, putWord32be, putWord64be )
12import Data.Binary.Bits
13import Data.Binary.Bits.Get
14import Data.Binary.Bits.Put
16import qualified Data.ByteString as B
17import qualified Data.ByteString.Lazy as L
19import Control.Applicative
20import Data.Bits
21import Data.Monoid
22import Data.Word
23import Foreign.Storable
24import System.Random
26import Test.Framework.Options ( TestOptions'(..) )
27import Test.Framework.Providers.QuickCheck2 ( testProperty )
28import Test.Framework.Runners.Console ( defaultMain )
29import Test.Framework.Runners.Options ( RunnerOptions'(..) )
30import Test.Framework ( Test, testGroup )
31import Test.QuickCheck
33main = defaultMain tests
35tests :: [Test]
36tests =
37 [ testGroup "Internal test functions"
38 [ testProperty "prop_bitreq" prop_bitreq ]
40 , testGroup "Custom test cases"
41 [ testProperty "prop_composite_case" prop_composite_case ]
43 , testGroup "getByteString"
44 [ testProperty "prop_getByteString_negative" prop_getByteString_negative ]
46 , testGroup "Fail"
47 [ testProperty "monadic fail" prop_fail ]
49 , testGroup "prop_bitput_with_get_from_binary"
50 [ testProperty "Word8" (prop_bitput_with_get_from_binary :: W [Word8] -> Property)
51 , testProperty "Word16" (prop_bitput_with_get_from_binary :: W [Word16] -> Property)
52 , testProperty "Word32" (prop_bitput_with_get_from_binary :: W [Word32] -> Property)
53 , testProperty "Word64" (prop_bitput_with_get_from_binary :: W [Word64] -> Property)
54 ]
56 , testGroup "prop_bitget_with_put_from_binary"
57 [ testProperty "Word8" (prop_bitget_with_put_from_binary :: W [Word8] -> Property)
58 , testProperty "Word16" (prop_bitget_with_put_from_binary :: W [Word16] -> Property)
59 , testProperty "Word32" (prop_bitget_with_put_from_binary :: W [Word32] -> Property)
60 , testProperty "Word64" (prop_bitget_with_put_from_binary :: W [Word64] -> Property)
61 ]
63 , testGroup "prop_compare_put_with_naive"
64 [ testProperty "Word8" (prop_compare_put_with_naive :: W [Word8] -> Property)
65 , testProperty "Word16" (prop_compare_put_with_naive :: W [Word16] -> Property)
66 , testProperty "Word32" (prop_compare_put_with_naive :: W [Word32] -> Property)
67 , testProperty "Word64" (prop_compare_put_with_naive :: W [Word64] -> Property)
68 ]
70 , testGroup "prop_compare_get_with_naive"
71 [ testProperty "Word8" (prop_compare_get_with_naive:: W [Word8] -> Property)
72 , testProperty "Word16" (prop_compare_get_with_naive:: W [Word16] -> Property)
73 , testProperty "Word32" (prop_compare_get_with_naive:: W [Word32] -> Property)
74 , testProperty "Word64" (prop_compare_get_with_naive:: W [Word64] -> Property)
75 ]
77 , testGroup "prop_put_with_bitreq"
78 [ testProperty "Word8" (prop_putget_with_bitreq :: W Word8 -> Property)
79 , testProperty "Word16" (prop_putget_with_bitreq :: W Word16 -> Property)
80 , testProperty "Word32" (prop_putget_with_bitreq :: W Word32 -> Property)
81 , testProperty "Word64" (prop_putget_with_bitreq :: W Word64 -> Property)
82 ]
84 , testGroup "prop_putget_list_simple"
85 [ testProperty "Bool" (prop_putget_list_simple :: W [Bool] -> Property)
86 , testProperty "Word8" (prop_putget_list_simple :: W [Word8] -> Property)
87 , testProperty "Word16" (prop_putget_list_simple :: W [Word16] -> Property)
88 , testProperty "Word32" (prop_putget_list_simple :: W [Word32] -> Property)
89 , testProperty "Word64" (prop_putget_list_simple :: W [Word64] -> Property)
90 ]
92 , testGroup "prop_putget_applicative_with_bitreq"
93 [ testProperty "Word8" (prop_putget_applicative_with_bitreq :: W [(Word8,Word8,Word8)] -> Property)
94 , testProperty "Word16" (prop_putget_applicative_with_bitreq :: W [(Word16,Word16,Word16)] -> Property)
95 , testProperty "Word32" (prop_putget_applicative_with_bitreq :: W [(Word32,Word32,Word32)] -> Property)
96 , testProperty "Word64" (prop_putget_applicative_with_bitreq :: W [(Word64,Word64,Word64)] -> Property)
97 ]
99 , testGroup "prop_putget_list_with_bitreq"
100 [ testProperty "Word8" (prop_putget_list_with_bitreq :: W [Word8] -> Property)
101 , testProperty "Word16" (prop_putget_list_with_bitreq :: W [Word16] -> Property)
102 , testProperty "Word32" (prop_putget_list_with_bitreq :: W [Word32] -> Property)
103 , testProperty "Word64" (prop_putget_list_with_bitreq :: W [Word64] -> Property)
104 ]
105 , testGroup "prop_bitget_bytestring_interspersed"
106 [ testProperty "Word8" (prop_bitget_bytestring_interspersed :: W Word8 -> [B.ByteString] -> Property)
107 , testProperty "Word16" (prop_bitget_bytestring_interspersed :: W Word16 -> [B.ByteString] -> Property)
108 , testProperty "Word32" (prop_bitget_bytestring_interspersed :: W Word32 -> [B.ByteString] -> Property)
109 , testProperty "Word64" (prop_bitget_bytestring_interspersed :: W Word64 -> [B.ByteString] -> Property)
110 ]
111 ]
114prop_getByteString_negative :: Int -> Property
115prop_getByteString_negative n =
116 n < 1 ==>
117 runGet (runBitGet (getByteString n)) L.empty == B.empty
119prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W a -> Property
120prop_putget_with_bitreq (W w) = property $
121 -- write all words with as many bits as it's required
122 let p = putBits (bitreq w) w
123 g = getBits (bitreq w)
124 lbs = runPut (runBitPut p)
125 w' = runGet (runBitGet g) lbs
126 in w == w'
128-- | Write a list of items. Each item is written with the maximum amount of
129-- bits, i.e. 8 for Word8, 16 for Word16, etc.
130prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => W [a] -> Property
131prop_putget_list_simple (W ws) = property $
132 let s = sizeOf (head ws) * 8
133 p = mapM_ (\v -> putBits s v) ws
134 g = mapM (const (getBits s)) ws
135 lbs = runPut (runBitPut p)
136 ws' = runGet (runBitGet g) lbs
137 in ws == ws'
139-- | Write a list of items. Each item is written with exactly as many bits
140-- as required. Then read it back.
141prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [a] -> Property
142prop_putget_list_with_bitreq (W ws) = property $
143 -- write all words with as many bits as it's required
144 let p = mapM_ (\v -> putBits (bitreq v) v) ws
145 g = mapM getBits bitlist
146 lbs = runPut (runBitPut p)
147 ws' = runGet (runBitGet g) lbs
148 in ws == ws'
149 where
150 bitlist = map bitreq ws
152prop_putget_applicative_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [(a,a,a)] -> Property
153prop_putget_applicative_with_bitreq (W ts) = property $
154 let p = mapM_ (\(a,b,c) -> do putBits (bitreq a) a
155 putBits (bitreq b) b
156 putBits (bitreq c) c) ts
157 g = mapM (\(a,b,c) -> (,,) <$> getBits a <*> getBits b <*> getBits c) bitlist
158 lbs = runPut (runBitPut p)
159 ts' = runGet (runBitGet g) lbs
160 in ts == ts'
161 where
162 bitlist = map (\(a,b,c) -> (bitreq a, bitreq b, bitreq c)) ts
164-- | Write bits using this library, and read them back using the binary
165-- library.
166prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
167prop_bitput_with_get_from_binary (W ws) = property $
168 let s = sizeOf (head ws) * 8
169 p = mapM_ (putBits s) ws
170 g = mapM (const get) ws
171 lbs = runPut (runBitPut p)
172 ws' = runGet g lbs
173 in ws == ws'
175-- | Write bits using the binary library, and read them back using this
176-- library.
177prop_bitget_with_put_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
178prop_bitget_with_put_from_binary (W ws) = property $
179 let s = sizeOf (head ws) * 8
180 p = mapM_ put ws
181 g = mapM (const (getBits s)) ws
182 lbs = runPut p
183 ws' = runGet (runBitGet g) lbs
184 in ws == ws'
186-- | Write each 'ByteString' with a variable sized value as a separator.
187prop_bitget_bytestring_interspersed :: (BinaryBit a, Binary a, Num a, Ord a, Bits a) => W a -> [B.ByteString] -> Property
188prop_bitget_bytestring_interspersed (W ws) bss = property $
189 let p = mapM_ (\bs -> putBits (bitreq ws) ws >> putByteString bs) bss
190 g = mapM (\bs -> (,) <$> (getBits (bitreq ws)) <*> (getByteString (B.length bs))) bss
191 lbs = runPut (runBitPut p)
192 r = runGet (runBitGet g) lbs
193 in map (ws,) bss == r
195-- | Test failing.
196prop_fail :: L.ByteString -> String -> Property
197prop_fail lbs errMsg0 = forAll (choose (0, 8 * L.length lbs)) $ \len ->
198 let (bytes,bits) = len `divMod` 8
199 expectedBytesConsumed
200 | bits == 0 = bytes
201 | otherwise = bytes + 1
202 p = do getByteString (fromIntegral bytes)
203 getBits (fromIntegral bits) :: BitGet Word8
204 fail errMsg0
205 r = runGetIncremental (runBitGet p) `pushChunks` lbs
206 in case r of
207 Fail remainingBS pos errMsg ->
208 and [ L.fromChunks [remainingBS] == L.drop expectedBytesConsumed lbs
209 , pos == expectedBytesConsumed
210 , errMsg == errMsg0
211 ]
212 _ -> False
214-- | number of bits required to write @v@
215bitreq :: (Num b, Num a, Bits a, Ord a) => a -> b
216bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]
218bittable :: (Bits a, Num a) => [(Integer, a)]
219bittable = [ (fromIntegral x, (1 `shiftL` x) - 1) | x <- [1..64] ]
221prop_bitreq :: W Word64 -> Property
222prop_bitreq (W w) = property $
223 ( w == 0 && bitreq w == 1 )
224 || bitreq w == (bitreq (w `shiftR` 1)) + 1
226prop_composite_case :: Bool -> W Word16 -> Property
227prop_composite_case b (W w) = w < 0x8000 ==>
228 let p = do putBool b
229 putWord16be 15 w
230 g = do v <- getBool
231 case v of
232 True -> getWord16be 15
233 False -> do
234 msb <- getWord8 7
235 lsb <- getWord8 8
236 return ((fromIntegral msb `shiftL` 8) .|. fromIntegral lsb)
237 lbs = runPut (runBitPut p)
238 w' = runGet (runBitGet g) lbs
239 in w == w'
241prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => W [a] -> Property
242prop_compare_put_with_naive (W ws) = property $
243 let pn = mapM_ (\v -> naive_put (bitreq v) v) ws
244 p = mapM_ (\v -> putBits (bitreq v) v) ws
245 lbs_n = runPut (runBitPut pn)
246 lbs = runPut (runBitPut p)
247 in lbs_n == lbs
249prop_compare_get_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => W [a] -> Property
250prop_compare_get_with_naive (W ws) = property $
251 let gn = mapM (\v -> naive_get (bitreq v)) ws
252 g = mapM (\v -> getBits (bitreq v)) ws
253 p = mapM_ (\v -> naive_put (bitreq v) v) ws
254 lbs = runPut (runBitPut p)
255 rn = runGet (runBitGet gn) lbs
256 r = runGet (runBitGet g ) lbs
257 -- we must help our compiler to resolve the types of 'gn' and 'g'
258 types = rn == ws && r == ws
259 in rn == r
261-- | Write one bit at a time until the full word has been written
262naive_put :: (Bits a) => Int -> a -> BitPut ()
263naive_put n w = mapM_ (\b -> putBool (testBit w b)) [n-1,n-2..0]
265-- | Read one bit at a time until we've reconstructed the whole word
266naive_get :: (Bits a, Num a) => Int -> BitGet a
267naive_get n0 =
268 let loop 0 acc = return acc
269 loop n acc = do
270 b <- getBool
271 case b of
272 False -> loop (n-1) (acc `shiftL` 1)
273 True -> loop (n-1) ((acc `shiftL` 1) + 1)
274 in loop n0 0
276shrinker :: (Num a, Ord a, Bits a) => a -> [a]
277shrinker 0 = []
278shrinker w = [ w `shiftR` 1 -- try to make everything roughly half size
279 ] ++ [ w' -- flip bits to zero, left->right
280 | m <- [n, n-1..1]
281 , let w' = w `clearBit` m
282 , w /= w'
283 ] ++ [w-1] -- just make it a little smaller
284 where
285 n = bitreq w
287data W a = W { unW :: a } deriving (Show, Eq, Ord)
289arbitraryW :: (Arbitrary (W a)) => Gen a
290arbitraryW = unW <$> arbitrary
292shrinkW :: (Arbitrary (W a)) => a -> [a]
293shrinkW x = unW <$> shrink (W x)
295instance Arbitrary (W Bool) where
296 arbitrary = W <$> arbitrary
297 shrink = map W <$> shrink . unW
299instance Arbitrary (W Word8) where
300 arbitrary = W <$> choose (minBound, maxBound)
301 shrink = map W . shrinker . unW
303instance Arbitrary (W Word16) where
304 arbitrary = W <$> choose (minBound, maxBound)
305 shrink = map W . shrinker . unW
307instance Arbitrary (W Word32) where
308 arbitrary = W <$> choose (minBound, maxBound)
309 shrink = map W . shrinker . unW
311instance Arbitrary (W Word64) where
312 arbitrary = W <$> choose (minBound, maxBound)
313 shrink = map W . shrinker . unW
315instance Arbitrary B.ByteString where
316 arbitrary = B.pack <$> arbitrary
317 shrink bs = B.pack <$> shrink (B.unpack bs)
319instance Arbitrary L.ByteString where
320 arbitrary = L.fromChunks <$> arbitrary
321 shrink bs = L.fromChunks <$> shrink (L.toChunks bs)
323instance (Arbitrary (W a)) => Arbitrary (W [a]) where
324 arbitrary = W . map unW <$> arbitrary
325 shrink = map (W . map unW) <$> mapM shrink . map W . unW
327instance (Arbitrary (W a), Arbitrary (W b)) => Arbitrary (W (a,b)) where
328 arbitrary = (W .) . (,) <$> arbitraryW <*> arbitraryW
329 shrink (W (a,b)) = (W .) . (,) <$> shrinkW a <*> shrinkW b
331instance (Arbitrary (W a), Arbitrary (W b), Arbitrary (W c)) => Arbitrary (W (a,b,c)) where
332 arbitrary = ((W .) .) . (,,) <$> arbitraryW <*> arbitraryW <*> arbitraryW
333 shrink (W (a,b,c)) = ((W .) .) . (,,) <$> shrinkW a <*> shrinkW b <*> shrinkW c
335integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
336integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
337 fromIntegral b :: Integer) g of
338 (x,g) -> (fromIntegral x, g)
340{-
341instance Random Word where
342 randomR = integralRandomR
343 random = randomR (minBound,maxBound)
345instance Random Word8 where
346 randomR = integralRandomR
347 random = randomR (minBound,maxBound)
349instance Random Word16 where
350 randomR = integralRandomR
351 random = randomR (minBound,maxBound)
353instance Random Word32 where
354 randomR = integralRandomR
355 random = randomR (minBound,maxBound)
357instance Random Word64 where
358 randomR = integralRandomR
359 random = randomR (minBound,maxBound)
360-}