code.grnet.gr Git - ganeti-local/blob - 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 -- | Tries to drop a prefix from a string.
  42 simplifyName :: String -> String -> String
  43 simplifyName pfx string = fromMaybe string (stripPrefix pfx string)
  44
  45 -- | Builds a test from a QuickCheck property.
  46 runQC :: Testable prop => String -> String -> prop -> Test
  47 runQC pfx name = testProperty (simplifyName ("prop_" ++ pfx ++ "_") name)
  48
  49 -- | Builds a test for a HUnit test case.
  50 runHUnit :: String -> String -> Assertion -> Test
  51 runHUnit pfx name = testCase (simplifyName ("case_" ++ pfx ++ "_") name)
  52
  53 -- | Runs the correct test provider for a given test, based on its
  54 -- name (not very nice, but...).
  55 run :: String -> Name -> Q Exp
  56 run tsname name =
  57   let str = nameBase name
  58       nameE = varE name
  59       strE = litE (StringL str)
  60   in case () of
  61        _ | "prop_" `isPrefixOf` str -> [| runQC tsname $strE $nameE |]
  62          | "case_" `isPrefixOf` str -> [| runHUnit tsname $strE $nameE |]
  63          | otherwise -> fail $ "Unsupported test function name '" ++ str ++ "'"
  64
  65 -- | Builds a test suite.
  66 testSuite :: String -> [Name] -> Q [Dec]
  67 testSuite tsname tdef = do
  68   let fullname = mkName $ "test" ++ tsname
  69   tests <- mapM (run tsname) tdef
  70   sigtype <- [t| (String, [Test]) |]
  71   return [ SigD fullname sigtype
  72          , ValD (VarP fullname) (NormalB (TupE [LitE (StringL tsname),
  73                                                 ListE tests])) []
  74          ]