mirror of
https://github.com/ilyakooo0/binary-bits.git
synced 2024-09-11 06:35:26 +03:00
Override default QC 2.4 Arbitrary instance
In previous QC versions we had to declare our own instances of Arbitrary for Word8/Word16/Word32/Word64. This suited us well, as we want to implement our own shrinking method. In this patch we're working around these instances with the W datatype, a wrapper for the datatypes we're interested in.
This commit is contained in:
Lennart Kolmodin
parent
5a9c73664a
commit
d259c3a2db
131
BitsQC.hs
131
BitsQC.hs
@ -1,3 +1,5 @@
|
||||
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Data.Binary ( encode, Binary(..) )
|
||||
@ -9,6 +11,7 @@ import qualified Data.Binary.Put as BP ( putWord8, putWord16be, putWord32be, put
|
||||
|
||||
import Bits
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Bits
|
||||
import Data.Monoid
|
||||
import Data.Word
|
||||
@ -37,53 +40,53 @@ tests =
|
||||
[ testProperty "prop_composite_case" prop_composite_case ]
|
||||
|
||||
, testGroup "prop_bitput_with_get_from_binary"
|
||||
[ testProperty "Word8" (prop_bitput_with_get_from_binary :: [Word8] -> Property)
|
||||
, testProperty "Word16" (prop_bitput_with_get_from_binary :: [Word16] -> Property)
|
||||
, testProperty "Word32" (prop_bitput_with_get_from_binary :: [Word32] -> Property)
|
||||
, testProperty "Word64" (prop_bitput_with_get_from_binary :: [Word64] -> Property)
|
||||
[ testProperty "Word8" (prop_bitput_with_get_from_binary :: W [Word8] -> Property)
|
||||
, testProperty "Word16" (prop_bitput_with_get_from_binary :: W [Word16] -> Property)
|
||||
, testProperty "Word32" (prop_bitput_with_get_from_binary :: W [Word32] -> Property)
|
||||
, testProperty "Word64" (prop_bitput_with_get_from_binary :: W [Word64] -> Property)
|
||||
]
|
||||
|
||||
, testGroup "prop_bitget_with_put_from_binary"
|
||||
[ testProperty "Word8" (prop_bitget_with_put_from_binary :: [Word8] -> Property)
|
||||
, testProperty "Word16" (prop_bitget_with_put_from_binary :: [Word16] -> Property)
|
||||
, testProperty "Word32" (prop_bitget_with_put_from_binary :: [Word32] -> Property)
|
||||
, testProperty "Word64" (prop_bitget_with_put_from_binary :: [Word64] -> Property)
|
||||
[ testProperty "Word8" (prop_bitget_with_put_from_binary :: W [Word8] -> Property)
|
||||
, testProperty "Word16" (prop_bitget_with_put_from_binary :: W [Word16] -> Property)
|
||||
, testProperty "Word32" (prop_bitget_with_put_from_binary :: W [Word32] -> Property)
|
||||
, testProperty "Word64" (prop_bitget_with_put_from_binary :: W [Word64] -> Property)
|
||||
]
|
||||
|
||||
, testGroup "prop_compare_put_with_naive"
|
||||
[ testProperty "Word8" (prop_compare_put_with_naive :: [Word8] -> Property)
|
||||
, testProperty "Word16" (prop_compare_put_with_naive :: [Word16] -> Property)
|
||||
, testProperty "Word32" (prop_compare_put_with_naive :: [Word32] -> Property)
|
||||
, testProperty "Word64" (prop_compare_put_with_naive :: [Word64] -> Property)
|
||||
[ testProperty "Word8" (prop_compare_put_with_naive :: W [Word8] -> Property)
|
||||
, testProperty "Word16" (prop_compare_put_with_naive :: W [Word16] -> Property)
|
||||
, testProperty "Word32" (prop_compare_put_with_naive :: W [Word32] -> Property)
|
||||
, testProperty "Word64" (prop_compare_put_with_naive :: W [Word64] -> Property)
|
||||
]
|
||||
|
||||
, testGroup "prop_compare_get_with_naive"
|
||||
[ testProperty "Word8" (prop_compare_get_with_naive:: [Word8] -> Property)
|
||||
, testProperty "Word16" (prop_compare_get_with_naive:: [Word16] -> Property)
|
||||
, testProperty "Word32" (prop_compare_get_with_naive:: [Word32] -> Property)
|
||||
, testProperty "Word64" (prop_compare_get_with_naive:: [Word64] -> Property)
|
||||
[ testProperty "Word8" (prop_compare_get_with_naive:: W [Word8] -> Property)
|
||||
, testProperty "Word16" (prop_compare_get_with_naive:: W [Word16] -> Property)
|
||||
, testProperty "Word32" (prop_compare_get_with_naive:: W [Word32] -> Property)
|
||||
, testProperty "Word64" (prop_compare_get_with_naive:: W [Word64] -> Property)
|
||||
]
|
||||
|
||||
, testGroup "prop_put_with_bitreq"
|
||||
[ testProperty "Word8" (prop_putget_with_bitreq :: Word8 -> Property)
|
||||
, testProperty "Word16" (prop_putget_with_bitreq :: Word16 -> Property)
|
||||
, testProperty "Word32" (prop_putget_with_bitreq :: Word32 -> Property)
|
||||
, testProperty "Word64" (prop_putget_with_bitreq :: Word64 -> Property)
|
||||
[ testProperty "Word8" (prop_putget_with_bitreq :: W Word8 -> Property)
|
||||
, testProperty "Word16" (prop_putget_with_bitreq :: W Word16 -> Property)
|
||||
, testProperty "Word32" (prop_putget_with_bitreq :: W Word32 -> Property)
|
||||
, testProperty "Word64" (prop_putget_with_bitreq :: W Word64 -> Property)
|
||||
]
|
||||
|
||||
, testGroup "prop_putget_list_simple"
|
||||
[ testProperty "Bool" (prop_putget_list_simple :: [Bool] -> Property)
|
||||
, testProperty "Word8" (prop_putget_list_simple :: [Word8] -> Property)
|
||||
, testProperty "Word16" (prop_putget_list_simple :: [Word16] -> Property)
|
||||
, testProperty "Word32" (prop_putget_list_simple :: [Word32] -> Property)
|
||||
, testProperty "Word64" (prop_putget_list_simple :: [Word64] -> Property)
|
||||
[ testProperty "Bool" (prop_putget_list_simple :: W [Bool] -> Property)
|
||||
, testProperty "Word8" (prop_putget_list_simple :: W [Word8] -> Property)
|
||||
, testProperty "Word16" (prop_putget_list_simple :: W [Word16] -> Property)
|
||||
, testProperty "Word32" (prop_putget_list_simple :: W [Word32] -> Property)
|
||||
, testProperty "Word64" (prop_putget_list_simple :: W [Word64] -> Property)
|
||||
]
|
||||
|
||||
, testGroup "prop_putget_list_with_bitreq"
|
||||
[ testProperty "Word8" (prop_putget_list_with_bitreq :: [Word8] -> Property)
|
||||
, testProperty "Word16" (prop_putget_list_with_bitreq :: [Word16] -> Property)
|
||||
, testProperty "Word32" (prop_putget_list_with_bitreq :: [Word32] -> Property)
|
||||
, testProperty "Word64" (prop_putget_list_with_bitreq :: [Word64] -> Property)
|
||||
[ testProperty "Word8" (prop_putget_list_with_bitreq :: W [Word8] -> Property)
|
||||
, testProperty "Word16" (prop_putget_list_with_bitreq :: W [Word16] -> Property)
|
||||
, testProperty "Word32" (prop_putget_list_with_bitreq :: W [Word32] -> Property)
|
||||
, testProperty "Word64" (prop_putget_list_with_bitreq :: W [Word64] -> Property)
|
||||
]
|
||||
]
|
||||
|
||||
@ -94,8 +97,8 @@ tests =
|
||||
-- quickCheck prop_Word32_from_Word8_and_Word16
|
||||
-}
|
||||
|
||||
prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => a -> Property
|
||||
prop_putget_with_bitreq w = property $
|
||||
prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W a -> Property
|
||||
prop_putget_with_bitreq (W w) = property $
|
||||
-- write all words with as many bits as it's required
|
||||
let p = putBits (bitreq w) w
|
||||
g = getBits (bitreq w)
|
||||
@ -105,8 +108,8 @@ prop_putget_with_bitreq w = property $
|
||||
|
||||
-- | Write a list of items. Each item is written with the maximum amount of
|
||||
-- bits, i.e. 8 for Word8, 16 for Word16, etc.
|
||||
prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => [a] -> Property
|
||||
prop_putget_list_simple ws = property $
|
||||
prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => W [a] -> Property
|
||||
prop_putget_list_simple (W ws) = property $
|
||||
let s = sizeOf (head ws) * 8
|
||||
p = mapM_ (\v -> putBits s v) ws
|
||||
g = mapM (const (getBits s)) ws
|
||||
@ -116,8 +119,8 @@ prop_putget_list_simple ws = property $
|
||||
|
||||
-- | Write a list of items. Each item is written with exactly as many bits
|
||||
-- as required. Then read it back.
|
||||
prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => [a] -> Property
|
||||
prop_putget_list_with_bitreq ws = property $
|
||||
prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [a] -> Property
|
||||
prop_putget_list_with_bitreq (W ws) = property $
|
||||
-- write all words with as many bits as it's required
|
||||
let p = mapM_ (\v -> putBits (bitreq v) v) ws
|
||||
g = mapM getBits bitlist
|
||||
@ -129,8 +132,8 @@ prop_putget_list_with_bitreq ws = property $
|
||||
|
||||
-- | Write bits using this library, and read them back using the binary
|
||||
-- library.
|
||||
prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => [a] -> Property
|
||||
prop_bitput_with_get_from_binary ws = property $
|
||||
prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
|
||||
prop_bitput_with_get_from_binary (W ws) = property $
|
||||
let s = sizeOf (head ws) * 8
|
||||
p = mapM_ (putBits s) ws
|
||||
g = mapM (const get) ws
|
||||
@ -140,8 +143,8 @@ prop_bitput_with_get_from_binary ws = property $
|
||||
|
||||
-- | Write bits using the binary library, and read them back using this
|
||||
-- library.
|
||||
prop_bitget_with_put_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => [a] -> Property
|
||||
prop_bitget_with_put_from_binary ws = property $
|
||||
prop_bitget_with_put_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
|
||||
prop_bitget_with_put_from_binary (W ws) = property $
|
||||
let s = sizeOf (head ws) * 8
|
||||
p = mapM_ put ws
|
||||
g = mapM (const (getBits s)) ws
|
||||
@ -156,13 +159,13 @@ bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]
|
||||
bittable :: Bits a => [(Integer, a)]
|
||||
bittable = [ (fromIntegral x, (1 `shiftL` x) - 1) | x <- [1..64] ]
|
||||
|
||||
prop_bitreq :: Word64 -> Property
|
||||
prop_bitreq w = property $
|
||||
prop_bitreq :: W Word64 -> Property
|
||||
prop_bitreq (W w) = property $
|
||||
( w == 0 && bitreq w == 1 )
|
||||
|| bitreq w == (bitreq (w `shiftR` 1)) + 1
|
||||
|
||||
prop_composite_case :: Bool -> Word16 -> Property
|
||||
prop_composite_case b w = w < 0x8000 ==>
|
||||
prop_composite_case :: Bool -> W Word16 -> Property
|
||||
prop_composite_case b (W w) = w < 0x8000 ==>
|
||||
let p = do putBool b
|
||||
putWord16be 15 w
|
||||
g = do v <- getBool
|
||||
@ -177,16 +180,16 @@ prop_composite_case b w = w < 0x8000 ==>
|
||||
in w == w'
|
||||
|
||||
|
||||
prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a) => [a] -> Property
|
||||
prop_compare_put_with_naive ws = property $
|
||||
prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a) => W [a] -> Property
|
||||
prop_compare_put_with_naive (W ws) = property $
|
||||
let pn = mapM_ (\v -> naive_put (bitreq v) v) ws
|
||||
p = mapM_ (\v -> putBits (bitreq v) v) ws
|
||||
lbs_n = runPut (runBitPut pn)
|
||||
lbs = runPut (runBitPut p)
|
||||
in lbs_n == lbs
|
||||
|
||||
prop_compare_get_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => [a] -> Property
|
||||
prop_compare_get_with_naive ws = property $
|
||||
prop_compare_get_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => W [a] -> Property
|
||||
prop_compare_get_with_naive (W ws) = property $
|
||||
let gn = mapM (\v -> naive_get (bitreq v)) ws
|
||||
g = mapM (\v -> getBits (bitreq v)) ws
|
||||
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
|
||||
where
|
||||
n = bitreq w
|
||||
|
||||
instance Arbitrary Word8 where
|
||||
arbitrary = choose (minBound, maxBound)
|
||||
shrink = shrinker
|
||||
data W a = W { unW :: a } deriving (Show, Eq, Ord)
|
||||
|
||||
instance Arbitrary Word16 where
|
||||
arbitrary = choose (minBound, maxBound)
|
||||
shrink = shrinker
|
||||
instance Arbitrary (W Bool) where
|
||||
arbitrary = W <$> arbitrary
|
||||
shrink = map W <$> shrink . unW
|
||||
|
||||
instance Arbitrary Word32 where
|
||||
arbitrary = choose (minBound, maxBound)
|
||||
shrink = shrinker
|
||||
instance (Arbitrary (W a)) => Arbitrary (W [a]) where
|
||||
arbitrary = W . map unW <$> arbitrary
|
||||
shrink = map (W . map unW) <$> mapM shrink . map W . unW
|
||||
|
||||
instance Arbitrary Word64 where
|
||||
arbitrary = choose (minBound, maxBound)
|
||||
shrink = shrinker
|
||||
instance Arbitrary (W Word8) where
|
||||
arbitrary = W <$> choose (minBound, maxBound)
|
||||
shrink = map W . shrinker . unW
|
||||
|
||||
instance Arbitrary (W Word16) where
|
||||
arbitrary = W <$> choose (minBound, maxBound)
|
||||
shrink = map W . shrinker . unW
|
||||
|
||||
instance Arbitrary (W Word32) where
|
||||
arbitrary = W <$> choose (minBound, maxBound)
|
||||
shrink = map W . shrinker . unW
|
||||
|
||||
instance Arbitrary (W Word64) where
|
||||
arbitrary = W <$> choose (minBound, maxBound)
|
||||
shrink = map W . shrinker . unW
|
||||
|
||||
integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
|
||||
integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
|
||||
|
||||
Loading…
Reference in New Issue
Block a user