← Back to branch summary

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

« back to all changes in this revision

Viewing changes to libraries/ghc-binary/tests/QuickCheckUtils.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/ghc-binary/tests/QuickCheckUtils.hs
 
1
{-# OPTIONS_GHC -fglasgow-exts #-}
 
2
--
 
3
-- Uses multi-param type classes
 
4
--
 
5
module QuickCheckUtils where
 
6
 
 
7
import Control.Monad
 
8
 
 
9
import Test.QuickCheck.Batch
 
10
import Test.QuickCheck
 
11
import Text.Show.Functions
 
12
 
 
13
import qualified Data.ByteString as B
 
14
import qualified Data.ByteString.Unsafe as B
 
15
import qualified Data.ByteString.Internal as B
 
16
import qualified Data.ByteString.Lazy as L
 
17
import qualified Data.Map as Map
 
18
import qualified Data.Set as Set
 
19
import qualified Data.IntMap as IntMap
 
20
import qualified Data.IntSet as IntSet
 
21
 
 
22
import qualified Control.Exception as C (evaluate)
 
23
 
 
24
import Control.Monad        ( liftM2 )
 
25
import Data.Char
 
26
import Data.List
 
27
import Data.Word
 
28
import Data.Int
 
29
import System.Random
 
30
import System.IO
 
31
 
 
32
-- import Control.Concurrent
 
33
import System.Mem
 
34
import System.CPUTime
 
35
import Text.Printf
 
36
 
 
37
import qualified Data.ByteString      as P
 
38
import qualified Data.ByteString.Lazy as L
 
39
import qualified Data.ByteString.Lazy.Internal as L
 
40
 
 
41
-- import qualified Data.Sequence as Seq
 
42
 
 
43
-- Enable this to get verbose test output. Including the actual tests.
 
44
debug = False
 
45
 
 
46
mytest :: Testable a => a -> Int -> IO ()
 
47
mytest a n = mycheck defaultConfig
 
48
    { configMaxTest=n
 
49
    , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a
 
50
 
 
51
mycheck :: Testable a => Config -> a -> IO ()
 
52
mycheck config a = do
 
53
     rnd <- newStdGen
 
54
     performGC -- >> threadDelay 100
 
55
     t <- mytests config (evaluate a) rnd 0 0 [] 0 -- 0
 
56
     printf " %0.3f seconds\n" (t :: Double)
 
57
     hFlush stdout
 
58
 
 
59
time :: a -> IO (a , Double)
 
60
time a = do
 
61
    start <- getCPUTime
 
62
    v     <- C.evaluate a
 
63
    v `seq` return ()
 
64
    end   <- getCPUTime
 
65
    return (v,     (      (fromIntegral (end - start)) / (10^12)))
 
66
 
 
67
mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> Double -> IO  Double
 
68
mytests config gen rnd0 ntest nfail stamps t0
 
69
  | ntest == configMaxTest config = do done "OK," ntest stamps
 
70
                                       return t0
 
71
 
 
72
  | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps
 
73
                                       return t0
 
74
 
 
75
  | otherwise = do
 
76
     (result,t1) <- time (generate (configSize config ntest) rnd2 gen)
 
77
 
 
78
     putStr (configEvery config ntest (arguments result)) >> hFlush stdout
 
79
     case ok result of
 
80
       Nothing    ->
 
81
         mytests config gen rnd1 ntest (nfail+1) stamps (t0 + t1)
 
82
       Just True  ->
 
83
         mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) (t0 + t1)
 
84
       Just False -> do
 
85
         putStr ( "Falsifiable after "
 
86
               ++ show ntest
 
87
               ++ " tests:\n"
 
88
               ++ unlines (arguments result)
 
89
                ) >> hFlush stdout
 
90
         return t0
 
91
 
 
92
     where
 
93
      (rnd1,rnd2) = split rnd0
 
94
 
 
95
done :: String -> Int -> [[String]] -> IO ()
 
96
done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
 
97
 where
 
98
  table = display
 
99
        . map entry
 
100
        . reverse
 
101
        . sort
 
102
        . map pairLength
 
103
        . group
 
104
        . sort
 
105
        . filter (not . null)
 
106
        $ stamps
 
107
 
 
108
  display []  = ". "
 
109
  display [x] = " (" ++ x ++ "). "
 
110
  display xs  = ".\n" ++ unlines (map (++ ".") xs)
 
111
 
 
112
  pairLength xss@(xs:_) = (length xss, xs)
 
113
  entry (n, xs)         = percentage n ntest
 
114
                       ++ " "
 
115
                       ++ concat (intersperse ", " xs)
 
116
 
 
117
  percentage n m        = show ((100 * n) `div` m) ++ "%"
 
118
 
 
119
------------------------------------------------------------------------
 
120
 
 
121
instance Random Word8 where
 
122
  randomR = integralRandomR
 
123
  random = randomR (minBound,maxBound)
 
124
 
 
125
instance Random Int8 where
 
126
  randomR = integralRandomR
 
127
  random = randomR (minBound,maxBound)
 
128
 
 
129
instance Random Word16 where
 
130
  randomR = integralRandomR
 
131
  random = randomR (minBound,maxBound)
 
132
 
 
133
instance Random Int16 where
 
134
  randomR = integralRandomR
 
135
  random = randomR (minBound,maxBound)
 
136
 
 
137
instance Random Word where
 
138
  randomR = integralRandomR
 
139
  random = randomR (minBound,maxBound)
 
140
 
 
141
instance Random Word32 where
 
142
  randomR = integralRandomR
 
143
  random = randomR (minBound,maxBound)
 
144
 
 
145
instance Random Int32 where
 
146
  randomR = integralRandomR
 
147
  random = randomR (minBound,maxBound)
 
148
 
 
149
instance Random Word64 where
 
150
  randomR = integralRandomR
 
151
  random = randomR (minBound,maxBound)
 
152
 
 
153
instance Random Int64 where
 
154
  randomR = integralRandomR
 
155
  random = randomR (minBound,maxBound)
 
156
 
 
157
------------------------------------------------------------------------
 
158
 
 
159
integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
 
160
integralRandomR  (a,b) g = case randomR (fromIntegral a :: Integer,
 
161
                                         fromIntegral b :: Integer) g of
 
162
                            (x,g) -> (fromIntegral x, g)
 
163
 
 
164
------------------------------------------------------------------------
 
165
 
 
166
instance Arbitrary Word8 where
 
167
    arbitrary       = choose (0, 2^8-1)
 
168
    coarbitrary w   = variant 0
 
169
 
 
170
instance Arbitrary Word16 where
 
171
    arbitrary       = choose (0, 2^16-1)
 
172
    coarbitrary     = undefined
 
173
 
 
174
instance Arbitrary Word32 where
 
175
--  arbitrary       = choose (0, 2^32-1)
 
176
    arbitrary       = choose (minBound, maxBound)
 
177
    coarbitrary     = undefined
 
178
 
 
179
instance Arbitrary Word64 where
 
180
--  arbitrary       = choose (0, 2^64-1)
 
181
    arbitrary       = choose (minBound, maxBound)
 
182
    coarbitrary     = undefined
 
183
 
 
184
instance Arbitrary Int8 where
 
185
--  arbitrary       = choose (0, 2^8-1)
 
186
    arbitrary       = choose (minBound, maxBound)
 
187
    coarbitrary w   = variant 0
 
188
 
 
189
instance Arbitrary Int16 where
 
190
--  arbitrary       = choose (0, 2^16-1)
 
191
    arbitrary       = choose (minBound, maxBound)
 
192
    coarbitrary     = undefined
 
193
 
 
194
instance Arbitrary Int32 where
 
195
--  arbitrary       = choose (0, 2^32-1)
 
196
    arbitrary       = choose (minBound, maxBound)
 
197
    coarbitrary     = undefined
 
198
 
 
199
instance Arbitrary Int64 where
 
200
--  arbitrary       = choose (0, 2^64-1)
 
201
    arbitrary       = choose (minBound, maxBound)
 
202
    coarbitrary     = undefined
 
203
 
 
204
instance Arbitrary Word where
 
205
    arbitrary       = choose (minBound, maxBound)
 
206
    coarbitrary w   = variant 0
 
207
 
 
208
------------------------------------------------------------------------
 
209
 
 
210
instance Arbitrary Char where
 
211
    arbitrary = choose (maxBound, minBound)
 
212
    coarbitrary = undefined
 
213
 
 
214
{-
 
215
instance Arbitrary a => Arbitrary (Maybe a) where
 
216
    arbitrary = oneof [ return Nothing, liftM Just arbitrary]
 
217
    coarbitrary = undefined
 
218
    -}
 
219
 
 
220
instance Arbitrary Ordering where
 
221
    arbitrary = oneof [ return LT,return  GT,return  EQ ]
 
222
    coarbitrary = undefined
 
223
 
 
224
{-
 
225
instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where
 
226
    arbitrary = oneof [ liftM Left arbitrary, liftM Right arbitrary]
 
227
    coarbitrary = undefined
 
228
    -}
 
229
 
 
230
instance Arbitrary IntSet.IntSet where
 
231
    arbitrary = fmap IntSet.fromList arbitrary
 
232
    coarbitrary = undefined
 
233
 
 
234
instance (Arbitrary e) => Arbitrary (IntMap.IntMap e) where
 
235
    arbitrary = fmap IntMap.fromList arbitrary
 
236
    coarbitrary = undefined
 
237
 
 
238
instance (Arbitrary a, Ord a) => Arbitrary (Set.Set a) where
 
239
    arbitrary = fmap Set.fromList arbitrary
 
240
    coarbitrary = undefined
 
241
 
 
242
instance (Arbitrary a, Ord a, Arbitrary b) => Arbitrary (Map.Map a b) where
 
243
    arbitrary = fmap Map.fromList arbitrary
 
244
    coarbitrary = undefined
 
245
 
 
246
{-
 
247
instance (Arbitrary a) => Arbitrary (Seq.Seq a) where
 
248
    arbitrary = fmap Seq.fromList arbitrary
 
249
    coarbitrary = undefined
 
250
-}
 
251
 
 
252
instance Arbitrary L.ByteString where
 
253
    arbitrary     = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant.
 
254
    coarbitrary s = coarbitrary (L.unpack s)
 
255
 
 
256
instance Arbitrary B.ByteString where
 
257
  arbitrary = B.pack `fmap` arbitrary
 
258
  coarbitrary s = coarbitrary (B.unpack s)