diff --git a/configure.ac b/configure.ac index 5beefdc13e13f3d926b3e034605eacd0a4244bc8..a10146133c921c50306e60d28935d3c4f9c7455a 100644 --- a/configure.ac +++ b/configure.ac @@ -376,8 +376,8 @@ else 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 @@ -390,7 +390,7 @@ else 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 diff --git a/doc/devnotes.rst b/doc/devnotes.rst index ae36c60e5a562f3ce5f98959c2baa4108732c0e1..1e708d35e4e91331138ff28370b89324d35032de 100644 --- a/doc/devnotes.rst +++ b/doc/devnotes.rst @@ -37,7 +37,7 @@ document, plus: - `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 diff --git a/htools/Ganeti/HTools/QC.hs b/htools/Ganeti/HTools/QC.hs index a2ed78bb48befb334299301c62a572111abbc677..e2b0e84769a54a27beffac95edaa63054190ff07 100644 --- a/htools/Ganeti/HTools/QC.hs +++ b/htools/Ganeti/HTools/QC.hs @@ -37,7 +37,6 @@ module Ganeti.HTools.QC ) where import Test.QuickCheck -import Test.QuickCheck.Batch import Data.List (findIndex, intercalate, nub, isPrefixOf) import Data.Maybe import Control.Monad @@ -66,6 +65,9 @@ import qualified Ganeti.HTools.Utils as Utils 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) @@ -147,10 +149,6 @@ assignInstance nl il inst pdx sdx = -- * 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 @@ -500,8 +498,8 @@ prop_Text_Load_Instance name mem dsk vcpus status pnode snode pdx sdx autobal = 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 = @@ -703,7 +701,8 @@ testNode = -- 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 @@ -712,11 +711,12 @@ prop_Score_Zero node count = 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)] diff --git a/htools/test.hs b/htools/test.hs index 12aa50da52995cbcee49d333a85717e45e74cdec..d0708ee27c2284b4891b94fff8932ea743a56061 100644 --- a/htools/test.hs +++ b/htools/test.hs @@ -4,7 +4,7 @@ {- -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 @@ -26,43 +26,68 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 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) @@ -84,7 +109,8 @@ main = do 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