git.iko.soy/binary-bits
on 8ce95bb help sign in
binary-bits/BitsQC.hs
289 lines 12 kB history raw
1{-# LANGUAGE 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
18import Control.Applicative
19import Data.Bits
20import Data.Monoid
21import Data.Word
22import Foreign.Storable
23import System.Random
25import Test.Framework.Options ( TestOptions'(..) )
26import Test.Framework.Providers.QuickCheck2 ( testProperty )
27import Test.Framework.Runners.Console ( defaultMain )
28import Test.Framework.Runners.Options ( RunnerOptions'(..) )
29import Test.Framework ( Test, testGroup )
30import Test.QuickCheck
32main = defaultMain tests
34tests :: [Test]
35tests =
36 [ testGroup "Internal test functions"
37 [ testProperty "prop_bitreq" prop_bitreq ]
39 , testGroup "Custom test cases"
40 [ testProperty "prop_composite_case" prop_composite_case ]
42 , testGroup "prop_bitput_with_get_from_binary"
43 [ testProperty "Word8" (prop_bitput_with_get_from_binary :: W [Word8] -> Property)
44 , testProperty "Word16" (prop_bitput_with_get_from_binary :: W [Word16] -> Property)
45 , testProperty "Word32" (prop_bitput_with_get_from_binary :: W [Word32] -> Property)
46 , testProperty "Word64" (prop_bitput_with_get_from_binary :: W [Word64] -> Property)
47 ]
49 , testGroup "prop_bitget_with_put_from_binary"
50 [ testProperty "Word8" (prop_bitget_with_put_from_binary :: W [Word8] -> Property)
51 , testProperty "Word16" (prop_bitget_with_put_from_binary :: W [Word16] -> Property)
52 , testProperty "Word32" (prop_bitget_with_put_from_binary :: W [Word32] -> Property)
53 , testProperty "Word64" (prop_bitget_with_put_from_binary :: W [Word64] -> Property)
54 ]
56 , testGroup "prop_compare_put_with_naive"
57 [ testProperty "Word8" (prop_compare_put_with_naive :: W [Word8] -> Property)
58 , testProperty "Word16" (prop_compare_put_with_naive :: W [Word16] -> Property)
59 , testProperty "Word32" (prop_compare_put_with_naive :: W [Word32] -> Property)
60 , testProperty "Word64" (prop_compare_put_with_naive :: W [Word64] -> Property)
61 ]
63 , testGroup "prop_compare_get_with_naive"
64 [ testProperty "Word8" (prop_compare_get_with_naive:: W [Word8] -> Property)
65 , testProperty "Word16" (prop_compare_get_with_naive:: W [Word16] -> Property)
66 , testProperty "Word32" (prop_compare_get_with_naive:: W [Word32] -> Property)
67 , testProperty "Word64" (prop_compare_get_with_naive:: W [Word64] -> Property)
68 ]
70 , testGroup "prop_put_with_bitreq"
71 [ testProperty "Word8" (prop_putget_with_bitreq :: W Word8 -> Property)
72 , testProperty "Word16" (prop_putget_with_bitreq :: W Word16 -> Property)
73 , testProperty "Word32" (prop_putget_with_bitreq :: W Word32 -> Property)
74 , testProperty "Word64" (prop_putget_with_bitreq :: W Word64 -> Property)
75 ]
77 , testGroup "prop_putget_list_simple"
78 [ testProperty "Bool" (prop_putget_list_simple :: W [Bool] -> Property)
79 , testProperty "Word8" (prop_putget_list_simple :: W [Word8] -> Property)
80 , testProperty "Word16" (prop_putget_list_simple :: W [Word16] -> Property)
81 , testProperty "Word32" (prop_putget_list_simple :: W [Word32] -> Property)
82 , testProperty "Word64" (prop_putget_list_simple :: W [Word64] -> Property)
83 ]
85 , testGroup "prop_putget_list_with_bitreq"
86 [ testProperty "Word8" (prop_putget_list_with_bitreq :: W [Word8] -> Property)
87 , testProperty "Word16" (prop_putget_list_with_bitreq :: W [Word16] -> Property)
88 , testProperty "Word32" (prop_putget_list_with_bitreq :: W [Word32] -> Property)
89 , testProperty "Word64" (prop_putget_list_with_bitreq :: W [Word64] -> Property)
90 ]
91 , testGroup "prop_bitget_bytestring_interspersed"
92 [ testProperty "Word8" (prop_bitget_bytestring_interspersed :: W Word8 -> [B.ByteString] -> Property)
93 , testProperty "Word16" (prop_bitget_bytestring_interspersed :: W Word16 -> [B.ByteString] -> Property)
94 , testProperty "Word32" (prop_bitget_bytestring_interspersed :: W Word32 -> [B.ByteString] -> Property)
95 , testProperty "Word64" (prop_bitget_bytestring_interspersed :: W Word64 -> [B.ByteString] -> Property)
96 ]
97 ]
99prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W a -> Property
100prop_putget_with_bitreq (W w) = property $
101 -- write all words with as many bits as it's required
102 let p = putBits (bitreq w) w
103 g = getBits (bitreq w)
104 lbs = runPut (runBitPut p)
105 w' = runGet (runBitGet g) lbs
106 in w == w'
108-- | Write a list of items. Each item is written with the maximum amount of
109-- bits, i.e. 8 for Word8, 16 for Word16, etc.
110prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => W [a] -> Property
111prop_putget_list_simple (W ws) = property $
112 let s = sizeOf (head ws) * 8
113 p = mapM_ (\v -> putBits s v) ws
114 g = mapM (const (getBits s)) ws
115 lbs = runPut (runBitPut p)
116 ws' = runGet (runBitGet g) lbs
117 in ws == ws'
119-- | Write a list of items. Each item is written with exactly as many bits
120-- as required. Then read it back.
121prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [a] -> Property
122prop_putget_list_with_bitreq (W ws) = property $
123 -- write all words with as many bits as it's required
124 let p = mapM_ (\v -> putBits (bitreq v) v) ws
125 g = mapM getBits bitlist
126 lbs = runPut (runBitPut p)
127 ws' = runGet (runBitGet g) lbs
128 in ws == ws'
129 where
130 bitlist = map bitreq ws
132-- | Write bits using this library, and read them back using the binary
133-- library.
134prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
135prop_bitput_with_get_from_binary (W ws) = property $
136 let s = sizeOf (head ws) * 8
137 p = mapM_ (putBits s) ws
138 g = mapM (const get) ws
139 lbs = runPut (runBitPut p)
140 ws' = runGet g lbs
141 in ws == ws'
143-- | Write bits using the binary library, and read them back using this
144-- library.
145prop_bitget_with_put_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
146prop_bitget_with_put_from_binary (W ws) = property $
147 let s = sizeOf (head ws) * 8
148 p = mapM_ put ws
149 g = mapM (const (getBits s)) ws
150 lbs = runPut p
151 ws' = runGet (runBitGet g) lbs
152 in ws == ws'
154-- | Write each 'ByteString' with a variable sized value as a separator.
155prop_bitget_bytestring_interspersed :: (BinaryBit a, Binary a, Num a, Ord a, Bits a) => W a -> [B.ByteString] -> Property
156prop_bitget_bytestring_interspersed (W ws) bss = property $
157 let p = mapM_ (\bs -> putBits (bitreq ws) ws >> putByteString bs) bss
158 g = mapM (\bs -> (,) <$> (getBits (bitreq ws)) <*> (getByteString (B.length bs))) bss
159 lbs = runPut (runBitPut p)
160 r = runGet (runBitGet g) lbs
161 in map (ws,) bss == r
163-- | number of bits required to write @v@
164bitreq :: (Num b, Bits a, Ord a) => a -> b
165bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]
167bittable :: Bits a => [(Integer, a)]
168bittable = [ (fromIntegral x, (1 `shiftL` x) - 1) | x <- [1..64] ]
170prop_bitreq :: W Word64 -> Property
171prop_bitreq (W w) = property $
172 ( w == 0 && bitreq w == 1 )
173 || bitreq w == (bitreq (w `shiftR` 1)) + 1
175prop_composite_case :: Bool -> W Word16 -> Property
176prop_composite_case b (W w) = w < 0x8000 ==>
177 let p = do putBool b
178 putWord16be 15 w
179 g = do v <- getBool
180 case v of
181 True -> getWord16be 15
182 False -> do
183 msb <- getWord8 7
184 lsb <- getWord8 8
185 return ((fromIntegral msb `shiftL` 8) .|. fromIntegral lsb)
186 lbs = runPut (runBitPut p)
187 w' = runGet (runBitGet g) lbs
188 in w == w'
190prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a) => W [a] -> Property
191prop_compare_put_with_naive (W ws) = property $
192 let pn = mapM_ (\v -> naive_put (bitreq v) v) ws
193 p = mapM_ (\v -> putBits (bitreq v) v) ws
194 lbs_n = runPut (runBitPut pn)
195 lbs = runPut (runBitPut p)
196 in lbs_n == lbs
198prop_compare_get_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => W [a] -> Property
199prop_compare_get_with_naive (W ws) = property $
200 let gn = mapM (\v -> naive_get (bitreq v)) ws
201 g = mapM (\v -> getBits (bitreq v)) ws
202 p = mapM_ (\v -> naive_put (bitreq v) v) ws
203 lbs = runPut (runBitPut p)
204 rn = runGet (runBitGet gn) lbs
205 r = runGet (runBitGet g ) lbs
206 -- we must help our compiler to resolve the types of 'gn' and 'g'
207 types = rn == ws && r == ws
208 in rn == r
210-- | Write one bit at a time until the full word has been written
211naive_put :: (Bits a) => Int -> a -> BitPut ()
212naive_put n w = mapM_ (\b -> putBool (testBit w b)) [n-1,n-2..0]
214-- | Read one bit at a time until we've reconstructed the whole word
215naive_get :: (Bits a, Num a) => Int -> BitGet a
216naive_get n0 =
217 let loop 0 acc = return acc
218 loop n acc = do
219 b <- getBool
220 case b of
221 False -> loop (n-1) (acc `shiftL` 1)
222 True -> loop (n-1) ((acc `shiftL` 1) + 1)
223 in loop n0 0
225shrinker :: (Num a, Ord a, Bits a) => a -> [a]
226shrinker 0 = []
227shrinker w = [ w `shiftR` 1 -- try to make everything roughly half size
228 ] ++ [ w' -- flip bits to zero, left->right
229 | m <- [n, n-1..1]
230 , let w' = w `clearBit` m
231 , w /= w'
232 ] ++ [w-1] -- just make it a little smaller
233 where
234 n = bitreq w
236data W a = W { unW :: a } deriving (Show, Eq, Ord)
238instance Arbitrary (W Bool) where
239 arbitrary = W <$> arbitrary
240 shrink = map W <$> shrink . unW
242instance (Arbitrary (W a)) => Arbitrary (W [a]) where
243 arbitrary = W . map unW <$> arbitrary
244 shrink = map (W . map unW) <$> mapM shrink . map W . unW
246instance Arbitrary (W Word8) where
247 arbitrary = W <$> choose (minBound, maxBound)
248 shrink = map W . shrinker . unW
250instance Arbitrary (W Word16) where
251 arbitrary = W <$> choose (minBound, maxBound)
252 shrink = map W . shrinker . unW
254instance Arbitrary (W Word32) where
255 arbitrary = W <$> choose (minBound, maxBound)
256 shrink = map W . shrinker . unW
258instance Arbitrary (W Word64) where
259 arbitrary = W <$> choose (minBound, maxBound)
260 shrink = map W . shrinker . unW
262instance Arbitrary B.ByteString where
263 arbitrary = B.pack <$> arbitrary
264 shrink bs = B.pack <$> shrink (B.unpack bs)
266integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
267integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
268 fromIntegral b :: Integer) g of
269 (x,g) -> (fromIntegral x, g)
271instance Random Word where
272 randomR = integralRandomR
273 random = randomR (minBound,maxBound)
275instance Random Word8 where
276 randomR = integralRandomR
277 random = randomR (minBound,maxBound)
279instance Random Word16 where
280 randomR = integralRandomR
281 random = randomR (minBound,maxBound)
283instance Random Word32 where
284 randomR = integralRandomR
285 random = randomR (minBound,maxBound)
287instance Random Word64 where
288 randomR = integralRandomR
289 random = randomR (minBound,maxBound)