mirror of
https://github.com/ilyakooo0/binary-bits.git
synced 2024-09-11 06:35:26 +03:00
Add test for Applicative BitGet.
What's more interesting is Applicative Block, but we don't have a class for Block reads yet, so we can't make the test polymorphic.
This commit is contained in:
parent
8ce95bb417
commit
df45a36c23
41
BitsQC.hs
41
BitsQC.hs
@ -82,6 +82,13 @@ tests =
|
||||
, testProperty "Word64" (prop_putget_list_simple :: W [Word64] -> Property)
|
||||
]
|
||||
|
||||
, testGroup "prop_putget_applicative_with_bitreq"
|
||||
[ testProperty "Word8" (prop_putget_applicative_with_bitreq :: W [(Word8,Word8,Word8)] -> Property)
|
||||
, testProperty "Word16" (prop_putget_applicative_with_bitreq :: W [(Word16,Word16,Word16)] -> Property)
|
||||
, testProperty "Word32" (prop_putget_applicative_with_bitreq :: W [(Word32,Word32,Word32)] -> Property)
|
||||
, testProperty "Word64" (prop_putget_applicative_with_bitreq :: W [(Word64,Word64,Word64)] -> Property)
|
||||
]
|
||||
|
||||
, testGroup "prop_putget_list_with_bitreq"
|
||||
[ testProperty "Word8" (prop_putget_list_with_bitreq :: W [Word8] -> Property)
|
||||
, testProperty "Word16" (prop_putget_list_with_bitreq :: W [Word16] -> Property)
|
||||
@ -129,6 +136,18 @@ prop_putget_list_with_bitreq (W ws) = property $
|
||||
where
|
||||
bitlist = map bitreq ws
|
||||
|
||||
prop_putget_applicative_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [(a,a,a)] -> Property
|
||||
prop_putget_applicative_with_bitreq (W ts) = property $
|
||||
let p = mapM_ (\(a,b,c) -> do putBits (bitreq a) a
|
||||
putBits (bitreq b) b
|
||||
putBits (bitreq c) c) ts
|
||||
g = mapM (\(a,b,c) -> (,,) <$> getBits a <*> getBits b <*> getBits c) bitlist
|
||||
lbs = runPut (runBitPut p)
|
||||
ts' = runGet (runBitGet g) lbs
|
||||
in ts == ts'
|
||||
where
|
||||
bitlist = map (\(a,b,c) -> (bitreq a, bitreq b, bitreq c)) ts
|
||||
|
||||
-- | 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) => W [a] -> Property
|
||||
@ -235,14 +254,16 @@ shrinker w = [ w `shiftR` 1 -- try to make everything roughly half size
|
||||
|
||||
data W a = W { unW :: a } deriving (Show, Eq, Ord)
|
||||
|
||||
arbitraryW :: (Arbitrary (W a)) => Gen a
|
||||
arbitraryW = unW <$> arbitrary
|
||||
|
||||
shrinkW :: (Arbitrary (W a)) => a -> [a]
|
||||
shrinkW x = unW <$> shrink (W x)
|
||||
|
||||
instance Arbitrary (W Bool) where
|
||||
arbitrary = W <$> arbitrary
|
||||
shrink = map W <$> shrink . unW
|
||||
|
||||
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 (W Word8) where
|
||||
arbitrary = W <$> choose (minBound, maxBound)
|
||||
shrink = map W . shrinker . unW
|
||||
@ -263,6 +284,18 @@ instance Arbitrary B.ByteString where
|
||||
arbitrary = B.pack <$> arbitrary
|
||||
shrink bs = B.pack <$> shrink (B.unpack bs)
|
||||
|
||||
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 (W a), Arbitrary (W b)) => Arbitrary (W (a,b)) where
|
||||
arbitrary = (W .) . (,) <$> arbitraryW <*> arbitraryW
|
||||
shrink (W (a,b)) = (W .) . (,) <$> shrinkW a <*> shrinkW b
|
||||
|
||||
instance (Arbitrary (W a), Arbitrary (W b), Arbitrary (W c)) => Arbitrary (W (a,b,c)) where
|
||||
arbitrary = ((W .) .) . (,,) <$> arbitraryW <*> arbitraryW <*> arbitraryW
|
||||
shrink (W (a,b,c)) = ((W .) .) . (,,) <$> shrinkW a <*> shrinkW b <*> shrinkW c
|
||||
|
||||
integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
|
||||
integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
|
||||
fromIntegral b :: Integer) g of
|
||||
|
Loading…
Reference in New Issue
Block a user