Since current distros don't package anymore QuickCheck 1.x, let's move
to 2.x.
This requires also a few changes to the code:
- Test.QuickCheck.Batch doesn't exist anymore, so we need to write some
scaffolding code to replace it
- the way test sizes are generated has changed, and we need to restrict
(in some tests) the cluster size, as our code is not yet ready for
hundreds of thousands of nodes in a cluster and we run out of stack
(which could be a bug somewhere by itself, needs investigation)
- at least with GHC 7, floating point errors make a perfect cluster
score even bigger, so we need to bump up the max. rounding error
allowed
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Guido Trotter <ultrotter@google.com>
AC_MSG_CHECKING([network])
GHC_PKG_NETWORK=$($GHC_PKG latest network)
AC_MSG_RESULT($GHC_PKG_NETWORK)
- AC_MSG_CHECKING([QuickCheck 1.x])
- GHC_PKG_QUICKCHECK=$($GHC_PKG --simple-output list 'QuickCheck-1.*')
+ AC_MSG_CHECKING([QuickCheck 2.x])
+ GHC_PKG_QUICKCHECK=$($GHC_PKG --simple-output list 'QuickCheck-2.*')
AC_MSG_RESULT($GHC_PKG_QUICKCHECK)
if test -z "$GHC_PKG_PARALLEL" || test -z "$GHC_PKG_JSON" || \
test -z "$GHC_PKG_NETWORK"; then
HTOOLS_MODULES="-package $GHC_PKG_PARALLEL"
fi
if test -z "$GHC_PKG_QUICKCHECK"; then
- AC_MSG_WARN(m4_normalize([The QuickCheck 1.x module was not found,
+ AC_MSG_WARN(m4_normalize([The QuickCheck 2.x module was not found,
you won't be able to run Haskell unittests]))
fi
fi
- `hlint <http://community.haskell.org/~ndm/hlint/>`_, a source code
linter (equivalent to pylint for Python)
- the `QuickCheck <http://hackage.haskell.org/package/QuickCheck>`_
- library, version 1.x
+ library, version 2.x
- ``hpc``, which comes with the compiler, so you should already have
it
) where
import Test.QuickCheck
-import Test.QuickCheck.Batch
import Data.List (findIndex, intercalate, nub, isPrefixOf)
import Data.Maybe
import Control.Monad
import qualified Ganeti.HTools.Version
import qualified Ganeti.Constants as C
+run :: Testable prop => prop -> Args -> IO Result
+run = flip quickCheckWithResult
+
-- * Constants
-- | Maximum memory (1TiB, somewhat random value)
-- * Arbitrary instances
--- copied from the introduction to quickcheck
-instance Arbitrary Char where
- arbitrary = choose ('\32', '\128')
-
newtype DNSChar = DNSChar { dnsGetChar::Char }
instance Arbitrary DNSChar where
arbitrary = do
prop_Text_Load_InstanceFail ktn fields =
length fields /= 9 ==>
case Text.loadInst nl fields of
- Right _ -> False
- Left msg -> isPrefixOf "Invalid/incomplete instance data: '" msg
+ Types.Ok _ -> False
+ Types.Bad msg -> "Invalid/incomplete instance data: '" `isPrefixOf` msg
where nl = Data.Map.fromList ktn
prop_Text_Load_Node name tm nm fm td fd tc fo =
-- Cluster tests
-- | Check that the cluster score is close to zero for a homogeneous cluster
-prop_Score_Zero node count =
+prop_Score_Zero node =
+ forAll (choose (1, 1024)) $ \count ->
(not (Node.offline node) && not (Node.failN1 node) && (count > 0) &&
(Node.tDsk node > 0) && (Node.tMem node > 0)) ==>
let fn = Node.buildPeers node Container.empty
score = Cluster.compCV nl
-- we can't say == 0 here as the floating point errors accumulate;
-- this should be much lower than the default score in CLI.hs
- in score <= 1e-15
+ in score <= 1e-12
-- | Check that cluster stats are sane
-prop_CStats_sane node count =
- (not (Node.offline node) && not (Node.failN1 node) && (count > 0) &&
+prop_CStats_sane node =
+ forAll (choose (1, 1024)) $ \count ->
+ (not (Node.offline node) && not (Node.failN1 node) &&
(Node.availDisk node > 0) && (Node.availMem node > 0)) ==>
let fn = Node.buildPeers node Container.empty
nlst = zip [1..] $ replicate count fn::[(Types.Ndx, Node.Node)]
{-
-Copyright (C) 2009 Google Inc.
+Copyright (C) 2009, 2011 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
module Main(main) where
import Data.IORef
-import Test.QuickCheck.Batch
+import Test.QuickCheck
import System.IO
import System.Exit
import System (getArgs)
+import Text.Printf
import Ganeti.HTools.QC
-fast :: TestOptions
-fast = TestOptions
- { no_of_tests = 500
- , length_of_tests = 10
- , debug_tests = False }
+fast :: Args
+fast = stdArgs
+ { maxSuccess = 500
+ , chatty = False
+ }
-slow :: TestOptions
-slow = TestOptions
- { no_of_tests = 50
- , length_of_tests = 100
- , debug_tests = False }
+slow :: Args
+slow = stdArgs
+ { maxSuccess = 50
+ , chatty = False
+ }
incIORef :: IORef Int -> IO ()
incIORef ir = atomicModifyIORef ir (\x -> (x + 1, ()))
-- | Wrapper over a test runner with error counting
wrapTest :: IORef Int
- -> (TestOptions -> IO TestResult)
- -> TestOptions -> IO TestResult
-wrapTest ir t to = do
- tr <- t to
- case tr of
- TestFailed _ _ -> incIORef ir
- TestAborted e -> do
- incIORef ir
- putStrLn ("Failure during test: <" ++ show e ++ ">")
- _ -> return ()
- return tr
-
-allTests :: [(String, TestOptions, [TestOptions -> IO TestResult])]
+ -> (Args -> IO Result)
+ -> Args
+ -> IO (Result, Char)
+wrapTest ir test opts = do
+ r <- test opts
+ c <- case r of
+ Success {} -> return '.'
+ GaveUp {} -> return '?'
+ Failure {} -> incIORef ir >> return '#'
+ NoExpectedFailure {} -> incIORef ir >> return '*'
+ return (r, c)
+
+runTests name opts tests max_count = do
+ _ <- printf "%25s : " name
+ hFlush stdout
+ results <- mapM (\t -> do
+ (r, c) <- t opts
+ putChar c
+ hFlush stdout
+ return r
+ ) tests
+ let alldone = sum . map numTests $ results
+ _ <- printf "%*s(%d)\n" (max_count - length tests + 1) " " alldone
+ mapM_ (\(idx, r) ->
+ case r of
+ Failure { output = o, usedSeed = u, usedSize = size } ->
+ printf "Test %d failed (seed was %s, test size %d): %s\n"
+ idx (show u) size o
+ GaveUp { numTests = passed } ->
+ printf "Test %d incomplete: gave up with only %d\
+ \ passes after discarding %d tests\n"
+ idx passed (maxDiscard opts)
+ _ -> return ()
+ ) $ zip ([1..]::[Int]) results
+ return results
+
+allTests :: [(String, Args, [Args -> IO Result])]
allTests =
[ ("Utils", fast, testUtils)
, ("PeerMap", fast, testPeerMap)
let tests = if null args
then allTests
else filter (\(name, _, _) -> name `elem` args) allTests
- mapM_ (\(name, opts, tl) -> runTests name opts (wrap tl)) tests
+ max_count = maximum $ map (\(_, _, t) -> length t) tests
+ mapM_ (\(name, opts, tl) -> runTests name opts (wrap tl) max_count) tests
terr <- readIORef errs
(if terr > 0
then do
projects / ganeti-local / commitdiff