Commit 23fe06c2 authored by Iustin Pop's avatar Iustin Pop
Browse files

Use TemplateHaskell to decorate tests with names



This makes error message change from "Test 4 failed …" to "Test
prop_Loader_mergeData failed", which is much more readable. It also
removes the duplication of test suite names in the test.hs file.
Signed-off-by: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarAgata Murawska <agatamurawska@google.com>
parent 12c19659
{-# LANGUAGE TemplateHaskell #-}
{-| Unittests for ganeti-htools.
-}
......@@ -71,8 +73,7 @@ import qualified Ganeti.HTools.Program.Hbal
import qualified Ganeti.HTools.Program.Hscan
import qualified Ganeti.HTools.Program.Hspace
run :: Testable prop => prop -> Args -> IO Result
run = flip quickCheckWithResult
import Ganeti.HTools.QCHelper (testSuite)
-- * Constants
......@@ -364,16 +365,16 @@ prop_Utils_parseUnit (NonNegative n) =
where _types = n::Int
-- | Test list for the Utils module.
testUtils =
[ run prop_Utils_commaJoinSplit
, run prop_Utils_commaSplitJoin
, run prop_Utils_fromObjWithDefault
, run prop_Utils_if'if
, run prop_Utils_select
, run prop_Utils_select_undefd
, run prop_Utils_select_undefv
, run prop_Utils_parseUnit
]
testSuite "Utils"
[ 'prop_Utils_commaJoinSplit
, 'prop_Utils_commaSplitJoin
, 'prop_Utils_fromObjWithDefault
, 'prop_Utils_if'if
, 'prop_Utils_select
, 'prop_Utils_select_undefd
, 'prop_Utils_select_undefv
, 'prop_Utils_parseUnit
]
-- ** PeerMap tests
......@@ -413,13 +414,13 @@ prop_PeerMap_maxElem pmap =
puniq = PeerMap.accumArray const pmap
-- | List of tests for the PeerMap module.
testPeerMap =
[ run prop_PeerMap_addIdempotent
, run prop_PeerMap_removeIdempotent
, run prop_PeerMap_maxElem
, run prop_PeerMap_addFind
, run prop_PeerMap_findMissing
]
testSuite "PeerMap"
[ 'prop_PeerMap_addIdempotent
, 'prop_PeerMap_removeIdempotent
, 'prop_PeerMap_maxElem
, 'prop_PeerMap_addFind
, 'prop_PeerMap_findMissing
]
-- ** Container tests
......@@ -458,11 +459,11 @@ prop_Container_findByName node othername =
Container.findByName nl' (Node.alias target) == Just target &&
Container.findByName nl' othername == Nothing
testContainer =
[ run prop_Container_addTwo
, run prop_Container_nameOf
, run prop_Container_findByName
]
testSuite "Container"
[ 'prop_Container_addTwo
, 'prop_Container_nameOf
, 'prop_Container_findByName
]
-- ** Instance tests
......@@ -551,24 +552,24 @@ prop_Instance_setMovable inst m =
Instance.movable inst' == m
where inst' = Instance.setMovable inst m
testInstance =
[ run prop_Instance_creat
, run prop_Instance_setIdx
, run prop_Instance_setName
, run prop_Instance_setAlias
, run prop_Instance_setPri
, run prop_Instance_setSec
, run prop_Instance_setBoth
, run prop_Instance_runStatus_True
, run prop_Instance_runStatus_False
, run prop_Instance_shrinkMG
, run prop_Instance_shrinkMF
, run prop_Instance_shrinkCG
, run prop_Instance_shrinkCF
, run prop_Instance_shrinkDG
, run prop_Instance_shrinkDF
, run prop_Instance_setMovable
]
testSuite "Instance"
[ 'prop_Instance_creat
, 'prop_Instance_setIdx
, 'prop_Instance_setName
, 'prop_Instance_setAlias
, 'prop_Instance_setPri
, 'prop_Instance_setSec
, 'prop_Instance_setBoth
, 'prop_Instance_runStatus_True
, 'prop_Instance_runStatus_False
, 'prop_Instance_shrinkMG
, 'prop_Instance_shrinkMF
, 'prop_Instance_shrinkCG
, 'prop_Instance_shrinkCF
, 'prop_Instance_shrinkDG
, 'prop_Instance_shrinkDF
, 'prop_Instance_setMovable
]
-- ** Text backend tests
......@@ -663,13 +664,13 @@ prop_Text_NodeLSIdempotent node =
-- override failN1 to what loadNode returns by default
where n = node { Node.failN1 = True, Node.offline = False }
testText =
[ run prop_Text_Load_Instance
, run prop_Text_Load_InstanceFail
, run prop_Text_Load_Node
, run prop_Text_Load_NodeFail
, run prop_Text_NodeLSIdempotent
]
testSuite "Text"
[ 'prop_Text_Load_Instance
, 'prop_Text_Load_InstanceFail
, 'prop_Text_Load_Node
, 'prop_Text_Load_NodeFail
, 'prop_Text_NodeLSIdempotent
]
-- ** Node tests
......@@ -790,7 +791,6 @@ prop_Node_showField node =
fst (Node.showHeader field) /= Types.unknownField &&
Node.showField node field /= Types.unknownField
prop_Node_computeGroups nodes =
let ng = Node.computeGroups nodes
onlyuuid = map fst ng
......@@ -799,23 +799,22 @@ prop_Node_computeGroups nodes =
length (nub onlyuuid) == length onlyuuid &&
(null nodes || not (null ng))
testNode =
[ run prop_Node_setAlias
, run prop_Node_setOffline
, run prop_Node_setMcpu
, run prop_Node_setXmem
, run prop_Node_addPriFM
, run prop_Node_addPriFD
, run prop_Node_addPriFC
, run prop_Node_addSec
, run prop_Node_rMem
, run prop_Node_setMdsk
, run prop_Node_tagMaps_idempotent
, run prop_Node_tagMaps_reject
, run prop_Node_showField
, run prop_Node_computeGroups
]
testSuite "Node"
[ 'prop_Node_setAlias
, 'prop_Node_setOffline
, 'prop_Node_setMcpu
, 'prop_Node_setXmem
, 'prop_Node_addPriFM
, 'prop_Node_addPriFD
, 'prop_Node_addPriFC
, 'prop_Node_addSec
, 'prop_Node_rMem
, 'prop_Node_setMdsk
, 'prop_Node_tagMaps_idempotent
, 'prop_Node_tagMaps_reject
, 'prop_Node_showField
, 'prop_Node_computeGroups
]
-- ** Cluster tests
......@@ -957,16 +956,16 @@ prop_ClusterSplitCluster node inst =
all (\(guuid, (nl'', _)) -> all ((== guuid) . Node.group)
(Container.elems nl'')) gni
testCluster =
[ run prop_Score_Zero
, run prop_CStats_sane
, run prop_ClusterAlloc_sane
, run prop_ClusterCanTieredAlloc
, run prop_ClusterAllocEvac
, run prop_ClusterAllocBalance
, run prop_ClusterCheckConsistency
, run prop_ClusterSplitCluster
]
testSuite "Cluster"
[ 'prop_Score_Zero
, 'prop_CStats_sane
, 'prop_ClusterAlloc_sane
, 'prop_ClusterCanTieredAlloc
, 'prop_ClusterAllocEvac
, 'prop_ClusterAllocBalance
, 'prop_ClusterCheckConsistency
, 'prop_ClusterSplitCluster
]
-- ** OpCodes tests
......@@ -977,9 +976,8 @@ prop_OpCodes_serialization op =
J.Ok op' -> op == op'
where _types = op::OpCodes.OpCode
testOpCodes =
[ run prop_OpCodes_serialization
]
testSuite "OpCodes"
[ 'prop_OpCodes_serialization ]
-- ** Jobs tests
......@@ -996,10 +994,10 @@ prop_JobStatus_serialization js =
J.Ok js' -> js == js'
where _types = js::Jobs.JobStatus
testJobs =
[ run prop_OpStatus_serialization
, run prop_JobStatus_serialization
]
testSuite "Jobs"
[ 'prop_OpStatus_serialization
, 'prop_JobStatus_serialization
]
-- ** Loader tests
......@@ -1044,14 +1042,14 @@ prop_Loader_compareNameComponent_prefix (NonEmpty s1) s2 =
Loader.compareNameComponent (s1 ++ "." ++ s2) s1 ==
Loader.LookupResult Loader.PartialMatch s1
testLoader =
[ run prop_Loader_lookupNode
, run prop_Loader_lookupInstance
, run prop_Loader_assignIndices
, run prop_Loader_mergeData
, run prop_Loader_compareNameComponent_equal
, run prop_Loader_compareNameComponent_prefix
]
testSuite "Loader"
[ 'prop_Loader_lookupNode
, 'prop_Loader_lookupInstance
, 'prop_Loader_assignIndices
, 'prop_Loader_mergeData
, 'prop_Loader_compareNameComponent_equal
, 'prop_Loader_compareNameComponent_prefix
]
-- ** Types tests
......@@ -1088,9 +1086,9 @@ prop_Types_eitherToResult ei =
where r = Types.eitherToResult ei
_types = ei::Either String Int
testTypes =
[ run prop_Types_AllocPolicy_serialisation
, run prop_Types_DiskTemplate_serialisation
, run prop_Types_opToResult
, run prop_Types_eitherToResult
]
testSuite "Types"
[ 'prop_Types_AllocPolicy_serialisation
, 'prop_Types_DiskTemplate_serialisation
, 'prop_Types_opToResult
, 'prop_Types_eitherToResult
]
{-# LANGUAGE TemplateHaskell #-}
{-| Unittest helpers for ganeti-htools
-}
{-
Copyright (C) 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
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.
-}
module Ganeti.HTools.QCHelper
( testSuite
) where
import Test.QuickCheck
import Language.Haskell.TH
run :: Testable prop => prop -> Args -> IO Result
run = flip quickCheckWithResult
testSuite :: String -> [Name] -> Q [Dec]
testSuite tsname tdef = do
let fullname = mkName $ "test" ++ tsname
tests <- mapM (\n -> [| (run $(varE n), $(litE . StringL . nameBase $ n)) |])
tdef
sigtype <- [t| (String, [(Args -> IO Result, String)]) |]
return $ [ SigD fullname sigtype
, ValD (VarP fullname) (NormalB (TupE [LitE (StringL tsname),
ListE tests])) []
]
......@@ -27,7 +27,7 @@ module Main(main) where
import Data.IORef
import Test.QuickCheck
import System.Console.GetOpt
import System.Console.GetOpt ()
import System.IO
import System.Exit
import System (getArgs)
......@@ -63,55 +63,61 @@ incIORef ir = atomicModifyIORef ir (\x -> (x + 1, ()))
-- | Wrapper over a test runner with error counting.
wrapTest :: IORef Int
-> (Args -> IO Result)
-> (Args -> IO Result, String)
-> Args
-> IO (Result, Char)
wrapTest ir test opts = do
-> 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)
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) <- t opts
(r, c, desc) <- t opts
putChar c
hFlush stdout
return r
return (r, desc)
) tests
let alldone = sum . map numTests $ results
let alldone = sum . map (numTests . fst) $ results
_ <- printf "%*s(%d)\n" (max_count - length tests + 1) " " alldone
mapM_ (\(idx, r) ->
mapM_ (\(r, desc) ->
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
printf "Test %s failed (seed was %s, test size %d): %s\n"
desc (show u) size o
GaveUp { numTests = passed } ->
printf "Test %d incomplete: gave up with only %d\
printf "Test %s incomplete: gave up with only %d\
\ passes after discarding %d tests\n"
idx passed (maxDiscard opts)
desc passed (maxDiscard opts)
_ -> return ()
) $ zip ([1..]::[Int]) results
) results
return results
allTests :: [(String, Args, [Args -> IO Result])]
allTests :: [(Args, (String, [(Args -> IO Result, String)]))]
allTests =
[ ("Utils", fast, testUtils)
, ("PeerMap", fast, testPeerMap)
, ("Container", fast, testContainer)
, ("Instance", fast, testInstance)
, ("Node", fast, testNode)
, ("Text", fast, testText)
, ("OpCodes", fast, testOpCodes)
, ("Jobs", fast, testJobs)
, ("Loader", fast, testLoader)
, ("Types", fast, testTypes)
, ("Cluster", slow, testCluster)
[ (fast, testUtils)
, (fast, testPeerMap)
, (fast, testContainer)
, (fast, testInstance)
, (fast, testNode)
, (fast, testText)
, (fast, testOpCodes)
, (fast, testJobs)
, (fast, testLoader)
, (fast, testTypes)
, (slow, testCluster)
]
transformTestOpts :: Args -> Options -> IO Args
......@@ -135,9 +141,9 @@ main = do
(opts, args) <- parseOpts cmd_args "test" options
let tests = if null args
then allTests
else filter (\(name, _, _) -> name `elem` args) allTests
max_count = maximum $ map (\(_, _, t) -> length t) tests
mapM_ (\(name, targs, tl) ->
else filter (\(_, (name, _)) -> name `elem` args) allTests
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
......
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