Commit 87ef1c27 authored by Bodigrim's avatar Bodigrim
Browse files

Clean up QuickCheckUtils

parent 4bfb3252
......@@ -34,7 +34,7 @@ data FPFormat = Exponent
| Generic
-- ^ Use decimal notation for values between @0.1@ and
-- @9,999,999@, and scientific notation otherwise.
deriving (Enum, Read, Show)
deriving (Enum, Read, Show, Bounded)
-- | Show a signed 'RealFloat' value to full precision,
-- using standard decimal notation for arguments whose absolute value lies
......
......@@ -53,10 +53,10 @@ 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
tb_decimal_big_int (Large (a::Int)) = tb_decimal a
tb_decimal_big_int64 (Large (a::Int64)) = tb_decimal a
tb_decimal_big_word (Large (a::Word)) = tb_decimal a
tb_decimal_big_word64 (Large (a::Word64)) = tb_decimal a
tb_hex :: (Integral a, Show a) => a -> Property
tb_hex = (TB.toLazyText . TB.hexadecimal) `eq` (TL.pack . flip showHex "")
......
......@@ -48,8 +48,7 @@ t_mul a b = mulRef a b === eval mul a b
t_dropWord16 m t = dropWord16 m t `T.isSuffixOf` t
t_takeWord16 m t = takeWord16 m t `T.isPrefixOf` t
t_take_drop_16 m t = T.append (takeWord16 n t) (dropWord16 n t) === t
where n = small m
t_take_drop_16 (Small n) t = T.append (takeWord16 n t) (dropWord16 n t) === t
t_use_from t = ioProperty $ (==t) <$> useAsPtr t fromPtr
t_copy t = T.copy t === t
......
......@@ -21,8 +21,7 @@ import qualified Data.Text.Lazy as TL
import qualified Tests.SlowFunctions as Slow
s_take n = L.take n `eqP` (unpackS . S.take n)
s_take_s m = L.take n `eqP` (unpackS . S.unstream . S.take n)
where n = small m
s_take_s (Small n) = L.take n `eqP` (unpackS . S.unstream . S.take n)
sf_take (applyFun -> p) n
= (L.take n . L.filter p) `eqP`
(unpackS . S.take n . S.filter p)
......@@ -33,8 +32,7 @@ tl_take n = L.take n `eqP` (unpackS . TL.take (fromIntegral n))
tl_takeEnd n = (L.reverse . L.take (fromIntegral n) . L.reverse) `eqP`
(unpackS . TL.takeEnd n)
s_drop n = L.drop n `eqP` (unpackS . S.drop n)
s_drop_s m = L.drop n `eqP` (unpackS . S.unstream . S.drop n)
where n = small m
s_drop_s (Small n) = L.drop n `eqP` (unpackS . S.unstream . S.drop n)
sf_drop (applyFun -> p) n
= (L.drop n . L.filter p) `eqP` (unpackS . S.drop n . S.filter p)
t_drop n = L.drop n `eqP` (unpackS . T.drop n)
......@@ -43,11 +41,9 @@ t_dropEnd n = (L.reverse . L.drop n . L.reverse) `eqP`
tl_drop n = L.drop n `eqP` (unpackS . TL.drop (fromIntegral n))
tl_dropEnd n = (L.reverse . L.drop n . L.reverse) `eqP`
(unpackS . TL.dropEnd (fromIntegral n))
s_take_drop m = (L.take n . L.drop n) `eqP` (unpackS . S.take n . S.drop n)
where n = small m
s_take_drop_s m = (L.take n . L.drop n) `eqP`
s_take_drop (Small n) = (L.take n . L.drop n) `eqP` (unpackS . S.take n . S.drop n)
s_take_drop_s (Small n) = (L.take n . L.drop n) `eqP`
(unpackS . S.unstream . S.take n . S.drop n)
where n = small m
s_takeWhile (applyFun -> p)
= L.takeWhile p `eqP` (unpackS . S.takeWhile p)
s_takeWhile_s (applyFun -> p)
......
......@@ -2,23 +2,20 @@
-- instances, and comparison functions, so we can focus on the actual properties
-- in the 'Tests.Properties' module.
--
{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Tests.QuickCheckUtils
( BigBounded(..)
, BigInt(..)
( BigInt(..)
, NotEmpty(..)
, Sqrt(..)
, SpacyString(..)
, Small(..)
, small
, Precision(..)
, precision
, integralRandomR
, DecodeErr(..)
, genDecodeErr
......@@ -31,14 +28,13 @@ module Tests.QuickCheckUtils
, write_read
) where
import Control.Arrow (first, (***))
import Control.Arrow ((***))
import Control.DeepSeq (NFData (..), deepseq)
import Control.Exception (bracket)
import Data.Char (isSpace)
import Data.Text.Foreign (I16)
import Data.Text.Lazy.Builder.RealFloat (FPFormat(..))
import Data.Word (Word8, Word16)
import System.Random (Random(..), RandomGen)
import Test.QuickCheck hiding (Fixed(..), Small (..), (.&.))
import Tests.Utils
import qualified Data.ByteString as B
......@@ -55,10 +51,6 @@ import qualified System.IO as IO
genWord8 :: Gen Word8
genWord8 = chooseAny
instance Random I16 where
randomR = integralRandomR
random = randomR (minBound,maxBound)
instance Arbitrary I16 where
arbitrary = arbitrarySizedIntegral
shrink = shrinkIntegral
......@@ -108,90 +100,21 @@ instance Arbitrary BigInt where
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)
instance Show a => Show (NotEmpty a) where
show (NotEmpty a) = show a
instance Functor NotEmpty where
fmap f (NotEmpty a) = NotEmpty (f a)
instance Arbitrary a => Arbitrary (NotEmpty [a]) where
arbitrary = sized (\n -> NotEmpty `fmap` (choose (1,n+1) >>= vector))
shrink = shrinkNotEmpty null
deriving (Eq, Ord, Show)
instance Arbitrary (NotEmpty T.Text) where
arbitrary = (fmap T.pack) `fmap` arbitrary
shrink = shrinkNotEmpty T.null
arbitrary = fmap (NotEmpty . T.pack . getNonEmpty) arbitrary
shrink = fmap (NotEmpty . T.pack . getNonEmpty)
. shrink . NonEmpty . T.unpack . notEmpty
instance Arbitrary (NotEmpty TL.Text) where
arbitrary = (fmap TL.pack) `fmap` arbitrary
shrink = shrinkNotEmpty TL.null
instance Arbitrary (NotEmpty B.ByteString) where
arbitrary = (fmap B.pack) `fmap` arbitrary
shrink = shrinkNotEmpty B.null
shrinkNotEmpty :: Arbitrary a => (a -> Bool) -> NotEmpty a -> [NotEmpty a]
shrinkNotEmpty isNull (NotEmpty xs) =
[ NotEmpty xs' | xs' <- shrink xs, not (isNull xs') ]
data Small = S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7
| S8 | S9 | S10 | S11 | S12 | S13 | S14 | S15
| S16 | S17 | S18 | S19 | S20 | S21 | S22 | S23
| S24 | S25 | S26 | S27 | S28 | S29 | S30 | S31
deriving (Eq, Ord, Enum, Bounded)
small :: Integral a => Small -> a
small = fromIntegral . fromEnum
intf :: (Int -> Int -> Int) -> Small -> Small -> Small
intf f a b = toEnum ((fromEnum a `f` fromEnum b) `mod` 32)
instance Show Small where
show = show . fromEnum
instance Read Small where
readsPrec n = map (first toEnum) . readsPrec n
instance Num Small where
fromInteger = toEnum . fromIntegral
signum _ = 1
abs = id
(+) = intf (+)
(-) = intf (-)
(*) = intf (*)
instance Real Small where
toRational = toRational . fromEnum
instance Integral Small where
toInteger = toInteger . fromEnum
quotRem a b = (toEnum x, toEnum y)
where (x, y) = fromEnum a `quotRem` fromEnum b
instance Random Small where
randomR = integralRandomR
random = randomR (minBound,maxBound)
instance Arbitrary Small where
arbitrary = choose (minBound, maxBound)
shrink = shrinkIntegral
integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
fromIntegral b :: Integer) g of
(x,h) -> (fromIntegral x, h)
arbitrary = fmap (NotEmpty . TL.pack . getNonEmpty) arbitrary
shrink = fmap (NotEmpty . TL.pack . getNonEmpty)
. shrink . NonEmpty . TL.unpack . notEmpty
data DecodeErr = Lenient | Ignore | Strict | Replace
deriving (Show, Eq)
deriving (Show, Eq, Bounded, Enum)
genDecodeErr :: DecodeErr -> Gen T.OnDecodeError
genDecodeErr Lenient = return T.lenientDecode
......@@ -203,7 +126,7 @@ genDecodeErr Replace = (\c _ _ -> c) <$> frequency
]
instance Arbitrary DecodeErr where
arbitrary = elements [Lenient, Ignore, Strict, Replace]
arbitrary = arbitraryBoundedEnum
class Stringy s where
packS :: String -> s
......@@ -262,7 +185,7 @@ eqPSqrt :: (Eq a, Show a, Stringy s) =>
eqPSqrt f g s = eqP f g (unSqrt s)
instance Arbitrary FPFormat where
arbitrary = elements [Exponent, Fixed, Generic]
arbitrary = arbitraryBoundedEnum
newtype Precision a = Precision (Maybe Int)
deriving (Eq, Show)
......
......@@ -202,7 +202,6 @@ test-suite tests
bytestring,
deepseq,
directory,
random,
tasty,
tasty-hunit,
tasty-quickcheck,
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment