QuickCheck 2.1.0.1 → 2.1.0.2

raw patch · 9 files changed

+548/−338 lines, 9 filesdep ~basenew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• QuickCheck.cabal +12/−5
• Test/QuickCheck.hs +2/−0
• Test/QuickCheck/Arbitrary.hs +46/−213
• Test/QuickCheck/Exception.hs +14/−3
• Test/QuickCheck/Function.hs +218/−101
• Test/QuickCheck/Gen.hs +9/−0
• Test/QuickCheck/Modifiers.hs +232/−0
• Test/QuickCheck/Monadic.hs +1/−2
• Test/QuickCheck/Poly.hs +14/−14

@@ -1,12 +1,12 @@ Name: QuickCheck-Version: 2.1.0.1+Version: 2.1.0.2 Cabal-Version: >= 1.2 Build-type: Simple License: BSD3 License-file: LICENSE Copyright: Koen Claessen <koen@chalmers.se> Author: Koen Claessen <koen@chalmers.se>-Maintainer: Koen Claessen <koen@chalmers.se>+Maintainer: QuickCheck developers <quickcheck@projects.haskell.org> Homepage: http://www.cs.chalmers.se/~koen Category:	    Testing Synopsis:	    Automatic testing of Haskell programs@@ -27,18 +27,25 @@ flag splitBase   Description: Choose the new smaller, split-up base package. +flag extensibleExceptions+  Description: Choose the even newer, even smaller, split-up base package.+ library   Build-depends: mtl-  if flag(splitBase)-    Build-depends: base >= 3, random+  if flag(extensibleExceptions)+    Build-depends: base >= 4 && < 5, random   else-    Build-depends: base < 3+    if flag(splitBase)+      Build-depends: base >= 3 && < 4, random+    else+      Build-depends: base < 3   Exposed-Modules:     Test.QuickCheck,     Test.QuickCheck.Arbitrary,     Test.QuickCheck.Function,     Test.QuickCheck.Gen,     Test.QuickCheck.Monadic,+    Test.QuickCheck.Modifiers,     Test.QuickCheck.Property,     Test.QuickCheck.Test,     Test.QuickCheck.Text,

@@ -60,6 +60,7 @@   , NonZero(..)   , NonNegative(..)   , Smart(..)+  , Shrink2(..)   , Shrinking(..)   , ShrinkState(..) @@ -94,6 +95,7 @@  import Test.QuickCheck.Gen import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Modifiers import Test.QuickCheck.Property hiding ( Result(..) ) import Test.QuickCheck.Test import Test.QuickCheck.Text

@@ -1,4 +1,3 @@-{-# OPTIONS -fglasgow-exts #-} module Test.QuickCheck.Arbitrary   (    -- * Arbitrary and CoArbitrary classes.@@ -12,6 +11,7 @@   , 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@@ -23,18 +23,6 @@   -- ** Generators which use arbitrary   , vector      -- :: Arbitrary a => Int -> Gen [a]   , orderedList -- :: (Ord a, Arbitrary a) => Gen [a]--  -- ** Type-level modifiers for changing generator behavior-  , Blind(..)-  , Fixed(..)-  , OrderedList(..)-  , NonEmptyList(..)-  , Positive(..)-  , NonZero(..)-  , NonNegative(..)-  , Smart(..)-  , Shrinking(..)-  , ShrinkState(..)   )  where @@ -55,6 +43,10 @@   ( chr   , ord   , isLower+  , isUpper+  , toLower+  , isDigit+  , isSpace   )  import Data.Ratio@@ -123,32 +115,34 @@     do k <- choose (0,n)        sequence [ arbitrary | _ <- [1..k] ] -  shrink xs = removeChunks xs-           ++ shrinkOne xs+  shrink xs = shrinkList shrink xs++shrinkList :: (a -> [a]) -> [a] -> [[a]]+shrinkList shr xs = removeChunks xs ++ shrinkOne xs+ where+  removeChunks xs = rem (length xs) xs    where-    removeChunks xs = rem (length xs) xs+    rem 0 _  = []+    rem 1 _  = [[]]+    rem n xs = xs1+             : xs2+             : ( [ xs1' ++ xs2 | xs1' <- rem n1 xs1, not (null xs1') ]+           `ilv` [ xs1 ++ xs2' | xs2' <- rem n2 xs2, not (null xs2') ]+               )      where-      rem 0 _  = []-      rem 1 _  = [[]]-      rem n xs = xs1-               : xs2-               : ( [ xs1' ++ xs2 | xs1' <- rem n1 xs1, not (null xs1') ]-             `ilv` [ xs1 ++ xs2' | xs2' <- rem n2 xs2, not (null xs2') ]-                 )-       where-        n1  = n `div` 2-        xs1 = take n1 xs-        n2  = n - n1-        xs2 = drop n1 xs-    -        []     `ilv` ys     = ys-        xs     `ilv` []     = xs-        (x:xs) `ilv` (y:ys) = x : y : (xs `ilv` ys)-    -    shrinkOne []     = []-    shrinkOne (x:xs) = [ x':xs | x'  <- shrink x ]-                    ++ [ x:xs' | xs' <- shrinkOne xs ] +      n1  = n `div` 2+      xs1 = take n1 xs+      n2  = n - n1+      xs2 = drop n1 xs +      []     `ilv` ys     = ys+      xs     `ilv` []     = xs+      (x:xs) `ilv` (y:ys) = x : y : (xs `ilv` ys)++  shrinkOne []     = []+  shrinkOne (x:xs) = [ x':xs | x'  <- shr x ]+                  ++ [ x:xs' | xs' <- shrinkOne xs ] + {-   -- "standard" definition for lists:   shrink []     = []@@ -212,8 +206,22 @@  instance Arbitrary Char where   arbitrary = chr `fmap` oneof [choose (0,127), choose (0,255)]-  shrink c  = [ c' | c' <- ['a','b','c'], c' < c || not (isLower c) ]-+  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@@ -433,181 +441,6 @@ -- | Generates an ordered list of a given length. orderedList :: (Ord a, Arbitrary a) => Gen [a] orderedList = sort `fmap` arbitrary------------------------------------------------------------------------------- ** arbitrary modifiers---- These datatypes are mainly here to *pattern match* on in properties.--- This is a stylistic alternative to using explicit quantification.--- In other words, they should not be replaced by type synonyms, and their--- constructors should be exported.---- Examples:-{--prop_TakeDropWhile (Blind p) (xs :: [A]) =           -- because functions cannot be shown-  takeWhile p xs ++ dropWhile p xs == xs--prop_TakeDrop (NonNegative n) (xs :: [A]) =          -- (BTW, also works for negative n)-  take n xs ++ drop n xs == xs--prop_Cycle (NonNegative n) (NonEmpty (xs :: [A])) =  -- cycle does not work for empty lists-  take n (cycle xs) == take n (xs ++ cycle xs)--prop_Sort (Ordered (xs :: [OrdA])) =                 -- instead of "forAll orderedList"-  sort xs == xs--}---- | @Blind x@: as x, but x does not have to be in the 'Show' class.-newtype Blind a = Blind a- deriving ( Eq, Ord, Num, Integral, Real, Enum )--instance Show (Blind a) where-  show _ = "(*)"--instance Arbitrary a => Arbitrary (Blind a) where-  arbitrary = Blind `fmap` arbitrary--  shrink (Blind x) = [ Blind x' | x' <- shrink x ]---- | @Fixed x@: as x, but will not be shrunk.-newtype Fixed a = Fixed a- deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )--instance Arbitrary a => Arbitrary (Fixed a) where-  arbitrary = Fixed `fmap` arbitrary-  -  -- no shrink function---- | @Ordered xs@: guarantees that xs is ordered.-newtype OrderedList a = Ordered [a]- deriving ( Eq, Ord, Show, Read )--instance (Ord a, Arbitrary a) => Arbitrary (OrderedList a) where-  arbitrary = Ordered `fmap` orderedList--  shrink (Ordered xs) =-    [ Ordered xs'-    | xs' <- shrink xs-    , sort xs' == xs'-    ]---- | @NonEmpty xs@: guarantees that xs is non-empty.-newtype NonEmptyList a = NonEmpty [a]- deriving ( Eq, Ord, Show, Read )--instance Arbitrary a => Arbitrary (NonEmptyList a) where-  arbitrary = NonEmpty `fmap` (arbitrary `suchThat` (not . null))--  shrink (NonEmpty xs) =-    [ NonEmpty xs'-    | xs' <- shrink xs-    , not (null xs')-    ]---- | @Positive x@: guarantees that @x \> 0@.-newtype Positive a = Positive a- deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )--instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where-  arbitrary =-    (Positive . abs) `fmap` (arbitrary `suchThat` (/= 0))--  shrink (Positive x) =-    [ Positive x'-    | x' <- shrink x-    , x' > 0-    ]---- | @NonZero x@: guarantees that @x \/= 0@.-newtype NonZero a = NonZero a- deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )--instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonZero a) where-  arbitrary = fmap NonZero $ arbitrary `suchThat` (/= 0)--  shrink (NonZero x) = [ NonZero x' | x' <- shrink x, x' /= 0 ]---- | @NonNegative x@: guarantees that @x \>= 0@.-newtype NonNegative a = NonNegative a- deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )--instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where-  arbitrary =-    frequency-      -- why is this distrbution like this?-      [ (5, (NonNegative . abs) `fmap` arbitrary)-      , (1, return 0)-      ]--  shrink (NonNegative x) =-    [ NonNegative x'-    | x' <- shrink x-    , x' >= 0-    ]---- | @Smart _ x@: tries a different order when shrinking.-data Smart a =-  Smart Int a--instance Show a => Show (Smart a) where-  showsPrec n (Smart _ x) = showsPrec n x--instance Arbitrary a => Arbitrary (Smart a) where-  arbitrary =-    do x <- arbitrary-       return (Smart 0 x)--  shrink (Smart i x) = take i' ys `ilv` drop i' ys-   where-    ys = [ Smart i y | (i,y) <- [0..] `zip` shrink x ]-    i' = 0 `max` (i-2)--    []     `ilv` bs     = bs-    as     `ilv` []     = as-    (a:as) `ilv` (b:bs) = a : b : (as `ilv` bs)-    -{--  shrink (Smart i x) = part0 ++ part2 ++ part1-   where-    ys = [ Smart i y | (i,y) <- [0..] `zip` shrink x ]-    i' = 0 `max` (i-2)-    k  = i `div` 10-    -    part0 = take k ys-    part1 = take (i'-k) (drop k ys)-    part2 = drop i' ys--}--    -- drop a (drop b xs) == drop (a+b) xs           | a,b >= 0-    -- take a (take b xs) == take (a `min` b) xs-    -- take a xs ++ drop a xs == xs-    -    --    take k ys ++ take (i'-k) (drop k ys) ++ drop i' ys-    -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys)-    -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys)-    -- == take k ys ++ drop k ys-    -- == ys---- | @Shrinking _ x@: allows for maintaining a state during shrinking.-data Shrinking s a =-  Shrinking s a--class ShrinkState s a where-  shrinkInit  :: a -> s-  shrinkState :: a -> s -> [(a,s)]--instance Show a => Show (Shrinking s a) where-  showsPrec n (Shrinking _ x) = showsPrec n x--instance (Arbitrary a, ShrinkState s a) => Arbitrary (Shrinking s a) where-  arbitrary =-    do x <- arbitrary-       return (Shrinking (shrinkInit x) x)--  shrink (Shrinking s x) =-    [ Shrinking s' x'-    | (x',s') <- shrinkState x s-    ]  -------------------------------------------------------------------------- -- the end.

@@ -1,18 +1,29 @@+{-# LANGUAGE CPP #-} module Test.QuickCheck.Exception where +#if defined(MIN_VERSION_base)+#if !(MIN_VERSION_base(4,0,0))+#define SomeException Exception+#endif+#endif++#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 609)+#define SomeException Exception+#endif+ import Control.Exception   ( evaluate   , try-  , Exception+  , SomeException   )  -------------------------------------------------------------------------- -- try evaluate -tryEvaluate :: a -> IO (Either Exception a)+tryEvaluate :: a -> IO (Either SomeException a) tryEvaluate x = tryEvaluateIO (return x) -tryEvaluateIO :: IO a -> IO (Either Exception a)+tryEvaluateIO :: IO a -> IO (Either SomeException a) tryEvaluateIO m = try (m >>= evaluate) --tryEvaluateIO m = Right `fmap` m 

@@ -1,13 +1,11 @@--- | Uses magic to show and shrink functions.+{-# LANGUAGE TypeOperators, GADTs #-} module Test.QuickCheck.Function-  (-  -- * Magic functions-    Function(..)-  , function-  -  -- * Generating monotonic functions-  , MonotonicFunction(..)-  , StrictlyMonotonicFunction(..)+  ( Fun(..)+  , apply+  , (:->)+  , FunArbitrary(..)+  , funArbitraryMap+  , funArbitraryShow   )  where @@ -17,124 +15,243 @@ import Test.QuickCheck.Gen import Test.QuickCheck.Arbitrary import Test.QuickCheck.Property+import Test.QuickCheck.Poly+import Test.QuickCheck.Modifiers -import Data.IORef-import Data.List+import Data.Char+import Data.Word -import System.IO.Unsafe-  ( unsafePerformIO -- this is used for the magic-  )+--------------------------------------------------------------------------+-- concrete functions +-- the type of possibly partial concrete functions+data a :-> c where+  Pair  :: (a :-> (b :-> c)) -> ((a,b) :-> c)+  (:+:) :: (a :-> c) -> (b :-> c) -> (Either a b :-> c)+  Unit  :: c -> (() :-> c)+  Nil   :: a :-> c+  Table :: Eq a => [(a,c)] -> (a :-> c)+  Map   :: (a -> b) -> (b -> a) -> (b :-> c) -> (a :-> c)++instance Functor ((:->) a) where+  fmap f (Pair p)    = Pair (fmap (fmap f) p)+  fmap f (p:+:q)     = fmap f p :+: fmap f q+  fmap f (Unit c)    = Unit (f c)+  fmap f Nil         = Nil+  fmap f (Table xys) = Table [ (x,f y) | (x,y) <- xys ]+  fmap f (Map g h p) = Map g h (fmap f p)++instance (Show a, Show b) => Show (a:->b) where+  -- only use this on finite functions+  show p =+    "{" ++ (case table p of+             []        -> ""+             (_,c):xcs -> concat [ show x ++ "->" ++ show c ++ ","+                                 | (x,c) <- xcs+                                 ]+                       ++ "_->" ++ show c)+        ++ "}"+   where+    xcs = table p++-- turning a concrete function into an abstract function (with a default result)+abstract :: (a :-> c) -> c -> (a -> c)+abstract (Pair p)    d (x,y) = abstract (fmap (\q -> abstract q d y) p) d x+abstract (p :+: q)   d exy   = either (abstract p d) (abstract q d) exy+abstract (Unit c)    _ _     = c+abstract Nil         d _     = d+abstract (Table xys) d x     = head ([y | (x',y) <- xys, x == x'] ++ [d])+abstract (Map g _ p) d x     = abstract p d (g x)++-- generating a table from a concrete function+table :: (a :-> c) -> [(a,c)]+table (Pair p)    = [ ((x,y),c) | (x,q) <- table p, (y,c) <- table q ]+table (p :+: q)   = [ (Left x, c) | (x,c) <- table p ]+                 ++ [ (Right y,c) | (y,c) <- table q ]+table (Unit c)    = [ ((), c) ]+table Nil         = []+table (Table xys) = xys+table (Map _ h p) = [ (h x, c) | (x,c) <- table p ]+ ----------------------------------------------------------------------------- | Functions from @a@ to @b@ which keep track of arguments--- that they are applied to. This allows showing function tables--- and shrinking functions.-data Function a b = Function (FunctionTable a b) (a -> b)+-- FunArbitrary -newtype FunctionTable a b = MkTable (IORef [(a,b)])+class FunArbitrary a where+  funArbitrary :: Arbitrary c => Gen (a :-> c) -function :: (a -> b) -> Function a b-function f =-  unsafePerformIO $-    do ref <- newIORef []-       return $ Function (MkTable ref) $ \x ->-         unsafePerformIO $-           let y = f x in-             do tab <- readIORef ref-                writeIORef ref ((x,y):tab)-                return y+instance (FunArbitrary a, Arbitrary c) => Arbitrary (a :-> c) where+  arbitrary = funArbitrary+  shrink    = shrinkFun shrink -getFunction :: Function a b -> (a -> b)-getFunction (Function _ f) = f+-- basic instances: pairs, sums, units -getTable :: Function a b -> IO [(a,b)]-getTable (Function (MkTable ref) _) =-  do xys <- readIORef ref-     return (reverse xys)+instance (FunArbitrary a, FunArbitrary b) => FunArbitrary (a,b) where+  funArbitrary =+    do p <- funArbitrary+       return (Pair p) -showTable :: (Show a, Show b) => [(a,b)] -> String-showTable xys =-     "{"-  ++ concat (intersperse ", " (tabulate (reverse xys)))-  ++ "}"- where-  tabulate = map (\((x,y):_) -> x ++ " -> " ++ y)-           . groupBy (\(x1,_) (x2,_) -> x1 == x2)-           . sortBy (\(x1,_) (x2,_) -> x1 `compare` x2)-           . map (\(x,y) -> (show x, show y))+instance (FunArbitrary a, FunArbitrary b) => FunArbitrary (Either a b) where+  funArbitrary =+    do p <- funArbitrary+       q <- funArbitrary+       return (p :+: q) -instance (Show a, Show b) => Show (Function a b) where-  show fun =-    unsafePerformIO $-      do xys <- getTable fun-         return (showTable xys)+instance FunArbitrary () where+  funArbitrary =+    do c <- arbitrary+       return (Unit c) -instance (Eq a, CoArbitrary a, Arbitrary b) => Arbitrary (Function a b) where-  arbitrary =-    function `fmap` arbitrary+instance FunArbitrary Word8 where+  funArbitrary =+    do xys <- sequence [ do y <- arbitrary+                            return (x,y)+                       | x <- [0..255]+                       ]+       return (Table xys) -  shrink fun@(Function _ f) =-    unsafePerformIO $-      do xys <- getTable fun-         return [ function (update x y' f)-                | (x,y) <- xys-                , y' <- shrink y-                ]-     where-      update x' y' f x-        | x == x'   = y'-        | otherwise = f x+-- other instances (using Map) +funArbitraryMap :: (FunArbitrary a, Arbitrary c) => (b -> a) -> (a -> b) -> Gen (b :-> c)+funArbitraryMap g h =+  do p <- funArbitrary+     return (Map g h p)++funArbitraryShow :: (Show a, Read a, Arbitrary c) => Gen (a :-> c)+funArbitraryShow = funArbitraryMap show read++instance FunArbitrary a => FunArbitrary [a] where+  funArbitrary = funArbitraryMap g h+   where+    g []     = Left ()+    g (x:xs) = Right (x,xs)++    h (Left _)       = []+    h (Right (x,xs)) = x:xs++instance FunArbitrary a => FunArbitrary (Maybe a) where+  funArbitrary = funArbitraryMap g h+   where+    g Nothing  = Left ()+    g (Just x) = Right x++    h (Left _)  = Nothing+    h (Right x) = Just x++instance FunArbitrary Bool where+  funArbitrary = funArbitraryMap g h+   where+    g False = Left ()+    g True  = Right ()+    +    h (Left _)  = False+    h (Right _) = True++instance FunArbitrary Integer where+  funArbitrary = funArbitraryMap gInteger hInteger+   where+    gInteger n | n < 0     = Left (gNatural (abs n - 1))+               | otherwise = Right (gNatural n)+    +    hInteger (Left ws)  = -(hNatural ws + 1)+    hInteger (Right ws) = hNatural ws+    +    gNatural 0 = []+    gNatural n = (fromIntegral (n `mod` 256) :: Word8) : gNatural (n `div` 256)+    +    hNatural []     = 0+    hNatural (w:ws) = fromIntegral w + 256 * hNatural ws++instance FunArbitrary Int where+  funArbitrary = funArbitraryMap fromIntegral fromInteger++instance FunArbitrary Char where+  funArbitrary = funArbitraryMap ord' chr'+   where+    ord' c = fromIntegral (ord c) :: Word8+    chr' n = chr (fromIntegral n)++-- poly instances++instance FunArbitrary A where+  funArbitrary = funArbitraryMap unA A++instance FunArbitrary B where+  funArbitrary = funArbitraryMap unB B++instance FunArbitrary C where+  funArbitrary = funArbitraryMap unC C++instance FunArbitrary OrdA where+  funArbitrary = funArbitraryMap unOrdA OrdA++instance FunArbitrary OrdB where+  funArbitrary = funArbitraryMap unOrdB OrdB++instance FunArbitrary OrdC where+  funArbitrary = funArbitraryMap unOrdC OrdC+ ----------------------------------------------------------------------------- monotonicity+-- shrinking --- | Monotonic fun: guarantees that fun is monotonic.-newtype MonotonicFunction = Monotonic (Function Int Int)- deriving ( Show )+shrinkFun :: (c -> [c]) -> (a :-> c) -> [a :-> c]+shrinkFun shr (Pair p) =+  [ pair p' | p' <- shrinkFun (\q -> shrinkFun shr q) p ]+ where+  pair Nil = Nil+  pair p   = Pair p -instance Arbitrary MonotonicFunction where-  arbitrary = Monotonic `fmap` arbMonotonicFunction (\(NonNegative x) -> x)+shrinkFun shr (p :+: q) =+  [ p .+. Nil | not (isNil q) ] +++  [ Nil .+. q | not (isNil p) ] +++  [ p' .+. q  | p' <- shrinkFun shr p ] +++  [ p  .+. q' | q' <- shrinkFun shr q ]+ where+  isNil Nil = True+  isNil _   = False+ +  Nil .+. Nil = Nil+  p   .+. q   = p :+: q --- | StrictlyMonotonic fun: guarantees that fun is strictly monotonic.-newtype StrictlyMonotonicFunction = StrictlyMonotonic (Function Int Int)- deriving ( Show )+shrinkFun shr (Unit c) =+  [ Nil ] +++  [ Unit c' | c' <- shr c ] -instance Arbitrary StrictlyMonotonicFunction where-  arbitrary = StrictlyMonotonic `fmap` arbMonotonicFunction (\(NonZero (NonNegative x)) -> x)+shrinkFun shr (Table xys) =+  [ table xys' | xys' <- shrinkList shrXy xys ]+ where+  shrXy (x,y) = [(x,y') | y' <- shr y]+  +  table []  = Nil+  table xys = Table xys --- helper functions+shrinkFun shr Nil =+  [] -arbMonotonicFunction :: Arbitrary a => (a -> Int) -> Gen (Function Int Int)-arbMonotonicFunction val =-  do ups   <- arbIncSeq-     downs <- arbIncSeq-     y0    <- arbitrary-     return $ function $ \x ->-       case x of-         0             -> y0-         _ | x > 0     -> y0 + (ups !! (x-1))-           | otherwise -> y0 - (downs !! (-x-1))+shrinkFun shr (Map g h p) =+  [ mapp g h p' | p' <- shrinkFun shr p ]  where-  arbIncSeq =-    do as <- sequence [ arbitrary | _ <- [1..] ]-       let sums s (x:xs) = s `seq` (s : sums (val x+s) xs)-       return (tail (sums 0 as))+  mapp g h Nil = Nil+  mapp g h p   = Map g h p  ----------------------------------------------------------------------------- properties+-- the Fun modifier -prop_Monotonic x y (Monotonic (Function _ f)) =-  x <= y ==>-    f x <= f y+data Fun a b = Fun (a :-> b) (a -> b) -prop_StrictlyMonotonic x y (StrictlyMonotonic (Function _ f)) =-  x < y ==>-    f x < f y+fun :: (a :-> b) -> Fun a b+fun p = Fun p (abstract p (snd (head (table p)))) -prop_StrictlyMonotonic_Wrong x y (Monotonic (Function _ f)) =-  expectFailure $-    x < y ==>-      f x < f y+apply :: Fun a b -> (a -> b)+apply (Fun _ f) = f++instance (Show a, Show b) => Show (Fun a b) where+  show (Fun p _) = show p++instance (FunArbitrary a, Arbitrary b) => Arbitrary (Fun a b) where+  arbitrary = fun `fmap` arbitrary++  shrink (Fun p _) =+    [ fun p' | p' <- shrink p, _:_ <- [table p'] ]  -------------------------------------------------------------------------- -- the end.

@@ -12,8 +12,13 @@  import Control.Monad   ( liftM+  , ap   ) +import Control.Applicative+  ( Applicative(..)+  )+ import Control.Monad.Reader()   -- needed for "instance Monad (a ->)"   @@ -30,6 +35,10 @@ instance Functor Gen where   fmap f (MkGen h) =     MkGen (\r n -> f (h r n))++instance Applicative Gen where+  pure  = return+  (<*>) = ap  instance Monad Gen where   return x =

@@ -0,0 +1,232 @@+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}+module Test.QuickCheck.Modifiers+  (+  -- ** Type-level modifiers for changing generator behavior+    Blind(..)+  , Fixed(..)+  , OrderedList(..)+  , NonEmptyList(..)+  , Positive(..)+  , NonZero(..)+  , NonNegative(..)+  , Smart(..)+  , Shrink2(..)+  , Shrinking(..)+  , ShrinkState(..)+  )+ where++--------------------------------------------------------------------------+-- imports++import Test.QuickCheck.Gen+import Test.QuickCheck.Arbitrary++import Data.List+  ( sort+  )++--------------------------------------------------------------------------+-- ** arbitrary modifiers++-- These datatypes are mainly here to *pattern match* on in properties.+-- This is a stylistic alternative to using explicit quantification.+-- In other words, they should not be replaced by type synonyms, and their+-- constructors should be exported.++-- Examples:+{-+prop_TakeDropWhile (Blind p) (xs :: [A]) =           -- because functions cannot be shown+  takeWhile p xs ++ dropWhile p xs == xs++prop_TakeDrop (NonNegative n) (xs :: [A]) =          -- (BTW, also works for negative n)+  take n xs ++ drop n xs == xs++prop_Cycle (NonNegative n) (NonEmpty (xs :: [A])) =  -- cycle does not work for empty lists+  take n (cycle xs) == take n (xs ++ cycle xs)++prop_Sort (Ordered (xs :: [OrdA])) =                 -- instead of "forAll orderedList"+  sort xs == xs+-}++--------------------------------------------------------------------------+-- | @Blind x@: as x, but x does not have to be in the 'Show' class.+newtype Blind a = Blind a+ deriving ( Eq, Ord, Num, Integral, Real, Enum )++instance Show (Blind a) where+  show _ = "(*)"++instance Arbitrary a => Arbitrary (Blind a) where+  arbitrary = Blind `fmap` arbitrary++  shrink (Blind x) = [ Blind x' | x' <- shrink x ]++--------------------------------------------------------------------------+-- | @Fixed x@: as x, but will not be shrunk.+newtype Fixed a = Fixed a+ deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )++instance Arbitrary a => Arbitrary (Fixed a) where+  arbitrary = Fixed `fmap` arbitrary+  +  -- no shrink function++--------------------------------------------------------------------------+-- | @Ordered xs@: guarantees that xs is ordered.+newtype OrderedList a = Ordered [a]+ deriving ( Eq, Ord, Show, Read )++instance (Ord a, Arbitrary a) => Arbitrary (OrderedList a) where+  arbitrary = Ordered `fmap` orderedList++  shrink (Ordered xs) =+    [ Ordered xs'+    | xs' <- shrink xs+    , sort xs' == xs'+    ]++--------------------------------------------------------------------------+-- | @NonEmpty xs@: guarantees that xs is non-empty.+newtype NonEmptyList a = NonEmpty [a]+ deriving ( Eq, Ord, Show, Read )++instance Arbitrary a => Arbitrary (NonEmptyList a) where+  arbitrary = NonEmpty `fmap` (arbitrary `suchThat` (not . null))++  shrink (NonEmpty xs) =+    [ NonEmpty xs'+    | xs' <- shrink xs+    , not (null xs')+    ]++--------------------------------------------------------------------------+-- | @Positive x@: guarantees that @x \> 0@.+newtype Positive a = Positive a+ deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )++instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where+  arbitrary =+    (Positive . abs) `fmap` (arbitrary `suchThat` (/= 0))++  shrink (Positive x) =+    [ Positive x'+    | x' <- shrink x+    , x' > 0+    ]++--------------------------------------------------------------------------+-- | @NonZero x@: guarantees that @x \/= 0@.+newtype NonZero a = NonZero a+ deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )++instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonZero a) where+  arbitrary = fmap NonZero $ arbitrary `suchThat` (/= 0)++  shrink (NonZero x) = [ NonZero x' | x' <- shrink x, x' /= 0 ]++--------------------------------------------------------------------------+-- | @NonNegative x@: guarantees that @x \>= 0@.+newtype NonNegative a = NonNegative a+ deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )++instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where+  arbitrary =+    frequency+      -- why is this distrbution like this?+      [ (5, (NonNegative . abs) `fmap` arbitrary)+      , (1, return 0)+      ]++  shrink (NonNegative x) =+    [ NonNegative x'+    | x' <- shrink x+    , x' >= 0+    ]++--------------------------------------------------------------------------+-- | @Shrink2 x@: allows 2 shrinking steps at the same time when shrinking x+newtype Shrink2 a = Shrink2 a+ deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )++instance Arbitrary a => Arbitrary (Shrink2 a) where+  arbitrary =+    Shrink2 `fmap` arbitrary++  shrink (Shrink2 x) =+    [ Shrink2 y | y <- shrink_x ] +++    [ Shrink2 z+    | y <- shrink_x+    , z <- shrink y+    ]+   where+    shrink_x = shrink x++--------------------------------------------------------------------------+-- | @Smart _ x@: tries a different order when shrinking.+data Smart a =+  Smart Int a++instance Show a => Show (Smart a) where+  showsPrec n (Smart _ x) = showsPrec n x++instance Arbitrary a => Arbitrary (Smart a) where+  arbitrary =+    do x <- arbitrary+       return (Smart 0 x)++  shrink (Smart i x) = take i' ys `ilv` drop i' ys+   where+    ys = [ Smart i y | (i,y) <- [0..] `zip` shrink x ]+    i' = 0 `max` (i-2)++    []     `ilv` bs     = bs+    as     `ilv` []     = as+    (a:as) `ilv` (b:bs) = a : b : (as `ilv` bs)+    +{-+  shrink (Smart i x) = part0 ++ part2 ++ part1+   where+    ys = [ Smart i y | (i,y) <- [0..] `zip` shrink x ]+    i' = 0 `max` (i-2)+    k  = i `div` 10+    +    part0 = take k ys+    part1 = take (i'-k) (drop k ys)+    part2 = drop i' ys+-}++    -- drop a (drop b xs) == drop (a+b) xs           | a,b >= 0+    -- take a (take b xs) == take (a `min` b) xs+    -- take a xs ++ drop a xs == xs+    +    --    take k ys ++ take (i'-k) (drop k ys) ++ drop i' ys+    -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys)+    -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys)+    -- == take k ys ++ drop k ys+    -- == ys++--------------------------------------------------------------------------+-- | @Shrinking _ x@: allows for maintaining a state during shrinking.+data Shrinking s a =+  Shrinking s a++class ShrinkState s a where+  shrinkInit  :: a -> s+  shrinkState :: a -> s -> [(a,s)]++instance Show a => Show (Shrinking s a) where+  showsPrec n (Shrinking _ x) = showsPrec n x++instance (Arbitrary a, ShrinkState s a) => Arbitrary (Shrinking s a) where+  arbitrary =+    do x <- arbitrary+       return (Shrinking (shrinkInit x) x)++  shrink (Shrinking s x) =+    [ Shrinking s' x'+    | (x',s') <- shrinkState x s+    ]++--------------------------------------------------------------------------+-- the end.

@@ -1,5 +1,4 @@-{-# OPTIONS_GHC -fglasgow-exts #-}-+{-# LANGUAGE Rank2Types #-} -- | Allows testing of monadic values. module Test.QuickCheck.Monadic where 

@@ -1,6 +1,6 @@ module Test.QuickCheck.Poly-  ( A, B, C-  , OrdA, OrdB, OrdC+  ( A(..), B(..), C(..)+  , OrdA(..), OrdB(..), OrdC(..)   )  where @@ -21,8 +21,8 @@   showsPrec n (A x) = showsPrec n x  instance Arbitrary A where-  arbitrary    = (A . abs) `fmap` arbitrary-  shrink (A x) = [ A x' | x' <- shrink x, x >= 0 ]+  arbitrary    = (A . (+1) . abs) `fmap` arbitrary+  shrink (A x) = [ A x' | x' <- shrink x, x' > 0 ]  instance CoArbitrary A where   coarbitrary = coarbitrary . unA@@ -36,8 +36,8 @@   showsPrec n (B x) = showsPrec n x  instance Arbitrary B where-  arbitrary    = (B . abs) `fmap` arbitrary-  shrink (B x) = [ B x' | x' <- shrink x, x >= 0 ]+  arbitrary    = (B . (+1) . abs) `fmap` arbitrary+  shrink (B x) = [ B x' | x' <- shrink x, x' > 0 ]  instance CoArbitrary B where   coarbitrary = coarbitrary . unB@@ -51,8 +51,8 @@   showsPrec n (C x) = showsPrec n x  instance Arbitrary C where-  arbitrary    = (C . abs) `fmap` arbitrary-  shrink (C x) = [ C x' | x' <- shrink x, x >= 0 ]+  arbitrary    = (C . (+1) . abs) `fmap` arbitrary+  shrink (C x) = [ C x' | x' <- shrink x, x' > 0 ]  instance CoArbitrary C where   coarbitrary = coarbitrary . unC@@ -69,8 +69,8 @@   showsPrec n (OrdA x) = showsPrec n x  instance Arbitrary OrdA where-  arbitrary       = (OrdA . abs) `fmap` arbitrary-  shrink (OrdA x) = [ OrdA x' | x' <- shrink x, x >= 0 ]+  arbitrary       = (OrdA . (+1) . abs) `fmap` arbitrary+  shrink (OrdA x) = [ OrdA x' | x' <- shrink x, x' > 0 ]  instance CoArbitrary OrdA where   coarbitrary = coarbitrary . unOrdA@@ -84,8 +84,8 @@   showsPrec n (OrdB x) = showsPrec n x  instance Arbitrary OrdB where-  arbitrary       = (OrdB . abs) `fmap` arbitrary-  shrink (OrdB x) = [ OrdB x' | x' <- shrink x, x >= 0 ]+  arbitrary       = (OrdB . (+1) . abs) `fmap` arbitrary+  shrink (OrdB x) = [ OrdB x' | x' <- shrink x, x' > 0 ]  instance CoArbitrary OrdB where   coarbitrary = coarbitrary . unOrdB@@ -99,8 +99,8 @@   showsPrec n (OrdC x) = showsPrec n x  instance Arbitrary OrdC where-  arbitrary       = (OrdC . abs) `fmap` arbitrary-  shrink (OrdC x) = [ OrdC x' | x' <- shrink x, x >= 0 ]+  arbitrary       = (OrdC . (+1) . abs) `fmap` arbitrary+  shrink (OrdC x) = [ OrdC x' | x' <- shrink x, x' > 0 ]  instance CoArbitrary OrdC where   coarbitrary = coarbitrary . unOrdC