{-# LANGUAGE TemplateHaskell #-}

{-| Unittest helpers for TemplateHaskell components.

-}

{-

Copyright (C) 2011, 2012 Google Inc.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

module Test.Ganeti.TestHelper
  ( testSuite
  , genArbitrary
  ) where

import Control.Applicative
import Data.List (stripPrefix, isPrefixOf)
import Data.Maybe (fromMaybe)
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.HUnit (Assertion)
import Test.QuickCheck
import Language.Haskell.TH

-- | Test property prefix.
propPrefix :: String
propPrefix = "prop_"

-- | Test case prefix.
casePrefix :: String
casePrefix = "case_"

-- | 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 QuickCheck property.
runProp :: Testable prop => String -> prop -> Test
runProp = testProperty . simplifyName propPrefix

-- | Builds a test for a HUnit test case.
runCase :: String -> Assertion -> Test
runCase = testCase . simplifyName casePrefix

-- | Runs the correct test provider for a given test, based on its
-- name (not very nice, but...).
run :: Name -> Q Exp
run name =
  let str = nameBase name
      nameE = varE name
      strE = litE (StringL str)
  in case () of
       _ | propPrefix `isPrefixOf` str -> [| runProp $strE $nameE |]
         | casePrefix `isPrefixOf` str -> [| runCase $strE $nameE |]
         | otherwise -> fail $ "Unsupported test function name '" ++ str ++ "'"

-- | Convert slashes in a name to underscores.
mapSlashes :: String -> String
mapSlashes = map (\c -> if c == '/' then '_' else c)

-- | Builds a test suite.
testSuite :: String -> [Name] -> Q [Dec]
testSuite tsname tdef = do
  let fullname = mkName $ "test" ++ mapSlashes tsname
  tests <- mapM run tdef
  sigtype <- [t| Test |]
  body <- [| testGroup $(litE $ stringL tsname) $(return $ ListE tests) |]
  return [ SigD fullname sigtype
         , ValD (VarP fullname) (NormalB body) []
         ]

-- | Builds an arbitrary value for a given constructor. This doesn't
-- use the actual types of the fields, since we expect arbitrary
-- instances for all of the types anyway, we only care about the
-- number of fields.
mkConsArbitrary :: (Name, [a]) -> Exp
mkConsArbitrary (name, types) =
  let infix_arb a = InfixE (Just a) (VarE '(<*>)) (Just (VarE 'arbitrary))
      constr = AppE (VarE 'pure) (ConE name)
  in foldl (\a _ -> infix_arb a) constr types

-- | Extracts the name and the types from a constructor.
conInfo :: Con -> (Name, [Type])
conInfo (NormalC name t)     = (name, map snd t)
conInfo (RecC    name t)     = (name, map (\(_, _, x) -> x) t)
conInfo (InfixC t1 name t2)  = (name, [snd t1, snd t2])
conInfo (ForallC _ _ subcon) = conInfo subcon

-- | Builds an arbitrary instance for a regular data type (i.e. not Bounded).
mkRegularArbitrary :: Name -> [Con] -> Q [Dec]
mkRegularArbitrary name cons = do
  expr <- case cons of
            [] -> fail "Can't make Arbitrary instance for an empty data type"
            [x] -> return $ mkConsArbitrary (conInfo x)
            xs -> appE (varE 'oneof) $
                  listE (map (return . mkConsArbitrary . conInfo) xs)
  return [InstanceD [] (AppT (ConT ''Arbitrary) (ConT name))
          [ValD (VarP 'arbitrary) (NormalB expr) []]]

-- | Builds a default Arbitrary instance for a type. This requires
-- that all members are of types that already have Arbitrary
-- instances, and that the arbitrary instances are well behaved
-- (w.r.t. recursive data structures, or similar concerns). In that
-- sense, this is not appropriate for all data types, just those that
-- are simple but very repetitive or have many simple fields.
genArbitrary :: Name -> Q [Dec]
genArbitrary name = do
  r <- reify name
  case r of
    TyConI (DataD _ _ _ cons _) ->
      mkRegularArbitrary name cons
    TyConI (NewtypeD _ _ _ con _) ->
      mkRegularArbitrary name [con]
    TyConI (TySynD _ _ (ConT tn)) -> genArbitrary tn
    _ -> fail $ "Invalid type in call to genArbitrary for " ++ show name
         ++ ", type " ++ show r