{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
--
-- 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 the API for HTF plugins.

-}

module Test.Framework.TestInterface (

    Assertion, TestResult(..), FullTestResult(..), HTFFailureException(..), failHTF, subAssertHTF
  , mkFullTestResult

) where

import Test.Framework.Location
import Test.Framework.Colors

import Control.Monad.Trans.Control
import Data.Typeable
import qualified Control.Exception as Exc
import qualified Control.Exception.Lifted as ExcLifted

{- | An assertion is just an 'IO' action. Internally, the body of any test
in HTF is of type 'Assertion'. If a test specification of a certain plugin
has a type different from 'Assertion', the plugin's preprocessor pass must
inject wrapper code to convert the test specification into an assertion.

Assertions may use 'failHTF' to signal a 'TestResult' different from
'Pass'. If the assertion finishes successfully, the tests passes
implicitly.

Please note: the assertion must not swallow any exceptions! Otherwise,
timeouts and other things might not work as expected.
-}
type Assertion = IO ()

-- | The summary result of a test.
data TestResult = Pass | Pending | Fail | Error
                deriving (Int -> TestResult -> ShowS
[TestResult] -> ShowS
TestResult -> String
(Int -> TestResult -> ShowS)
-> (TestResult -> String)
-> ([TestResult] -> ShowS)
-> Show TestResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestResult] -> ShowS
$cshowList :: [TestResult] -> ShowS
show :: TestResult -> String
$cshow :: TestResult -> String
showsPrec :: Int -> TestResult -> ShowS
$cshowsPrec :: Int -> TestResult -> ShowS
Show, ReadPrec [TestResult]
ReadPrec TestResult
Int -> ReadS TestResult
ReadS [TestResult]
(Int -> ReadS TestResult)
-> ReadS [TestResult]
-> ReadPrec TestResult
-> ReadPrec [TestResult]
-> Read TestResult
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TestResult]
$creadListPrec :: ReadPrec [TestResult]
readPrec :: ReadPrec TestResult
$creadPrec :: ReadPrec TestResult
readList :: ReadS [TestResult]
$creadList :: ReadS [TestResult]
readsPrec :: Int -> ReadS TestResult
$creadsPrec :: Int -> ReadS TestResult
Read, TestResult -> TestResult -> Bool
(TestResult -> TestResult -> Bool)
-> (TestResult -> TestResult -> Bool) -> Eq TestResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestResult -> TestResult -> Bool
$c/= :: TestResult -> TestResult -> Bool
== :: TestResult -> TestResult -> Bool
$c== :: TestResult -> TestResult -> Bool
Eq)

-- | The full result of a test, as used by HTF plugins.
data FullTestResult
    = FullTestResult
      { FullTestResult -> Maybe Location
ftr_location :: Maybe Location                     -- ^ The location of a possible failure
      , FullTestResult -> [(Maybe String, Location)]
ftr_callingLocations :: [(Maybe String, Location)] -- ^ The "stack" to the location of a possible failure
      , FullTestResult -> Maybe ColorString
ftr_message :: Maybe ColorString                   -- ^ An error message
      , FullTestResult -> Maybe TestResult
ftr_result :: Maybe TestResult                     -- ^ The outcome of the test, 'Nothing' means timeout
      } deriving (FullTestResult -> FullTestResult -> Bool
(FullTestResult -> FullTestResult -> Bool)
-> (FullTestResult -> FullTestResult -> Bool) -> Eq FullTestResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FullTestResult -> FullTestResult -> Bool
$c/= :: FullTestResult -> FullTestResult -> Bool
== :: FullTestResult -> FullTestResult -> Bool
$c== :: FullTestResult -> FullTestResult -> Bool
Eq, Int -> FullTestResult -> ShowS
[FullTestResult] -> ShowS
FullTestResult -> String
(Int -> FullTestResult -> ShowS)
-> (FullTestResult -> String)
-> ([FullTestResult] -> ShowS)
-> Show FullTestResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FullTestResult] -> ShowS
$cshowList :: [FullTestResult] -> ShowS
show :: FullTestResult -> String
$cshow :: FullTestResult -> String
showsPrec :: Int -> FullTestResult -> ShowS
$cshowsPrec :: Int -> FullTestResult -> ShowS
Show, ReadPrec [FullTestResult]
ReadPrec FullTestResult
Int -> ReadS FullTestResult
ReadS [FullTestResult]
(Int -> ReadS FullTestResult)
-> ReadS [FullTestResult]
-> ReadPrec FullTestResult
-> ReadPrec [FullTestResult]
-> Read FullTestResult
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FullTestResult]
$creadListPrec :: ReadPrec [FullTestResult]
readPrec :: ReadPrec FullTestResult
$creadPrec :: ReadPrec FullTestResult
readList :: ReadS [FullTestResult]
$creadList :: ReadS [FullTestResult]
readsPrec :: Int -> ReadS FullTestResult
$creadsPrec :: Int -> ReadS FullTestResult
Read)

-- | Auxiliary function for contructing a 'FullTestResult'.
mkFullTestResult :: TestResult -> Maybe String -> FullTestResult
mkFullTestResult :: TestResult -> Maybe String -> FullTestResult
mkFullTestResult TestResult
r Maybe String
msg =
    FullTestResult :: Maybe Location
-> [(Maybe String, Location)]
-> Maybe ColorString
-> Maybe TestResult
-> FullTestResult
FullTestResult
    { ftr_location :: Maybe Location
ftr_location = Maybe Location
forall a. Maybe a
Nothing
    , ftr_callingLocations :: [(Maybe String, Location)]
ftr_callingLocations = []
    , ftr_message :: Maybe ColorString
ftr_message = (String -> ColorString) -> Maybe String -> Maybe ColorString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> ColorString
noColor Maybe String
msg
    , ftr_result :: Maybe TestResult
ftr_result = TestResult -> Maybe TestResult
forall a. a -> Maybe a
Just TestResult
r
    }

-- Internal exception type for propagating exceptions.
data HTFFailureException
    = HTFFailure FullTestResult
      deriving (Int -> HTFFailureException -> ShowS
[HTFFailureException] -> ShowS
HTFFailureException -> String
(Int -> HTFFailureException -> ShowS)
-> (HTFFailureException -> String)
-> ([HTFFailureException] -> ShowS)
-> Show HTFFailureException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HTFFailureException] -> ShowS
$cshowList :: [HTFFailureException] -> ShowS
show :: HTFFailureException -> String
$cshow :: HTFFailureException -> String
showsPrec :: Int -> HTFFailureException -> ShowS
$cshowsPrec :: Int -> HTFFailureException -> ShowS
Show, Typeable)

instance Exc.Exception HTFFailureException

{- |
Terminate a HTF test, usually to signal a failure. The result of the test
is given in the 'FullTestResult' argument.
-}
failHTF :: MonadBaseControl IO m => FullTestResult -> m a
-- Important: force the string argument, otherwise an error embedded
-- lazily inside the string might escape.
failHTF :: FullTestResult -> m a
failHTF FullTestResult
r = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (FullTestResult -> String
forall a. Show a => a -> String
show FullTestResult
r) Int -> m a -> m a
`seq` HTFFailureException -> m a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
ExcLifted.throwIO (FullTestResult -> HTFFailureException
HTFFailure FullTestResult
r)

{- |
Opens a new assertion stack frame to allow for sensible location information.
-}
subAssertHTF :: MonadBaseControl IO m => Location -> Maybe String -> m a -> m a
subAssertHTF :: Location -> Maybe String -> m a -> m a
subAssertHTF Location
loc Maybe String
mMsg m a
action =
    m a
action m a -> (HTFFailureException -> m a) -> m a
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`ExcLifted.catch`
               (\(HTFFailure FullTestResult
res) ->
                    let newRes :: FullTestResult
newRes = FullTestResult
res { ftr_callingLocations :: [(Maybe String, Location)]
ftr_callingLocations = (Maybe String
mMsg, Location
loc) (Maybe String, Location)
-> [(Maybe String, Location)] -> [(Maybe String, Location)]
forall a. a -> [a] -> [a]
: FullTestResult -> [(Maybe String, Location)]
ftr_callingLocations FullTestResult
res }
                    in FullTestResult -> m a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
FullTestResult -> m a
failHTF FullTestResult
newRes)