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   , genArbitrary
  31   ) where
  32
  33 import Control.Applicative
  34 import Data.List (stripPrefix, isPrefixOf)
  35 import Data.Maybe (fromMaybe)
  36 import Test.Framework
  37 import Test.Framework.Providers.HUnit
  38 import Test.Framework.Providers.QuickCheck2
  39 import Test.HUnit (Assertion)
  40 import Test.QuickCheck
  41 import Language.Haskell.TH
  42
  43 -- | Test property prefix.
  44 propPrefix :: String
  45 propPrefix = "prop_"
  46
  47 -- | Test case prefix.
  48 casePrefix :: String
  49 casePrefix = "case_"
  50
  51 -- | Tries to drop a prefix from a string.
  52 simplifyName :: String -> String -> String
  53 simplifyName pfx string = fromMaybe string (stripPrefix pfx string)
  54
  55 -- | Builds a test from a QuickCheck property.
  56 runProp :: Testable prop => String -> prop -> Test
  57 runProp = testProperty . simplifyName propPrefix
  58
  59 -- | Builds a test for a HUnit test case.
  60 runCase :: String -> Assertion -> Test
  61 runCase = testCase . simplifyName casePrefix
  62
  63 -- | Runs the correct test provider for a given test, based on its
  64 -- name (not very nice, but...).
  65 run :: Name -> Q Exp
  66 run name =
  67   let str = nameBase name
  68       nameE = varE name
  69       strE = litE (StringL str)
  70   in case () of
  71        _ | propPrefix `isPrefixOf` str -> [| runProp $strE $nameE |]
  72          | casePrefix `isPrefixOf` str -> [| runCase $strE $nameE |]
  73          | otherwise -> fail $ "Unsupported test function name '" ++ str ++ "'"
  74
  75 -- | Convert slashes in a name to underscores.
  76 mapSlashes :: String -> String
  77 mapSlashes = map (\c -> if c == '/' then '_' else c)
  78
  79 -- | Builds a test suite.
  80 testSuite :: String -> [Name] -> Q [Dec]
  81 testSuite tsname tdef = do
  82   let fullname = mkName $ "test" ++ mapSlashes tsname
  83   tests <- mapM run tdef
  84   sigtype <- [t| (String, [Test]) |]
  85   return [ SigD fullname sigtype
  86          , ValD (VarP fullname) (NormalB (TupE [LitE (StringL tsname),
  87                                                 ListE tests])) []
  88          ]
  89
  90 -- | Builds an arbitrary value for a given constructor. This doesn't
  91 -- use the actual types of the fields, since we expect arbitrary
  92 -- instances for all of the types anyway, we only care about the
  93 -- number of fields.
  94 mkConsArbitrary :: (Name, [a]) -> Exp
  95 mkConsArbitrary (name, types) =
  96   let infix_arb a = InfixE (Just a) (VarE '(<*>)) (Just (VarE 'arbitrary))
  97       constr = AppE (VarE 'pure) (ConE name)
  98   in foldl (\a _ -> infix_arb a) constr types
  99
 100 -- | Extracts the name and the types from a constructor.
 101 conInfo :: Con -> (Name, [Type])
 102 conInfo (NormalC name t)     = (name, map snd t)
 103 conInfo (RecC    name t)     = (name, map (\(_, _, x) -> x) t)
 104 conInfo (InfixC t1 name t2)  = (name, [snd t1, snd t2])
 105 conInfo (ForallC _ _ subcon) = conInfo subcon
 106
 107 -- | Builds an arbitrary instance for a regular data type (i.e. not Bounded).
 108 mkRegularArbitrary :: Name -> [Con] -> Q [Dec]
 109 mkRegularArbitrary name cons = do
 110   expr <- case cons of
 111             [] -> fail "Can't make Arbitrary instance for an empty data type"
 112             [x] -> return $ mkConsArbitrary (conInfo x)
 113             xs -> appE (varE 'oneof) $
 114                   listE (map (return . mkConsArbitrary . conInfo) xs)
 115   return [InstanceD [] (AppT (ConT ''Arbitrary) (ConT name))
 116           [ValD (VarP 'arbitrary) (NormalB expr) []]]
 117
 118 -- | Builds a default Arbitrary instance for a type. This requires
 119 -- that all members are of types that already have Arbitrary
 120 -- instances, and that the arbitrary instances are well behaved
 121 -- (w.r.t. recursive data structures, or similar concerns). In that
 122 -- sense, this is not appropriate for all data types, just those that
 123 -- are simple but very repetitive or have many simple fields.
 124 genArbitrary :: Name -> Q [Dec]
 125 genArbitrary name = do
 126   r <- reify name
 127   case r of
 128     TyConI (DataD _ _ _ cons _) ->
 129       mkRegularArbitrary name cons
 130     TyConI (NewtypeD _ _ _ con _) ->
 131       mkRegularArbitrary name [con]
 132     TyConI (TySynD _ _ (ConT tn)) -> genArbitrary tn
 133     _ -> fail $ "Invalid type in call to genArbitrary for " ++ show name
 134          ++ ", type " ++ show r