1{-# LANGUAGE CPP #-} 2#ifndef NO_SAFE_HASKELL 3{-# LANGUAGE Trustworthy #-} 4#endif 5#ifndef NO_MULTI_PARAM_TYPE_CLASSES 6{-# LANGUAGE MultiParamTypeClasses #-} 7#endif 8#ifndef NO_NEWTYPE_DERIVING 9{-# LANGUAGE GeneralizedNewtypeDeriving #-} 10#endif 11#ifndef NO_TYPEABLE 12{-# LANGUAGE DeriveDataTypeable #-} 13#endif 14-- | Modifiers for test data. 15-- 16-- These types do things such as restricting the kind of test data that can be generated. 17-- They can be pattern-matched on in properties as a stylistic 18-- alternative to using explicit quantification. 19-- 20-- __Note__: the contents of this module are re-exported by 21-- "Test.QuickCheck". You do not need to import it directly. 22-- 23-- Examples: 24-- 25-- @ 26-- -- Functions cannot be shown (but see "Test.QuickCheck.Function") 27-- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) = 28-- takeWhile p xs ++ dropWhile p xs == xs 29-- @ 30-- 31-- @ 32-- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) = 33-- take n xs ++ drop n xs == xs 34-- @ 35-- 36-- @ 37-- -- cycle does not work for empty lists 38-- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) = 39-- take n (cycle xs) == take n (xs ++ cycle xs) 40-- @ 41-- 42-- @ 43-- -- Instead of 'forAll' 'orderedList' 44-- prop_Sort ('Ordered' (xs :: ['OrdA'])) = 45-- sort xs == xs 46-- @ 47module Test.QuickCheck.Modifiers 48 ( 49 -- ** Type-level modifiers for changing generator behavior 50 Blind(..) 51 , Fixed(..) 52 , OrderedList(..) 53 , NonEmptyList(..) 54 , InfiniteList(..) 55 , SortedList(..) 56 , Positive(..) 57 , Negative(..) 58 , NonZero(..) 59 , NonNegative(..) 60 , NonPositive(..) 61 , Large(..) 62 , Small(..) 63 , Smart(..) 64 , Shrink2(..) 65#ifndef NO_MULTI_PARAM_TYPE_CLASSES 66 , Shrinking(..) 67 , ShrinkState(..) 68#endif 69 , ASCIIString(..) 70 , UnicodeString(..) 71 , PrintableString(..) 72 ) 73 where 74 75-------------------------------------------------------------------------- 76-- imports 77 78import Test.QuickCheck.Gen 79import Test.QuickCheck.Arbitrary 80import Test.QuickCheck.Exception 81 82import Data.List 83 ( sort 84 ) 85import Data.Ix (Ix) 86 87#ifndef NO_TYPEABLE 88import Data.Typeable (Typeable) 89#endif 90 91-------------------------------------------------------------------------- 92-- | @Blind x@: as x, but x does not have to be in the 'Show' class. 93newtype Blind a = Blind {getBlind :: a} 94 deriving ( Eq, Ord 95#ifndef NO_NEWTYPE_DERIVING 96 , Num, Integral, Real, Enum 97#endif 98#ifndef NO_TYPEABLE 99 , Typeable 100#endif 101 ) 102 103instance Functor Blind where 104 fmap f (Blind x) = Blind (f x) 105 106instance Show (Blind a) where 107 show _ = "(*)" 108 109instance Arbitrary a => Arbitrary (Blind a) where 110 arbitrary = Blind `fmap` arbitrary 111 112 shrink (Blind x) = [ Blind x' | x' <- shrink x ] 113 114-------------------------------------------------------------------------- 115-- | @Fixed x@: as x, but will not be shrunk. 116newtype Fixed a = Fixed {getFixed :: a} 117 deriving ( Eq, Ord, Show, Read 118#ifndef NO_NEWTYPE_DERIVING 119 , Num, Integral, Real, Enum 120#endif 121#ifndef NO_TYPEABLE 122 , Typeable 123#endif 124 ) 125 126instance Functor Fixed where 127 fmap f (Fixed x) = Fixed (f x) 128 129instance Arbitrary a => Arbitrary (Fixed a) where 130 arbitrary = Fixed `fmap` arbitrary 131 132 -- no shrink function 133 134-------------------------------------------------------------------------- 135-- | @Ordered xs@: guarantees that xs is ordered. 136newtype OrderedList a = Ordered {getOrdered :: [a]} 137 deriving ( Eq, Ord, Show, Read 138#ifndef NO_TYPEABLE 139 , Typeable 140#endif 141 ) 142 143instance Functor OrderedList where 144 fmap f (Ordered x) = Ordered (map f x) 145 146instance (Ord a, Arbitrary a) => Arbitrary (OrderedList a) where 147 arbitrary = Ordered `fmap` orderedList 148 149 shrink (Ordered xs) = 150 [ Ordered xs' 151 | xs' <- shrink xs 152 , sort xs' == xs' 153 ] 154 155-------------------------------------------------------------------------- 156-- | @NonEmpty xs@: guarantees that xs is non-empty. 157newtype NonEmptyList a = NonEmpty {getNonEmpty :: [a]} 158 deriving ( Eq, Ord, Show, Read 159#ifndef NO_TYPEABLE 160 , Typeable 161#endif 162 ) 163 164instance Functor NonEmptyList where 165 fmap f (NonEmpty x) = NonEmpty (map f x) 166 167instance Arbitrary a => Arbitrary (NonEmptyList a) where 168 arbitrary = NonEmpty `fmap` (arbitrary `suchThat` (not . null)) 169 170 shrink (NonEmpty xs) = 171 [ NonEmpty xs' 172 | xs' <- shrink xs 173 , not (null xs') 174 ] 175 176---------------------------------------------------------------------- 177-- | @InfiniteList xs _@: guarantees that xs is an infinite list. 178-- When a counterexample is found, only prints the prefix of xs 179-- that was used by the program. 180-- 181-- Here is a contrived example property: 182-- 183-- > prop_take_10 :: InfiniteList Char -> Bool 184-- > prop_take_10 (InfiniteList xs _) = 185-- > or [ x == 'a' | x <- take 10 xs ] 186-- 187-- In the following counterexample, the list must start with @"bbbbbbbbbb"@ but 188-- the remaining (infinite) part can contain anything: 189-- 190-- >>> quickCheck prop_take_10 191-- *** Failed! Falsified (after 1 test and 14 shrinks): 192-- "bbbbbbbbbb" ++ ... 193data InfiniteList a = 194 InfiniteList { 195 getInfiniteList :: [a], 196 infiniteListInternalData :: InfiniteListInternalData a } 197 198-- Uses a similar trick to Test.QuickCheck.Function: 199-- the Arbitrary instance generates an infinite list, which is 200-- reduced to a finite prefix by shrinking. We use discard to 201-- check that nothing coming after the finite prefix is used 202-- (see infiniteListFromData). 203data InfiniteListInternalData a = Infinite [a] | FinitePrefix [a] 204 205infiniteListFromData :: InfiniteListInternalData a -> InfiniteList a 206infiniteListFromData info@(Infinite xs) = InfiniteList xs info 207infiniteListFromData info@(FinitePrefix xs) = 208 InfiniteList (xs ++ discard) info 209 210instance Show a => Show (InfiniteList a) where 211 showsPrec _ (InfiniteList _ (Infinite _)) = 212 ("<infinite list>" ++) 213 showsPrec n (InfiniteList _ (FinitePrefix xs)) = 214 (if n > 10 then ('(':) else id) . 215 showsPrec 0 xs . 216 (" ++ ..." ++) . 217 (if n > 10 then (')':) else id) 218 219instance Arbitrary a => Arbitrary (InfiniteList a) where 220 arbitrary = fmap infiniteListFromData arbitrary 221 shrink (InfiniteList _ info) = 222 map infiniteListFromData (shrink info) 223 224instance Arbitrary a => Arbitrary (InfiniteListInternalData a) where 225 arbitrary = fmap Infinite infiniteList 226 shrink (Infinite xs) = 227 [FinitePrefix (take n xs) | n <- map (2^) [0..]] 228 shrink (FinitePrefix xs) = 229 map FinitePrefix (shrink xs) 230 231-------------------------------------------------------------------------- 232-- | @Sorted xs@: guarantees that xs is sorted. 233newtype SortedList a = Sorted {getSorted :: [a]} 234 deriving ( Eq, Ord, Show, Read 235#ifndef NO_TYPEABLE 236 , Typeable 237#endif 238 ) 239 240instance Functor SortedList where 241 fmap f (Sorted x) = Sorted (map f x) 242 243instance (Arbitrary a, Ord a) => Arbitrary (SortedList a) where 244 arbitrary = fmap (Sorted . sort) arbitrary 245 246 shrink (Sorted xs) = 247 [ Sorted xs' 248 | xs' <- map sort (shrink xs) 249 ] 250 251-------------------------------------------------------------------------- 252-- | @Positive x@: guarantees that @x \> 0@. 253newtype Positive a = Positive {getPositive :: a} 254 deriving ( Eq, Ord, Show, Read 255#ifndef NO_NEWTYPE_DERIVING 256 , Enum 257#endif 258#ifndef NO_TYPEABLE 259 , Typeable 260#endif 261 ) 262 263instance Functor Positive where 264 fmap f (Positive x) = Positive (f x) 265 266instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where 267 arbitrary = fmap Positive (fmap abs arbitrary `suchThat` (> 0)) 268 shrink (Positive x) = [ Positive x' | x' <- shrink x , x' > 0 ] 269 270-------------------------------------------------------------------------- 271-- | @Negative x@: guarantees that @x \< 0@. 272newtype Negative a = Negative {getNegative :: a} 273 deriving ( Eq, Ord, Show, Read 274#ifndef NO_NEWTYPE_DERIVING 275 , Enum 276#endif 277#ifndef NO_TYPEABLE 278 , Typeable 279#endif 280 ) 281 282instance Functor Negative where 283 fmap f (Negative x) = Negative (f x) 284 285instance (Num a, Ord a, Arbitrary a) => Arbitrary (Negative a) where 286 arbitrary = fmap Negative (arbitrary `suchThat` (< 0)) 287 shrink (Negative x) = [ Negative x' | x' <- shrink x , x' < 0 ] 288 289-------------------------------------------------------------------------- 290-- | @NonZero x@: guarantees that @x \/= 0@. 291newtype NonZero a = NonZero {getNonZero :: a} 292 deriving ( Eq, Ord, Show, Read 293#ifndef NO_NEWTYPE_DERIVING 294 , Enum 295#endif 296#ifndef NO_TYPEABLE 297 , Typeable 298#endif 299 ) 300 301instance Functor NonZero where 302 fmap f (NonZero x) = NonZero (f x) 303 304instance (Num a, Eq a, Arbitrary a) => Arbitrary (NonZero a) where 305 arbitrary = fmap NonZero $ arbitrary `suchThat` (/= 0) 306 307 shrink (NonZero x) = [ NonZero x' | x' <- shrink x, x' /= 0 ] 308 309-------------------------------------------------------------------------- 310-- | @NonNegative x@: guarantees that @x \>= 0@. 311newtype NonNegative a = NonNegative {getNonNegative :: a} 312 deriving ( Eq, Ord, Show, Read 313#ifndef NO_NEWTYPE_DERIVING 314 , Enum 315#endif 316#ifndef NO_TYPEABLE 317 , Typeable 318#endif 319 ) 320 321instance Functor NonNegative where 322 fmap f (NonNegative x) = NonNegative (f x) 323 324instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where 325 arbitrary = fmap NonNegative (fmap abs arbitrary `suchThat` (>= 0)) 326 shrink (NonNegative x) = [ NonNegative x' | x' <- shrink x , x' >= 0 ] 327 328-------------------------------------------------------------------------- 329-- | @NonPositive x@: guarantees that @x \<= 0@. 330newtype NonPositive a = NonPositive {getNonPositive :: a} 331 deriving ( Eq, Ord, Show, Read 332#ifndef NO_NEWTYPE_DERIVING 333 , Enum 334#endif 335#ifndef NO_TYPEABLE 336 , Typeable 337#endif 338 ) 339 340instance Functor NonPositive where 341 fmap f (NonPositive x) = NonPositive (f x) 342 343instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonPositive a) where 344 arbitrary = fmap NonPositive (arbitrary `suchThat` (<= 0)) 345 shrink (NonPositive x) = [ NonPositive x' | x' <- shrink x , x' <= 0 ] 346 347-------------------------------------------------------------------------- 348-- | @Large x@: by default, QuickCheck generates 'Int's drawn from a small 349-- range. @Large Int@ gives you values drawn from the entire range instead. 350newtype Large a = Large {getLarge :: a} 351 deriving ( Eq, Ord, Show, Read 352#ifndef NO_NEWTYPE_DERIVING 353 , Num, Integral, Real, Enum, Ix 354#endif 355#ifndef NO_TYPEABLE 356 , Typeable 357#endif 358 ) 359 360instance Functor Large where 361 fmap f (Large x) = Large (f x) 362 363instance (Integral a, Bounded a) => Arbitrary (Large a) where 364 arbitrary = fmap Large arbitrarySizedBoundedIntegral 365 shrink (Large x) = fmap Large (shrinkIntegral x) 366 367-------------------------------------------------------------------------- 368-- | @Small x@: generates values of @x@ drawn from a small range. 369-- The opposite of 'Large'. 370newtype Small a = Small {getSmall :: a} 371 deriving ( Eq, Ord, Show, Read 372#ifndef NO_NEWTYPE_DERIVING 373 , Num, Integral, Real, Enum, Ix 374#endif 375#ifndef NO_TYPEABLE 376 , Typeable 377#endif 378 ) 379 380instance Functor Small where 381 fmap f (Small x) = Small (f x) 382 383instance Integral a => Arbitrary (Small a) where 384 arbitrary = fmap Small arbitrarySizedIntegral 385 shrink (Small x) = map Small (shrinkIntegral x) 386 387-------------------------------------------------------------------------- 388-- | @Shrink2 x@: allows 2 shrinking steps at the same time when shrinking x 389newtype Shrink2 a = Shrink2 {getShrink2 :: a} 390 deriving ( Eq, Ord, Show, Read 391#ifndef NO_NEWTYPE_DERIVING 392 , Num, Integral, Real, Enum 393#endif 394#ifndef NO_TYPEABLE 395 , Typeable 396#endif 397 ) 398 399instance Functor Shrink2 where 400 fmap f (Shrink2 x) = Shrink2 (f x) 401 402instance Arbitrary a => Arbitrary (Shrink2 a) where 403 arbitrary = 404 Shrink2 `fmap` arbitrary 405 406 shrink (Shrink2 x) = 407 [ Shrink2 y | y <- shrink_x ] ++ 408 [ Shrink2 z 409 | y <- shrink_x 410 , z <- shrink y 411 ] 412 where 413 shrink_x = shrink x 414 415-------------------------------------------------------------------------- 416-- | @Smart _ x@: tries a different order when shrinking. 417data Smart a = 418 Smart Int a 419 420instance Functor Smart where 421 fmap f (Smart n x) = Smart n (f x) 422 423instance Show a => Show (Smart a) where 424 showsPrec n (Smart _ x) = showsPrec n x 425 426instance Arbitrary a => Arbitrary (Smart a) where 427 arbitrary = 428 do x <- arbitrary 429 return (Smart 0 x) 430 431 shrink (Smart i x) = take i' ys `ilv` drop i' ys 432 where 433 ys = [ Smart j y | (j,y) <- [0..] `zip` shrink x ] 434 i' = 0 `max` (i-2) 435 436 [] `ilv` bs = bs 437 as `ilv` [] = as 438 (a:as) `ilv` (b:bs) = a : b : (as `ilv` bs) 439 440{- 441 shrink (Smart i x) = part0 ++ part2 ++ part1 442 where 443 ys = [ Smart i y | (i,y) <- [0..] `zip` shrink x ] 444 i' = 0 `max` (i-2) 445 k = i `div` 10 446 447 part0 = take k ys 448 part1 = take (i'-k) (drop k ys) 449 part2 = drop i' ys 450-} 451 452 -- drop a (drop b xs) == drop (a+b) xs | a,b >= 0 453 -- take a (take b xs) == take (a `min` b) xs 454 -- take a xs ++ drop a xs == xs 455 456 -- take k ys ++ take (i'-k) (drop k ys) ++ drop i' ys 457 -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys) 458 -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys) 459 -- == take k ys ++ drop k ys 460 -- == ys 461 462#ifndef NO_MULTI_PARAM_TYPE_CLASSES 463-------------------------------------------------------------------------- 464-- | @Shrinking _ x@: allows for maintaining a state during shrinking. 465data Shrinking s a = 466 Shrinking s a 467 468class ShrinkState s a where 469 shrinkInit :: a -> s 470 shrinkState :: a -> s -> [(a,s)] 471 472instance Functor (Shrinking s) where 473 fmap f (Shrinking s x) = Shrinking s (f x) 474 475instance Show a => Show (Shrinking s a) where 476 showsPrec n (Shrinking _ x) = showsPrec n x 477 478instance (Arbitrary a, ShrinkState s a) => Arbitrary (Shrinking s a) where 479 arbitrary = 480 do x <- arbitrary 481 return (Shrinking (shrinkInit x) x) 482 483 shrink (Shrinking s x) = 484 [ Shrinking s' x' 485 | (x',s') <- shrinkState x s 486 ] 487 488#endif /* NO_MULTI_PARAM_TYPE_CLASSES */ 489 490-------------------------------------------------------------------------- 491-- | @ASCIIString@: generates an ASCII string. 492newtype ASCIIString = ASCIIString {getASCIIString :: String} 493 deriving ( Eq, Ord, Show, Read 494#ifndef NO_TYPEABLE 495 , Typeable 496#endif 497 ) 498 499instance Arbitrary ASCIIString where 500 arbitrary = ASCIIString `fmap` listOf arbitraryASCIIChar 501 shrink (ASCIIString xs) = ASCIIString `fmap` shrink xs 502 503-------------------------------------------------------------------------- 504-- | @UnicodeString@: generates a unicode String. 505-- The string will not contain surrogate pairs. 506newtype UnicodeString = UnicodeString {getUnicodeString :: String} 507 deriving ( Eq, Ord, Show, Read 508#ifndef NO_TYPEABLE 509 , Typeable 510#endif 511 ) 512 513instance Arbitrary UnicodeString where 514 arbitrary = UnicodeString `fmap` listOf arbitraryUnicodeChar 515 shrink (UnicodeString xs) = UnicodeString `fmap` shrink xs 516 517-------------------------------------------------------------------------- 518-- | @PrintableString@: generates a printable unicode String. 519-- The string will not contain surrogate pairs. 520newtype PrintableString = PrintableString {getPrintableString :: String} 521 deriving ( Eq, Ord, Show, Read 522#ifndef NO_TYPEABLE 523 , Typeable 524#endif 525 ) 526 527instance Arbitrary PrintableString where 528 arbitrary = PrintableString `fmap` listOf arbitraryPrintableChar 529 shrink (PrintableString xs) = PrintableString `fmap` shrink xs 530 531-- the end. 532