← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to libraries/filepath/test/AutoTest.hs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libraries/filepath/test/AutoTest.hs
 
1
 
 
2
module AutoTest(
 
3
    module AutoTest,
 
4
    module Test.QuickCheck,
 
5
    module Data.List
 
6
    ) where
 
7
 
 
8
import Test.QuickCheck hiding (check,(==>))
 
9
import Data.Char
 
10
import System.Random
 
11
import Data.List
 
12
import Control.Monad
 
13
 
 
14
infixr 0 ==>
 
15
a ==> b = not a || b
 
16
 
 
17
 
 
18
constTest :: Bool -> IO ()
 
19
constTest True = return ()
 
20
constTest False = error "Failed on constTest"
 
21
 
 
22
 
 
23
 
 
24
data QFilePath = QFilePath FilePath
 
25
                 deriving Show
 
26
 
 
27
instance Arbitrary QFilePath where
 
28
    arbitrary = liftM QFilePath arbitrary
 
29
    coarbitrary = undefined
 
30
 
 
31
 
 
32
instance Arbitrary Char where
 
33
    arbitrary = elements "?|./:\\abcd 123;_"
 
34
    coarbitrary = undefined
 
35
 
 
36
 
 
37
 
 
38
-- below is mainly stolen from Test.QuickCheck, modified to crash out on failure
 
39
 
 
40
quickSafe :: Testable a => a -> IO ()
 
41
quickSafe prop = check quick prop
 
42
 
 
43
quick :: Config
 
44
quick = Config
 
45
  { configMaxTest = 500
 
46
  , configMaxFail = 1000
 
47
  , configSize    = (+ 3) . (`div` 2)
 
48
  , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
 
49
  }
 
50
         
 
51
 
 
52
check :: Testable a => Config -> a -> IO ()
 
53
check config a =
 
54
  do rnd <- newStdGen
 
55
     tests config (evaluate a) rnd 0 0 []
 
56
 
 
57
 
 
58
tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () 
 
59
tests config gen rnd0 ntest nfail stamps
 
60
  | ntest == configMaxTest config = do done "OK, passed" ntest stamps
 
61
  | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps
 
62
                                       error "More entropy required!"
 
63
  | otherwise               =
 
64
      do putStr (configEvery config ntest (arguments result))
 
65
         case ok result of
 
66
           Nothing    ->
 
67
             tests config gen rnd1 ntest (nfail+1) stamps
 
68
           Just True  ->
 
69
             tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
 
70
           Just False ->
 
71
             error ( "Falsifiable, after "
 
72
                   ++ show ntest
 
73
                   ++ " tests:\n"
 
74
                   ++ unlines (arguments result)
 
75
                    )
 
76
     where
 
77
      result      = generate (configSize config ntest) rnd2 gen
 
78
      (rnd1,rnd2) = split rnd0
 
79
 
 
80
done :: String -> Int -> [[String]] -> IO ()
 
81
done mesg ntest stamps =
 
82
  do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
 
83
 where
 
84
  table = display
 
85
        . map entry
 
86
        . reverse
 
87
        . sort
 
88
        . map pairLength
 
89
        . group
 
90
        . sort
 
91
        . filter (not . null)
 
92
        $ stamps
 
93
 
 
94
  display []  = ".\n"
 
95
  display [x] = " (" ++ x ++ ").\n"
 
96
  display xs  = ".\n" ++ unlines (map (++ ".") xs)
 
97
 
 
98
  pairLength xss@(xs:_) = (length xss, xs)
 
99
  entry (n, xs)         = percentage n ntest
 
100
                       ++ " "
 
101
                       ++ concat (intersperse ", " xs)
 
102
 
 
103
  percentage n m        = show ((100 * n) `div` m) ++ "%"