Commit 95f6c931 authored by Iustin Pop's avatar Iustin Pop
Browse files

Switch Haskell test harness to test-framework

This patch replaces our home-grown, and quite limited, test runner
infrastructure with test-framework
(http://batterseapower.github.com/test-framework/

). The rationale for
doing so is as follows:

- we will need to add support for HUnit tests, so either we add more
  custom code or we switch to an existing library
- test-framework is mature and already packaged, at least in
  Debian/Ubuntu
- it supports more features: parallel test running, better test
  selection, etc.

As you can see, the changes are trivial, and don't touch the tests at
all; if/when we split the QC.hs file into per-module files, then we
could drop QCHelper too, and replace it with test-framework-th, which
does the same, but even more automated (auto-discovery, without having
to list the tests at all).

Dependencies are updated in devnotes.rst; note that I've already added
the hunit dependencies since we're going to use that soon.
Signed-off-by: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarAgata Murawska <agatamurawska@google.com>
parent a03b2e1c
......@@ -64,15 +64,25 @@ document, plus:
above (tested with 1.8.15)
- the `QuickCheck <http://hackage.haskell.org/package/QuickCheck>`_
library, version 2.x
- the `HUnit <http://hunit.sourceforge.net/>`_ library (tested with
1.2.x)
- the `test-framework
<http://batterseapower.github.com/test-framework/>`_ libraries,
tested versions: ``test-framework``: 0.6, ``test-framework-hunit``:
0.2.7, ``test-framework-quickcheck2``: 0.2.12
- ``hpc``, which comes with the compiler, so you should already have
it
- `shelltestrunner <http://joyful.com/shelltestrunner>`_, used for
running unit-tests
running shell-based unit-tests
Under Debian Wheezy or later, these can be installed (on top of the
required ones from the quick install document) via::
$ apt-get install libghc-quickcheck2-dev hscolour hlint
$ apt-get install libghc-quickcheck2-dev libghc-hunit-dev \
libghc-test-framework-dev \
libghc-test-framework-quickcheck2-dev \
libghc-test-framework-hunit-dev \
hscolour hlint
Or alternatively via ``cabal``::
......
......@@ -6,7 +6,7 @@
{-
Copyright (C) 2011 Google Inc.
Copyright (C) 2011, 2012 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
......@@ -29,18 +29,29 @@ module Ganeti.HTools.QCHelper
( testSuite
) where
import Data.List (stripPrefix)
import Data.Maybe (fromMaybe)
import Test.QuickCheck
import Test.Framework
import Test.Framework.Providers.QuickCheck2
import Language.Haskell.TH
run :: Testable prop => prop -> Args -> IO Result
run = flip quickCheckWithResult
-- | Tries to drop a prefix from a string.
simplifyName :: String -> String -> String
simplifyName pfx string = fromMaybe string (stripPrefix pfx string)
-- | Builds a test from a property and given arguments.
run :: Testable prop => String -> String -> prop -> Test
run pfx name = testProperty (simplifyName ("prop_" ++ pfx ++ "_") name)
-- | Builds a test suite.
testSuite :: String -> [Name] -> Q [Dec]
testSuite tsname tdef = do
let fullname = mkName $ "test" ++ tsname
tests <- mapM (\n -> [| (run $(varE n), $(litE . StringL . nameBase $ n)) |])
tests <- mapM (\n -> [| run tsname
$(litE . StringL . nameBase $ n) $(varE n) |])
tdef
sigtype <- [t| (String, [(Args -> IO Result, String)]) |]
sigtype <- [t| (String, [Test]) |]
return [ SigD fullname sigtype
, ValD (VarP fullname) (NormalB (TupE [LitE (StringL tsname),
ListE tests])) []
......
......@@ -25,161 +25,82 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
module Main(main) where
import Data.Char
import Data.IORef
import Data.List
import Data.Maybe (fromMaybe)
import System.Console.GetOpt ()
import Data.Monoid (mappend)
import Test.Framework
import System.Environment (getArgs)
import System.Exit
import System.IO
import Test.QuickCheck
import Text.Printf
import Ganeti.HTools.QC
import Ganeti.HTools.CLI
import Ganeti.HTools.Utils (sepSplit)
-- | Options list and functions.
options :: [OptType]
options =
[ oReplay
, oVerbose
, oShowVer
, oShowHelp
, oTestCount
]
fast :: Args
fast = stdArgs
{ maxSuccess = 500
, chatty = False
-- | Our default test options, overring the built-in test-framework
-- ones.
fast :: TestOptions
fast = TestOptions
{ topt_seed = Nothing
, topt_maximum_generated_tests = Just 500
, topt_maximum_unsuitable_generated_tests = Just 5000
, topt_maximum_test_size = Nothing
, topt_maximum_test_depth = Nothing
, topt_timeout = Nothing
}
slow :: Args
slow = stdArgs
{ maxSuccess = 50
, chatty = False
-- | Our slow test options.
slow :: TestOptions
slow = fast
{ topt_maximum_generated_tests = Just 50
, topt_maximum_unsuitable_generated_tests = Just 500
}
incIORef :: IORef Int -> IO ()
incIORef ir = atomicModifyIORef ir (\x -> (x + 1, ()))
-- | Wrapper over a test runner with error counting.
wrapTest :: IORef Int
-> (Args -> IO Result, String)
-> Args
-> IO (Result, Char, String)
wrapTest ir (test, desc) opts = do
r <- test opts
c <- case r of
Success {} -> return '.'
GaveUp {} -> return '?'
Failure {} -> incIORef ir >> return '#'
NoExpectedFailure {} -> incIORef ir >> return '*'
return (r, c, desc)
runTests :: String
-> Args
-> [Args -> IO (Result, Char, String)]
-> Int
-> IO [(Result, String)]
runTests name opts tests max_count = do
_ <- printf "%25s : " name
hFlush stdout
results <- mapM (\t -> do
(r, c, desc) <- t opts
putChar c
hFlush stdout
return (r, desc)
) tests
let alldone = sum . map (numTests . fst) $ results
_ <- printf "%*s(%d)\n" (max_count - length tests + 1) " " alldone
mapM_ (\(r, desc) ->
case r of
Failure { output = o, usedSeed = u, usedSize = size } ->
printf "Test %s failed (seed was %s, test size %d): %s\n"
desc (show u) size o
GaveUp { numTests = passed } ->
printf "Test %s incomplete: gave up with only %d\
\ passes after discarding %d tests\n"
desc passed (maxDiscard opts)
_ -> return ()
) results
return results
allTests :: [(Args, (String, [(Args -> IO Result, String)]))]
-- | All our defined tests.
allTests :: [(Bool, (String, [Test]))]
allTests =
[ (fast, testUtils)
, (fast, testPeerMap)
, (fast, testContainer)
, (fast, testInstance)
, (fast, testNode)
, (fast, testText)
, (fast, testSimu)
, (fast, testOpCodes)
, (fast, testJobs)
, (fast, testLoader)
, (fast, testTypes)
, (fast, testCLI)
, (fast, testJSON)
, (fast, testLUXI)
, (fast, testSsconf)
, (fast, testQlang)
, (slow, testCluster)
, (fast, testRpc)
[ (True, testUtils)
, (True, testPeerMap)
, (True, testContainer)
, (True, testInstance)
, (True, testNode)
, (True, testText)
, (True, testSimu)
, (True, testOpCodes)
, (True, testJobs)
, (True, testLoader)
, (True, testTypes)
, (True, testCLI)
, (True, testJSON)
, (True, testLUXI)
, (True, testSsconf)
, (True, testQlang)
, (True, testRpc)
, (False, testCluster)
]
-- | Extracts the name of a test group.
extractName :: (Args, (String, [(Args -> IO Result, String)])) -> String
extractName (_, (name, _)) = name
-- | Lowercase a string.
lower :: String -> String
lower = map toLower
transformTestOpts :: Args -> Options -> IO Args
transformTestOpts args opts = do
r <- case optReplay opts of
Nothing -> return Nothing
Just str -> do
let vs = sepSplit ',' str
case vs of
[rng, size] -> return $ Just (read rng, read size)
_ -> fail "Invalid state given"
return args { chatty = optVerbose opts > 1
, replay = r
, maxSuccess = fromMaybe (maxSuccess args) (optTestCount opts)
, maxDiscard = fromMaybe (maxDiscard args) (optTestCount opts)
}
-- | Slow a test's max tests, if provided as such.
makeSlowOrFast :: Bool -> TestOptions -> TestOptions
makeSlowOrFast is_fast opts =
let template = if is_fast then fast else slow
fn_val v = if is_fast then v else v `div` 10
in case topt_maximum_generated_tests opts of
-- user didn't override the max_tests, so we'll do it here
Nothing -> opts `mappend` template
-- user did override, so we ignore the template and just directly
-- decrease the max_tests, if needed
Just max_tests -> opts { topt_maximum_generated_tests =
Just (fn_val max_tests)
}
-- | Main function. Note we don't use defaultMain since we want to
-- control explicitly our test sizes (and override the default).
main :: IO ()
main = do
errs <- newIORef 0
let wrap = map (wrapTest errs)
cmd_args <- getArgs
(opts, args) <- parseOpts cmd_args "test" options
tests <- if null args
then return allTests
else let args' = map lower args
selected = filter ((`elem` args') . lower .
extractName) allTests
in if null selected
then do
hPutStrLn stderr $ "No tests matching '"
++ unwords args ++ "', available tests: "
++ intercalate ", " (map extractName allTests)
exitWith $ ExitFailure 1
else return selected
let max_count = maximum $ map (\(_, (_, t)) -> length t) tests
mapM_ (\(targs, (name, tl)) ->
transformTestOpts targs opts >>= \newargs ->
runTests name newargs (wrap tl) max_count) tests
terr <- readIORef errs
if terr > 0
then do
hPutStrLn stderr $ "A total of " ++ show terr ++ " tests failed."
exitWith $ ExitFailure 1
else putStrLn "All tests succeeded."
ropts <- getArgs >>= interpretArgsOrExit
-- note: we do this overriding here since we need some groups to
-- have a smaller test count; so in effect we're basically
-- overriding t-f's inheritance here, but only for max_tests
let (act_fast, act_slow) =
case ropt_test_options ropts of
Nothing -> (fast, slow)
Just topts -> (makeSlowOrFast True topts, makeSlowOrFast False topts)
actual_opts is_fast = if is_fast then act_fast else act_slow
let tests = map (\(is_fast, (group_name, group_tests)) ->
plusTestOptions (actual_opts is_fast) $
testGroup group_name group_tests) allTests
defaultMainWithOpts tests ropts
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment