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/core/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 System.Random
  92 import Control.Concurrent
  93 import Control.Exception hiding (catch, evaluate)
  94 import qualified Control.Exception as Exception (catch, evaluate)
  95 import Debug.QuickCheck
  96 import System.IO.Unsafe
  97
  98 data TestOptions = TestOptions {
  99         no_of_tests     :: Int,
 100         length_of_tests :: Int,
 101         debug_tests     :: Bool }
 102
 103 defOpt :: TestOptions
 104 defOpt = TestOptions
 105         { no_of_tests = 100
 106         , length_of_tests = 1
 107         , debug_tests = False
 108         }
 109
 110 data TestResult = TestOk        String  Int [[String]]
 111                 | TestExausted  String  Int [[String]]
 112                 | TestFailed   [String] Int
 113                 | TestAborted   Exception
 114
 115 tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]]
 116       -> IO TestResult
 117 tests config gen rnd0 ntest nfail stamps
 118   | ntest == configMaxTest config = return (TestOk  "OK, passed" ntest stamps)
 119   | nfail == configMaxFail config = return (TestExausted "Arguments exhausted after"
 120                                          ntest stamps)
 121   | otherwise               =
 122       do (if not (null txt) then putStr txt else return ())
 123          case ok result of
 124            Nothing    ->
 125              tests config gen rnd1 ntest (nfail+1) stamps
 126            Just True  ->
 127              tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
 128            Just False ->
 129              do return (TestFailed (arguments result) ntest)
 130      where
 131       txt         = configEvery config ntest (arguments result)
 132       result      = generate (configSize config ntest) rnd2 gen
 133       (rnd1,rnd2) = split rnd0
 134
 135 batch n v = Config
 136   { configMaxTest = n
 137   , configMaxFail = n * 10
 138   , configSize    = (+ 3) . (`div` 2)
 139   , configEvery   = \n args -> if v then show n ++ ":\n" ++ unlines args else ""
 140   }
 141
 142 -- Here we use the same random number each time,
 143 -- so we get reproducable results!
 144 run :: Testable a => a -> TestOptions -> IO TestResult
 145 run a TestOptions { no_of_tests = n, length_of_tests = len, debug_tests = debug } =
 146   do me <- myThreadId
 147      ready <- newEmptyMVar
 148      r <- if len == 0
 149            then try theTest
 150            else try (do
 151              -- This waits a bit, then raises an exception in its parent,
 152              -- saying, right, you've had long enough!
 153              watcher <- forkIO (Exception.catch
 154                               (do threadDelay (len * 1000 * 1000)
 155                                   takeMVar ready
 156                                   throwTo me NonTermination
 157                                   return ())
 158                               (\ _ -> return ()))
 159              -- Tell the watcher we are starting...
 160              putMVar ready ()
 161              -- This is cheating, because possibly some of the internal message
 162              -- inside "r" might be _|_, but anyway....
 163              r <- theTest
 164              -- Now, we turn off the watcher.
 165              -- Ignored if the watcher is already dead,
 166              -- (unless some unlucky thread picks up the same name)
 167              killThread watcher
 168              return r)
 169      case r of
 170         Right r -> return r
 171         Left  e -> return (TestAborted e)
 172   where
 173         theTest = tests (batch n debug) (evaluate a) (mkStdGen 0) 0 0 []
 174
 175 -- Prints a one line summary of various tests with common theme
 176 runTests :: String -> TestOptions -> [TestOptions -> IO TestResult] -> IO ()
 177 runTests name scale actions =
 178   do putStr (rjustify 25 name ++ " : ")
 179      f <- tr 1 actions [] 0
 180      mapM fa f
 181      return ()
 182   where
 183         rjustify n s = replicate (max 0 (n - length s)) ' ' ++ s
 184
 185         tr n [] xs c = do
 186                         putStr (rjustify (max 0 (35-n)) " (" ++ show c ++ ")\n")
 187                         return xs
 188         tr n (action:actions) others c =
 189            do r <- action scale
 190               case r of
 191                 (TestOk _ m _)
 192                         -> do { putStr "." ;
 193                                tr (n+1) actions others (c+m) }
 194                 (TestExausted s m ss)
 195
 196                         -> do { putStr "?" ;
 197                                tr (n+1) actions others (c+m) }
 198                 (TestAborted e)
 199                         -> do { putStr "*" ;
 200                                tr (n+1) actions others c }
 201                 (TestFailed f num)
 202                         -> do { putStr "#" ;
 203                                 tr (n+1) actions ((f,n,num):others) (c+num) }
 204
 205         fa :: ([String],Int,Int) -> IO ()
 206         fa (f,n,no) =
 207           do putStr "\n"
 208              putStr ("    ** test "
 209                         ++ show (n  :: Int)
 210                         ++ " of "
 211                         ++ name
 212                         ++ " failed with the binding(s)\n")
 213              sequence_ [putStr ("    **   " ++ v ++ "\n")
 214                         | v <- f ]
 215              putStr "\n"
 216
 217 -- Look out behind you! These can be misused badly.
 218 -- However, in the context of a batch tester, can also be very useful.
 219
 220 bottom = error "_|_"
 221
 222 isBottom :: a -> Bool
 223 isBottom a = unsafePerformIO (do
 224         a' <- try (Exception.evaluate a)
 225         case a' of
 226            Left _ -> return True
 227            Right _ -> return False)