{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
--
-- Copyright (c) 2009-2022   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 tests, i.e. unit tests and quickcheck properties.

This functionality is mainly used internally in the code
generated by the @hftpp@ pre-processor.
-}

module Test.Framework.TestInterface (

    Assertion, TestResult(..), FullTestResult(..), HTFFailureException(..)
  , HtfStackEntry(..), HtfStack, emptyHtfStack, mkHtfStack, formatHtfStack
  , failureLocationFromStack, failureLocation
  , restCallStack, htfStackToList
  , failHTF, subAssertHTF, addCallerToSubAssertStack
  , mkFullTestResult

) where

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

import Control.Monad.Trans.Control
import Data.Typeable
import GHC.Stack
import qualified Data.List as L
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
$cshowsPrec :: Int -> TestResult -> ShowS
showsPrec :: Int -> TestResult -> ShowS
$cshow :: TestResult -> String
show :: TestResult -> String
$cshowList :: [TestResult] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS TestResult
readsPrec :: Int -> ReadS TestResult
$creadList :: ReadS [TestResult]
readList :: ReadS [TestResult]
$creadPrec :: ReadPrec TestResult
readPrec :: ReadPrec TestResult
$creadListPrec :: ReadPrec [TestResult]
readListPrec :: ReadPrec [TestResult]
Read, TestResult -> TestResult -> Bool
(TestResult -> TestResult -> Bool)
-> (TestResult -> TestResult -> Bool) -> Eq TestResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestResult -> TestResult -> Bool
== :: TestResult -> TestResult -> Bool
$c/= :: TestResult -> TestResult -> Bool
/= :: TestResult -> TestResult -> Bool
Eq)

data HtfStackEntry
    = HtfStackEntry
    { HtfStackEntry -> Location
hse_location :: Location
    , HtfStackEntry -> String
hse_calledFunction :: String
    , HtfStackEntry -> Maybe String
hse_message :: Maybe String
    } deriving (HtfStackEntry -> HtfStackEntry -> Bool
(HtfStackEntry -> HtfStackEntry -> Bool)
-> (HtfStackEntry -> HtfStackEntry -> Bool) -> Eq HtfStackEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HtfStackEntry -> HtfStackEntry -> Bool
== :: HtfStackEntry -> HtfStackEntry -> Bool
$c/= :: HtfStackEntry -> HtfStackEntry -> Bool
/= :: HtfStackEntry -> HtfStackEntry -> Bool
Eq, Eq HtfStackEntry
Eq HtfStackEntry =>
(HtfStackEntry -> HtfStackEntry -> Ordering)
-> (HtfStackEntry -> HtfStackEntry -> Bool)
-> (HtfStackEntry -> HtfStackEntry -> Bool)
-> (HtfStackEntry -> HtfStackEntry -> Bool)
-> (HtfStackEntry -> HtfStackEntry -> Bool)
-> (HtfStackEntry -> HtfStackEntry -> HtfStackEntry)
-> (HtfStackEntry -> HtfStackEntry -> HtfStackEntry)
-> Ord HtfStackEntry
HtfStackEntry -> HtfStackEntry -> Bool
HtfStackEntry -> HtfStackEntry -> Ordering
HtfStackEntry -> HtfStackEntry -> HtfStackEntry
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HtfStackEntry -> HtfStackEntry -> Ordering
compare :: HtfStackEntry -> HtfStackEntry -> Ordering
$c< :: HtfStackEntry -> HtfStackEntry -> Bool
< :: HtfStackEntry -> HtfStackEntry -> Bool
$c<= :: HtfStackEntry -> HtfStackEntry -> Bool
<= :: HtfStackEntry -> HtfStackEntry -> Bool
$c> :: HtfStackEntry -> HtfStackEntry -> Bool
> :: HtfStackEntry -> HtfStackEntry -> Bool
$c>= :: HtfStackEntry -> HtfStackEntry -> Bool
>= :: HtfStackEntry -> HtfStackEntry -> Bool
$cmax :: HtfStackEntry -> HtfStackEntry -> HtfStackEntry
max :: HtfStackEntry -> HtfStackEntry -> HtfStackEntry
$cmin :: HtfStackEntry -> HtfStackEntry -> HtfStackEntry
min :: HtfStackEntry -> HtfStackEntry -> HtfStackEntry
Ord, Int -> HtfStackEntry -> ShowS
[HtfStackEntry] -> ShowS
HtfStackEntry -> String
(Int -> HtfStackEntry -> ShowS)
-> (HtfStackEntry -> String)
-> ([HtfStackEntry] -> ShowS)
-> Show HtfStackEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HtfStackEntry -> ShowS
showsPrec :: Int -> HtfStackEntry -> ShowS
$cshow :: HtfStackEntry -> String
show :: HtfStackEntry -> String
$cshowList :: [HtfStackEntry] -> ShowS
showList :: [HtfStackEntry] -> ShowS
Show, ReadPrec [HtfStackEntry]
ReadPrec HtfStackEntry
Int -> ReadS HtfStackEntry
ReadS [HtfStackEntry]
(Int -> ReadS HtfStackEntry)
-> ReadS [HtfStackEntry]
-> ReadPrec HtfStackEntry
-> ReadPrec [HtfStackEntry]
-> Read HtfStackEntry
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS HtfStackEntry
readsPrec :: Int -> ReadS HtfStackEntry
$creadList :: ReadS [HtfStackEntry]
readList :: ReadS [HtfStackEntry]
$creadPrec :: ReadPrec HtfStackEntry
readPrec :: ReadPrec HtfStackEntry
$creadListPrec :: ReadPrec [HtfStackEntry]
readListPrec :: ReadPrec [HtfStackEntry]
Read)

-- The first entry in the list is the location of the assertion failure
data HtfStack
    = HtfStack
      { HtfStack -> [HtfStackEntry]
hs_assertStack :: [HtfStackEntry]
      , HtfStack -> [HtfStackEntry]
hs_subAssertStack :: [HtfStackEntry]
      }
    deriving (HtfStack -> HtfStack -> Bool
(HtfStack -> HtfStack -> Bool)
-> (HtfStack -> HtfStack -> Bool) -> Eq HtfStack
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HtfStack -> HtfStack -> Bool
== :: HtfStack -> HtfStack -> Bool
$c/= :: HtfStack -> HtfStack -> Bool
/= :: HtfStack -> HtfStack -> Bool
Eq, Eq HtfStack
Eq HtfStack =>
(HtfStack -> HtfStack -> Ordering)
-> (HtfStack -> HtfStack -> Bool)
-> (HtfStack -> HtfStack -> Bool)
-> (HtfStack -> HtfStack -> Bool)
-> (HtfStack -> HtfStack -> Bool)
-> (HtfStack -> HtfStack -> HtfStack)
-> (HtfStack -> HtfStack -> HtfStack)
-> Ord HtfStack
HtfStack -> HtfStack -> Bool
HtfStack -> HtfStack -> Ordering
HtfStack -> HtfStack -> HtfStack
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HtfStack -> HtfStack -> Ordering
compare :: HtfStack -> HtfStack -> Ordering
$c< :: HtfStack -> HtfStack -> Bool
< :: HtfStack -> HtfStack -> Bool
$c<= :: HtfStack -> HtfStack -> Bool
<= :: HtfStack -> HtfStack -> Bool
$c> :: HtfStack -> HtfStack -> Bool
> :: HtfStack -> HtfStack -> Bool
$c>= :: HtfStack -> HtfStack -> Bool
>= :: HtfStack -> HtfStack -> Bool
$cmax :: HtfStack -> HtfStack -> HtfStack
max :: HtfStack -> HtfStack -> HtfStack
$cmin :: HtfStack -> HtfStack -> HtfStack
min :: HtfStack -> HtfStack -> HtfStack
Ord, Int -> HtfStack -> ShowS
[HtfStack] -> ShowS
HtfStack -> String
(Int -> HtfStack -> ShowS)
-> (HtfStack -> String) -> ([HtfStack] -> ShowS) -> Show HtfStack
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HtfStack -> ShowS
showsPrec :: Int -> HtfStack -> ShowS
$cshow :: HtfStack -> String
show :: HtfStack -> String
$cshowList :: [HtfStack] -> ShowS
showList :: [HtfStack] -> ShowS
Show, ReadPrec [HtfStack]
ReadPrec HtfStack
Int -> ReadS HtfStack
ReadS [HtfStack]
(Int -> ReadS HtfStack)
-> ReadS [HtfStack]
-> ReadPrec HtfStack
-> ReadPrec [HtfStack]
-> Read HtfStack
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS HtfStack
readsPrec :: Int -> ReadS HtfStack
$creadList :: ReadS [HtfStack]
readList :: ReadS [HtfStack]
$creadPrec :: ReadPrec HtfStack
readPrec :: ReadPrec HtfStack
$creadListPrec :: ReadPrec [HtfStack]
readListPrec :: ReadPrec [HtfStack]
Read)

mkHtfStack :: CallStack -> HtfStack
mkHtfStack :: CallStack -> HtfStack
mkHtfStack CallStack
cs = [HtfStackEntry] -> [HtfStackEntry] -> HtfStack
HtfStack (((String, SrcLoc) -> HtfStackEntry)
-> [(String, SrcLoc)] -> [HtfStackEntry]
forall a b. (a -> b) -> [a] -> [b]
map (String, SrcLoc) -> HtfStackEntry
mkHtfStackEntry ([(String, SrcLoc)] -> [(String, SrcLoc)]
removeHtfPrefix (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs))) []

removeHtfPrefix :: [(String, SrcLoc)] -> [(String, SrcLoc)]
removeHtfPrefix :: [(String, SrcLoc)] -> [(String, SrcLoc)]
removeHtfPrefix [] = []
removeHtfPrefix all :: [(String, SrcLoc)]
all@((String
_, SrcLoc
srcLoc) : [(String, SrcLoc)]
rest) =
    if String
"Test.Framework" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` SrcLoc -> String
srcLocModule SrcLoc
srcLoc
    then [(String, SrcLoc)] -> [(String, SrcLoc)]
removeHtfPrefix [(String, SrcLoc)]
rest
    else [(String, SrcLoc)]
all

mkHtfStackEntry :: (String, SrcLoc) -> HtfStackEntry
mkHtfStackEntry :: (String, SrcLoc) -> HtfStackEntry
mkHtfStackEntry (String, SrcLoc)
x = (String, SrcLoc) -> Maybe String -> HtfStackEntry
mkHtfStackEntry' (String, SrcLoc)
x Maybe String
forall a. Maybe a
Nothing

mkHtfStackEntry' :: (String, SrcLoc) -> Maybe String -> HtfStackEntry
mkHtfStackEntry' :: (String, SrcLoc) -> Maybe String -> HtfStackEntry
mkHtfStackEntry' (String
funName, SrcLoc
srcLoc) Maybe String
mMsg =
    HtfStackEntry
    { hse_location :: Location
hse_location = String -> Int -> Location
makeLoc (SrcLoc -> String
srcLocFile SrcLoc
srcLoc) (SrcLoc -> Int
srcLocStartLine SrcLoc
srcLoc)
    , hse_calledFunction :: String
hse_calledFunction = String
funName
    , hse_message :: Maybe String
hse_message = Maybe String
mMsg
    }

htfStackToList :: HtfStack -> [HtfStackEntry]
htfStackToList :: HtfStack -> [HtfStackEntry]
htfStackToList HtfStack
s = HtfStack -> [HtfStackEntry]
hs_assertStack HtfStack
s [HtfStackEntry] -> [HtfStackEntry] -> [HtfStackEntry]
forall a. [a] -> [a] -> [a]
++ [HtfStackEntry] -> [HtfStackEntry]
forall a. [a] -> [a]
reverse (HtfStack -> [HtfStackEntry]
hs_subAssertStack HtfStack
s)

emptyHtfStack :: HtfStack
emptyHtfStack :: HtfStack
emptyHtfStack = [HtfStackEntry] -> [HtfStackEntry] -> HtfStack
HtfStack [] []

failureLocation :: HasCallStack => Maybe Location
failureLocation :: HasCallStack => Maybe Location
failureLocation = HtfStack -> Maybe Location
failureLocationFromStack (CallStack -> HtfStack
mkHtfStack CallStack
HasCallStack => CallStack
callStack)

failureLocationFromStack :: HtfStack -> Maybe Location
failureLocationFromStack :: HtfStack -> Maybe Location
failureLocationFromStack HtfStack
stack =
    case HtfStack -> [HtfStackEntry]
htfStackToList HtfStack
stack of
      [] -> Maybe Location
forall a. Maybe a
Nothing
      HtfStackEntry
e:[HtfStackEntry]
_ -> Location -> Maybe Location
forall a. a -> Maybe a
Just (HtfStackEntry -> Location
hse_location HtfStackEntry
e)

restCallStack :: HtfStack -> [HtfStackEntry]
restCallStack :: HtfStack -> [HtfStackEntry]
restCallStack HtfStack
stack =
    case HtfStack -> [HtfStackEntry]
htfStackToList HtfStack
stack of
      [] -> []
      HtfStackEntry
_:[HtfStackEntry]
rest -> [HtfStackEntry]
rest

-- | Formats a stack trace.
formatHtfStack :: HtfStack -> String
formatHtfStack :: HtfStack -> String
formatHtfStack HtfStack
stack =
    [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Integer, HtfStackEntry) -> String)
-> [(Integer, HtfStackEntry)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, HtfStackEntry) -> String
forall {a}. (Ord a, Num a) => (a, HtfStackEntry) -> String
formatStackElem ([(Integer, HtfStackEntry)] -> [String])
-> [(Integer, HtfStackEntry)] -> [String]
forall a b. (a -> b) -> a -> b
$ [Integer] -> [HtfStackEntry] -> [(Integer, HtfStackEntry)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] ([HtfStackEntry] -> [(Integer, HtfStackEntry)])
-> [HtfStackEntry] -> [(Integer, HtfStackEntry)]
forall a b. (a -> b) -> a -> b
$ HtfStack -> [HtfStackEntry]
htfStackToList HtfStack
stack
    where
      formatStackElem :: (a, HtfStackEntry) -> String
formatStackElem (a
pos, HtfStackEntry Location
loc String
_ Maybe String
mMsg) =
          let pref :: String
pref = if a
pos a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 then String
"  called from " else String
"  at "
          in String
pref String -> ShowS
forall a. [a] -> [a] -> [a]
++ Location -> String
showLoc Location
loc String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
showMsg Maybe String
mMsg
      showMsg :: Maybe String -> String
showMsg Maybe String
Nothing = String
""
      showMsg (Just String
m) = String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

-- | The full result of a test, as used by HTF plugins.
data FullTestResult
    = FullTestResult
      { FullTestResult -> HtfStack
ftr_stack :: HtfStack                  -- ^ 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
$c== :: FullTestResult -> FullTestResult -> Bool
== :: FullTestResult -> FullTestResult -> Bool
$c/= :: FullTestResult -> FullTestResult -> Bool
/= :: 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
$cshowsPrec :: Int -> FullTestResult -> ShowS
showsPrec :: Int -> FullTestResult -> ShowS
$cshow :: FullTestResult -> String
show :: FullTestResult -> String
$cshowList :: [FullTestResult] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS FullTestResult
readsPrec :: Int -> ReadS FullTestResult
$creadList :: ReadS [FullTestResult]
readList :: ReadS [FullTestResult]
$creadPrec :: ReadPrec FullTestResult
readPrec :: ReadPrec FullTestResult
$creadListPrec :: ReadPrec [FullTestResult]
readListPrec :: ReadPrec [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
    { ftr_stack :: HtfStack
ftr_stack = HtfStack
emptyHtfStack
    , ftr_message :: Maybe ColorString
ftr_message = (String -> ColorString) -> Maybe String -> Maybe ColorString
forall a b. (a -> b) -> Maybe a -> Maybe b
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
$cshowsPrec :: Int -> HTFFailureException -> ShowS
showsPrec :: Int -> HTFFailureException -> ShowS
$cshow :: HTFFailureException -> String
show :: HTFFailureException -> String
$cshowList :: [HTFFailureException] -> ShowS
showList :: [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 :: forall (m :: * -> *) a.
MonadBaseControl IO m =>
FullTestResult -> m a
failHTF FullTestResult
r = String -> Int
forall a. [a] -> 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
forall a b. a -> b -> b
`seq` HTFFailureException -> m a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
ExcLifted.throwIO (FullTestResult -> HTFFailureException
HTFFailure FullTestResult
r)

addCallerToSubAssertStack :: CallStack -> HtfStack -> Maybe String -> HtfStack
addCallerToSubAssertStack :: CallStack -> HtfStack -> Maybe String -> HtfStack
addCallerToSubAssertStack CallStack
ghcStack stack :: HtfStack
stack@(HtfStack [HtfStackEntry]
s1 [HtfStackEntry]
s2) Maybe String
mMsg =
    case [(String, SrcLoc)] -> [(String, SrcLoc)]
removeHtfPrefix (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
ghcStack) of
      [] -> HtfStack
stack
      ((String, SrcLoc)
entry : [(String, SrcLoc)]
_) -> [HtfStackEntry] -> [HtfStackEntry] -> HtfStack
HtfStack [HtfStackEntry]
s1 (((String, SrcLoc) -> Maybe String -> HtfStackEntry
mkHtfStackEntry' (String, SrcLoc)
entry Maybe String
mMsg) HtfStackEntry -> [HtfStackEntry] -> [HtfStackEntry]
forall a. a -> [a] -> [a]
: [HtfStackEntry]
s2)

{- |
Opens a new assertion stack frame to allow for sensible location information.
This function should be used if the function being called does not carry
a 'HasCallStack' annotation.
-}
subAssertHTF :: (HasCallStack, MonadBaseControl IO m) => Maybe String -> m a -> m a
subAssertHTF :: forall (m :: * -> *) a.
(HasCallStack, MonadBaseControl IO m) =>
Maybe String -> m a -> m a
subAssertHTF Maybe String
mMsg m a
action =
    let stack :: CallStack
stack = CallStack
HasCallStack => CallStack
callStack
    in 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_stack =
                                         addCallerToSubAssertStack stack (ftr_stack res) mMsg }
                       in FullTestResult -> m a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
FullTestResult -> m a
failHTF FullTestResult
newRes)