From 6dd92942398411a8d24710ab2604b12f9347e479 Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Mon, 20 Aug 2012 00:25:49 +0200
Subject: [PATCH] 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: Iustin Pop <iustin@google.com>
Reviewed-by: Agata Murawska <agatamurawska@google.com>
---
htools/Ganeti/HTools/QCHelper.hs | 32 ++++++++++++++++++++++++--------
1 file changed, 24 insertions(+), 8 deletions(-)
diff --git a/htools/Ganeti/HTools/QCHelper.hs b/htools/Ganeti/HTools/QCHelper.hs
index a1bc0395c..b853b289d 100644
--- a/htools/Ganeti/HTools/QCHelper.hs
+++ b/htools/Ganeti/HTools/QCHelper.hs
@@ -29,28 +29,44 @@ module Ganeti.HTools.QCHelper
( testSuite
) where
-import Data.List (stripPrefix)
+import Data.List (stripPrefix, isPrefixOf)
import Data.Maybe (fromMaybe)
-import Test.QuickCheck
import Test.Framework
+import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
+import Test.HUnit (Assertion)
+import Test.QuickCheck
import Language.Haskell.TH
-- | 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 from a QuickCheck property.
+runQC :: Testable prop => String -> String -> prop -> Test
+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.
testSuite :: String -> [Name] -> Q [Dec]
testSuite tsname tdef = do
let fullname = mkName $ "test" ++ tsname
- tests <- mapM (\n -> [| run tsname
- $(litE . StringL . nameBase $ n) $(varE n) |])
- tdef
+ tests <- mapM (run tsname) tdef
sigtype <- [t| (String, [Test]) |]
return [ SigD fullname sigtype
, ValD (VarP fullname) (NormalB (TupE [LitE (StringL tsname),
--
GitLab