← Back to branch summary

~ubuntu-branches/ubuntu/saucy/haskell-quickcheck/saucy-proposed

« back to all changes in this revision

Viewing changes to Test/QuickCheck/Arbitrary.hs

  • Committer: Bazaar Package Importer
  • Author(s): Iain Lane, Iain Lane, Joachim Breitner
  • Date: 2009-12-27 16:21:45 UTC
  • mfrom: (8.1.2 sid)
  • Revision ID: james.westby@ubuntu.com-20091227162145-o5j9zurdrauy3yp3
[ Iain Lane ]
* New upstream release 2.1.0.2
* debian/control:
  + Switch to team maintenance — thanks to Kari Pahula for previous
    maintainership.
  + Add myself to Uploaders.
  + Update Standards-Version to 3.8.3, no changes required. 

[ Joachim Breitner ]
* really add debian/watch file

Show diffs side-by-side

added added

removed removed

Lines of Context:
Test/QuickCheck/Arbitrary.hs
1
 
{-# OPTIONS -fglasgow-exts #-}
2
1
module Test.QuickCheck.Arbitrary
3
2
  ( 
4
3
  -- * Arbitrary and CoArbitrary classes.
12
11
  , arbitraryBoundedRandom   -- :: (Bounded a, Random a) => Gen a
13
12
  -- ** Helper functions for implementing shrink
14
13
  , shrinkNothing            -- :: a -> [a]
 
14
  , shrinkList               -- :: (a -> [a]) -> [a] -> [[a]]
15
15
  , shrinkIntegral           -- :: Integral a => a -> [a]
16
16
  , shrinkRealFrac           -- :: RealFrac a => a -> [a]
17
17
  -- ** Helper functions for implementing coarbitrary
23
23
  -- ** Generators which use arbitrary
24
24
  , vector      -- :: Arbitrary a => Int -> Gen [a]
25
25
  , orderedList -- :: (Ord a, Arbitrary a) => Gen [a]
26
 
 
27
 
  -- ** Type-level modifiers for changing generator behavior
28
 
  , Blind(..)
29
 
  , Fixed(..)
30
 
  , OrderedList(..)
31
 
  , NonEmptyList(..)
32
 
  , Positive(..)
33
 
  , NonZero(..)
34
 
  , NonNegative(..)
35
 
  , Smart(..)
36
 
  , Shrinking(..)
37
 
  , ShrinkState(..)
38
26
  )
39
27
 where
40
28
 
55
43
  ( chr
56
44
  , ord
57
45
  , isLower
 
46
  , isUpper
 
47
  , toLower
 
48
  , isDigit
 
49
  , isSpace
58
50
  )
59
51
 
60
52
import Data.Ratio
123
115
    do k <- choose (0,n)
124
116
       sequence [ arbitrary | _ <- [1..k] ]
125
117
 
126
 
  shrink xs = removeChunks xs
127
 
           ++ shrinkOne xs
 
118
  shrink xs = shrinkList shrink xs
 
119
 
 
120
shrinkList :: (a -> [a]) -> [a] -> [[a]]
 
121
shrinkList shr xs = removeChunks xs ++ shrinkOne xs
 
122
 where
 
123
  removeChunks xs = rem (length xs) xs
128
124
   where
129
 
    removeChunks xs = rem (length xs) xs
 
125
    rem 0 _  = []
 
126
    rem 1 _  = [[]]
 
127
    rem n xs = xs1
 
128
             : xs2
 
129
             : ( [ xs1' ++ xs2 | xs1' <- rem n1 xs1, not (null xs1') ]
 
130
           `ilv` [ xs1 ++ xs2' | xs2' <- rem n2 xs2, not (null xs2') ]
 
131
               )
130
132
     where
131
 
      rem 0 _  = []
132
 
      rem 1 _  = [[]]
133
 
      rem n xs = xs1
134
 
               : xs2
135
 
               : ( [ xs1' ++ xs2 | xs1' <- rem n1 xs1, not (null xs1') ]
136
 
             `ilv` [ xs1 ++ xs2' | xs2' <- rem n2 xs2, not (null xs2') ]
137
 
                 )
138
 
       where
139
 
        n1  = n `div` 2
140
 
        xs1 = take n1 xs
141
 
        n2  = n - n1
142
 
        xs2 = drop n1 xs
143
 
    
144
 
        []     `ilv` ys     = ys
145
 
        xs     `ilv` []     = xs
146
 
        (x:xs) `ilv` (y:ys) = x : y : (xs `ilv` ys)
147
 
    
148
 
    shrinkOne []     = []
149
 
    shrinkOne (x:xs) = [ x':xs | x'  <- shrink x ]
150
 
                    ++ [ x:xs' | xs' <- shrinkOne xs ] 
 
133
      n1  = n `div` 2
 
134
      xs1 = take n1 xs
 
135
      n2  = n - n1
 
136
      xs2 = drop n1 xs
 
137
 
 
138
      []     `ilv` ys     = ys
 
139
      xs     `ilv` []     = xs
 
140
      (x:xs) `ilv` (y:ys) = x : y : (xs `ilv` ys)
 
141
 
 
142
  shrinkOne []     = []
 
143
  shrinkOne (x:xs) = [ x':xs | x'  <- shr x ]
 
144
                  ++ [ x:xs' | xs' <- shrinkOne xs ] 
151
145
 
152
146
{-
153
147
  -- "standard" definition for lists:
212
206
 
213
207
instance Arbitrary Char where
214
208
  arbitrary = chr `fmap` oneof [choose (0,127), choose (0,255)]
215
 
  shrink c  = [ c' | c' <- ['a','b','c'], c' < c || not (isLower c) ]
216
 
 
 
209
  shrink c  = filter (<. c) $ nub
 
210
            $ ['a','b','c']
 
211
           ++ [ toLower c | isUpper c ]
 
212
           ++ ['A','B','C']
 
213
           ++ ['1','2','3']
 
214
           ++ [' ','\n']
 
215
   where
 
216
    a <. b  = stamp a < stamp b
 
217
    stamp a = ( not (isLower a)
 
218
              , not (isUpper a)
 
219
              , not (isDigit a)
 
220
              , not (a==' ')
 
221
              , not (isSpace a)
 
222
              , a
 
223
              )
 
224
    
217
225
instance Arbitrary Float where
218
226
  arbitrary = arbitrarySizedFractional
219
227
  shrink    = shrinkRealFrac
435
443
orderedList = sort `fmap` arbitrary
436
444
 
437
445
--------------------------------------------------------------------------
438
 
 
439
 
 
440
 
{-
441
 
prop_TakeDropWhile (Blind p) (xs :: [A]) =           -- because functions cannot be shown
442
 
  takeWhile p xs ++ dropWhile p xs == xs
443
 
 
444
 
prop_TakeDrop (NonNegative n) (xs :: [A]) =          -- (BTW, also works for negative n)
445
 
  take n xs ++ drop n xs == xs
446
 
 
447
 
prop_Cycle (NonNegative n) (NonEmpty (xs :: [A])) =  -- cycle does not work for empty lists
448
 
  take n (cycle xs) == take n (xs ++ cycle xs)
449
 
 
450
 
prop_Sort (Ordered (xs :: [OrdA])) =                 -- instead of "forAll orderedList"
451
 
  sort xs == xs
452
 
-}
453
 
 
454
 
newtype Blind a = Blind a
455
 
 deriving ( Eq, Ord, Num, Integral, Real, Enum )
456
 
 
457
 
instance Show (Blind a) where
458
 
  show _ = "(*)"
459
 
 
460
 
instance Arbitrary a => Arbitrary (Blind a) where
461
 
  arbitrary = Blind `fmap` arbitrary
462
 
 
463
 
  shrink (Blind x) = [ Blind x' | x' <- shrink x ]
464
 
 
465
 
newtype Fixed a = Fixed a
466
 
 deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )
467
 
 
468
 
instance Arbitrary a => Arbitrary (Fixed a) where
469
 
  arbitrary = Fixed `fmap` arbitrary
470
 
  
471
 
  -- no shrink function
472
 
 
473
 
newtype OrderedList a = Ordered [a]
474
 
 deriving ( Eq, Ord, Show, Read )
475
 
 
476
 
instance (Ord a, Arbitrary a) => Arbitrary (OrderedList a) where
477
 
  arbitrary = Ordered `fmap` orderedList
478
 
 
479
 
  shrink (Ordered xs) =
480
 
    [ Ordered xs'
481
 
    | xs' <- shrink xs
482
 
    , sort xs' == xs'
483
 
    ]
484
 
 
485
 
newtype NonEmptyList a = NonEmpty [a]
486
 
 deriving ( Eq, Ord, Show, Read )
487
 
 
488
 
instance Arbitrary a => Arbitrary (NonEmptyList a) where
489
 
  arbitrary = NonEmpty `fmap` (arbitrary `suchThat` (not . null))
490
 
 
491
 
  shrink (NonEmpty xs) =
492
 
    [ NonEmpty xs'
493
 
    | xs' <- shrink xs
494
 
    , not (null xs')
495
 
    ]
496
 
 
497
 
newtype Positive a = Positive a
498
 
 deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )
499
 
 
500
 
instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where
501
 
  arbitrary =
502
 
    (Positive . abs) `fmap` (arbitrary `suchThat` (/= 0))
503
 
 
504
 
  shrink (Positive x) =
505
 
    [ Positive x'
506
 
    | x' <- shrink x
507
 
    , x' > 0
508
 
    ]
509
 
 
510
 
newtype NonZero a = NonZero a
511
 
 deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )
512
 
 
513
 
instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonZero a) where
514
 
  arbitrary = fmap NonZero $ arbitrary `suchThat` (/= 0)
515
 
 
516
 
  shrink (NonZero x) = [ NonZero x' | x' <- shrink x, x' /= 0 ]
517
 
 
518
 
newtype NonNegative a = NonNegative a
519
 
 deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )
520
 
 
521
 
instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where
522
 
  arbitrary =
523
 
    frequency
524
 
      -- why is this distrbution like this?
525
 
      [ (5, (NonNegative . abs) `fmap` arbitrary)
526
 
      , (1, return 0)
527
 
      ]
528
 
 
529
 
  shrink (NonNegative x) =
530
 
    [ NonNegative x'
531
 
    | x' <- shrink x
532
 
    , x' >= 0
533
 
    ]
534
 
 
535
 
data Smart a =
536
 
  Smart Int a
537
 
 
538
 
instance Show a => Show (Smart a) where
539
 
  showsPrec n (Smart _ x) = showsPrec n x
540
 
 
541
 
instance Arbitrary a => Arbitrary (Smart a) where
542
 
  arbitrary =
543
 
    do x <- arbitrary
544
 
       return (Smart 0 x)
545
 
 
546
 
  shrink (Smart i x) = take i' ys `ilv` drop i' ys
547
 
   where
548
 
    ys = [ Smart i y | (i,y) <- [0..] `zip` shrink x ]
549
 
    i' = 0 `max` (i-2)
550
 
 
551
 
    []     `ilv` bs     = bs
552
 
    as     `ilv` []     = as
553
 
    (a:as) `ilv` (b:bs) = a : b : (as `ilv` bs)
554
 
    
555
 
{-
556
 
  shrink (Smart i x) = part0 ++ part2 ++ part1
557
 
   where
558
 
    ys = [ Smart i y | (i,y) <- [0..] `zip` shrink x ]
559
 
    i' = 0 `max` (i-2)
560
 
    k  = i `div` 10
561
 
    
562
 
    part0 = take k ys
563
 
    part1 = take (i'-k) (drop k ys)
564
 
    part2 = drop i' ys
565
 
-}
566
 
 
567
 
    -- drop a (drop b xs) == drop (a+b) xs           | a,b >= 0
568
 
    -- take a (take b xs) == take (a `min` b) xs
569
 
    -- take a xs ++ drop a xs == xs
570
 
    
571
 
    --    take k ys ++ take (i'-k) (drop k ys) ++ drop i' ys
572
 
    -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys)
573
 
    -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys)
574
 
    -- == take k ys ++ drop k ys
575
 
    -- == ys
576
 
 
577
 
data Shrinking s a =
578
 
  Shrinking s a
579
 
 
580
 
class ShrinkState s a where
581
 
  shrinkInit  :: a -> s
582
 
  shrinkState :: a -> s -> [(a,s)]
583
 
 
584
 
instance Show a => Show (Shrinking s a) where
585
 
  showsPrec n (Shrinking _ x) = showsPrec n x
586
 
 
587
 
instance (Arbitrary a, ShrinkState s a) => Arbitrary (Shrinking s a) where
588
 
  arbitrary =
589
 
    do x <- arbitrary
590
 
       return (Shrinking (shrinkInit x) x)
591
 
 
592
 
  shrink (Shrinking s x) =
593
 
    [ Shrinking s' x'
594
 
    | (x',s') <- shrinkState x s
595
 
    ]
596
 
 
597
 
--------------------------------------------------------------------------
598
446
-- the end.