TestManager.hs

--
-- Copyright (c) 2009-2012   Stefan Wehr - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library 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
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--

{- |

This module defines function for running a set of tests. Furthermore,
it provides functionality for organzing tests into a hierarchical
structure. This functionality is mainly used internally in the code
generated by the @hftpp@ pre-processor.
-}

module Test.Framework.TestManager (

  -- * Re-exports
  module Test.Framework.TestTypes,

  -- * Running tests
  htfMain, runTest, runTest', runTestWithArgs, runTestWithArgs',
  runTestWithOptions, runTestWithOptions', runTestWithConfig, runTestWithConfig',

  -- * Organzing tests
  TestableHTF,

  makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite,
  makeAnonTestSuite,
  addToTestSuite, testSuiteAsTest,

) where

import Control.Monad.RWS
import System.Exit (ExitCode(..), exitWith)
import System.Environment (getArgs)
import Control.Exception (finally)
import qualified Data.List as List

import System.IO

import qualified Test.HUnit.Lang as HU

import Test.Framework.Utils
import Test.Framework.TestManagerInternal
import Test.Framework.TestTypes
import Test.Framework.CmdlineOptions
import Test.Framework.TestReporter
import Test.Framework.Location
import Test.Framework.Colors
import Test.Framework.ThreadPool

-- | Construct a test where the given 'Assertion' checks a quick check property.
-- Mainly used internally by the htfpp preprocessor.
makeQuickCheckTest :: TestID -> Location -> Assertion -> Test
makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) defaultTestOptions ass

-- | Construct a unit test from the given 'IO' action.
-- Mainly used internally by the htfpp preprocessor.
makeUnitTest :: AssertionWithTestOptions a => TestID -> Location -> a -> Test
makeUnitTest id loc ass =
    BaseTest UnitTest id (Just loc) (testOptions ass) (assertion ass)

-- | Construct a black box test from the given 'Assertion'.
-- Mainly used internally.
makeBlackBoxTest :: TestID -> Assertion -> Test
makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing defaultTestOptions ass

-- | Create a named 'TestSuite' from a list of 'Test' values.
makeTestSuite :: TestID -> [Test] -> TestSuite
makeTestSuite = TestSuite

-- | Create an unnamed 'TestSuite' from a list of 'Test' values.
makeAnonTestSuite :: [Test] -> TestSuite
makeAnonTestSuite = AnonTestSuite

-- | Turn a 'TestSuite' into a proper 'Test'.
testSuiteAsTest :: TestSuite -> Test
testSuiteAsTest = CompoundTest

-- | Extend a 'TestSuite' with a list of 'Test' values
addToTestSuite :: TestSuite -> [Test] -> TestSuite
addToTestSuite (TestSuite id ts) ts' = TestSuite id (ts ++ ts')
addToTestSuite (AnonTestSuite ts) ts' = AnonTestSuite (ts ++ ts')

-- | A type class for things that can be run as tests.
-- Mainly used internally.
class TestableHTF t where
    flatten :: t -> [FlatTest]

instance TestableHTF Test where
    flatten = flattenTest

instance TestableHTF TestSuite where
    flatten = flattenTestSuite

instance TestableHTF t => TestableHTF [t] where
    flatten = concatMap flatten

instance TestableHTF (IO a) where
    flatten action = flatten (makeUnitTest "unnamed test" unknownLocation action)

flattenTest :: Test -> [FlatTest]
flattenTest (BaseTest sort id mloc opts x) =
    [FlatTest sort (TestPathBase id) mloc (WithTestOptions opts x)]
flattenTest (CompoundTest ts) =
    flattenTestSuite ts

flattenTestSuite :: TestSuite -> [FlatTest]
flattenTestSuite (TestSuite id ts) =
    let fts = concatMap flattenTest ts
    in map (\ft -> ft { ft_path = TestPathCompound (Just id) (ft_path ft) }) fts
flattenTestSuite (AnonTestSuite ts) =
    let fts = concatMap flattenTest ts
    in map (\ft -> ft { ft_path = TestPathCompound Nothing (ft_path ft) }) fts

mkFlatTestRunner :: FlatTest -> ThreadPoolEntry TR () (Maybe (Bool, String), Int)
mkFlatTestRunner ft = (pre, action, post)
    where
      pre = reportTestStart ft
      action _ = measure $ HU.performTestCase (wto_payload (ft_payload ft))
      post excOrResult =
          let (testResult, (mLoc, callers, msg, time)) =
                 case excOrResult of
                   Left exc -> (Error, (Nothing,
                                        [],
                                        noColor ("Running test unexpectedly failed: " ++ show exc),
                                        (-1)))
                   Right (res, time) ->
                       case res of
                         Nothing -> (Pass, (Nothing, [], emptyColorString, time))
                         Just (isFailure, msg') ->
                           if ft_sort ft /= QuickCheckTest
                              then let utr = deserializeHUnitMsg msg'
                                       r = case () of
                                             _| utr_pending utr -> Pending
                                              | isFailure -> Fail
                                              | otherwise -> Error
                                   in (r, (utr_location utr, utr_callingLocations utr, utr_message utr, time))
                              else let (r, s) = deserializeQuickCheckMsg msg'
                                   in (r, (Nothing, [], noColor s, time))
              rr = FlatTest
                     { ft_sort = ft_sort ft
                     , ft_path = ft_path ft
                     , ft_location = ft_location ft
                     , ft_payload = RunResult testResult mLoc callers msg time }
          in do modify (\s -> s { ts_results = rr : ts_results s })
                reportTestResult rr

runAllFlatTests :: [FlatTest] -> TR ()
runAllFlatTests tests =
    do reportGlobalStart tests
       tc <- ask
       case tc_threads tc of
         Nothing ->
             let entries = map mkFlatTestRunner tests
             in tp_run sequentialThreadPool entries
         Just i ->
             let (ptests, stests) = List.partition (\t -> to_parallel (wto_options (ft_payload t))) tests
                 pentries' = map mkFlatTestRunner ptests
                 sentries = map mkFlatTestRunner stests
             in do tp <- parallelThreadPool i
                   pentries <- if tc_shuffle tc
                               then liftIO (shuffleIO pentries')
                               else return pentries'
                   tp_run tp pentries
                   tp_run sequentialThreadPool sentries

-- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'.
runTest :: TestableHTF t => t              -- ^ Testable thing
                         -> IO ExitCode    -- ^ See 'runTestWithOptions' for a specification of the 'ExitCode' result
runTest = runTestWithOptions defaultCmdlineOptions

-- | Run something testable using the 'Test.Framework.TestConfig.defaultCmdlineOptions'.
runTest' :: TestableHTF t => t              -- ^ Testable thing
                         -> IO (IO (), ExitCode)    -- ^ 'IO' action for printing the overall test results, and exit code for the test run. See 'runTestWithOptions' for a specification of the 'ExitCode' result
runTest' = runTestWithOptions' defaultCmdlineOptions

-- | Run something testable, parse the 'CmdlineOptions' from the given commandline arguments.
-- Does not print the overall test results but returns an 'IO' action for doing so.
runTestWithArgs :: TestableHTF t => [String]        -- ^ Commandline arguments
                                 -> t               -- ^ Testable thing
                                 -> IO ExitCode     -- ^ See 'runTestWithConfig' for a specification of the 'ExitCode' result.
runTestWithArgs args t =
    do (printSummary, ecode) <- runTestWithArgs' args t
       printSummary
       return ecode


-- | Run something testable, parse the 'CmdlineOptions' from the given commandline arguments.
runTestWithArgs' :: TestableHTF t => [String]        -- ^ Commandline arguments
                                 -> t               -- ^ Testable thing
                                 -> IO (IO (), ExitCode)  -- ^ 'IO' action for printing the overall test results, and exit code for the test run. See 'runTestWithConfig' for a specification of the 'ExitCode' result.
runTestWithArgs' args t =
    case parseTestArgs args of
      Left err ->
          do hPutStrLn stderr err
             return $ (return (), ExitFailure 1)
      Right opts ->
          runTestWithOptions' opts t

-- | Runs something testable with the given 'CmdlineOptions'.
-- See 'runTestWithConfig' for a specification of the 'ExitCode' result.
runTestWithOptions :: TestableHTF t => CmdlineOptions -> t -> IO ExitCode
runTestWithOptions opts t =
    do (printSummary, ecode) <- runTestWithOptions' opts t
       printSummary
       return ecode

-- | Runs something testable with the given 'CmdlineOptions'. Does not
-- print the overall test results but returns an 'IO' action for doing so.
-- See 'runTestWithConfig' for a specification of the 'ExitCode' result.
runTestWithOptions' :: TestableHTF t => CmdlineOptions -> t -> IO (IO (), ExitCode)
runTestWithOptions' opts t =
    if opts_help opts
       then do hPutStrLn stderr helpString
               return $ (return (), ExitFailure 1)
       else do tc <- testConfigFromCmdlineOptions opts
               (printSummary, ecode) <-
                   (if opts_listTests opts
                      then let fts = filter (opts_filter opts) (flatten t)
                           in return (runRWST (reportAllTests fts) tc initTestState >> return (), ExitSuccess)
                      else runTestWithConfig' tc t)
               return (printSummary `finally` cleanup tc, ecode)
    where
      cleanup tc =
          case tc_output tc of
            TestOutputHandle h True -> hClose h
            _ -> return ()

-- | Runs something testable with the given 'TestConfig'.
-- The result is 'ExitSuccess' if all tests were executed successfully,
-- 'ExitFailure' otherwise. In the latter case, an error code of @1@ indicates
-- that failures but no errors occurred, otherwise the error code @2@ is used.
--
-- A test is /successful/ if the test terminates and no assertion fails.
-- A test is said to /fail/ if an assertion fails but no other error occur.
runTestWithConfig :: TestableHTF t => TestConfig -> t -> IO ExitCode
runTestWithConfig tc t =
    do (printSummary, ecode) <- runTestWithConfig' tc t
       printSummary
       return ecode

-- | Runs something testable with the given 'TestConfig'. Does not
-- print the overall test results but returns an 'IO' action for doing so.
-- See 'runTestWithConfig' for a specification of the 'ExitCode' result.
runTestWithConfig' :: TestableHTF t => TestConfig -> t -> IO (IO (), ExitCode)
runTestWithConfig' tc t =
     do ((_, s, _), time) <-
            measure $
            runRWST (runAllFlatTests (filter (tc_filter tc) (flatten t))) tc initTestState
        let results = reverse (ts_results s)
            passed = filter (\ft -> (rr_result . ft_payload) ft == Pass) results
            pending = filter (\ft -> (rr_result . ft_payload) ft == Pending) results
            failed = filter (\ft -> (rr_result . ft_payload) ft == Fail) results
            error = filter (\ft -> (rr_result . ft_payload) ft == Error) results
        let printSummary =
                runRWST (reportGlobalResults time passed pending failed error) tc (TestState [] (ts_index s)) -- keep index from run
        return (printSummary >> return (),
                case () of
                   _| length failed == 0 && length error == 0 -> ExitSuccess
                    | length error == 0 -> ExitFailure 1
                    | otherwise -> ExitFailure 2)

-- | Runs something testable by parsing the commandline arguments as test options
-- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'.
-- This function is the main entry point for running tests.
htfMain :: TestableHTF t => t -> IO ()
htfMain tests =
    do args <- getArgs
       ecode <- runTestWithArgs args tests
       exitWith ecode