git.iko.soy/binary-bits
on master help sign in
Override default QC 2.4 Arbitrary instance
d259c3aLennart Kolmodin
BitsQC.hs+72−59
compare with master
unifiedsplit
@@ -1,3 +1,5 @@
1+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
2+
1module Main where
3module Main where
2
4
3import Data.Binary ( encode, Binary(..) )
5import Data.Binary ( encode, Binary(..) )
@@ -9,6 +11,7 @@ import qualified Data.Binary.Put as BP ( putWord8, putWord16be, putWord32be, put
9
11
10import Bits
12import Bits
11
13
14+import Control.Applicative
12import Data.Bits
15import Data.Bits
13import Data.Monoid
16import Data.Monoid
14import Data.Word
17import Data.Word
@@ -37,53 +40,53 @@ tests =
37 [ testProperty "prop_composite_case" prop_composite_case ]
40 [ testProperty "prop_composite_case" prop_composite_case ]
38
41
39 , testGroup "prop_bitput_with_get_from_binary"
42 , testGroup "prop_bitput_with_get_from_binary"
40− [ testProperty "Word8" (prop_bitput_with_get_from_binary :: [Word8] -> Property)
43+ [ testProperty "Word8" (prop_bitput_with_get_from_binary :: W [Word8] -> Property)
41− , testProperty "Word16" (prop_bitput_with_get_from_binary :: [Word16] -> Property)
44+ , testProperty "Word16" (prop_bitput_with_get_from_binary :: W [Word16] -> Property)
42− , testProperty "Word32" (prop_bitput_with_get_from_binary :: [Word32] -> Property)
45+ , testProperty "Word32" (prop_bitput_with_get_from_binary :: W [Word32] -> Property)
43− , testProperty "Word64" (prop_bitput_with_get_from_binary :: [Word64] -> Property)
46+ , testProperty "Word64" (prop_bitput_with_get_from_binary :: W [Word64] -> Property)
44 ]
47 ]
45
48
46 , testGroup "prop_bitget_with_put_from_binary"
49 , testGroup "prop_bitget_with_put_from_binary"
47− [ testProperty "Word8" (prop_bitget_with_put_from_binary :: [Word8] -> Property)
50+ [ testProperty "Word8" (prop_bitget_with_put_from_binary :: W [Word8] -> Property)
48− , testProperty "Word16" (prop_bitget_with_put_from_binary :: [Word16] -> Property)
51+ , testProperty "Word16" (prop_bitget_with_put_from_binary :: W [Word16] -> Property)
49− , testProperty "Word32" (prop_bitget_with_put_from_binary :: [Word32] -> Property)
52+ , testProperty "Word32" (prop_bitget_with_put_from_binary :: W [Word32] -> Property)
50− , testProperty "Word64" (prop_bitget_with_put_from_binary :: [Word64] -> Property)
53+ , testProperty "Word64" (prop_bitget_with_put_from_binary :: W [Word64] -> Property)
51 ]
54 ]
52
55
53 , testGroup "prop_compare_put_with_naive"
56 , testGroup "prop_compare_put_with_naive"
54− [ testProperty "Word8" (prop_compare_put_with_naive :: [Word8] -> Property)
57+ [ testProperty "Word8" (prop_compare_put_with_naive :: W [Word8] -> Property)
55− , testProperty "Word16" (prop_compare_put_with_naive :: [Word16] -> Property)
58+ , testProperty "Word16" (prop_compare_put_with_naive :: W [Word16] -> Property)
56− , testProperty "Word32" (prop_compare_put_with_naive :: [Word32] -> Property)
59+ , testProperty "Word32" (prop_compare_put_with_naive :: W [Word32] -> Property)
57− , testProperty "Word64" (prop_compare_put_with_naive :: [Word64] -> Property)
60+ , testProperty "Word64" (prop_compare_put_with_naive :: W [Word64] -> Property)
58 ]
61 ]
59
62
60 , testGroup "prop_compare_get_with_naive"
63 , testGroup "prop_compare_get_with_naive"
61− [ testProperty "Word8" (prop_compare_get_with_naive:: [Word8] -> Property)
64+ [ testProperty "Word8" (prop_compare_get_with_naive:: W [Word8] -> Property)
62− , testProperty "Word16" (prop_compare_get_with_naive:: [Word16] -> Property)
65+ , testProperty "Word16" (prop_compare_get_with_naive:: W [Word16] -> Property)
63− , testProperty "Word32" (prop_compare_get_with_naive:: [Word32] -> Property)
66+ , testProperty "Word32" (prop_compare_get_with_naive:: W [Word32] -> Property)
64− , testProperty "Word64" (prop_compare_get_with_naive:: [Word64] -> Property)
67+ , testProperty "Word64" (prop_compare_get_with_naive:: W [Word64] -> Property)
65 ]
68 ]
66
69
67 , testGroup "prop_put_with_bitreq"
70 , testGroup "prop_put_with_bitreq"
68− [ testProperty "Word8" (prop_putget_with_bitreq :: Word8 -> Property)
71+ [ testProperty "Word8" (prop_putget_with_bitreq :: W Word8 -> Property)
69− , testProperty "Word16" (prop_putget_with_bitreq :: Word16 -> Property)
72+ , testProperty "Word16" (prop_putget_with_bitreq :: W Word16 -> Property)
70− , testProperty "Word32" (prop_putget_with_bitreq :: Word32 -> Property)
73+ , testProperty "Word32" (prop_putget_with_bitreq :: W Word32 -> Property)
71− , testProperty "Word64" (prop_putget_with_bitreq :: Word64 -> Property)
74+ , testProperty "Word64" (prop_putget_with_bitreq :: W Word64 -> Property)
72 ]
75 ]
73
76
74 , testGroup "prop_putget_list_simple"
77 , testGroup "prop_putget_list_simple"
75− [ testProperty "Bool" (prop_putget_list_simple :: [Bool] -> Property)
78+ [ testProperty "Bool" (prop_putget_list_simple :: W [Bool] -> Property)
76− , testProperty "Word8" (prop_putget_list_simple :: [Word8] -> Property)
79+ , testProperty "Word8" (prop_putget_list_simple :: W [Word8] -> Property)
77− , testProperty "Word16" (prop_putget_list_simple :: [Word16] -> Property)
80+ , testProperty "Word16" (prop_putget_list_simple :: W [Word16] -> Property)
78− , testProperty "Word32" (prop_putget_list_simple :: [Word32] -> Property)
81+ , testProperty "Word32" (prop_putget_list_simple :: W [Word32] -> Property)
79− , testProperty "Word64" (prop_putget_list_simple :: [Word64] -> Property)
82+ , testProperty "Word64" (prop_putget_list_simple :: W [Word64] -> Property)
80 ]
83 ]
81
84
82 , testGroup "prop_putget_list_with_bitreq"
85 , testGroup "prop_putget_list_with_bitreq"
83− [ testProperty "Word8" (prop_putget_list_with_bitreq :: [Word8] -> Property)
86+ [ testProperty "Word8" (prop_putget_list_with_bitreq :: W [Word8] -> Property)
84− , testProperty "Word16" (prop_putget_list_with_bitreq :: [Word16] -> Property)
87+ , testProperty "Word16" (prop_putget_list_with_bitreq :: W [Word16] -> Property)
85− , testProperty "Word32" (prop_putget_list_with_bitreq :: [Word32] -> Property)
88+ , testProperty "Word32" (prop_putget_list_with_bitreq :: W [Word32] -> Property)
86− , testProperty "Word64" (prop_putget_list_with_bitreq :: [Word64] -> Property)
89+ , testProperty "Word64" (prop_putget_list_with_bitreq :: W [Word64] -> Property)
87 ]
90 ]
88 ]
91 ]
89
92
@@ -94,8 +97,8 @@ tests =
94 -- quickCheck prop_Word32_from_Word8_and_Word16
97 -- quickCheck prop_Word32_from_Word8_and_Word16
95-}
98-}
96
99
97−prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => a -> Property
100+prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W a -> Property
98−prop_putget_with_bitreq w = property $
101+prop_putget_with_bitreq (W w) = property $
99 -- write all words with as many bits as it's required
102 -- write all words with as many bits as it's required
100 let p = putBits (bitreq w) w
103 let p = putBits (bitreq w) w
101 g = getBits (bitreq w)
104 g = getBits (bitreq w)
@@ -105,8 +108,8 @@ prop_putget_with_bitreq w = property $
105
108
106-- | Write a list of items. Each item is written with the maximum amount of
109-- | Write a list of items. Each item is written with the maximum amount of
107-- bits, i.e. 8 for Word8, 16 for Word16, etc.
110-- bits, i.e. 8 for Word8, 16 for Word16, etc.
108−prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => [a] -> Property
111+prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => W [a] -> Property
109−prop_putget_list_simple ws = property $
112+prop_putget_list_simple (W ws) = property $
110 let s = sizeOf (head ws) * 8
113 let s = sizeOf (head ws) * 8
111 p = mapM_ (\v -> putBits s v) ws
114 p = mapM_ (\v -> putBits s v) ws
112 g = mapM (const (getBits s)) ws
115 g = mapM (const (getBits s)) ws
@@ -116,8 +119,8 @@ prop_putget_list_simple ws = property $
116
119
117-- | Write a list of items. Each item is written with exactly as many bits
120-- | Write a list of items. Each item is written with exactly as many bits
118-- as required. Then read it back.
121-- as required. Then read it back.
119−prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => [a] -> Property
122+prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [a] -> Property
120−prop_putget_list_with_bitreq ws = property $
123+prop_putget_list_with_bitreq (W ws) = property $
121 -- write all words with as many bits as it's required
124 -- write all words with as many bits as it's required
122 let p = mapM_ (\v -> putBits (bitreq v) v) ws
125 let p = mapM_ (\v -> putBits (bitreq v) v) ws
123 g = mapM getBits bitlist
126 g = mapM getBits bitlist
@@ -129,8 +132,8 @@ prop_putget_list_with_bitreq ws = property $
129
132
130-- | Write bits using this library, and read them back using the binary
133-- | Write bits using this library, and read them back using the binary
131-- library.
134-- library.
132−prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => [a] -> Property
135+prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
133−prop_bitput_with_get_from_binary ws = property $
136+prop_bitput_with_get_from_binary (W ws) = property $
134 let s = sizeOf (head ws) * 8
137 let s = sizeOf (head ws) * 8
135 p = mapM_ (putBits s) ws
138 p = mapM_ (putBits s) ws
136 g = mapM (const get) ws
139 g = mapM (const get) ws
@@ -140,8 +143,8 @@ prop_bitput_with_get_from_binary ws = property $
140
143
141-- | Write bits using the binary library, and read them back using this
144-- | Write bits using the binary library, and read them back using this
142-- library.
145-- library.
143−prop_bitget_with_put_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => [a] -> Property
146+prop_bitget_with_put_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
144−prop_bitget_with_put_from_binary ws = property $
147+prop_bitget_with_put_from_binary (W ws) = property $
145 let s = sizeOf (head ws) * 8
148 let s = sizeOf (head ws) * 8
146 p = mapM_ put ws
149 p = mapM_ put ws
147 g = mapM (const (getBits s)) ws
150 g = mapM (const (getBits s)) ws
@@ -156,13 +159,13 @@ bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]
156bittable :: Bits a => [(Integer, a)]
159bittable :: Bits a => [(Integer, a)]
157bittable = [ (fromIntegral x, (1 `shiftL` x) - 1) | x <- [1..64] ]
160bittable = [ (fromIntegral x, (1 `shiftL` x) - 1) | x <- [1..64] ]
158
161
159−prop_bitreq :: Word64 -> Property
162+prop_bitreq :: W Word64 -> Property
160−prop_bitreq w = property $
163+prop_bitreq (W w) = property $
161 ( w == 0 && bitreq w == 1 )
164 ( w == 0 && bitreq w == 1 )
162 || bitreq w == (bitreq (w `shiftR` 1)) + 1
165 || bitreq w == (bitreq (w `shiftR` 1)) + 1
163
166
164−prop_composite_case :: Bool -> Word16 -> Property
167+prop_composite_case :: Bool -> W Word16 -> Property
165−prop_composite_case b w = w < 0x8000 ==>
168+prop_composite_case b (W w) = w < 0x8000 ==>
166 let p = do putBool b
169 let p = do putBool b
167 putWord16be 15 w
170 putWord16be 15 w
168 g = do v <- getBool
171 g = do v <- getBool
@@ -177,16 +180,16 @@ prop_composite_case b w = w < 0x8000 ==>
177 in w == w'
180 in w == w'
178
181
179
182
180−prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a) => [a] -> Property
183+prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a) => W [a] -> Property
181−prop_compare_put_with_naive ws = property $
184+prop_compare_put_with_naive (W ws) = property $
182 let pn = mapM_ (\v -> naive_put (bitreq v) v) ws
185 let pn = mapM_ (\v -> naive_put (bitreq v) v) ws
183 p = mapM_ (\v -> putBits (bitreq v) v) ws
186 p = mapM_ (\v -> putBits (bitreq v) v) ws
184 lbs_n = runPut (runBitPut pn)
187 lbs_n = runPut (runBitPut pn)
185 lbs = runPut (runBitPut p)
188 lbs = runPut (runBitPut p)
186 in lbs_n == lbs
189 in lbs_n == lbs
187
190
188−prop_compare_get_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => [a] -> Property
191+prop_compare_get_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => W [a] -> Property
189−prop_compare_get_with_naive ws = property $
192+prop_compare_get_with_naive (W ws) = property $
190 let gn = mapM (\v -> naive_get (bitreq v)) ws
193 let gn = mapM (\v -> naive_get (bitreq v)) ws
191 g = mapM (\v -> getBits (bitreq v)) ws
194 g = mapM (\v -> getBits (bitreq v)) ws
192 p = mapM_ (\v -> naive_put (bitreq v) v) ws
195 p = mapM_ (\v -> naive_put (bitreq v) v) ws
@@ -244,21 +247,31 @@ shrinker w = [ w `shiftR` 1 -- try to make everything roughly half size
244 where
247 where
245 n = bitreq w
248 n = bitreq w
246
249
250+data W a = W { unW :: a } deriving (Show, Eq, Ord)
251+
252+instance Arbitrary (W Bool) where
253+ arbitrary = W <$> arbitrary
254+ shrink = map W <$> shrink . unW
255+
256+instance (Arbitrary (W a)) => Arbitrary (W [a]) where
257+ arbitrary = W . map unW <$> arbitrary
258+ shrink = map (W . map unW) <$> mapM shrink . map W . unW
259+
247−instance Arbitrary Word8 where
260+instance Arbitrary (W Word8) where
248− arbitrary = choose (minBound, maxBound)
261+ arbitrary = W <$> choose (minBound, maxBound)
249− shrink = shrinker
262+ shrink = map W . shrinker . unW
250
263
251−instance Arbitrary Word16 where
264+instance Arbitrary (W Word16) where
252− arbitrary = choose (minBound, maxBound)
265+ arbitrary = W <$> choose (minBound, maxBound)
253− shrink = shrinker
266+ shrink = map W . shrinker . unW
254
267
255−instance Arbitrary Word32 where
268+instance Arbitrary (W Word32) where
256− arbitrary = choose (minBound, maxBound)
269+ arbitrary = W <$> choose (minBound, maxBound)
257− shrink = shrinker
270+ shrink = map W . shrinker . unW
258
271
259−instance Arbitrary Word64 where
272+instance Arbitrary (W Word64) where
260− arbitrary = choose (minBound, maxBound)
273+ arbitrary = W <$> choose (minBound, maxBound)
261− shrink = shrinker
274+ shrink = map W . shrinker . unW
262
275
263integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
276integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
264integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
277integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,