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 Prelude
  71
  72 import System.Random
  73 import Data.List( group, sort, intersperse )
  74 import Control.Monad( liftM2, liftM3, liftM4 )
  75
  76 infixr 0 ==>
  77 infix  1 `classify`
  78
  79 --------------------------------------------------------------------
  80 -- Generator
  81
  82 newtype Gen a
  83   = Gen (Int -> StdGen -> a)
  84
  85 sized :: (Int -> Gen a) -> Gen a
  86 sized fgen = Gen (\n r -> let Gen m = fgen n in m n r)
  87
  88 resize :: Int -> Gen a -> Gen a
  89 resize n (Gen m) = Gen (\_ r -> m n r)
  90
  91 rand :: Gen StdGen
  92 rand = Gen (\n r -> r)
  93
  94 promote :: (a -> Gen b) -> Gen (a -> b)
  95 promote f = Gen (\n r -> \a -> let Gen m = f a in m n r)
  96
  97 variant :: Int -> Gen a -> Gen a
  98 variant v (Gen m) = Gen (\n r -> m n (rands r !! (v+1)))
  99  where
 100   rands r0 = r1 : rands r2 where (r1, r2) = split r0
 101
 102 generate :: Int -> StdGen -> Gen a -> a
 103 generate n rnd (Gen m) = m size rnd'
 104  where
 105   (size, rnd') = randomR (0, n) rnd
 106
 107 instance Functor Gen where
 108   fmap f m = m >>= return . f
 109
 110 instance Monad Gen where
 111   return a    = Gen (\n r -> a)
 112   Gen m >>= k =
 113     Gen (\n r0 -> let (r1,r2) = split r0
 114                       Gen m'  = k (m n r1)
 115                    in m' n r2)
 116
 117 -- derived
 118
 119 choose :: Random a => (a, a) -> Gen a
 120 choose bounds = (fst . randomR bounds) `fmap` rand
 121
 122 elements :: [a] -> Gen a
 123 elements xs = (xs !!) `fmap` choose (0, length xs - 1)
 124
 125 vector :: Arbitrary a => Int -> Gen [a]
 126 vector n = sequence [ arbitrary | i <- [1..n] ]
 127
 128 oneof :: [Gen a] -> Gen a
 129 oneof gens = elements gens >>= id
 130
 131 frequency :: [(Int, Gen a)] -> Gen a
 132 frequency xs = choose (1, tot) >>= (`pick` xs)
 133  where
 134   tot = sum (map fst xs)
 135
 136   pick n ((k,x):xs)
 137     | n <= k    = x
 138     | otherwise = pick (n-k) xs
 139
 140 -- general monadic
 141
 142 two :: Monad m => m a -> m (a, a)
 143 two m = liftM2 (,) m m
 144
 145 three :: Monad m => m a -> m (a, a, a)
 146 three m = liftM3 (,,) m m m
 147
 148 four :: Monad m => m a -> m (a, a, a, a)
 149 four m = liftM4 (,,,) m m m m
 150
 151 --------------------------------------------------------------------
 152 -- Arbitrary
 153
 154 class Arbitrary a where
 155   arbitrary   :: Gen a
 156   coarbitrary :: a -> Gen b -> Gen b
 157
 158 instance Arbitrary () where
 159   arbitrary     = return ()
 160   coarbitrary _ = variant 0
 161
 162 instance Arbitrary Bool where
 163   arbitrary     = elements [True, False]
 164   coarbitrary b = if b then variant 0 else variant 1
 165
 166 instance Arbitrary Int where
 167   arbitrary     = sized $ \n -> choose (-n,n)
 168   coarbitrary n = variant (if n >= 0 then 2*n else 2*(-n) + 1)
 169
 170 instance Arbitrary Integer where
 171   arbitrary     = sized $ \n -> choose (-fromIntegral n,fromIntegral n)
 172   coarbitrary n = variant (fromInteger (if n >= 0 then 2*n else 2*(-n) + 1))
 173
 174 instance Arbitrary Float where
 175   arbitrary     = liftM3 fraction arbitrary arbitrary arbitrary
 176   coarbitrary x = coarbitrary (decodeFloat x)
 177
 178 instance Arbitrary Double where
 179   arbitrary     = liftM3 fraction arbitrary arbitrary arbitrary
 180   coarbitrary x = coarbitrary (decodeFloat x)
 181
 182 fraction a b c = fromInteger a + (fromInteger b / (abs (fromInteger c) + 1))
 183
 184 instance (Arbitrary a, Arbitrary b) => Arbitrary (a, b) where
 185   arbitrary          = liftM2 (,) arbitrary arbitrary
 186   coarbitrary (a, b) = coarbitrary a . coarbitrary b
 187
 188 instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (a, b, c) where
 189   arbitrary             = liftM3 (,,) arbitrary arbitrary arbitrary
 190   coarbitrary (a, b, c) = coarbitrary a . coarbitrary b . coarbitrary c
 191
 192 instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)
 193       => Arbitrary (a, b, c, d)
 194  where
 195   arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary
 196   coarbitrary (a, b, c, d) =
 197     coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d
 198
 199 instance Arbitrary a => Arbitrary [a] where
 200   arbitrary          = sized (\n -> choose (0,n) >>= vector)
 201   coarbitrary []     = variant 0
 202   coarbitrary (a:as) = coarbitrary a . variant 1 . coarbitrary as
 203
 204 instance (Arbitrary a, Arbitrary b) => Arbitrary (a -> b) where
 205   arbitrary         = promote (`coarbitrary` arbitrary)
 206   coarbitrary f gen = arbitrary >>= ((`coarbitrary` gen) . f)
 207
 208 --------------------------------------------------------------------
 209 -- Testable
 210
 211 data Result
 212   = Result { ok :: Maybe Bool, stamp :: [String], arguments :: [String] }
 213
 214 nothing :: Result
 215 nothing = Result{ ok = Nothing, stamp = [], arguments = [] }
 216
 217 newtype Property
 218   = Prop (Gen Result)
 219
 220 result :: Result -> Property
 221 result res = Prop (return res)
 222
 223 evaluate :: Testable a => a -> Gen Result
 224 evaluate a = gen where Prop gen = property a
 225
 226 class Testable a where
 227   property :: a -> Property
 228
 229 instance Testable () where
 230   property _ = result nothing
 231
 232 instance Testable Bool where
 233   property b = result (nothing{ ok = Just b })
 234
 235 instance Testable Result where
 236   property res = result res
 237
 238 instance Testable Property where
 239   property prop = prop
 240
 241 instance (Arbitrary a, Show a, Testable b) => Testable (a -> b) where
 242   property f = forAll arbitrary f
 243
 244 forAll :: (Show a, Testable b) => Gen a -> (a -> b) -> Property
 245 forAll gen body = Prop $
 246   do a   <- gen
 247      res <- evaluate (body a)
 248      return (argument a res)
 249  where
 250   argument a res = res{ arguments = show a : arguments res }
 251
 252 (==>) :: Testable a => Bool -> a -> Property
 253 True  ==> a = property a
 254 False ==> a = property ()
 255
 256 label :: Testable a => String -> a -> Property
 257 label s a = Prop (add `fmap` evaluate a)
 258  where
 259   add res = res{ stamp = s : stamp res }
 260
 261 classify :: Testable a => Bool -> String -> a -> Property
 262 classify True  name = label name
 263 classify False _    = property
 264
 265 trivial :: Testable a => Bool -> a -> Property
 266 trivial = (`classify` "trivial")
 267
 268 collect :: (Show a, Testable b) => a -> b -> Property
 269 collect v = label (show v)
 270
 271 --------------------------------------------------------------------
 272 -- Testing
 273
 274 data Config = Config
 275   { configMaxTest :: Int
 276   , configMaxFail :: Int
 277   , configSize    :: Int -> Int
 278   , configEvery   :: Int -> [String] -> String
 279   }
 280
 281 quick :: Config
 282 quick = Config
 283   { configMaxTest = 100
 284   , configMaxFail = 1000
 285   , configSize    = (+ 3) . (`div` 2)
 286   , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
 287   }
 288
 289 verbose :: Config
 290 verbose = quick
 291   { configEvery = \n args -> show n ++ ":\n" ++ unlines args
 292   }
 293
 294 test, quickCheck, verboseCheck :: Testable a => a -> IO ()
 295 test         = check quick
 296 quickCheck   = check quick
 297 verboseCheck = check verbose
 298
 299 check :: Testable a => Config -> a -> IO ()
 300 check config a =
 301   do rnd <- newStdGen
 302      tests config (evaluate a) rnd 0 0 []
 303
 304 tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO ()
 305 tests config gen rnd0 ntest nfail stamps
 306   | ntest == configMaxTest config = do done "OK, passed" ntest stamps
 307   | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps
 308   | otherwise               =
 309       do putStr (configEvery config ntest (arguments result))
 310          case ok result of
 311            Nothing    ->
 312              tests config gen rnd1 ntest (nfail+1) stamps
 313            Just True  ->
 314              tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
 315            Just False ->
 316              putStr ( "Falsifiable, after "
 317                    ++ show ntest
 318                    ++ " tests:\n"
 319                    ++ unlines (arguments result)
 320                     )
 321      where
 322       result      = generate (configSize config ntest) rnd2 gen
 323       (rnd1,rnd2) = split rnd0
 324
 325 done :: String -> Int -> [[String]] -> IO ()
 326 done mesg ntest stamps =
 327   do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
 328  where
 329   table = display
 330         . map entry
 331         . reverse
 332         . sort
 333         . map pairLength
 334         . group
 335         . sort
 336         . filter (not . null)
 337         $ stamps
 338
 339   display []  = ".\n"
 340   display [x] = " (" ++ x ++ ").\n"
 341   display xs  = ".\n" ++ unlines (map (++ ".") xs)
 342
 343   pairLength xss@(xs:_) = (length xss, xs)
 344   entry (n, xs)         = percentage n ntest
 345                        ++ " "
 346                        ++ concat (intersperse ", " xs)
 347
 348   percentage n m        = show ((100 * n) `div` m) ++ "%"
 349
 350 --------------------------------------------------------------------
 351 -- the end.