Debug/QuickCheck/Batch.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Debug.QuickCheck.Batch
   4 -- Copyright   :  (c) Andy Gill 2001
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  experimental
   9 -- Portability :  non-portable (uses Control.Exception, Control.Concurrent)
  10 --
  11 -- This is a batch driver for runing QuickCheck.
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 {-
  16  - Here is the key for reading the output.
  17  -  . = test successful
  18  -  ? = every example passed, but quickcheck did not find enough good examples
  19  -  * = test aborted for some reason (out-of-time, bottom, etc)
  20  -  # = test failed outright
  21  -
  22  - We also provide the dangerous "isBottom".
  23  -
  24  - Here is is an example of use for sorting:
  25  -
  26  - testOptions :: TestOptions
  27  - testOptions = TestOptions
  28  -                 { no_of_tests = 100          -- number of tests to run
  29  -                 , length_of_tests = 1        -- 1 second max per check
  30  -                                              -- where a check == n tests
  31  -                 , debug_tests = False        -- True => debugging info
  32  -                 }
  33  -
  34  - prop_sort1 xs = sort xs == sortBy compare xs
  35  -   where types = (xs :: [OrdALPHA])
  36  - prop_sort2 xs =
  37  -         (not (null xs)) ==>
  38  -         (head (sort xs) == minimum xs)
  39  -   where types = (xs :: [OrdALPHA])
  40  - prop_sort3 xs = (not (null xs)) ==>
  41  -         last (sort xs) == maximum xs
  42  -   where types = (xs :: [OrdALPHA])
  43  - prop_sort4 xs ys =
  44  -         (not (null xs)) ==>
  45  -         (not (null ys)) ==>
  46  -         (head (sort (xs ++ ys)) == min (minimum xs) (minimum ys))
  47  -   where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
  48  - prop_sort6 xs ys =
  49  -         (not (null xs)) ==>
  50  -         (not (null ys)) ==>
  51  -         (last (sort (xs ++ ys)) == max (maximum xs) (maximum ys))
  52  -   where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
  53  - prop_sort5 xs ys =
  54  -         (not (null xs)) ==>
  55  -         (not (null ys)) ==>
  56  -         (head (sort (xs ++ ys)) == max (maximum xs) (maximum ys))
  57  -   where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
  58  -
  59  - test_sort = runTests "sort" testOptions
  60  -         [ run prop_sort1
  61  -         , run prop_sort2
  62  -         , run prop_sort3
  63  -         , run prop_sort4
  64  -         , run prop_sort5
  65  -         ]
  66  -
  67  - When run, this gives
  68  - Main> test_sort
  69  -                     sort : .....
  70  -
  71  - You would tie together all the test_* functions
  72  - into one test_everything, on a per module basis.
  73  -
  74  - Examples of use of bottom and isBottom:
  75  -      {- test for abort -}
  76  -      prop_head2 = isBottom (head [])
  77  -      {- test for strictness -}
  78  -      prop_head3 = isBottom (head bottom)
  79  -}
  80
  81 module Debug.QuickCheck.Batch
  82    ( run                -- :: Testable a => a -> TestOptions -> IO TestResult
  83    , runTests           -- :: String -> TestOptions ->
  84                         --      [TestOptions -> IO TestResult] -> IO ()
  85    , defOpt             -- :: TestOptions
  86    , TestOptions (..)
  87    , isBottom           -- :: a -> Bool
  88    , bottom             -- :: a                 {- _|_ -}
  89    ) where
  90
  91 import Prelude
  92
  93 import System.Random
  94 import Control.Concurrent
  95 import Control.Exception hiding (catch, evaluate)
  96 import qualified Control.Exception as Exception (catch, evaluate)
  97 import Debug.QuickCheck
  98 import System.IO.Unsafe
  99
 100 data TestOptions = TestOptions {
 101         no_of_tests     :: Int,
 102         length_of_tests :: Int,
 103         debug_tests     :: Bool }
 104
 105 defOpt :: TestOptions
 106 defOpt = TestOptions
 107         { no_of_tests = 100
 108         , length_of_tests = 1
 109         , debug_tests = False
 110         }
 111
 112 data TestResult = TestOk        String  Int [[String]]
 113                 | TestExausted  String  Int [[String]]
 114                 | TestFailed   [String] Int
 115                 | TestAborted   Exception
 116
 117 tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]]
 118       -> IO TestResult
 119 tests config gen rnd0 ntest nfail stamps
 120   | ntest == configMaxTest config = return (TestOk  "OK, passed" ntest stamps)
 121   | nfail == configMaxFail config = return (TestExausted "Arguments exhausted after"
 122                                          ntest stamps)
 123   | otherwise               =
 124       do (if not (null txt) then putStr txt else return ())
 125          case ok result of
 126            Nothing    ->
 127              tests config gen rnd1 ntest (nfail+1) stamps
 128            Just True  ->
 129              tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
 130            Just False ->
 131              do return (TestFailed (arguments result) ntest)
 132      where
 133       txt         = configEvery config ntest (arguments result)
 134       result      = generate (configSize config ntest) rnd2 gen
 135       (rnd1,rnd2) = split rnd0
 136
 137 batch n v = Config
 138   { configMaxTest = n
 139   , configMaxFail = n * 10
 140   , configSize    = (+ 3) . (`div` 2)
 141   , configEvery   = \n args -> if v then show n ++ ":\n" ++ unlines args else ""
 142   }
 143
 144 -- Here we use the same random number each time,
 145 -- so we get reproducable results!
 146 run :: Testable a => a -> TestOptions -> IO TestResult
 147 run a TestOptions { no_of_tests = n, length_of_tests = len, debug_tests = debug } =
 148   do me <- myThreadId
 149      ready <- newEmptyMVar
 150      r <- if len == 0
 151            then try theTest
 152            else try (do
 153              -- This waits a bit, then raises an exception in its parent,
 154              -- saying, right, you've had long enough!
 155              watcher <- forkIO (Exception.catch
 156                               (do threadDelay (len * 1000 * 1000)
 157                                   takeMVar ready
 158                                   throwTo me NonTermination
 159                                   return ())
 160                               (\ _ -> return ()))
 161              -- Tell the watcher we are starting...
 162              putMVar ready ()
 163              -- This is cheating, because possibly some of the internal message
 164              -- inside "r" might be _|_, but anyway....
 165              r <- theTest
 166              -- Now, we turn off the watcher.
 167              -- Ignored if the watcher is already dead,
 168              -- (unless some unlucky thread picks up the same name)
 169              killThread watcher
 170              return r)
 171      case r of
 172         Right r -> return r
 173         Left  e -> return (TestAborted e)
 174   where
 175         theTest = tests (batch n debug) (evaluate a) (mkStdGen 0) 0 0 []
 176
 177 -- Prints a one line summary of various tests with common theme
 178 runTests :: String -> TestOptions -> [TestOptions -> IO TestResult] -> IO ()
 179 runTests name scale actions =
 180   do putStr (rjustify 25 name ++ " : ")
 181      f <- tr 1 actions [] 0
 182      mapM fa f
 183      return ()
 184   where
 185         rjustify n s = replicate (max 0 (n - length s)) ' ' ++ s
 186
 187         tr n [] xs c = do
 188                         putStr (rjustify (max 0 (35-n)) " (" ++ show c ++ ")\n")
 189                         return xs
 190         tr n (action:actions) others c =
 191            do r <- action scale
 192               case r of
 193                 (TestOk _ m _)
 194                         -> do { putStr "." ;
 195                                tr (n+1) actions others (c+m) }
 196                 (TestExausted s m ss)
 197
 198                         -> do { putStr "?" ;
 199                                tr (n+1) actions others (c+m) }
 200                 (TestAborted e)
 201                         -> do { putStr "*" ;
 202                                tr (n+1) actions others c }
 203                 (TestFailed f num)
 204                         -> do { putStr "#" ;
 205                                 tr (n+1) actions ((f,n,num):others) (c+num) }
 206
 207         fa :: ([String],Int,Int) -> IO ()
 208         fa (f,n,no) =
 209           do putStr "\n"
 210              putStr ("    ** test "
 211                         ++ show (n  :: Int)
 212                         ++ " of "
 213                         ++ name
 214                         ++ " failed with the binding(s)\n")
 215              sequence_ [putStr ("    **   " ++ v ++ "\n")
 216                         | v <- f ]
 217              putStr "\n"
 218
 219 -- Look out behind you! These can be misused badly.
 220 -- However, in the context of a batch tester, can also be very useful.
 221
 222 bottom = error "_|_"
 223
 224 isBottom :: a -> Bool
 225 isBottom a = unsafePerformIO (do
 226         a' <- try (Exception.evaluate a)
 227         case a' of
 228            Left _ -> return True
 229            Right _ -> return False)