mirror of
https://github.com/ilyakooo0/binary-bits.git
synced 2024-10-26 06:40:48 +03:00
Add tests regarding failure and that BitGet has the current chunk.
This commit is contained in:
parent
0e5029eff1
commit
fe6389e97a
28
BitsQC.hs
28
BitsQC.hs
@ -3,7 +3,7 @@
|
|||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Data.Binary ( encode, Binary(..) )
|
import Data.Binary ( encode, Binary(..) )
|
||||||
import Data.Binary.Get ( runGet )
|
import Data.Binary.Get ( runGet, runGetPartial, feedLBS, Result(..) )
|
||||||
import Data.Binary.Put ( runPut )
|
import Data.Binary.Put ( runPut )
|
||||||
|
|
||||||
import qualified Data.Binary.Get as BG ( getWord8, getWord16be, getWord32be, getWord64be )
|
import qualified Data.Binary.Get as BG ( getWord8, getWord16be, getWord32be, getWord64be )
|
||||||
@ -43,6 +43,9 @@ tests =
|
|||||||
, testGroup "getByteString"
|
, testGroup "getByteString"
|
||||||
[ testProperty "prop_getByteString_negative" prop_getByteString_negative ]
|
[ testProperty "prop_getByteString_negative" prop_getByteString_negative ]
|
||||||
|
|
||||||
|
, testGroup "Fail"
|
||||||
|
[ testProperty "monadic fail" prop_fail ]
|
||||||
|
|
||||||
, testGroup "prop_bitput_with_get_from_binary"
|
, testGroup "prop_bitput_with_get_from_binary"
|
||||||
[ testProperty "Word8" (prop_bitput_with_get_from_binary :: W [Word8] -> Property)
|
[ testProperty "Word8" (prop_bitput_with_get_from_binary :: W [Word8] -> Property)
|
||||||
, testProperty "Word16" (prop_bitput_with_get_from_binary :: W [Word16] -> Property)
|
, testProperty "Word16" (prop_bitput_with_get_from_binary :: W [Word16] -> Property)
|
||||||
@ -189,6 +192,25 @@ prop_bitget_bytestring_interspersed (W ws) bss = property $
|
|||||||
r = runGet (runBitGet g) lbs
|
r = runGet (runBitGet g) lbs
|
||||||
in map (ws,) bss == r
|
in map (ws,) bss == r
|
||||||
|
|
||||||
|
-- | Test failing.
|
||||||
|
prop_fail :: L.ByteString -> String -> Property
|
||||||
|
prop_fail lbs errMsg0 = forAll (choose (0, 8 * L.length lbs)) $ \len ->
|
||||||
|
let (bytes,bits) = len `divMod` 8
|
||||||
|
expectedBytesConsumed
|
||||||
|
| bits == 0 = bytes
|
||||||
|
| otherwise = bytes + 1
|
||||||
|
p = do getByteString (fromIntegral bytes)
|
||||||
|
getBits (fromIntegral bits) :: BitGet Word8
|
||||||
|
fail errMsg0
|
||||||
|
r = runGetPartial (runBitGet p) `feedLBS` lbs
|
||||||
|
in case r of
|
||||||
|
Fail remainingBS pos errMsg ->
|
||||||
|
and [ L.fromChunks [remainingBS] == L.drop expectedBytesConsumed lbs
|
||||||
|
, pos == expectedBytesConsumed
|
||||||
|
, errMsg == errMsg0
|
||||||
|
]
|
||||||
|
_ -> False
|
||||||
|
|
||||||
-- | number of bits required to write @v@
|
-- | number of bits required to write @v@
|
||||||
bitreq :: (Num b, Bits a, Ord a) => a -> b
|
bitreq :: (Num b, Bits a, Ord a) => a -> b
|
||||||
bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]
|
bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]
|
||||||
@ -294,6 +316,10 @@ instance Arbitrary B.ByteString where
|
|||||||
arbitrary = B.pack <$> arbitrary
|
arbitrary = B.pack <$> arbitrary
|
||||||
shrink bs = B.pack <$> shrink (B.unpack bs)
|
shrink bs = B.pack <$> shrink (B.unpack bs)
|
||||||
|
|
||||||
|
instance Arbitrary L.ByteString where
|
||||||
|
arbitrary = L.fromChunks <$> arbitrary
|
||||||
|
shrink bs = L.fromChunks <$> shrink (L.toChunks bs)
|
||||||
|
|
||||||
instance (Arbitrary (W a)) => Arbitrary (W [a]) where
|
instance (Arbitrary (W a)) => Arbitrary (W [a]) where
|
||||||
arbitrary = W . map unW <$> arbitrary
|
arbitrary = W . map unW <$> arbitrary
|
||||||
shrink = map (W . map unW) <$> mapM shrink . map W . unW
|
shrink = map (W . map unW) <$> mapM shrink . map W . unW
|
||||||
|
Loading…
Reference in New Issue
Block a user