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