@@ -1,3 +1,5 @@
1+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
2+
13module Main where
24
35import Data.Binary ( encode, Binary(..) )
@@ -9,6 +11,7 @@ import qualified Data.Binary.Put as BP ( putWord8, putWord16be, putWord32be, put
911
1012import Bits
1113
14+import Control.Applicative
1215import Data.Bits
1316import Data.Monoid
1417import Data.Word
@@ -37,53 +40,53 @@ tests =
3740 [ testProperty "prop_composite_case" prop_composite_case ]
3841
3942 , testGroup "prop_bitput_with_get_from_binary"
40− [ testProperty "Word8" (prop_bitput_with_get_from_binary :: [Word8] -> Property)
41− , testProperty "Word16" (prop_bitput_with_get_from_binary :: [Word16] -> Property)
42− , testProperty "Word32" (prop_bitput_with_get_from_binary :: [Word32] -> Property)
43− , testProperty "Word64" (prop_bitput_with_get_from_binary :: [Word64] -> Property)
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)
4447 ]
4548
4649 , testGroup "prop_bitget_with_put_from_binary"
47− [ testProperty "Word8" (prop_bitget_with_put_from_binary :: [Word8] -> Property)
48− , testProperty "Word16" (prop_bitget_with_put_from_binary :: [Word16] -> Property)
49− , testProperty "Word32" (prop_bitget_with_put_from_binary :: [Word32] -> Property)
50− , testProperty "Word64" (prop_bitget_with_put_from_binary :: [Word64] -> Property)
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)
5154 ]
5255
5356 , testGroup "prop_compare_put_with_naive"
54− [ testProperty "Word8" (prop_compare_put_with_naive :: [Word8] -> Property)
55− , testProperty "Word16" (prop_compare_put_with_naive :: [Word16] -> Property)
56− , testProperty "Word32" (prop_compare_put_with_naive :: [Word32] -> Property)
57− , testProperty "Word64" (prop_compare_put_with_naive :: [Word64] -> Property)
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)
5861 ]
5962
6063 , testGroup "prop_compare_get_with_naive"
61− [ testProperty "Word8" (prop_compare_get_with_naive:: [Word8] -> Property)
62− , testProperty "Word16" (prop_compare_get_with_naive:: [Word16] -> Property)
63− , testProperty "Word32" (prop_compare_get_with_naive:: [Word32] -> Property)
64− , testProperty "Word64" (prop_compare_get_with_naive:: [Word64] -> Property)
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)
6568 ]
6669
6770 , testGroup "prop_put_with_bitreq"
68− [ testProperty "Word8" (prop_putget_with_bitreq :: Word8 -> Property)
69− , testProperty "Word16" (prop_putget_with_bitreq :: Word16 -> Property)
70− , testProperty "Word32" (prop_putget_with_bitreq :: Word32 -> Property)
71− , testProperty "Word64" (prop_putget_with_bitreq :: Word64 -> Property)
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)
7275 ]
7376
7477 , testGroup "prop_putget_list_simple"
75− [ testProperty "Bool" (prop_putget_list_simple :: [Bool] -> Property)
76− , testProperty "Word8" (prop_putget_list_simple :: [Word8] -> Property)
77− , testProperty "Word16" (prop_putget_list_simple :: [Word16] -> Property)
78− , testProperty "Word32" (prop_putget_list_simple :: [Word32] -> Property)
79− , testProperty "Word64" (prop_putget_list_simple :: [Word64] -> Property)
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)
8083 ]
8184
8285 , testGroup "prop_putget_list_with_bitreq"
83− [ testProperty "Word8" (prop_putget_list_with_bitreq :: [Word8] -> Property)
84− , testProperty "Word16" (prop_putget_list_with_bitreq :: [Word16] -> Property)
85− , testProperty "Word32" (prop_putget_list_with_bitreq :: [Word32] -> Property)
86− , testProperty "Word64" (prop_putget_list_with_bitreq :: [Word64] -> Property)
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)
8790 ]
8891 ]
8992
@@ -94,8 +97,8 @@ tests =
9497 -- quickCheck prop_Word32_from_Word8_and_Word16
9598-}
9699
97−prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => a -> Property
98−prop_putget_with_bitreq w = property $
100+prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W a -> Property
101+prop_putget_with_bitreq (W w) = property $
99102 -- write all words with as many bits as it's required
100103 let p = putBits (bitreq w) w
101104 g = getBits (bitreq w)
@@ -105,8 +108,8 @@ prop_putget_with_bitreq w = property $
105108
106109-- | Write a list of items. Each item is written with the maximum amount of
107110-- bits, i.e. 8 for Word8, 16 for Word16, etc.
108−prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => [a] -> Property
109−prop_putget_list_simple ws = property $
111+prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => W [a] -> Property
112+prop_putget_list_simple (W ws) = property $
110113 let s = sizeOf (head ws) * 8
111114 p = mapM_ (\v -> putBits s v) ws
112115 g = mapM (const (getBits s)) ws
@@ -116,8 +119,8 @@ prop_putget_list_simple ws = property $
116119
117120-- | Write a list of items. Each item is written with exactly as many bits
118121-- as required. Then read it back.
119−prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => [a] -> Property
120−prop_putget_list_with_bitreq ws = property $
122+prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [a] -> Property
123+prop_putget_list_with_bitreq (W ws) = property $
121124 -- write all words with as many bits as it's required
122125 let p = mapM_ (\v -> putBits (bitreq v) v) ws
123126 g = mapM getBits bitlist
@@ -129,8 +132,8 @@ prop_putget_list_with_bitreq ws = property $
129132
130133-- | Write bits using this library, and read them back using the binary
131134-- library.
132−prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => [a] -> Property
133−prop_bitput_with_get_from_binary ws = property $
135+prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
136+prop_bitput_with_get_from_binary (W ws) = property $
134137 let s = sizeOf (head ws) * 8
135138 p = mapM_ (putBits s) ws
136139 g = mapM (const get) ws
@@ -140,8 +143,8 @@ prop_bitput_with_get_from_binary ws = property $
140143
141144-- | Write bits using the binary library, and read them back using this
142145-- library.
143−prop_bitget_with_put_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => [a] -> Property
144−prop_bitget_with_put_from_binary ws = property $
146+prop_bitget_with_put_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
147+prop_bitget_with_put_from_binary (W ws) = property $
145148 let s = sizeOf (head ws) * 8
146149 p = mapM_ put ws
147150 g = mapM (const (getBits s)) ws
@@ -156,13 +159,13 @@ bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]
156159bittable :: Bits a => [(Integer, a)]
157160bittable = [ (fromIntegral x, (1 `shiftL` x) - 1) | x <- [1..64] ]
158161
159−prop_bitreq :: Word64 -> Property
160−prop_bitreq w = property $
162+prop_bitreq :: W Word64 -> Property
163+prop_bitreq (W w) = property $
161164 ( w == 0 && bitreq w == 1 )
162165 || bitreq w == (bitreq (w `shiftR` 1)) + 1
163166
164−prop_composite_case :: Bool -> Word16 -> Property
165−prop_composite_case b w = w < 0x8000 ==>
167+prop_composite_case :: Bool -> W Word16 -> Property
168+prop_composite_case b (W w) = w < 0x8000 ==>
166169 let p = do putBool b
167170 putWord16be 15 w
168171 g = do v <- getBool
@@ -177,16 +180,16 @@ prop_composite_case b w = w < 0x8000 ==>
177180 in w == w'
178181
179182
180−prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a) => [a] -> Property
181−prop_compare_put_with_naive ws = property $
183+prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a) => W [a] -> Property
184+prop_compare_put_with_naive (W ws) = property $
182185 let pn = mapM_ (\v -> naive_put (bitreq v) v) ws
183186 p = mapM_ (\v -> putBits (bitreq v) v) ws
184187 lbs_n = runPut (runBitPut pn)
185188 lbs = runPut (runBitPut p)
186189 in lbs_n == lbs
187190
188−prop_compare_get_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => [a] -> Property
189−prop_compare_get_with_naive ws = property $
191+prop_compare_get_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => W [a] -> Property
192+prop_compare_get_with_naive (W ws) = property $
190193 let gn = mapM (\v -> naive_get (bitreq v)) ws
191194 g = mapM (\v -> getBits (bitreq v)) ws
192195 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
244247 where
245248 n = bitreq w
246249
247−instance Arbitrary Word8 where
248− arbitrary = choose (minBound, maxBound)
249− shrink = shrinker
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+
260+instance Arbitrary (W Word8) where
261+ arbitrary = W <$> choose (minBound, maxBound)
262+ shrink = map W . shrinker . unW
250263
251−instance Arbitrary Word16 where
252− arbitrary = choose (minBound, maxBound)
253− shrink = shrinker
264+instance Arbitrary (W Word16) where
265+ arbitrary = W <$> choose (minBound, maxBound)
266+ shrink = map W . shrinker . unW
254267
255−instance Arbitrary Word32 where
256− arbitrary = choose (minBound, maxBound)
257− shrink = shrinker
268+instance Arbitrary (W Word32) where
269+ arbitrary = W <$> choose (minBound, maxBound)
270+ shrink = map W . shrinker . unW
258271
259−instance Arbitrary Word64 where
260− arbitrary = choose (minBound, maxBound)
261− shrink = shrinker
272+instance Arbitrary (W Word64) where
273+ arbitrary = W <$> choose (minBound, maxBound)
274+ shrink = map W . shrinker . unW
262275
263276integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
264277integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,