ghc/tests/array/should_run/arr016.hs

   1 module Main where
   2
   3 {-
   4  - This is a test framework for Arrays, using QuickCheck
   5  -
   6  -}
   7
   8 import qualified Array
   9 import List
  10 import Monad ( liftM2, liftM3, liftM4 )
  11 import Random
  12
  13
  14 import Ix
  15 import List( (\\) )
  16
  17 infixl 9  !, //
  18 infixr 0 ==>
  19 infix  1 `classify`
  20
  21 prop_array =
  22     forAll genBounds       $ \ (b :: (Int,Int))     ->
  23     forAll (genIVPs b 10)     $ \ (vs :: [(Int,Int)]) ->
  24     Array.array b vs
  25          `same_arr`
  26     array b vs
  27 prop_listArray =
  28     forAll genBounds       $ \ (b :: (Int,Int))     ->
  29     forAll (vector (length [fst b..snd b]))
  30                            $ \ (vs :: [Bool]) ->
  31     Array.listArray b vs == Array.array b (zipWith (\ a b -> (a,b))
  32                                                    (Array.range b) vs)
  33
  34 prop_indices =
  35     forAll genBounds       $ \ (b :: (Int,Int))     ->
  36     forAll (genIVPs b 10)     $ \ (vs :: [(Int,Int)]) ->
  37     let arr = Array.array b vs
  38     in Array.indices arr == ((Array.range . Array.bounds) arr)
  39
  40 prop_elems =
  41     forAll genBounds       $ \ (b :: (Int,Int))     ->
  42     forAll (genIVPs b 10)     $ \ (vs :: [(Int,Int)]) ->
  43     let arr = Array.array b vs
  44     in Array.elems arr == [arr Array.! i | i <- Array.indices arr]
  45
  46 prop_assocs =
  47     forAll genBounds       $ \ (b :: (Int,Int))     ->
  48     forAll (genIVPs b 10)     $ \ (vs :: [(Int,Int)]) ->
  49     let arr = Array.array b vs
  50     in Array.assocs arr == [(i, arr Array.! i) | i <- Array.indices arr]
  51
  52 prop_slashslash =
  53     forAll genBounds       $ \ (b :: (Int,Int))     ->
  54     forAll (genIVPs b 10)     $ \ (vs :: [(Int,Int)])  ->
  55     let arr = Array.array b vs
  56         us = []
  57     in arr Array.// us == Array.array (Array.bounds arr)
  58                           ([(i,arr Array.! i)
  59                             | i <- Array.indices arr \\ [i | (i,_) <- us]]
  60                              ++ us)
  61 prop_accum =
  62     forAll genBounds          $ \ (b :: (Int,Int))    ->
  63     forAll (genIVPs b 10)     $ \ (vs :: [(Int,Int)]) ->
  64
  65     forAll (genIVPs b 10)     $ \ (us :: [(Int,Int)]) ->
  66     forAll (choose (0,length us))
  67                            $ \ n ->
  68     let us' = take n us in
  69     forAll arbitrary       $ \ (fn :: Int -> Int -> Int) ->
  70     let arr = Array.array b vs
  71     in Array.accum fn arr us'
  72         == foldl (\a (i,v) -> a Array.// [(i,fn (a Array.! i) v)]) arr us'
  73
  74 prop_accumArray =
  75     forAll arbitrary          $ \ (f :: Int -> Int -> Int) ->
  76     forAll arbitrary          $ \ (z :: Int) ->
  77     forAll genBounds          $ \ (b :: (Int,Int))    ->
  78     forAll (genIVPs b 10)     $ \ (vs :: [(Int,Int)]) ->
  79     Array.accumArray f z b vs == Array.accum f
  80                 (Array.array b [(i,z) | i <- Array.range b]) vs
  81
  82
  83 same_arr :: (Eq b) => Array.Array Int b -> Array Int b -> Bool
  84 same_arr a1 a2 = a == c && b == d
  85                  && all (\ n -> (a1 Array.! n) == (a2 ! n)) [a..b]
  86     where (a,b) = Array.bounds a1 :: (Int,Int)
  87           (c,d) = bounds a2 :: (Int,Int)
  88
  89 genBounds :: Gen (Int,Int)
  90 genBounds = do m <- choose (0,20)
  91                n <- choose (minBound,maxBound-m)
  92                return (n,n+m-1)
  93
  94 genIVP :: Arbitrary a => (Int,Int) -> Gen (Int,a)
  95 genIVP b = do { i <- choose b
  96               ; v <- arbitrary
  97               ; return (i,v)
  98               }
  99
 100 genIVPs :: Arbitrary a => (Int,Int) -> Int -> Gen [(Int,a)]
 101 genIVPs b@(low,high) s
 102   = do { let is = [low..high]
 103        ; vs <- vector (length is)
 104        ; shuffle s (zip is vs)
 105        }
 106
 107 prop_id = forAll genBounds $ \ (b :: (Int,Int)) ->
 108           forAll (genIVPs b 10) $ \ (ivps :: [(Int,Int)])  ->
 109           label (show (ivps :: [(Int,Int)])) True
 110
 111 -- rift takes a list, split it (using an Int argument),
 112 -- and then rifts together the split lists into one.
 113 -- Think: rifting a pack of cards.
 114 rift :: Int -> [a] -> [a]
 115 rift n xs = comb (drop n xs) (take n xs)
 116    where
 117       comb (a:as) (b:bs) = a : b : comb as bs
 118       comb (a:as) []     = a : as
 119       comb []     (b:bs) = b : bs
 120       comb []     []     = []
 121
 122
 123 -- suffle makes n random rifts. Typically after
 124 -- log n rifts, the list is in a pretty random order.
 125 -- (where n is the number of elements in the list)
 126
 127 shuffle :: Int -> [a] -> Gen [a]
 128 shuffle 0 m = return m
 129 shuffle n m = do { r <- choose (1,length m)
 130                  ; shuffle (n-1) (rift r m)
 131                  }
 132 prop_shuffle =
 133     forAll (shuffle 10 [1..10::Int]) $ \ lst ->
 134     label (show lst) True
 135
 136 ------------------------------------------------------------------------------
 137
 138 main = do test prop_array
 139           test prop_listArray
 140           test prop_indices
 141           test prop_elems
 142           test prop_assocs
 143           test prop_slashslash
 144           test prop_accum
 145           test prop_accumArray
 146
 147
 148 instance Show (a -> b) where { show _ = "<FN>" }
 149
 150 ------------------------------------------------------------------------------
 151
 152 data (Ix a) => Array a b = MkArray (a,a) (a -> b) deriving ()
 153
 154 array       :: (Ix a) => (a,a) -> [(a,b)] -> Array a b
 155 array b ivs =
 156     if and [inRange b i | (i,_) <- ivs]
 157         then MkArray b
 158                      (\j -> case [v | (i,v) <- ivs, i == j] of
 159                             [v]   -> v
 160                             []    -> error "Array.!: \
 161                                            \undefined array element"
 162                             _     -> error "Array.!: \
 163                                            \multiply defined array element")
 164         else error "Array.array: out-of-range array association"
 165
 166 listArray             :: (Ix a) => (a,a) -> [b] -> Array a b
 167 listArray b vs        =  array b (zipWith (\ a b -> (a,b)) (range b) vs)
 168
 169 (!)                   :: (Ix a) => Array a b -> a -> b
 170 (!) (MkArray _ f)     =  f
 171
 172 bounds                :: (Ix a) => Array a b -> (a,a)
 173 bounds (MkArray b _)  =  b
 174
 175 indices               :: (Ix a) => Array a b -> [a]
 176 indices               =  range . bounds
 177
 178 elems                 :: (Ix a) => Array a b -> [b]
 179 elems a               =  [a!i | i <- indices a]
 180
 181 assocs                :: (Ix a) => Array a b -> [(a,b)]
 182 assocs a              =  [(i, a!i) | i <- indices a]
 183
 184 (//)                  :: (Ix a) => Array a b -> [(a,b)] -> Array a b
 185 a // us               =  array (bounds a)
 186                             ([(i,a!i) | i <- indices a \\ [i | (i,_) <- us]]
 187                              ++ us)
 188
 189 accum                 :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)]
 190                                    -> Array a b
 191 accum f               =  foldl (\a (i,v) -> a // [(i,f (a!i) v)])
 192
 193 accumArray            :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)]
 194                                    -> Array a b
 195 accumArray f z b      =  accum f (array b [(i,z) | i <- range b])
 196
 197 ixmap                 :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c
 198                                          -> Array a c
 199 ixmap b f a           = array b [(i, a ! f i) | i <- range b]
 200
 201 instance  (Ix a)          => Functor (Array a) where
 202     fmap fn (MkArray b f) =  MkArray b (fn . f)
 203
 204 instance  (Ix a, Eq b)  => Eq (Array a b)  where
 205     a == a'             =  assocs a == assocs a'
 206
 207 instance  (Ix a, Ord b) => Ord (Array a b)  where
 208     a <=  a'            =  assocs a <=  assocs a'
 209
 210 instance  (Ix a, Show a, Show b) => Show (Array a b)  where
 211     showsPrec p a = showParen (p > 9) (
 212                     showString "array " .
 213                     shows (bounds a) . showChar ' ' .
 214                     shows (assocs a)                  )
 215
 216 instance  (Ix a, Read a, Read b) => Read (Array a b)  where
 217     readsPrec p = readParen (p > 9)
 218            (\r -> [(array b as, u) | ("array",s) <- lex r,
 219                                      (b,t)       <- reads s,
 220                                      (as,u)      <- reads t   ])
 221 --------------------------------------------------------------------
 222
 223 -- QuickCheck v.0.2
 224 -- DRAFT implementation; last update 000104.
 225 -- Koen Claessen, John Hughes.
 226 -- This file represents work in progress, and might change at a later date.
 227
 228
 229 --------------------------------------------------------------------
 230 -- Generator
 231
 232 newtype Gen a
 233   = Gen (Int -> StdGen -> a)
 234
 235 sized :: (Int -> Gen a) -> Gen a
 236 sized fgen = Gen (\n r -> let Gen m = fgen n in m n r)
 237
 238 resize :: Int -> Gen a -> Gen a
 239 resize n (Gen m) = Gen (\_ r -> m n r)
 240
 241 rand :: Gen StdGen
 242 rand = Gen (\n r -> r)
 243
 244 promote :: (a -> Gen b) -> Gen (a -> b)
 245 promote f = Gen (\n r -> \a -> let Gen m = f a in m n r)
 246
 247 variant :: Int -> Gen a -> Gen a
 248 variant v (Gen m) = Gen (\n r -> m n (rands r !! (v+1)))
 249  where
 250   rands r0 = r1 : rands r2 where (r1, r2) = split r0
 251
 252 generate :: Int -> StdGen -> Gen a -> a
 253 generate n rnd (Gen m) = m size rnd'
 254  where
 255   (size, rnd') = randomR (0, n) rnd
 256
 257 instance Functor Gen where
 258   fmap f m = m >>= return . f
 259
 260 instance Monad Gen where
 261   return a    = Gen (\n r -> a)
 262   Gen m >>= k =
 263     Gen (\n r0 -> let (r1,r2) = split r0
 264                       Gen m'  = k (m n r1)
 265                    in m' n r2)
 266
 267 -- derived
 268
 269 --choose :: Random a => (a, a) -> Gen a
 270 choose bounds = ((fst . randomR bounds) `fmap` rand)
 271
 272 elements :: [a] -> Gen a
 273 elements xs = (xs !!) `fmap` choose (0, length xs - 1)
 274
 275 vector :: Arbitrary a => Int -> Gen [a]
 276 vector n = sequence [ arbitrary | i <- [1..n] ]
 277
 278 oneof :: [Gen a] -> Gen a
 279 oneof gens = elements gens >>= id
 280
 281 frequency :: [(Int, Gen a)] -> Gen a
 282 frequency xs = choose (1, tot) >>= (`pick` xs)
 283  where
 284   tot = sum (map fst xs)
 285
 286   pick n ((k,x):xs)
 287     | n <= k    = x
 288     | otherwise = pick (n-k) xs
 289
 290 -- general monadic
 291
 292 two :: Monad m => m a -> m (a, a)
 293 two m = liftM2 (,) m m
 294
 295 three :: Monad m => m a -> m (a, a, a)
 296 three m = liftM3 (,,) m m m
 297
 298 four :: Monad m => m a -> m (a, a, a, a)
 299 four m = liftM4 (,,,) m m m m
 300
 301 --------------------------------------------------------------------
 302 -- Arbitrary
 303
 304 class Arbitrary a where
 305   arbitrary   :: Gen a
 306   coarbitrary :: a -> Gen b -> Gen b
 307
 308 instance Arbitrary () where
 309   arbitrary     = return ()
 310   coarbitrary _ = variant 0
 311
 312 instance Arbitrary Bool where
 313   arbitrary     = elements [True, False]
 314   coarbitrary b = if b then variant 0 else variant 1
 315
 316 instance Arbitrary Int where
 317   arbitrary     = sized $ \n -> choose (-n,n)
 318   coarbitrary n = variant (if n >= 0 then 2*n else 2*(-n) + 1)
 319
 320 instance Arbitrary Integer where
 321   arbitrary     = sized $ \n -> choose (-fromIntegral n,fromIntegral n)
 322   coarbitrary n = variant (fromInteger (if n >= 0 then 2*n else 2*(-n) + 1))
 323
 324 instance Arbitrary Float where
 325   arbitrary     = liftM3 fraction arbitrary arbitrary arbitrary
 326   coarbitrary x = coarbitrary (decodeFloat x)
 327
 328 instance Arbitrary Double where
 329   arbitrary     = liftM3 fraction arbitrary arbitrary arbitrary
 330   coarbitrary x = coarbitrary (decodeFloat x)
 331
 332 fraction a b c = fromInteger a + (fromInteger b / (abs (fromInteger c) + 1))
 333
 334 instance (Arbitrary a, Arbitrary b) => Arbitrary (a, b) where
 335   arbitrary          = liftM2 (,) arbitrary arbitrary
 336   coarbitrary (a, b) = coarbitrary a . coarbitrary b
 337
 338 instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (a, b, c) where
 339   arbitrary             = liftM3 (,,) arbitrary arbitrary arbitrary
 340   coarbitrary (a, b, c) = coarbitrary a . coarbitrary b . coarbitrary c
 341
 342 instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)
 343       => Arbitrary (a, b, c, d)
 344  where
 345   arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary
 346   coarbitrary (a, b, c, d) =
 347     coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d
 348
 349 instance Arbitrary a => Arbitrary [a] where
 350   arbitrary          = sized (\n -> choose (0,n) >>= vector)
 351   coarbitrary []     = variant 0
 352   coarbitrary (a:as) = coarbitrary a . variant 1 . coarbitrary as
 353
 354 instance (Arbitrary a, Arbitrary b) => Arbitrary (a -> b) where
 355   arbitrary         = promote (`coarbitrary` arbitrary)
 356   coarbitrary f gen = arbitrary >>= ((`coarbitrary` gen) . f)
 357
 358 --------------------------------------------------------------------
 359 -- Testable
 360
 361 data Result
 362   = Result { ok :: Maybe Bool, stamp :: [String], arguments :: [String] }
 363
 364 nothing :: Result
 365 nothing = Result{ ok = Nothing, stamp = [], arguments = [] }
 366
 367 newtype Property
 368   = Prop (Gen Result)
 369
 370 result :: Result -> Property
 371 result res = Prop (return res)
 372
 373 evaluate :: Testable a => a -> Gen Result
 374 evaluate a = gen where Prop gen = property a
 375
 376 class Testable a where
 377   property :: a -> Property
 378
 379 instance Testable () where
 380   property _ = result nothing
 381
 382 instance Testable Bool where
 383   property b = result (nothing{ ok = Just b })
 384
 385 instance Testable Result where
 386   property res = result res
 387
 388 instance Testable Property where
 389   property prop = prop
 390
 391 instance (Arbitrary a, Show a, Testable b) => Testable (a -> b) where
 392   property f = forAll arbitrary f
 393
 394 forAll :: (Show a, Testable b) => Gen a -> (a -> b) -> Property
 395 forAll gen body = Prop $
 396   do a   <- gen
 397      res <- evaluate (body a)
 398      return (argument a res)
 399  where
 400   argument a res = res{ arguments = show a : arguments res }
 401
 402 (==>) :: Testable a => Bool -> a -> Property
 403 True  ==> a = property a
 404 False ==> a = property ()
 405
 406 label :: Testable a => String -> a -> Property
 407 label s a = Prop (add `fmap` evaluate a)
 408  where
 409   add res = res{ stamp = s : stamp res }
 410
 411 classify :: Testable a => Bool -> String -> a -> Property
 412 classify True  name = label name
 413 classify False _    = property
 414
 415 trivial :: Testable a => Bool -> a -> Property
 416 trivial = (`classify` "trivial")
 417
 418 collect :: (Show a, Testable b) => a -> b -> Property
 419 collect v = label (show v)
 420
 421 --------------------------------------------------------------------
 422 -- Testing
 423
 424 data Config = Config
 425   { configMaxTest :: Int
 426   , configMaxFail :: Int
 427   , configSize    :: Int -> Int
 428   , configEvery   :: Int -> [String] -> String
 429   }
 430
 431 quick :: Config
 432 quick = Config
 433   { configMaxTest = 100
 434   , configMaxFail = 1000
 435   , configSize    = (+ 3) . (`div` 2)
 436   , configEvery   = \n args -> let s = show n in s ++ ","
 437   }
 438
 439 verbose :: Config
 440 verbose = quick
 441   { configEvery = \n args -> show n ++ ":\n" ++ unlines args
 442   }
 443
 444 test, quickCheck, verboseCheck :: Testable a => a -> IO ()
 445 test         = check quick
 446 quickCheck   = check quick
 447 verboseCheck = check verbose
 448
 449 check :: Testable a => Config -> a -> IO ()
 450 check config a =
 451   do rnd <- newStdGen
 452      tests config (evaluate a) rnd 0 0 []
 453
 454 tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO ()
 455 tests config gen rnd0 ntest nfail stamps
 456   | ntest == configMaxTest config = do done "OK, passed" ntest stamps
 457   | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps
 458   | otherwise               =
 459       do putStr (configEvery config ntest (arguments result))
 460          case ok result of
 461            Nothing    ->
 462              tests config gen rnd1 ntest (nfail+1) stamps
 463            Just True  ->
 464              tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
 465            Just False ->
 466              putStr ( "Falsifiable, after "
 467                    ++ show ntest
 468                    ++ " tests:\n"
 469                    ++ unlines (arguments result)
 470                     )
 471      where
 472       result      = generate (configSize config ntest) rnd2 gen
 473       (rnd1,rnd2) = split rnd0
 474
 475 done :: String -> Int -> [[String]] -> IO ()
 476 done mesg ntest stamps =
 477   do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
 478  where
 479   table = display
 480         . map entry
 481         . reverse
 482         . sort
 483         . map pairLength
 484         . group
 485         . sort
 486         . filter (not . null)
 487         $ stamps
 488
 489   display []  = ".\n"
 490   display [x] = " (" ++ x ++ ").\n"
 491   display xs  = ".\n" ++ unlines (map (++ ".") xs)
 492
 493   pairLength xss@(xs:_) = (length xss, xs)
 494   entry (n, xs)         = percentage n ntest
 495                        ++ " "
 496                        ++ concat (intersperse ", " xs)
 497
 498   percentage n m        = show ((100 * n) `div` m) ++ "%"
 499
 500 --------------------------------------------------------------------
 501 -- the end.
 502
 503 {-
 504 instance Observable StdGen where { observer = observeBase }
 505
 506 instance Observable a => Observable (Gen a) where
 507   observer (Gen a) = send "Gen" (return (Gen) << a)
 508
 509 -}