From 18dd483e9e24adf7bfc3f765e2abff0c9f2a3e17 Mon Sep 17 00:00:00 2001
From: Bryan O'Sullivan <bos@serpentine.com>
Date: Mon, 3 Nov 2014 14:44:11 -0800
Subject: [PATCH] Add more near-boundary-condition tests for bounded ints
---
tests/Tests/Properties.hs | 43 +++++++++++++++++++++++++++++++++-
tests/Tests/QuickCheckUtils.hs | 9 ++++++-
2 files changed, 50 insertions(+), 2 deletions(-)
diff --git a/tests/Tests/Properties.hs b/tests/Tests/Properties.hs
index 3100731f..7d4a3e6d 100644
--- a/tests/Tests/Properties.hs
+++ b/tests/Tests/Properties.hs
@@ -753,6 +753,41 @@ tb_decimal_word16 (a::Word16) = tb_decimal a
tb_decimal_word32 (a::Word32) = tb_decimal a
tb_decimal_word64 (a::Word64) = tb_decimal a
+tb_decimal_big_int (BigBounded (a::Int)) = tb_decimal a
+tb_decimal_big_int64 (BigBounded (a::Int64)) = tb_decimal a
+tb_decimal_big_word (BigBounded (a::Word)) = tb_decimal a
+tb_decimal_big_word64 (BigBounded (a::Word64)) = tb_decimal a
+
+countDigits :: (Integral a) => a -> Int
+countDigits v0
+ | v0 > max64 = big 20 (v0 `quot` 10000000000000000000)
+ | otherwise = go 1 (fromIntegral v0 :: Word64)
+ where
+ max64 = fromIntegral (maxBound :: Word64)
+ big !k v
+ | v > max64 = big (k+20) (v `quot` 10000000000000000000)
+ | otherwise = go k (fromIntegral v :: Word64)
+ go !k v
+ | v < 10 = k
+ | v < 100 = k + 1
+ | v < 1000 = k + 2
+ | v < 1000000000000 =
+ k + if v < 100000000
+ then if v < 1000000
+ then if v < 10000
+ then 3
+ else 4 + fin v 100000
+ else 6 + fin v 10000000
+ else if v < 10000000000
+ then 8 + fin v 1000000000
+ else 10 + fin v 100000000000
+ | otherwise = go (k + 12) (v `quot` 1000000000000)
+ fin v n = if v >= n then 1 else 0
+
+t_cd (Big k) = counterexample (show x ++ " /= " ++ show y) (x == y)
+ where x = countDigits k
+ y = length (show k)
+
tb_hex :: (Integral a, Show a) => a -> Bool
tb_hex = (TB.toLazyText . TB.hexadecimal) `eq` (TL.pack . flip showHex "")
@@ -854,6 +889,8 @@ shorten n t@(S.Stream arr off len)
tests :: Test
tests =
testGroup "Properties" [
+ testProperty "t_cd" t_cd,
+
testGroup "creation/elimination" [
testProperty "t_pack_unpack" t_pack_unpack,
testProperty "tl_pack_unpack" tl_pack_unpack,
@@ -1258,7 +1295,11 @@ tests =
testProperty "tb_decimal_word8" tb_decimal_word8,
testProperty "tb_decimal_word16" tb_decimal_word16,
testProperty "tb_decimal_word32" tb_decimal_word32,
- testProperty "tb_decimal_word64" tb_decimal_word64
+ testProperty "tb_decimal_word64" tb_decimal_word64,
+ testProperty "tb_decimal_big_int" tb_decimal_big_int,
+ testProperty "tb_decimal_big_word" tb_decimal_big_word,
+ testProperty "tb_decimal_big_int64" tb_decimal_big_int64,
+ testProperty "tb_decimal_big_word64" tb_decimal_big_word64
],
testGroup "hexadecimal" [
testProperty "tb_hexadecimal_int" tb_hexadecimal_int,
diff --git a/tests/Tests/QuickCheckUtils.hs b/tests/Tests/QuickCheckUtils.hs
index f7c4374b..6aa45e07 100644
--- a/tests/Tests/QuickCheckUtils.hs
+++ b/tests/Tests/QuickCheckUtils.hs
@@ -18,6 +18,7 @@ module Tests.QuickCheckUtils
, unsquare
, smallArbitrary
+ , BigBounded(..)
, BigInt(..)
, NotEmpty (..)
@@ -166,10 +167,16 @@ newtype BigInt = Big Integer
deriving (Eq, Show)
instance Arbitrary BigInt where
- arbitrary = choose (20::Int,200) >>= \e -> Big <$> choose (10^(e-1),10^e)
+ arbitrary = choose (1::Int,200) >>= \e -> Big <$> choose (10^(e-1),10^e)
shrink (Big a) = [Big (a `div` 2^(l-e)) | e <- shrink l]
where l = truncate (log (fromIntegral a) / log 2 :: Double) :: Integer
+newtype BigBounded a = BigBounded a
+ deriving (Eq, Show)
+
+instance (Bounded a, Random a, Arbitrary a) => Arbitrary (BigBounded a) where
+ arbitrary = BigBounded <$> choose (minBound, maxBound)
+
newtype NotEmpty a = NotEmpty { notEmpty :: a }
deriving (Eq, Ord)
--
GitLab