From 2b13adaf2b0f4bc425a20c7b9e0a25db36b113f2 Mon Sep 17 00:00:00 2001
From: Bryan O'Sullivan <bos@serpentine.com>
Date: Fri, 31 Oct 2014 16:46:03 -0700
Subject: [PATCH] A better test for gh-99
---
tests/Tests/Properties.hs | 3 +--
tests/Tests/QuickCheckUtils.hs | 10 ++++++++++
2 files changed, 11 insertions(+), 2 deletions(-)
diff --git a/tests/Tests/Properties.hs b/tests/Tests/Properties.hs
index e88cc473..3100731f 100644
--- a/tests/Tests/Properties.hs
+++ b/tests/Tests/Properties.hs
@@ -741,8 +741,7 @@ tb_decimal :: (Integral a, Show a) => a -> Bool
tb_decimal = (TB.toLazyText . TB.decimal) `eq` (TL.pack . show)
tb_decimal_integer (a::Integer) = tb_decimal a
-tb_decimal_integer_big = forAll big tb_decimal
- where big = choose (20::Int,200) >>= \e -> choose (10^(e-1),10^e::Integer)
+tb_decimal_integer_big (Big a) = tb_decimal a
tb_decimal_int (a::Int) = tb_decimal a
tb_decimal_int8 (a::Int8) = tb_decimal a
tb_decimal_int16 (a::Int16) = tb_decimal a
diff --git a/tests/Tests/QuickCheckUtils.hs b/tests/Tests/QuickCheckUtils.hs
index 242af447..f7c4374b 100644
--- a/tests/Tests/QuickCheckUtils.hs
+++ b/tests/Tests/QuickCheckUtils.hs
@@ -18,6 +18,7 @@ module Tests.QuickCheckUtils
, unsquare
, smallArbitrary
+ , BigInt(..)
, NotEmpty (..)
, Small (..)
@@ -37,6 +38,7 @@ module Tests.QuickCheckUtils
, write_read
) where
+import Control.Applicative ((<$>))
import Control.Arrow (first, (***))
import Control.DeepSeq (NFData (..), deepseq)
import Control.Exception (bracket)
@@ -160,6 +162,14 @@ instance Arbitrary TL.Text where
arbitrary = (TL.fromChunks . map notEmpty) `fmap` smallArbitrary
shrink = map TL.pack . shrink . TL.unpack
+newtype BigInt = Big Integer
+ deriving (Eq, Show)
+
+instance Arbitrary BigInt where
+ arbitrary = choose (20::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 NotEmpty a = NotEmpty { notEmpty :: a }
deriving (Eq, Ord)
--
GitLab