On Mon, Sep 26, 2011 at 11:57 AM, Iustin Pop <[email protected]> wrote:
> 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.
> ---
> htools/Ganeti/HTools/QC.hs | 194
> +++++++++++++++++++-------------------
> htools/Ganeti/HTools/QCHelper.hs | 47 +++++++++
> htools/test.hs | 64 +++++++------
> 3 files changed, 178 insertions(+), 127 deletions(-)
> create mode 100644 htools/Ganeti/HTools/QCHelper.hs
>
> diff --git a/htools/Ganeti/HTools/QC.hs b/htools/Ganeti/HTools/QC.hs
> index cbd9b18..68bcc0d 100644
> --- a/htools/Ganeti/HTools/QC.hs
> +++ b/htools/Ganeti/HTools/QC.hs
> @@ -1,3 +1,5 @@
> +{-# 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
>
> @@ -959,16 +958,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
>
> @@ -979,9 +978,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
>
> @@ -998,10 +996,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
>
> @@ -1046,14 +1044,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
>
> @@ -1090,9 +1088,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
> + ]
> diff --git a/htools/Ganeti/HTools/QCHelper.hs
> b/htools/Ganeti/HTools/QCHelper.hs
> new file mode 100644
> index 0000000..5057b5f
> --- /dev/null
> +++ b/htools/Ganeti/HTools/QCHelper.hs
> @@ -0,0 +1,47 @@
> +{-# 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])) []
> + ]
This I find little hard to read, because of the brackets (especially
tests <- ..). And yes, I am a huge fan of '.' and '$' ;)
> diff --git a/htools/test.hs b/htools/test.hs
> index 34bd05a..4c9ddf2 100644
> --- a/htools/test.hs
> +++ b/htools/test.hs
> @@ -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
> --
> 1.7.3.1
>
>
Rest LGTM
