{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, Rank2Types, NoMonomorphismRestriction #-} import Test.QuickCheck import Test.QuickCheck.Gen.Unsafe import Data.List import Data.Int import Data.Word import Data.Version (showVersion, parseVersion) import Text.ParserCombinators.ReadP (readP_to_S) newtype Path a = Path [a] deriving (Show, Functor) instance Arbitrary a => Arbitrary (Path a) where arbitrary = do x <- arbitrary fmap Path (pathFrom x) where pathFrom x = sized \$ \n -> fmap (x:) \$ oneof \$ [return []] ++ [resize (n-1) (pathFrom y) | n > 0, y <- shrink x] shrink (Path xs) = map Path [ ys | ys <- inits xs, length ys > 0 && length ys < length xs ] path :: (a -> Bool) -> Path a -> Bool path p (Path xs) = all p xs somePath :: (a -> Bool) -> Path a -> Property somePath p = expectFailure . path (not . p) newtype Extremal a = Extremal { getExtremal :: a } deriving (Show, Eq, Ord, Num, Enum, Real, Integral) instance (Arbitrary a, Bounded a) => Arbitrary (Extremal a) where arbitrary = fmap Extremal \$ frequency [(1, return minBound), (1, return maxBound), (8, arbitrary)] shrink (Extremal x) = map Extremal (shrink x) smallProp :: Integral a => Path a -> Bool smallProp = path (\x -> (x >= -100 || -100 `asTypeOf` x >= 0) && x <= 100) largeProp :: Integral a => Path a -> Property largeProp = somePath (\x -> x < -1000000 || x > 1000000) prop_int :: Path Int -> Bool prop_int = smallProp prop_int32 :: Path Int32 -> Property prop_int32 = largeProp prop_word :: Path Word -> Property prop_word = largeProp prop_word32 :: Path Word32 -> Property prop_word32 = largeProp prop_integer :: Path Integer -> Bool prop_integer = smallProp prop_small :: Path (Small Int) -> Bool prop_small = smallProp prop_large :: Path (Large Int) -> Property prop_large = largeProp prop_smallWord :: Path (Small Word) -> Bool prop_smallWord = smallProp prop_largeWord :: Path (Large Word) -> Property prop_largeWord = largeProp data Choice a b = Choice a b deriving Show instance (Arbitrary a, Arbitrary b) => Arbitrary (Choice a b) where arbitrary = do Capture eval <- capture return (Choice (eval arbitrary) (eval arbitrary)) idemProp :: (Eq a, Arbitrary a, Arbitrary b) => (b -> a) -> Choice a b -> Bool idemProp f (Choice x y) = x == f y prop_fixed_length :: Arbitrary a => Path (Fixed a) -> Bool prop_fixed_length (Path xs) = length xs == 1 prop_fixed_idem = idemProp getFixed prop_blind_idem = idemProp getBlind prop_ordered_list = path (\(Ordered xs) -> sort xs == xs) prop_nonempty_list = path (\(NonEmpty xs) -> not (null xs)) pathInt, somePathInt :: (Arbitrary (f (Extremal Int)), Show (f (Extremal Int)), Arbitrary (f Integer), Show (f Integer), Arbitrary (f (Extremal Int8)), Show (f (Extremal Int8)), Arbitrary (f (Extremal Int16)), Show (f (Extremal Int16)), Arbitrary (f (Extremal Int32)), Show (f (Extremal Int32)), Arbitrary (f (Extremal Int64)), Show (f (Extremal Int64)), Arbitrary (f (Extremal Word)), Show (f (Extremal Word)), Arbitrary (f (Extremal Word8)), Show (f (Extremal Word8)), Arbitrary (f (Extremal Word16)), Show (f (Extremal Word16)), Arbitrary (f (Extremal Word32)), Show (f (Extremal Word32)), Arbitrary (f (Extremal Word64)), Show (f (Extremal Word64))) => (forall a. f a -> a) -> (forall a. Integral a => a -> Bool) -> Property pathInt f p = conjoin [counterexample "Int" (path ((p :: Int -> Bool) . getExtremal . f)), counterexample "Integer" (path ((p :: Integer -> Bool) . f)), counterexample "Int8" (path ((p :: Int8 -> Bool) . getExtremal . f)), counterexample "Int16" (path ((p :: Int16 -> Bool) . getExtremal . f)), counterexample "Int32" (path ((p :: Int32 -> Bool) . getExtremal . f)), counterexample "Int64" (path ((p :: Int64 -> Bool) . getExtremal . f)), counterexample "Word" (path ((p :: Word -> Bool) . getExtremal . f)), counterexample "Word8" (path ((p :: Word8 -> Bool) . getExtremal . f)), counterexample "Word16" (path ((p :: Word16 -> Bool) . getExtremal . f)), counterexample "Word32" (path ((p :: Word32 -> Bool) . getExtremal . f)), counterexample "Word64" (path ((p :: Word64 -> Bool) . getExtremal . f))] somePathInt f p = expectFailure (pathInt f (not . p)) prop_positive = pathInt getPositive (> 0) prop_positive_bound = somePathInt getPositive (== 1) prop_nonzero = pathInt getNonZero (/= 0) prop_nonzero_bound_1 = somePathInt getNonZero (== 1) prop_nonzero_bound_2 = somePathInt getNonZero (== -1) prop_nonnegative = pathInt getNonNegative (>= 0) prop_nonnegative_bound = somePathInt getNonNegative (== 0) reachesBound :: (Bounded a, Integral a, Arbitrary a) => a -> Property reachesBound x = expectFailure (x < 3 * (maxBound `div` 4)) prop_reachesBound_Int8 = reachesBound :: Int8 -> Property prop_reachesBound_Int16 = reachesBound :: Int16 -> Property prop_reachesBound_Int32 = reachesBound :: Int32 -> Property prop_reachesBound_Int64 = reachesBound :: Int64 -> Property prop_reachesBound_Word = reachesBound :: Word -> Property prop_reachesBound_Word8 = reachesBound :: Word8 -> Property prop_reachesBound_Word16 = reachesBound :: Word16 -> Property prop_reachesBound_Word32 = reachesBound :: Word32 -> Property prop_reachesBound_Word64 = reachesBound :: Word64 -> Property -- Bad shrink: infinite list -- -- remove unexpectedFailure in prop_B1, shrinking should not loop forever. data B1 = B1 Int deriving (Eq, Show) instance Arbitrary B1 where arbitrary = fmap B1 arbitrary shrink x = x : shrink x prop_B1 :: B1 -> Property prop_B1 (B1 n) = expectFailure \$ n === n + 1 return [] main = \$forAllProperties (quickCheckWithResult stdArgs { maxShrinks = 10000 }) >>= print