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