Simplify property and test case names
[ganeti-local] / htest / Test / Ganeti / TestHelper.hs
1 {-# LANGUAGE TemplateHaskell #-}
2
3 {-| Unittest helpers for Haskell components
4
5 -}
6
7 {-
8
9 Copyright (C) 2011, 2012 Google Inc.
10
11 This program is free software; you can redistribute it and/or modify
12 it under the terms of the GNU General Public License as published by
13 the Free Software Foundation; either version 2 of the License, or
14 (at your option) any later version.
15
16 This program is distributed in the hope that it will be useful, but
17 WITHOUT ANY WARRANTY; without even the implied warranty of
18 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
19 General Public License for more details.
20
21 You should have received a copy of the GNU General Public License
22 along with this program; if not, write to the Free Software
23 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24 02110-1301, USA.
25
26 -}
27
28 module Test.Ganeti.TestHelper
29   ( testSuite
30   ) where
31
32 import Data.List (stripPrefix, isPrefixOf)
33 import Data.Maybe (fromMaybe)
34 import Test.Framework
35 import Test.Framework.Providers.HUnit
36 import Test.Framework.Providers.QuickCheck2
37 import Test.HUnit (Assertion)
38 import Test.QuickCheck
39 import Language.Haskell.TH
40
41 -- | Test property prefix.
42 propPrefix :: String
43 propPrefix = "prop_"
44
45 -- | Test case prefix.
46 casePrefix :: String
47 casePrefix = "case_"
48
49 -- | Tries to drop a prefix from a string.
50 simplifyName :: String -> String -> String
51 simplifyName pfx string = fromMaybe string (stripPrefix pfx string)
52
53 -- | Builds a test from a QuickCheck property.
54 runProp :: Testable prop => String -> prop -> Test
55 runProp = testProperty . simplifyName propPrefix
56
57 -- | Builds a test for a HUnit test case.
58 runCase :: String -> Assertion -> Test
59 runCase = testCase . simplifyName casePrefix
60
61 -- | Runs the correct test provider for a given test, based on its
62 -- name (not very nice, but...).
63 run :: Name -> Q Exp
64 run name =
65   let str = nameBase name
66       nameE = varE name
67       strE = litE (StringL str)
68   in case () of
69        _ | propPrefix `isPrefixOf` str -> [| runProp $strE $nameE |]
70          | casePrefix `isPrefixOf` str -> [| runCase $strE $nameE |]
71          | otherwise -> fail $ "Unsupported test function name '" ++ str ++ "'"
72
73 -- | Builds a test suite.
74 testSuite :: String -> [Name] -> Q [Dec]
75 testSuite tsname tdef = do
76   let fullname = mkName $ "test" ++ tsname
77   tests <- mapM run tdef
78   sigtype <- [t| (String, [Test]) |]
79   return [ SigD fullname sigtype
80          , ValD (VarP fullname) (NormalB (TupE [LitE (StringL tsname),
81                                                 ListE tests])) []
82          ]