module Test.QuickCheck.Arbitrary ( -- * Arbitrary and CoArbitrary classes. Arbitrary(..) , CoArbitrary(..) -- ** Helper functions for implementing arbitrary , arbitrarySizedIntegral -- :: Num a => Gen a , arbitraryBoundedIntegral -- :: (Bounded a, Integral a) => Gen a , arbitrarySizedBoundedIntegral -- :: (Bounded a, Integral a) => Gen a , arbitrarySizedFractional -- :: Fractional a => Gen a , arbitraryBoundedRandom -- :: (Bounded a, Random a) => Gen a -- ** Helper functions for implementing shrink , shrinkNothing -- :: a -> [a] , shrinkList -- :: (a -> [a]) -> [a] -> [[a]] , shrinkIntegral -- :: Integral a => a -> [a] , shrinkRealFrac -- :: RealFrac a => a -> [a] -- ** Helper functions for implementing coarbitrary , (><) , coarbitraryIntegral -- :: Integral a => a -> Gen b -> Gen b , coarbitraryReal -- :: Real a => a -> Gen b -> Gen b , coarbitraryShow -- :: Show a => a -> Gen b -> Gen b -- ** Generators which use arbitrary , vector -- :: Arbitrary a => Int -> Gen [a] , orderedList -- :: (Ord a, Arbitrary a) => Gen [a] ) where -------------------------------------------------------------------------- -- imports import Test.QuickCheck.Gen {- import Data.Generics ( (:*:)(..) , (:+:)(..) , Unit(..) ) -} import Data.Char ( chr , ord , isLower , isUpper , toLower , isDigit , isSpace ) import Data.Ratio ( Ratio , (%) , numerator , denominator ) import Data.Complex ( Complex((:+)) ) import System.Random ( Random ) import Data.List ( sort , nub ) import Control.Monad ( liftM , liftM2 , liftM3 , liftM4 , liftM5 ) import Data.Int(Int8, Int16, Int32, Int64) import Data.Word(Word, Word8, Word16, Word32, Word64) -------------------------------------------------------------------------- -- ** class Arbitrary -- | Random generation and shrinking of values. class Arbitrary a where -- | A generator for values of the given type. arbitrary :: Gen a arbitrary = error "no default generator" -- | Produces a (possibly) empty list of all the possible -- immediate shrinks of the given value. shrink :: a -> [a] shrink _ = [] -- instances instance (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where arbitrary = promote (`coarbitrary` arbitrary) instance Arbitrary () where arbitrary = return () instance Arbitrary Bool where arbitrary = choose (False,True) shrink True = [False] shrink False = [] instance Arbitrary a => Arbitrary (Maybe a) where arbitrary = frequency [(1, return Nothing), (3, liftM Just arbitrary)] shrink (Just x) = Nothing : [ Just x' | x' <- shrink x ] shrink _ = [] instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where arbitrary = oneof [liftM Left arbitrary, liftM Right arbitrary] shrink (Left x) = [ Left x' | x' <- shrink x ] shrink (Right y) = [ Right y' | y' <- shrink y ] instance Arbitrary a => Arbitrary [a] where arbitrary = sized $ \n -> do k <- choose (0,n) sequence [ arbitrary | _ <- [1..k] ] shrink xs = shrinkList shrink xs shrinkList :: (a -> [a]) -> [a] -> [[a]] shrinkList shr xs0 = removeChunks xs0 ++ shrinkOne xs0 where shrinkOne [] = [] shrinkOne (x:xs) = [ x':xs | x' <- shr x ] ++ [ x:xs' | xs' <- shrinkOne xs ] {- -- "standard" definition for lists: shrink [] = [] shrink (x:xs) = [ xs ] ++ [ x:xs' | xs' <- shrink xs ] ++ [ x':xs | x' <- shrink x ] -} removeChunks :: [a] -> [[a]] removeChunks xs0 = remC (length xs0) xs0 where remC 0 _ = [] remC 1 _ = [[]] remC n xs = xs1 : xs2 : ( [ xs1' ++ xs2 | xs1' <- remC n1 xs1, not (null xs1') ] `ilv` [ xs1 ++ xs2' | xs2' <- remC n2 xs2, not (null xs2') ] ) where n1 = n `div` 2 xs1 = take n1 xs n2 = n - n1 xs2 = drop n1 xs [] `ilv` bs = bs as `ilv` [] = as (a:as) `ilv` (b:bs) = a : b : (as `ilv` bs) instance (Integral a, Arbitrary a) => Arbitrary (Ratio a) where arbitrary = arbitrarySizedFractional shrink = shrinkRealFrac instance (RealFloat a, Arbitrary a) => Arbitrary (Complex a) where arbitrary = liftM2 (:+) arbitrary arbitrary shrink (x :+ y) = [ x' :+ y | x' <- shrink x ] ++ [ x :+ y' | y' <- shrink y ] instance (Arbitrary a, Arbitrary b) => Arbitrary (a,b) where arbitrary = liftM2 (,) arbitrary arbitrary shrink (x,y) = [ (x',y) | x' <- shrink x ] ++ [ (x,y') | y' <- shrink y ] instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (a,b,c) where arbitrary = liftM3 (,,) arbitrary arbitrary arbitrary shrink (x,y,z) = [ (x',y,z) | x' <- shrink x ] ++ [ (x,y',z) | y' <- shrink y ] ++ [ (x,y,z') | z' <- shrink z ] instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) => Arbitrary (a,b,c,d) where arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary shrink (w,x,y,z) = [ (w',x,y,z) | w' <- shrink w ] ++ [ (w,x',y,z) | x' <- shrink x ] ++ [ (w,x,y',z) | y' <- shrink y ] ++ [ (w,x,y,z') | z' <- shrink z ] instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) => Arbitrary (a,b,c,d,e) where arbitrary = liftM5 (,,,,) arbitrary arbitrary arbitrary arbitrary arbitrary shrink (v,w,x,y,z) = [ (v',w,x,y,z) | v' <- shrink v ] ++ [ (v,w',x,y,z) | w' <- shrink w ] ++ [ (v,w,x',y,z) | x' <- shrink x ] ++ [ (v,w,x,y',z) | y' <- shrink y ] ++ [ (v,w,x,y,z') | z' <- shrink z ] -- typical instance for primitive (numerical) types instance Arbitrary Integer where arbitrary = arbitrarySizedIntegral shrink = shrinkIntegral instance Arbitrary Int where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Int8 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Int16 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Int32 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Int64 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Word where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Word8 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Word16 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Word32 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Word64 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral instance Arbitrary Char where arbitrary = chr `fmap` oneof [choose (0,127), choose (0,255)] shrink c = filter (<. c) $ nub $ ['a','b','c'] ++ [ toLower c | isUpper c ] ++ ['A','B','C'] ++ ['1','2','3'] ++ [' ','\n'] where a <. b = stamp a < stamp b stamp a = ( not (isLower a) , not (isUpper a) , not (isDigit a) , not (a==' ') , not (isSpace a) , a ) instance Arbitrary Float where arbitrary = arbitrarySizedFractional shrink = shrinkRealFrac instance Arbitrary Double where arbitrary = arbitrarySizedFractional shrink = shrinkRealFrac -- ** Helper functions for implementing arbitrary -- | Generates an integral number. The number can be positive or negative -- and its maximum absolute value depends on the size parameter. arbitrarySizedIntegral :: Num a => Gen a arbitrarySizedIntegral = sized $ \n -> let n' = toInteger n in fmap fromInteger (choose (-n', n')) -- | Generates a fractional number. The number can be positive or negative -- and its maximum absolute value depends on the size parameter. arbitrarySizedFractional :: Fractional a => Gen a arbitrarySizedFractional = sized $ \n -> let n' = toInteger n in do a <- choose ((-n') * precision, n' * precision) b <- choose (1, precision) return (fromRational (a % b)) where precision = 9999999999999 :: Integer -- | Generates an integral number. The number is chosen uniformly from -- the entire range of the type. You may want to use -- 'arbitrarySizedBoundedIntegral' instead. arbitraryBoundedIntegral :: (Bounded a, Integral a) => Gen a arbitraryBoundedIntegral = do let mn = minBound mx = maxBound `asTypeOf` mn n <- choose (toInteger mn, toInteger mx) return (fromInteger n `asTypeOf` mn) -- | Generates an element of a bounded type. The element is -- chosen from the entire range of the type. arbitraryBoundedRandom :: (Bounded a, Random a) => Gen a arbitraryBoundedRandom = choose (minBound,maxBound) -- | Generates an integral number from a bounded domain. The number is -- chosen from the entire range of the type, but small numbers are -- generated more often than big numbers. Inspired by demands from -- Phil Wadler. arbitrarySizedBoundedIntegral :: (Bounded a, Integral a) => Gen a arbitrarySizedBoundedIntegral = sized $ \s -> do let mn = minBound mx = maxBound `asTypeOf` mn bits n | n `quot` 2 == 0 = 0 | otherwise = 1 + bits (n `quot` 2) k = 2^(s*(bits mn `max` bits mx `max` 40) `div` 100) n <- choose (toInteger mn `max` (-k), toInteger mx `min` k) return (fromInteger n `asTypeOf` mn) -- ** Helper functions for implementing shrink -- | Returns no shrinking alternatives. shrinkNothing :: a -> [a] shrinkNothing _ = [] -- | Shrink an integral number. shrinkIntegral :: Integral a => a -> [a] shrinkIntegral x = nub $ [ -x | x < 0, -x > x ] ++ [ x' | x' <- takeWhile (<< x) (0:[ x - i | i <- tail (iterate (`quot` 2) x) ]) ] where -- a << b is "morally" abs a < abs b, but taking care of overflow. a << b = case (a >= 0, b >= 0) of (True, True) -> a < b (False, False) -> a > b (True, False) -> a + b < 0 (False, True) -> a + b > 0 -- | Shrink a fraction. shrinkRealFrac :: RealFrac a => a -> [a] shrinkRealFrac x = nub $ [ -x | x < 0 ] ++ [ x' | x' <- [fromInteger (truncate x)] , x' << x ] where a << b = abs a < abs b -------------------------------------------------------------------------- -- ** CoArbitrary -- | Used for random generation of functions. class CoArbitrary a where -- | Used to generate a function of type @a -> c@. The implementation -- should use the first argument to perturb the random generator -- given as the second argument. the returned generator -- is then used to generate the function result. -- You can often use 'variant' and '><' to implement -- 'coarbitrary'. coarbitrary :: a -> Gen c -> Gen c {- -- GHC definition: coarbitrary{| Unit |} Unit = id coarbitrary{| a :*: b |} (x :*: y) = coarbitrary x >< coarbitrary y coarbitrary{| a :+: b |} (Inl x) = variant 0 . coarbitrary x coarbitrary{| a :+: b |} (Inr y) = variant (-1) . coarbitrary y -} -- | Combine two generator perturbing functions, for example the -- results of calls to 'variant' or 'coarbitrary'. (><) :: (Gen a -> Gen a) -> (Gen a -> Gen a) -> (Gen a -> Gen a) (><) f g gen = do n <- arbitrary (g . variant (n :: Int) . f) gen -- for the sake of non-GHC compilers, I have added definitions -- for coarbitrary here. instance (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where coarbitrary f gen = do xs <- arbitrary coarbitrary (map f xs) gen instance CoArbitrary () where coarbitrary _ = id instance CoArbitrary Bool where coarbitrary False = variant 0 coarbitrary True = variant (-1) instance CoArbitrary a => CoArbitrary (Maybe a) where coarbitrary Nothing = variant 0 coarbitrary (Just x) = variant (-1) . coarbitrary x instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (Either a b) where coarbitrary (Left x) = variant 0 . coarbitrary x coarbitrary (Right y) = variant (-1) . coarbitrary y instance CoArbitrary a => CoArbitrary [a] where coarbitrary [] = variant 0 coarbitrary (x:xs) = variant (-1) . coarbitrary (x,xs) instance (Integral a, CoArbitrary a) => CoArbitrary (Ratio a) where coarbitrary r = coarbitrary (numerator r,denominator r) instance (RealFloat a, CoArbitrary a) => CoArbitrary (Complex a) where coarbitrary (x :+ y) = coarbitrary x >< coarbitrary y instance (CoArbitrary a, CoArbitrary b) => CoArbitrary (a,b) where coarbitrary (x,y) = coarbitrary x >< coarbitrary y instance (CoArbitrary a, CoArbitrary b, CoArbitrary c) => CoArbitrary (a,b,c) where coarbitrary (x,y,z) = coarbitrary x >< coarbitrary y >< coarbitrary z instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d) => CoArbitrary (a,b,c,d) where coarbitrary (x,y,z,v) = coarbitrary x >< coarbitrary y >< coarbitrary z >< coarbitrary v instance (CoArbitrary a, CoArbitrary b, CoArbitrary c, CoArbitrary d, CoArbitrary e) => CoArbitrary (a,b,c,d,e) where coarbitrary (x,y,z,v,w) = coarbitrary x >< coarbitrary y >< coarbitrary z >< coarbitrary v >< coarbitrary w -- typical instance for primitive (numerical) types instance CoArbitrary Integer where coarbitrary = coarbitraryIntegral instance CoArbitrary Int where coarbitrary = coarbitraryIntegral instance CoArbitrary Int8 where coarbitrary = coarbitraryIntegral instance CoArbitrary Int16 where coarbitrary = coarbitraryIntegral instance CoArbitrary Int32 where coarbitrary = coarbitraryIntegral instance CoArbitrary Int64 where coarbitrary = coarbitraryIntegral instance CoArbitrary Word where coarbitrary = coarbitraryIntegral instance CoArbitrary Word8 where coarbitrary = coarbitraryIntegral instance CoArbitrary Word16 where coarbitrary = coarbitraryIntegral instance CoArbitrary Word32 where coarbitrary = coarbitraryIntegral instance CoArbitrary Word64 where coarbitrary = coarbitraryIntegral instance CoArbitrary Char where coarbitrary = coarbitrary . ord instance CoArbitrary Float where coarbitrary = coarbitraryReal instance CoArbitrary Double where coarbitrary = coarbitraryReal -- ** Helpers for implementing coarbitrary -- | A 'coarbitrary' implementation for integral numbers. coarbitraryIntegral :: Integral a => a -> Gen b -> Gen b coarbitraryIntegral = variant -- | A 'coarbitrary' implementation for real numbers. coarbitraryReal :: Real a => a -> Gen b -> Gen b coarbitraryReal x = coarbitrary (toRational x) -- | 'coarbitrary' helper for lazy people :-). coarbitraryShow :: Show a => a -> Gen b -> Gen b coarbitraryShow x = coarbitrary (show x) -------------------------------------------------------------------------- -- ** arbitrary generators -- these are here and not in Gen because of the Arbitrary class constraint -- | Generates a list of a given length. vector :: Arbitrary a => Int -> Gen [a] vector k = vectorOf k arbitrary -- | Generates an ordered list of a given length. orderedList :: (Ord a, Arbitrary a) => Gen [a] orderedList = sort `fmap` arbitrary -------------------------------------------------------------------------- -- the end.