Commit 6dd92942 authored by Iustin Pop's avatar Iustin Pop
Browse files

QCHelper: add support for defining HUnit test cases



This will allow us to use exactly the same method as for defining and
using QuickCheck properties. The differentiation is based on name,
which is not very nice but is the same method used in
test-framework-th, for example (so we will be able to switch
trivially).
Signed-off-by: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarAgata Murawska <agatamurawska@google.com>
parent 2c4eb054
...@@ -29,28 +29,44 @@ module Ganeti.HTools.QCHelper ...@@ -29,28 +29,44 @@ module Ganeti.HTools.QCHelper
( testSuite ( testSuite
) where ) where
import Data.List (stripPrefix) import Data.List (stripPrefix, isPrefixOf)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Test.QuickCheck
import Test.Framework import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2 import Test.Framework.Providers.QuickCheck2
import Test.HUnit (Assertion)
import Test.QuickCheck
import Language.Haskell.TH import Language.Haskell.TH
-- | Tries to drop a prefix from a string. -- | Tries to drop a prefix from a string.
simplifyName :: String -> String -> String simplifyName :: String -> String -> String
simplifyName pfx string = fromMaybe string (stripPrefix pfx string) simplifyName pfx string = fromMaybe string (stripPrefix pfx string)
-- | Builds a test from a property and given arguments. -- | Builds a test from a QuickCheck property.
run :: Testable prop => String -> String -> prop -> Test runQC :: Testable prop => String -> String -> prop -> Test
run pfx name = testProperty (simplifyName ("prop_" ++ pfx ++ "_") name) runQC pfx name = testProperty (simplifyName ("prop_" ++ pfx ++ "_") name)
-- | Builds a test for a HUnit test case.
runHUnit :: String -> String -> Assertion -> Test
runHUnit pfx name = testCase (simplifyName ("case_" ++ pfx ++ "_") name)
-- | Runs the correct test provider for a given test, based on its
-- name (not very nice, but...).
run :: String -> Name -> Q Exp
run tsname name =
let str = nameBase name
nameE = varE name
strE = litE (StringL str)
in case () of
_ | "prop_" `isPrefixOf` str -> [| runQC tsname $strE $nameE |]
| "case_" `isPrefixOf` str -> [| runHUnit tsname $strE $nameE |]
| otherwise -> fail $ "Unsupported test function name '" ++ str ++ "'"
-- | Builds a test suite. -- | Builds a test suite.
testSuite :: String -> [Name] -> Q [Dec] testSuite :: String -> [Name] -> Q [Dec]
testSuite tsname tdef = do testSuite tsname tdef = do
let fullname = mkName $ "test" ++ tsname let fullname = mkName $ "test" ++ tsname
tests <- mapM (\n -> [| run tsname tests <- mapM (run tsname) tdef
$(litE . StringL . nameBase $ n) $(varE n) |])
tdef
sigtype <- [t| (String, [Test]) |] sigtype <- [t| (String, [Test]) |]
return [ SigD fullname sigtype return [ SigD fullname sigtype
, ValD (VarP fullname) (NormalB (TupE [LitE (StringL tsname), , ValD (VarP fullname) (NormalB (TupE [LitE (StringL tsname),
......
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