Debug/QuickCheck.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Debug.QuickCheck
   4 -- Copyright   :  (c) Koen Claessen, John Hughes 2001
   5 -- License     :  BSD-style (see the file libraries/core/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  experimental
   9 -- Portability :  portable
  10 --
  11 -- QuickCheck v.0.2
  12 -- DRAFT implementation; last update 000104.
  13 -- Koen Claessen, John Hughes.
  14 -- This file represents work in progress, and might change at a later date.
  15 --
  16 -----------------------------------------------------------------------------
  17
  18 module Debug.QuickCheck
  19   -- testing functions
  20   ( quickCheck    -- :: prop -> IO ()
  21   , verboseCheck  -- :: prop -> IO ()
  22   , test          -- :: prop -> IO ()  -- = quickCheck
  23
  24   , Config(..)    -- :: *
  25   , check         -- :: Config -> prop -> IO ()
  26
  27   -- property combinators
  28   , forAll        -- :: Gen a -> (a -> prop) -> prop
  29   , (==>)         -- :: Bool -> prop -> prop
  30
  31   -- gathering test-case information
  32   , label         -- :: String         -> prop -> prop
  33   , collect       -- :: Show a => a    -> prop -> prop
  34   , classify      -- :: Bool -> String -> prop -> prop
  35   , trivial       -- :: Bool           -> prop -> prop
  36
  37   -- generator combinators
  38   , Gen           -- :: * -> * ; Functor, Monad
  39
  40   , elements      -- :: [a] -> Gen a
  41   , two           -- :: Gen a -> Gen (a,a)
  42   , three         -- :: Gen a -> Gen (a,a,a)
  43   , four          -- :: Gen a -> Gen (a,a,a,a)
  44
  45   , sized         -- :: (Int -> Gen a) -> Gen a
  46   , resize        -- :: Int -> Gen a -> Gen a
  47   , choose        -- :: Random a => (a, a) -> Gen a
  48   , oneof         -- :: [Gen a] -> Gen a
  49   , frequency     -- :: [(Int, Gen a)] -> Gen a
  50
  51   , vector        -- :: Arbitrary a => Int -> Gen [a]
  52
  53   -- default generators
  54   , Arbitrary(..) -- :: class
  55   , rand          -- :: Gen StdGen
  56   , promote       -- :: (a -> Gen b) -> Gen (a -> b)
  57   , variant       -- :: Int -> Gen a -> Gen a
  58
  59   -- testable
  60   , Testable(..)  -- :: class
  61   , Property      -- :: *
  62
  63   -- For writing your own driver
  64   , Result(..)   -- :: data
  65   , generate     -- :: Int -> StdGen -> Gen a -> a
  66   , evaluate     -- :: Testable a => a -> Gen Result
  67   )
  68  where
  69
  70 import System.Random
  71 import Data.List( group, sort, intersperse )
  72 import Control.Monad( liftM2, liftM3, liftM4 )
  73
  74 infixr 0 ==>
  75 infix  1 `classify`
  76
  77 --------------------------------------------------------------------
  78 -- Generator
  79
  80 newtype Gen a
  81   = Gen (Int -> StdGen -> a)
  82
  83 sized :: (Int -> Gen a) -> Gen a
  84 sized fgen = Gen (\n r -> let Gen m = fgen n in m n r)
  85
  86 resize :: Int -> Gen a -> Gen a
  87 resize n (Gen m) = Gen (\_ r -> m n r)
  88
  89 rand :: Gen StdGen
  90 rand = Gen (\n r -> r)
  91
  92 promote :: (a -> Gen b) -> Gen (a -> b)
  93 promote f = Gen (\n r -> \a -> let Gen m = f a in m n r)
  94
  95 variant :: Int -> Gen a -> Gen a
  96 variant v (Gen m) = Gen (\n r -> m n (rands r !! (v+1)))
  97  where
  98   rands r0 = r1 : rands r2 where (r1, r2) = split r0
  99
 100 generate :: Int -> StdGen -> Gen a -> a
 101 generate n rnd (Gen m) = m size rnd'
 102  where
 103   (size, rnd') = randomR (0, n) rnd
 104
 105 instance Functor Gen where
 106   fmap f m = m >>= return . f
 107
 108 instance Monad Gen where
 109   return a    = Gen (\n r -> a)
 110   Gen m >>= k =
 111     Gen (\n r0 -> let (r1,r2) = split r0
 112                       Gen m'  = k (m n r1)
 113                    in m' n r2)
 114
 115 -- derived
 116
 117 choose :: Random a => (a, a) -> Gen a
 118 choose bounds = (fst . randomR bounds) `fmap` rand
 119
 120 elements :: [a] -> Gen a
 121 elements xs = (xs !!) `fmap` choose (0, length xs - 1)
 122
 123 vector :: Arbitrary a => Int -> Gen [a]
 124 vector n = sequence [ arbitrary | i <- [1..n] ]
 125
 126 oneof :: [Gen a] -> Gen a
 127 oneof gens = elements gens >>= id
 128
 129 frequency :: [(Int, Gen a)] -> Gen a
 130 frequency xs = choose (1, tot) >>= (`pick` xs)
 131  where
 132   tot = sum (map fst xs)
 133
 134   pick n ((k,x):xs)
 135     | n <= k    = x
 136     | otherwise = pick (n-k) xs
 137
 138 -- general monadic
 139
 140 two :: Monad m => m a -> m (a, a)
 141 two m = liftM2 (,) m m
 142
 143 three :: Monad m => m a -> m (a, a, a)
 144 three m = liftM3 (,,) m m m
 145
 146 four :: Monad m => m a -> m (a, a, a, a)
 147 four m = liftM4 (,,,) m m m m
 148
 149 --------------------------------------------------------------------
 150 -- Arbitrary
 151
 152 class Arbitrary a where
 153   arbitrary   :: Gen a
 154   coarbitrary :: a -> Gen b -> Gen b
 155
 156 instance Arbitrary () where
 157   arbitrary     = return ()
 158   coarbitrary _ = variant 0
 159
 160 instance Arbitrary Bool where
 161   arbitrary     = elements [True, False]
 162   coarbitrary b = if b then variant 0 else variant 1
 163
 164 instance Arbitrary Int where
 165   arbitrary     = sized $ \n -> choose (-n,n)
 166   coarbitrary n = variant (if n >= 0 then 2*n else 2*(-n) + 1)
 167
 168 instance Arbitrary Integer where
 169   arbitrary     = sized $ \n -> choose (-fromIntegral n,fromIntegral n)
 170   coarbitrary n = variant (fromInteger (if n >= 0 then 2*n else 2*(-n) + 1))
 171
 172 instance Arbitrary Float where
 173   arbitrary     = liftM3 fraction arbitrary arbitrary arbitrary
 174   coarbitrary x = coarbitrary (decodeFloat x)
 175
 176 instance Arbitrary Double where
 177   arbitrary     = liftM3 fraction arbitrary arbitrary arbitrary
 178   coarbitrary x = coarbitrary (decodeFloat x)
 179
 180 fraction a b c = fromInteger a + (fromInteger b / (abs (fromInteger c) + 1))
 181
 182 instance (Arbitrary a, Arbitrary b) => Arbitrary (a, b) where
 183   arbitrary          = liftM2 (,) arbitrary arbitrary
 184   coarbitrary (a, b) = coarbitrary a . coarbitrary b
 185
 186 instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (a, b, c) where
 187   arbitrary             = liftM3 (,,) arbitrary arbitrary arbitrary
 188   coarbitrary (a, b, c) = coarbitrary a . coarbitrary b . coarbitrary c
 189
 190 instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)
 191       => Arbitrary (a, b, c, d)
 192  where
 193   arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary
 194   coarbitrary (a, b, c, d) =
 195     coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d
 196
 197 instance Arbitrary a => Arbitrary [a] where
 198   arbitrary          = sized (\n -> choose (0,n) >>= vector)
 199   coarbitrary []     = variant 0
 200   coarbitrary (a:as) = coarbitrary a . variant 1 . coarbitrary as
 201
 202 instance (Arbitrary a, Arbitrary b) => Arbitrary (a -> b) where
 203   arbitrary         = promote (`coarbitrary` arbitrary)
 204   coarbitrary f gen = arbitrary >>= ((`coarbitrary` gen) . f)
 205
 206 --------------------------------------------------------------------
 207 -- Testable
 208
 209 data Result
 210   = Result { ok :: Maybe Bool, stamp :: [String], arguments :: [String] }
 211
 212 nothing :: Result
 213 nothing = Result{ ok = Nothing, stamp = [], arguments = [] }
 214
 215 newtype Property
 216   = Prop (Gen Result)
 217
 218 result :: Result -> Property
 219 result res = Prop (return res)
 220
 221 evaluate :: Testable a => a -> Gen Result
 222 evaluate a = gen where Prop gen = property a
 223
 224 class Testable a where
 225   property :: a -> Property
 226
 227 instance Testable () where
 228   property _ = result nothing
 229
 230 instance Testable Bool where
 231   property b = result (nothing{ ok = Just b })
 232
 233 instance Testable Result where
 234   property res = result res
 235
 236 instance Testable Property where
 237   property prop = prop
 238
 239 instance (Arbitrary a, Show a, Testable b) => Testable (a -> b) where
 240   property f = forAll arbitrary f
 241
 242 forAll :: (Show a, Testable b) => Gen a -> (a -> b) -> Property
 243 forAll gen body = Prop $
 244   do a   <- gen
 245      res <- evaluate (body a)
 246      return (argument a res)
 247  where
 248   argument a res = res{ arguments = show a : arguments res }
 249
 250 (==>) :: Testable a => Bool -> a -> Property
 251 True  ==> a = property a
 252 False ==> a = property ()
 253
 254 label :: Testable a => String -> a -> Property
 255 label s a = Prop (add `fmap` evaluate a)
 256  where
 257   add res = res{ stamp = s : stamp res }
 258
 259 classify :: Testable a => Bool -> String -> a -> Property
 260 classify True  name = label name
 261 classify False _    = property
 262
 263 trivial :: Testable a => Bool -> a -> Property
 264 trivial = (`classify` "trivial")
 265
 266 collect :: (Show a, Testable b) => a -> b -> Property
 267 collect v = label (show v)
 268
 269 --------------------------------------------------------------------
 270 -- Testing
 271
 272 data Config = Config
 273   { configMaxTest :: Int
 274   , configMaxFail :: Int
 275   , configSize    :: Int -> Int
 276   , configEvery   :: Int -> [String] -> String
 277   }
 278
 279 quick :: Config
 280 quick = Config
 281   { configMaxTest = 100
 282   , configMaxFail = 1000
 283   , configSize    = (+ 3) . (`div` 2)
 284   , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
 285   }
 286
 287 verbose :: Config
 288 verbose = quick
 289   { configEvery = \n args -> show n ++ ":\n" ++ unlines args
 290   }
 291
 292 test, quickCheck, verboseCheck :: Testable a => a -> IO ()
 293 test         = check quick
 294 quickCheck   = check quick
 295 verboseCheck = check verbose
 296
 297 check :: Testable a => Config -> a -> IO ()
 298 check config a =
 299   do rnd <- newStdGen
 300      tests config (evaluate a) rnd 0 0 []
 301
 302 tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO ()
 303 tests config gen rnd0 ntest nfail stamps
 304   | ntest == configMaxTest config = do done "OK, passed" ntest stamps
 305   | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps
 306   | otherwise               =
 307       do putStr (configEvery config ntest (arguments result))
 308          case ok result of
 309            Nothing    ->
 310              tests config gen rnd1 ntest (nfail+1) stamps
 311            Just True  ->
 312              tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
 313            Just False ->
 314              putStr ( "Falsifiable, after "
 315                    ++ show ntest
 316                    ++ " tests:\n"
 317                    ++ unlines (arguments result)
 318                     )
 319      where
 320       result      = generate (configSize config ntest) rnd2 gen
 321       (rnd1,rnd2) = split rnd0
 322
 323 done :: String -> Int -> [[String]] -> IO ()
 324 done mesg ntest stamps =
 325   do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
 326  where
 327   table = display
 328         . map entry
 329         . reverse
 330         . sort
 331         . map pairLength
 332         . group
 333         . sort
 334         . filter (not . null)
 335         $ stamps
 336
 337   display []  = ".\n"
 338   display [x] = " (" ++ x ++ ").\n"
 339   display xs  = ".\n" ++ unlines (map (++ ".") xs)
 340
 341   pairLength xss@(xs:_) = (length xss, xs)
 342   entry (n, xs)         = percentage n ntest
 343                        ++ " "
 344                        ++ concat (intersperse ", " xs)
 345
 346   percentage n m        = show ((100 * n) `div` m) ++ "%"
 347
 348 --------------------------------------------------------------------
 349 -- the end.