Revision 20bc5360 htest/Test/Ganeti/TestHelper.hs
| b/htest/Test/Ganeti/TestHelper.hs | ||
|---|---|---|
| 38 | 38 |
import Test.QuickCheck |
| 39 | 39 |
import Language.Haskell.TH |
| 40 | 40 |
|
| 41 |
-- | Test property prefix. |
|
| 42 |
propPrefix :: String |
|
| 43 |
propPrefix = "prop_" |
|
| 44 |
|
|
| 45 |
-- | Test case prefix. |
|
| 46 |
casePrefix :: String |
|
| 47 |
casePrefix = "case_" |
|
| 48 |
|
|
| 41 | 49 |
-- | Tries to drop a prefix from a string. |
| 42 | 50 |
simplifyName :: String -> String -> String |
| 43 | 51 |
simplifyName pfx string = fromMaybe string (stripPrefix pfx string) |
| 44 | 52 |
|
| 45 | 53 |
-- | Builds a test from a QuickCheck property. |
| 46 |
runQC :: Testable prop => String -> String -> prop -> Test
|
|
| 47 |
runQC pfx name = testProperty (simplifyName ("prop_" ++ pfx ++ "_") name)
|
|
| 54 |
runProp :: Testable prop => String -> prop -> Test
|
|
| 55 |
runProp = testProperty . simplifyName propPrefix
|
|
| 48 | 56 |
|
| 49 | 57 |
-- | Builds a test for a HUnit test case. |
| 50 |
runHUnit :: String -> String -> Assertion -> Test
|
|
| 51 |
runHUnit pfx name = testCase (simplifyName ("case_" ++ pfx ++ "_") name)
|
|
| 58 |
runCase :: String -> Assertion -> Test
|
|
| 59 |
runCase = testCase . simplifyName casePrefix
|
|
| 52 | 60 |
|
| 53 | 61 |
-- | Runs the correct test provider for a given test, based on its |
| 54 | 62 |
-- name (not very nice, but...). |
| 55 |
run :: String -> Name -> Q Exp
|
|
| 56 |
run tsname name =
|
|
| 63 |
run :: Name -> Q Exp |
|
| 64 |
run name = |
|
| 57 | 65 |
let str = nameBase name |
| 58 | 66 |
nameE = varE name |
| 59 | 67 |
strE = litE (StringL str) |
| 60 | 68 |
in case () of |
| 61 |
_ | "prop_" `isPrefixOf` str -> [| runQC tsname $strE $nameE |]
|
|
| 62 |
| "case_" `isPrefixOf` str -> [| runHUnit tsname $strE $nameE |]
|
|
| 69 |
_ | propPrefix `isPrefixOf` str -> [| runProp $strE $nameE |]
|
|
| 70 |
| casePrefix `isPrefixOf` str -> [| runCase $strE $nameE |]
|
|
| 63 | 71 |
| otherwise -> fail $ "Unsupported test function name '" ++ str ++ "'" |
| 64 | 72 |
|
| 65 | 73 |
-- | Builds a test suite. |
| 66 | 74 |
testSuite :: String -> [Name] -> Q [Dec] |
| 67 | 75 |
testSuite tsname tdef = do |
| 68 | 76 |
let fullname = mkName $ "test" ++ tsname |
| 69 |
tests <- mapM (run tsname) tdef
|
|
| 77 |
tests <- mapM run tdef
|
|
| 70 | 78 |
sigtype <- [t| (String, [Test]) |] |
| 71 | 79 |
return [ SigD fullname sigtype |
| 72 | 80 |
, ValD (VarP fullname) (NormalB (TupE [LitE (StringL tsname), |
Also available in: Unified diff