git.iko.soy/binary-bits
on 3bb50f1 help sign in
binary-bits/BitsQC.hs
334 lines 14 kB history raw
1{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts, TupleSections #-}
3module Main where
5import Data.Binary ( encode, Binary(..) )
6import Data.Binary.Get ( runGet )
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 "prop_bitput_with_get_from_binary"
47 [ testProperty "Word8" (prop_bitput_with_get_from_binary :: W [Word8] -> Property)
48 , testProperty "Word16" (prop_bitput_with_get_from_binary :: W [Word16] -> Property)
49 , testProperty "Word32" (prop_bitput_with_get_from_binary :: W [Word32] -> Property)
50 , testProperty "Word64" (prop_bitput_with_get_from_binary :: W [Word64] -> Property)
51 ]
53 , testGroup "prop_bitget_with_put_from_binary"
54 [ testProperty "Word8" (prop_bitget_with_put_from_binary :: W [Word8] -> Property)
55 , testProperty "Word16" (prop_bitget_with_put_from_binary :: W [Word16] -> Property)
56 , testProperty "Word32" (prop_bitget_with_put_from_binary :: W [Word32] -> Property)
57 , testProperty "Word64" (prop_bitget_with_put_from_binary :: W [Word64] -> Property)
58 ]
60 , testGroup "prop_compare_put_with_naive"
61 [ testProperty "Word8" (prop_compare_put_with_naive :: W [Word8] -> Property)
62 , testProperty "Word16" (prop_compare_put_with_naive :: W [Word16] -> Property)
63 , testProperty "Word32" (prop_compare_put_with_naive :: W [Word32] -> Property)
64 , testProperty "Word64" (prop_compare_put_with_naive :: W [Word64] -> Property)
65 ]
67 , testGroup "prop_compare_get_with_naive"
68 [ testProperty "Word8" (prop_compare_get_with_naive:: W [Word8] -> Property)
69 , testProperty "Word16" (prop_compare_get_with_naive:: W [Word16] -> Property)
70 , testProperty "Word32" (prop_compare_get_with_naive:: W [Word32] -> Property)
71 , testProperty "Word64" (prop_compare_get_with_naive:: W [Word64] -> Property)
72 ]
74 , testGroup "prop_put_with_bitreq"
75 [ testProperty "Word8" (prop_putget_with_bitreq :: W Word8 -> Property)
76 , testProperty "Word16" (prop_putget_with_bitreq :: W Word16 -> Property)
77 , testProperty "Word32" (prop_putget_with_bitreq :: W Word32 -> Property)
78 , testProperty "Word64" (prop_putget_with_bitreq :: W Word64 -> Property)
79 ]
81 , testGroup "prop_putget_list_simple"
82 [ testProperty "Bool" (prop_putget_list_simple :: W [Bool] -> Property)
83 , testProperty "Word8" (prop_putget_list_simple :: W [Word8] -> Property)
84 , testProperty "Word16" (prop_putget_list_simple :: W [Word16] -> Property)
85 , testProperty "Word32" (prop_putget_list_simple :: W [Word32] -> Property)
86 , testProperty "Word64" (prop_putget_list_simple :: W [Word64] -> Property)
87 ]
89 , testGroup "prop_putget_applicative_with_bitreq"
90 [ testProperty "Word8" (prop_putget_applicative_with_bitreq :: W [(Word8,Word8,Word8)] -> Property)
91 , testProperty "Word16" (prop_putget_applicative_with_bitreq :: W [(Word16,Word16,Word16)] -> Property)
92 , testProperty "Word32" (prop_putget_applicative_with_bitreq :: W [(Word32,Word32,Word32)] -> Property)
93 , testProperty "Word64" (prop_putget_applicative_with_bitreq :: W [(Word64,Word64,Word64)] -> Property)
94 ]
96 , testGroup "prop_putget_list_with_bitreq"
97 [ testProperty "Word8" (prop_putget_list_with_bitreq :: W [Word8] -> Property)
98 , testProperty "Word16" (prop_putget_list_with_bitreq :: W [Word16] -> Property)
99 , testProperty "Word32" (prop_putget_list_with_bitreq :: W [Word32] -> Property)
100 , testProperty "Word64" (prop_putget_list_with_bitreq :: W [Word64] -> Property)
101 ]
102 , testGroup "prop_bitget_bytestring_interspersed"
103 [ testProperty "Word8" (prop_bitget_bytestring_interspersed :: W Word8 -> [B.ByteString] -> Property)
104 , testProperty "Word16" (prop_bitget_bytestring_interspersed :: W Word16 -> [B.ByteString] -> Property)
105 , testProperty "Word32" (prop_bitget_bytestring_interspersed :: W Word32 -> [B.ByteString] -> Property)
106 , testProperty "Word64" (prop_bitget_bytestring_interspersed :: W Word64 -> [B.ByteString] -> Property)
107 ]
108 ]
111prop_getByteString_negative :: Int -> Property
112prop_getByteString_negative n =
113 n < 1 ==>
114 runGet (runBitGet (getByteString n)) L.empty == B.empty
116prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W a -> Property
117prop_putget_with_bitreq (W w) = property $
118 -- write all words with as many bits as it's required
119 let p = putBits (bitreq w) w
120 g = getBits (bitreq w)
121 lbs = runPut (runBitPut p)
122 w' = runGet (runBitGet g) lbs
123 in w == w'
125-- | Write a list of items. Each item is written with the maximum amount of
126-- bits, i.e. 8 for Word8, 16 for Word16, etc.
127prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => W [a] -> Property
128prop_putget_list_simple (W ws) = property $
129 let s = sizeOf (head ws) * 8
130 p = mapM_ (\v -> putBits s v) ws
131 g = mapM (const (getBits s)) ws
132 lbs = runPut (runBitPut p)
133 ws' = runGet (runBitGet g) lbs
134 in ws == ws'
136-- | Write a list of items. Each item is written with exactly as many bits
137-- as required. Then read it back.
138prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [a] -> Property
139prop_putget_list_with_bitreq (W ws) = property $
140 -- write all words with as many bits as it's required
141 let p = mapM_ (\v -> putBits (bitreq v) v) ws
142 g = mapM getBits bitlist
143 lbs = runPut (runBitPut p)
144 ws' = runGet (runBitGet g) lbs
145 in ws == ws'
146 where
147 bitlist = map bitreq ws
149prop_putget_applicative_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [(a,a,a)] -> Property
150prop_putget_applicative_with_bitreq (W ts) = property $
151 let p = mapM_ (\(a,b,c) -> do putBits (bitreq a) a
152 putBits (bitreq b) b
153 putBits (bitreq c) c) ts
154 g = mapM (\(a,b,c) -> (,,) <$> getBits a <*> getBits b <*> getBits c) bitlist
155 lbs = runPut (runBitPut p)
156 ts' = runGet (runBitGet g) lbs
157 in ts == ts'
158 where
159 bitlist = map (\(a,b,c) -> (bitreq a, bitreq b, bitreq c)) ts
161-- | Write bits using this library, and read them back using the binary
162-- library.
163prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
164prop_bitput_with_get_from_binary (W ws) = property $
165 let s = sizeOf (head ws) * 8
166 p = mapM_ (putBits s) ws
167 g = mapM (const get) ws
168 lbs = runPut (runBitPut p)
169 ws' = runGet g lbs
170 in ws == ws'
172-- | Write bits using the binary library, and read them back using this
173-- library.
174prop_bitget_with_put_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
175prop_bitget_with_put_from_binary (W ws) = property $
176 let s = sizeOf (head ws) * 8
177 p = mapM_ put ws
178 g = mapM (const (getBits s)) ws
179 lbs = runPut p
180 ws' = runGet (runBitGet g) lbs
181 in ws == ws'
183-- | Write each 'ByteString' with a variable sized value as a separator.
184prop_bitget_bytestring_interspersed :: (BinaryBit a, Binary a, Num a, Ord a, Bits a) => W a -> [B.ByteString] -> Property
185prop_bitget_bytestring_interspersed (W ws) bss = property $
186 let p = mapM_ (\bs -> putBits (bitreq ws) ws >> putByteString bs) bss
187 g = mapM (\bs -> (,) <$> (getBits (bitreq ws)) <*> (getByteString (B.length bs))) bss
188 lbs = runPut (runBitPut p)
189 r = runGet (runBitGet g) lbs
190 in map (ws,) bss == r
192-- | number of bits required to write @v@
193bitreq :: (Num b, Bits a, Ord a) => a -> b
194bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]
196bittable :: Bits a => [(Integer, a)]
197bittable = [ (fromIntegral x, (1 `shiftL` x) - 1) | x <- [1..64] ]
199prop_bitreq :: W Word64 -> Property
200prop_bitreq (W w) = property $
201 ( w == 0 && bitreq w == 1 )
202 || bitreq w == (bitreq (w `shiftR` 1)) + 1
204prop_composite_case :: Bool -> W Word16 -> Property
205prop_composite_case b (W w) = w < 0x8000 ==>
206 let p = do putBool b
207 putWord16be 15 w
208 g = do v <- getBool
209 case v of
210 True -> getWord16be 15
211 False -> do
212 msb <- getWord8 7
213 lsb <- getWord8 8
214 return ((fromIntegral msb `shiftL` 8) .|. fromIntegral lsb)
215 lbs = runPut (runBitPut p)
216 w' = runGet (runBitGet g) lbs
217 in w == w'
219prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a) => W [a] -> Property
220prop_compare_put_with_naive (W ws) = property $
221 let pn = mapM_ (\v -> naive_put (bitreq v) v) ws
222 p = mapM_ (\v -> putBits (bitreq v) v) ws
223 lbs_n = runPut (runBitPut pn)
224 lbs = runPut (runBitPut p)
225 in lbs_n == lbs
227prop_compare_get_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => W [a] -> Property
228prop_compare_get_with_naive (W ws) = property $
229 let gn = mapM (\v -> naive_get (bitreq v)) ws
230 g = mapM (\v -> getBits (bitreq v)) ws
231 p = mapM_ (\v -> naive_put (bitreq v) v) ws
232 lbs = runPut (runBitPut p)
233 rn = runGet (runBitGet gn) lbs
234 r = runGet (runBitGet g ) lbs
235 -- we must help our compiler to resolve the types of 'gn' and 'g'
236 types = rn == ws && r == ws
237 in rn == r
239-- | Write one bit at a time until the full word has been written
240naive_put :: (Bits a) => Int -> a -> BitPut ()
241naive_put n w = mapM_ (\b -> putBool (testBit w b)) [n-1,n-2..0]
243-- | Read one bit at a time until we've reconstructed the whole word
244naive_get :: (Bits a, Num a) => Int -> BitGet a
245naive_get n0 =
246 let loop 0 acc = return acc
247 loop n acc = do
248 b <- getBool
249 case b of
250 False -> loop (n-1) (acc `shiftL` 1)
251 True -> loop (n-1) ((acc `shiftL` 1) + 1)
252 in loop n0 0
254shrinker :: (Num a, Ord a, Bits a) => a -> [a]
255shrinker 0 = []
256shrinker w = [ w `shiftR` 1 -- try to make everything roughly half size
257 ] ++ [ w' -- flip bits to zero, left->right
258 | m <- [n, n-1..1]
259 , let w' = w `clearBit` m
260 , w /= w'
261 ] ++ [w-1] -- just make it a little smaller
262 where
263 n = bitreq w
265data W a = W { unW :: a } deriving (Show, Eq, Ord)
267arbitraryW :: (Arbitrary (W a)) => Gen a
268arbitraryW = unW <$> arbitrary
270shrinkW :: (Arbitrary (W a)) => a -> [a]
271shrinkW x = unW <$> shrink (W x)
273instance Arbitrary (W Bool) where
274 arbitrary = W <$> arbitrary
275 shrink = map W <$> shrink . unW
277instance Arbitrary (W Word8) where
278 arbitrary = W <$> choose (minBound, maxBound)
279 shrink = map W . shrinker . unW
281instance Arbitrary (W Word16) where
282 arbitrary = W <$> choose (minBound, maxBound)
283 shrink = map W . shrinker . unW
285instance Arbitrary (W Word32) where
286 arbitrary = W <$> choose (minBound, maxBound)
287 shrink = map W . shrinker . unW
289instance Arbitrary (W Word64) where
290 arbitrary = W <$> choose (minBound, maxBound)
291 shrink = map W . shrinker . unW
293instance Arbitrary B.ByteString where
294 arbitrary = B.pack <$> arbitrary
295 shrink bs = B.pack <$> shrink (B.unpack bs)
297instance (Arbitrary (W a)) => Arbitrary (W [a]) where
298 arbitrary = W . map unW <$> arbitrary
299 shrink = map (W . map unW) <$> mapM shrink . map W . unW
301instance (Arbitrary (W a), Arbitrary (W b)) => Arbitrary (W (a,b)) where
302 arbitrary = (W .) . (,) <$> arbitraryW <*> arbitraryW
303 shrink (W (a,b)) = (W .) . (,) <$> shrinkW a <*> shrinkW b
305instance (Arbitrary (W a), Arbitrary (W b), Arbitrary (W c)) => Arbitrary (W (a,b,c)) where
306 arbitrary = ((W .) .) . (,,) <$> arbitraryW <*> arbitraryW <*> arbitraryW
307 shrink (W (a,b,c)) = ((W .) .) . (,,) <$> shrinkW a <*> shrinkW b <*> shrinkW c
309integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
310integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
311 fromIntegral b :: Integer) g of
312 (x,g) -> (fromIntegral x, g)
314{-
315instance Random Word where
316 randomR = integralRandomR
317 random = randomR (minBound,maxBound)
319instance Random Word8 where
320 randomR = integralRandomR
321 random = randomR (minBound,maxBound)
323instance Random Word16 where
324 randomR = integralRandomR
325 random = randomR (minBound,maxBound)
327instance Random Word32 where
328 randomR = integralRandomR
329 random = randomR (minBound,maxBound)
331instance Random Word64 where
332 randomR = integralRandomR
333 random = randomR (minBound,maxBound)
334-}