{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{- |
Module    :  Test.Tasty.Bdd
Copyright :  (c) Paolo Veronelli, Pavlo Kerestey 2017-2020
License   :  BSD-3-Clause
Maintainer:  paolo.veronelli@gmail.com
Stability :  experimental
Portability: non-portable

Tasty driver for 'Language'
-}
module Test.Tasty.Bdd
    ( (@?=)
    , (@?/=)
    , (^?=)
    , (^?/=)
    , acquire
    , acquirePure
    , Phase (..)
    , Language (..)
    , testBehavior
    , testBehaviorIO
    , BDDTesting
    , BDDPreparing
    , TestableMonad (..)
    , failFastIngredients
    , failFastTester
    , prettyDifferences
    , beforeEach
    , afterEach
    , before
    , after
    , onEach
    , captureStdout
    , testBehaviorF
    )
where

import Control.Monad (foldM)
import Control.Monad.Catch
    ( Exception (..)
    , MonadCatch (..)
    , MonadThrow (..)
    , catchAll
    )
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Maybe (fromMaybe, isNothing)
import Data.Tagged (Tagged (..))
import Data.TreeDiff
import Data.Typeable (Proxy (..), Typeable)
import System.CaptureStdout
import System.IO.Unsafe (unsafePerformIO)
import Test.BDD.Language
import Test.BDD.LanguageFree
import Test.Tasty
    ( withResource
    )
import Test.Tasty.Ingredients.FailFast (FailFast (..), failFast)
import Test.Tasty.Options (OptionDescription (..), lookupOption)
import Test.Tasty.Providers
    ( IsTest (..)
    , singleTest
    , testFailed
    , testPassed
    )
import Test.Tasty.Runners
import Text.Printf (printf)

data FreeBDDCase m = FreeBDDCase (m Result -> IO Result) (m (BDDResult m))

-- | Adapt a free-monad scenario to Tasty using a runner for its monad.
testBehaviorF
    :: (Typeable m, MonadCatch m)
    => (m Result -> IO Result)
    -> String
    -> FreeBDD m x
    -> TestTree
testBehaviorF :: forall (m :: * -> *) x.
(Typeable m, MonadCatch m) =>
(m Result -> IO Result) -> String -> FreeBDD m x -> TestTree
testBehaviorF m Result -> IO Result
f String
s = String -> FreeBDDCase m -> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest String
s (FreeBDDCase m -> TestTree)
-> (FreeBDD m x -> FreeBDDCase m) -> FreeBDD m x -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m Result -> IO Result) -> m (BDDResult m) -> FreeBDDCase m
forall (m :: * -> *).
(m Result -> IO Result) -> m (BDDResult m) -> FreeBDDCase m
FreeBDDCase m Result -> IO Result
f (m (BDDResult m) -> FreeBDDCase m)
-> (FreeBDD m x -> m (BDDResult m)) -> FreeBDD m x -> FreeBDDCase m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeBDD m x -> m (BDDResult m)
forall (m :: * -> *) x.
MonadCatch m =>
Free (GivenFree m) x -> m (BDDResult m)
testFreeBDD

instance (MonadCatch m, Typeable m) => IsTest (FreeBDDCase m) where
    run :: OptionSet -> FreeBDDCase m -> (Progress -> IO ()) -> IO Result
run OptionSet
_ (FreeBDDCase m Result -> IO Result
rc m (BDDResult m)
test) Progress -> IO ()
_ = m Result -> IO Result
rc (m Result -> IO Result) -> m Result -> IO Result
forall a b. (a -> b) -> a -> b
$ m (BDDResult m)
test m (BDDResult m) -> (BDDResult m -> m Result) -> m Result
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BDDResult m -> m Result
forall {m :: * -> *}. MonadCatch m => BDDResult m -> m Result
g
      where
        g :: BDDResult m -> m Result
g (Failed SomeException
e m ()
td) = do
            m ()
td m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAll` m () -> SomeException -> m ()
forall a b. a -> b -> a
const (() -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
            m Result
-> (EqualityDoesntHold -> m Result)
-> Maybe EqualityDoesntHold
-> m Result
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                (SomeException -> m Result
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM SomeException
e)
                (Result -> m Result
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> m Result)
-> (EqualityDoesntHold -> Result) -> EqualityDoesntHold -> m Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Result
testFailed (String -> Result)
-> (EqualityDoesntHold -> String) -> EqualityDoesntHold -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EqualityDoesntHold -> String
testFailMessage)
                (Maybe EqualityDoesntHold -> m Result)
-> Maybe EqualityDoesntHold -> m Result
forall a b. (a -> b) -> a -> b
$ SomeException -> Maybe EqualityDoesntHold
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e
        g (Succeded m ()
td) = m ()
td m () -> m Result -> m Result
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Result -> m Result
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Result
testPassed String
"")
    testOptions :: Tagged (FreeBDDCase m) [OptionDescription]
testOptions = [OptionDescription] -> Tagged (FreeBDDCase m) [OptionDescription]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Proxy FailFast -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy FailFast
forall {k} (t :: k). Proxy t
Proxy :: Proxy FailFast)]

-- | testable monads can map to IO a Tasty Result
class (MonadCatch m, MonadIO m, Monad m, Typeable m) => TestableMonad m where
    runCase :: m Result -> IO Result

instance TestableMonad IO where
    runCase :: IO Result -> IO Result
runCase = IO Result -> IO Result
forall a. a -> a
id

-- | any testable monad can make a BDDTest a tasty test
instance
    (Typeable t, TestableMonad m)
    => IsTest (BDDTest m t ())
    where
    run :: OptionSet -> BDDTest m t () -> (Progress -> IO ()) -> IO Result
run OptionSet
os (BDDTest [t -> m ()]
ts [TestContext m]
rup m t
w) Progress -> IO ()
f = m Result -> IO Result
forall (m :: * -> *). TestableMonad m => m Result -> IO Result
runCase (m Result -> IO Result) -> m Result -> IO Result
forall a b. (a -> b) -> a -> b
$ do
        (teardowns, acquisitionFailure) <- [TestContext m] -> m ([m ()], Maybe (m Result))
forall (m :: * -> *).
MonadCatch m =>
[TestContext m] -> m ([m ()], Maybe (m Result))
acquireAll [TestContext m]
rup
        outcome <- case acquisitionFailure of
            Just m Result
rethrow -> Either (m Result) (Maybe String)
-> m (Either (m Result) (Maybe String))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (m Result) (Maybe String)
 -> m (Either (m Result) (Maybe String)))
-> Either (m Result) (Maybe String)
-> m (Either (m Result) (Maybe String))
forall a b. (a -> b) -> a -> b
$ m Result -> Either (m Result) (Maybe String)
forall a b. a -> Either a b
Left m Result
rethrow
            Maybe (m Result)
Nothing -> (Maybe String -> Either (m Result) (Maybe String)
forall a b. b -> Either a b
Right (Maybe String -> Either (m Result) (Maybe String))
-> m (Maybe String) -> m (Either (m Result) (Maybe String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (m t
w m t -> (t -> m (Maybe String)) -> m (Maybe String)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t -> m (Maybe String)
loop)) m (Either (m Result) (Maybe String))
-> (SomeException -> m (Either (m Result) (Maybe String)))
-> m (Either (m Result) (Maybe String))
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAll` (Either (m Result) (Maybe String)
-> m (Either (m Result) (Maybe String))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (m Result) (Maybe String)
 -> m (Either (m Result) (Maybe String)))
-> (SomeException -> Either (m Result) (Maybe String))
-> SomeException
-> m (Either (m Result) (Maybe String))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m Result -> Either (m Result) (Maybe String)
forall a b. a -> Either a b
Left (m Result -> Either (m Result) (Maybe String))
-> (SomeException -> m Result)
-> SomeException
-> Either (m Result) (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> m Result
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM)
        let stepsPassed = (m Result -> Bool)
-> (Maybe String -> Bool)
-> Either (m Result) (Maybe String)
-> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> m Result -> Bool
forall a b. a -> b -> a
const Bool
False) Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Either (m Result) (Maybe String)
outcome
        teardownFailure <- case lookupOption os of
            FailFast Bool
True | Bool -> Bool
not Bool
stepsPassed -> Maybe (m Result) -> m (Maybe (m Result))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (m Result)
forall a. Maybe a
Nothing
            FailFast
_ -> [m ()] -> m (Maybe (m Result))
forall (m :: * -> *).
MonadCatch m =>
[m ()] -> m (Maybe (m Result))
releaseAll [m ()]
teardowns
        case (outcome, teardownFailure) of
            (Left m Result
rethrow, Maybe (m Result)
_) -> m Result
rethrow
            (Right (Just String
reason), Maybe (m Result)
_) -> Result -> m Result
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> m Result) -> Result -> m Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testFailed String
reason
            (Right Maybe String
Nothing, Just m Result
rethrow) -> m Result
rethrow
            (Right Maybe String
Nothing, Maybe (m Result)
Nothing) -> Result -> m Result
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> m Result) -> Result -> m Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testPassed String
""
      where
        loop :: t -> m (Maybe String)
loop t
resultOfWhen = [t -> m ()] -> m (Maybe String)
go [t -> m ()]
ts
          where
            go :: [t -> m ()] -> m (Maybe String)
go [] = Maybe String -> m (Maybe String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
            go (t -> m ()
then' : [t -> m ()]
xs) = do
                IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
                    Progress -> IO ()
f
                        ( String -> Float -> Progress
Progress
                            String
""
                            (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([t -> m ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [t -> m ()]
xs) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([t -> m ()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [t -> m ()]
ts))
                        )
                (t -> m ()
then' t
resultOfWhen m () -> m (Maybe String) -> m (Maybe String)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [t -> m ()] -> m (Maybe String)
go [t -> m ()]
xs)
                    m (Maybe String)
-> (EqualityDoesntHold -> m (Maybe String)) -> m (Maybe String)
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(EqualityDoesntHold String
e) -> Maybe String -> m (Maybe String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
e))
    testOptions :: Tagged (BDDTest m t ()) [OptionDescription]
testOptions = [OptionDescription] -> Tagged (BDDTest m t ()) [OptionDescription]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Proxy FailFast -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy FailFast
forall {k} (t :: k). Proxy t
Proxy :: Proxy FailFast)]

{- | Run the acquisitions in order, stopping at the first that throws.
Returns the teardowns of the acquired resources, most recent first, and,
if an acquisition threw, the action rethrowing its exception.
-}
acquireAll
    :: (MonadCatch m)
    => [TestContext m]
    -> m ([m ()], Maybe (m Result))
acquireAll :: forall (m :: * -> *).
MonadCatch m =>
[TestContext m] -> m ([m ()], Maybe (m Result))
acquireAll = [m ()] -> [TestContext m] -> m ([m ()], Maybe (m Result))
forall {m :: * -> *} {m :: * -> *} {a}.
(MonadCatch m, MonadThrow m) =>
[m ()] -> [TestContext m] -> m ([m ()], Maybe (m a))
go []
  where
    go :: [m ()] -> [TestContext m] -> m ([m ()], Maybe (m a))
go [m ()]
held [] = ([m ()], Maybe (m a)) -> m ([m ()], Maybe (m a))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([m ()]
held, Maybe (m a)
forall a. Maybe a
Nothing)
    go [m ()]
held (TestContext m r
g r -> m ()
a : [TestContext m]
cs) = do
        acquired <- (r -> Either (m a) r
forall a b. b -> Either a b
Right (r -> Either (m a) r) -> m r -> m (Either (m a) r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m r
g) m (Either (m a) r)
-> (SomeException -> m (Either (m a) r)) -> m (Either (m a) r)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAll` (Either (m a) r -> m (Either (m a) r)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (m a) r -> m (Either (m a) r))
-> (SomeException -> Either (m a) r)
-> SomeException
-> m (Either (m a) r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Either (m a) r
forall a b. a -> Either a b
Left (m a -> Either (m a) r)
-> (SomeException -> m a) -> SomeException -> Either (m a) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM)
        case acquired of
            Left m a
rethrow -> ([m ()], Maybe (m a)) -> m ([m ()], Maybe (m a))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([m ()]
held, m a -> Maybe (m a)
forall a. a -> Maybe a
Just m a
rethrow)
            Right r
r -> [m ()] -> [TestContext m] -> m ([m ()], Maybe (m a))
go (r -> m ()
a r
r m () -> [m ()] -> [m ()]
forall a. a -> [a] -> [a]
: [m ()]
held) [TestContext m]
cs

{- | Run every teardown in order, even when one throws. Returns the action
rethrowing the exception of the first teardown that threw, if any.
-}
releaseAll :: (MonadCatch m) => [m ()] -> m (Maybe (m Result))
releaseAll :: forall (m :: * -> *).
MonadCatch m =>
[m ()] -> m (Maybe (m Result))
releaseAll = (Maybe (m Result) -> m () -> m (Maybe (m Result)))
-> Maybe (m Result) -> [m ()] -> m (Maybe (m Result))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Maybe (m Result) -> m () -> m (Maybe (m Result))
forall {m :: * -> *} {m :: * -> *} {a} {a}.
(MonadCatch m, MonadThrow m) =>
Maybe (m a) -> m a -> m (Maybe (m a))
release Maybe (m Result)
forall a. Maybe a
Nothing
  where
    release :: Maybe (m a) -> m a -> m (Maybe (m a))
release Maybe (m a)
first m a
td =
        (m a
td m a -> m (Maybe (m a)) -> m (Maybe (m a))
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (m a) -> m (Maybe (m a))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (m a)
first)
            m (Maybe (m a))
-> (SomeException -> m (Maybe (m a))) -> m (Maybe (m a))
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAll` \SomeException
e -> Maybe (m a) -> m (Maybe (m a))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (m a) -> m (Maybe (m a))) -> Maybe (m a) -> m (Maybe (m a))
forall a b. (a -> b) -> a -> b
$ m a -> Maybe (m a)
forall a. a -> Maybe a
Just (m a -> Maybe (m a)) -> m a -> Maybe (m a)
forall a b. (a -> b) -> a -> b
$ m a -> Maybe (m a) -> m a
forall a. a -> Maybe a -> a
fromMaybe (SomeException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM SomeException
e) Maybe (m a)
first

-- | show a coloured difference of 2 values
prettyDifferences :: (ToExpr a) => a -> a -> String
prettyDifferences :: forall a. ToExpr a => a -> a -> String
prettyDifferences a
a1 a
a2 =
    Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Edit EditExpr -> Doc
ansiWlEditExpr (Edit EditExpr -> Doc) -> Edit EditExpr -> Doc
forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Edit EditExpr
exprDiff (a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
a1) (a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
a2)

-- internal exception to trigger visual inspection on output
newtype EqualityDoesntHold = EqualityDoesntHold {EqualityDoesntHold -> String
testFailMessage :: String}
    deriving (Int -> EqualityDoesntHold -> ShowS
[EqualityDoesntHold] -> ShowS
EqualityDoesntHold -> String
(Int -> EqualityDoesntHold -> ShowS)
-> (EqualityDoesntHold -> String)
-> ([EqualityDoesntHold] -> ShowS)
-> Show EqualityDoesntHold
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EqualityDoesntHold -> ShowS
showsPrec :: Int -> EqualityDoesntHold -> ShowS
$cshow :: EqualityDoesntHold -> String
show :: EqualityDoesntHold -> String
$cshowList :: [EqualityDoesntHold] -> ShowS
showList :: [EqualityDoesntHold] -> ShowS
Show)

instance Exception EqualityDoesntHold

infixl 4 @?=

-- | equality test which show pretty differences on fail
(@?=) :: (ToExpr a, Eq a, Typeable a, MonadThrow m) => a -> a -> m ()
a
a1 @?= :: forall a (m :: * -> *).
(ToExpr a, Eq a, Typeable a, MonadThrow m) =>
a -> a -> m ()
@?= a
a2 =
    if a
a1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a2
        then () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else
            EqualityDoesntHold -> m ()
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (EqualityDoesntHold -> m ()) -> EqualityDoesntHold -> m ()
forall a b. (a -> b) -> a -> b
$
                String -> EqualityDoesntHold
EqualityDoesntHold (String -> EqualityDoesntHold) -> String -> EqualityDoesntHold
forall a b. (a -> b) -> a -> b
$
                    String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Expected equality:\n%s" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
                        a -> a -> String
forall a. ToExpr a => a -> a -> String
prettyDifferences a
a1 a
a2

-- | inequality test which show pretty differences on fail
(@?/=) :: (ToExpr a, Eq a, Typeable a, MonadThrow m) => a -> a -> m ()
a
a1 @?/= :: forall a (m :: * -> *).
(ToExpr a, Eq a, Typeable a, MonadThrow m) =>
a -> a -> m ()
@?/= a
a2 =
    if a
a1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
a2
        then () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else
            EqualityDoesntHold -> m ()
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (EqualityDoesntHold -> m ()) -> EqualityDoesntHold -> m ()
forall a b. (a -> b) -> a -> b
$
                String -> EqualityDoesntHold
EqualityDoesntHold (String -> EqualityDoesntHold) -> String -> EqualityDoesntHold
forall a b. (a -> b) -> a -> b
$
                    String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Expected inequality:\n%s" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
                        a -> a -> String
forall a. ToExpr a => a -> a -> String
prettyDifferences a
a1 a
a2

{- | shortcut to ignore the input and run another action instead in Then
matching equality
-}
(^?=)
    :: (ToExpr a, Eq a, Typeable a, MonadThrow m) => m a -> a -> b -> m ()
m a
f ^?= :: forall a (m :: * -> *) b.
(ToExpr a, Eq a, Typeable a, MonadThrow m) =>
m a -> a -> b -> m ()
^?= a
t = m () -> b -> m ()
forall a b. a -> b -> a
const (m () -> b -> m ()) -> m () -> b -> m ()
forall a b. (a -> b) -> a -> b
$ m a
f m a -> (a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> a -> m ()
forall a (m :: * -> *).
(ToExpr a, Eq a, Typeable a, MonadThrow m) =>
a -> a -> m ()
@?= a
t)

{- | shortcut to ignore the input and run another action instead in Then
matching inequality
-}
(^?/=)
    :: (ToExpr a, Eq a, Typeable a, MonadThrow m) => m a -> a -> b -> m ()
m a
f ^?/= :: forall a (m :: * -> *) b.
(ToExpr a, Eq a, Typeable a, MonadThrow m) =>
m a -> a -> b -> m ()
^?/= a
t = m () -> b -> m ()
forall a b. a -> b -> a
const (m () -> b -> m ()) -> m () -> b -> m ()
forall a b. (a -> b) -> a -> b
$ m a
f m a -> (a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> a -> m ()
forall a (m :: * -> *).
(ToExpr a, Eq a, Typeable a, MonadThrow m) =>
a -> a -> m ()
@?/= a
t)

-- | interpret a 'Language' scenario to a single 'TestTree'
testBehavior
    :: (MonadIO m, TestableMonad m, Typeable t)
    => String
    -- ^ test name
    -> BDDPreparing m t ()
    -- ^ bdd test definition
    -> TestTree
    -- ^ resulting tasty test
testBehavior :: forall (m :: * -> *) t.
(MonadIO m, TestableMonad m, Typeable t) =>
String -> BDDPreparing m t () -> TestTree
testBehavior String
s = String -> BDDTest m t () -> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest String
s (BDDTest m t () -> TestTree)
-> (BDDPreparing m t () -> BDDTest m t ())
-> BDDPreparing m t ()
-> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BDDPreparing m t () -> BDDTest m t ()
forall (m :: * -> *) t q (a :: Phase).
Monad m =>
Language m t q a -> BDDTest m t q
interpret

-- | specialize withResource to prepend an action
before :: IO () -> TestTree -> TestTree
before :: IO () -> TestTree -> TestTree
before IO ()
f = IO () -> (() -> IO ()) -> (IO () -> TestTree) -> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource IO ()
f () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((IO () -> TestTree) -> TestTree)
-> (TestTree -> IO () -> TestTree) -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTree -> IO () -> TestTree
forall a b. a -> b -> a
const

-- | specialize withResource to append an action
after :: IO () -> TestTree -> TestTree
after :: IO () -> TestTree -> TestTree
after IO ()
f = IO () -> (() -> IO ()) -> (IO () -> TestTree) -> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (IO () -> () -> IO ()
forall a b. a -> b -> a
const IO ()
f) ((IO () -> TestTree) -> TestTree)
-> (TestTree -> IO () -> TestTree) -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTree -> IO () -> TestTree
forall a b. a -> b -> a
const

-- | recursively prepend an action
beforeEach :: IO () -> TestTree -> TestTree
beforeEach :: IO () -> TestTree -> TestTree
beforeEach = (TestTree -> TestTree) -> TestTree -> TestTree
onEach ((TestTree -> TestTree) -> TestTree -> TestTree)
-> (IO () -> TestTree -> TestTree) -> IO () -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> TestTree -> TestTree
before

-- | recursively modify a 'TestTree'
onEach :: (TestTree -> TestTree) -> TestTree -> TestTree
onEach :: (TestTree -> TestTree) -> TestTree -> TestTree
onEach TestTree -> TestTree
op t :: TestTree
t@(SingleTest String
_ t
_) = TestTree -> TestTree
op TestTree
t
onEach TestTree -> TestTree
op (TestGroup String
n [TestTree]
ts) = String -> [TestTree] -> TestTree
TestGroup String
n ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$ ((TestTree -> TestTree) -> [TestTree] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
map ((TestTree -> TestTree) -> [TestTree] -> [TestTree])
-> (TestTree -> TestTree) -> [TestTree] -> [TestTree]
forall a b. (a -> b) -> a -> b
$ (TestTree -> TestTree) -> TestTree -> TestTree
onEach TestTree -> TestTree
op) [TestTree]
ts
onEach TestTree -> TestTree
op (WithResource ResourceSpec a
spec IO a -> TestTree
rf) = ResourceSpec a -> (IO a -> TestTree) -> TestTree
forall a. ResourceSpec a -> (IO a -> TestTree) -> TestTree
WithResource ResourceSpec a
spec ((IO a -> TestTree) -> TestTree) -> (IO a -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ (TestTree -> TestTree) -> TestTree -> TestTree
onEach TestTree -> TestTree
op (TestTree -> TestTree) -> (IO a -> TestTree) -> IO a -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> TestTree
rf
onEach TestTree -> TestTree
op (AskOptions OptionSet -> TestTree
rf) = (OptionSet -> TestTree) -> TestTree
AskOptions ((OptionSet -> TestTree) -> TestTree)
-> (OptionSet -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ (TestTree -> TestTree) -> TestTree -> TestTree
onEach TestTree -> TestTree
op (TestTree -> TestTree)
-> (OptionSet -> TestTree) -> OptionSet -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptionSet -> TestTree
rf
onEach TestTree -> TestTree
op (PlusTestOptions OptionSet -> OptionSet
g TestTree
t) = (OptionSet -> OptionSet) -> TestTree -> TestTree
PlusTestOptions OptionSet -> OptionSet
g (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ (TestTree -> TestTree) -> TestTree -> TestTree
onEach TestTree -> TestTree
op TestTree
t
onEach TestTree -> TestTree
op (After DependencyType
x Expr
y TestTree
t) = DependencyType -> Expr -> TestTree -> TestTree
After DependencyType
x Expr
y (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ (TestTree -> TestTree) -> TestTree -> TestTree
onEach TestTree -> TestTree
op TestTree
t

-- | recursively append an action
afterEach :: IO () -> TestTree -> TestTree
afterEach :: IO () -> TestTree -> TestTree
afterEach = (TestTree -> TestTree) -> TestTree -> TestTree
onEach ((TestTree -> TestTree) -> TestTree -> TestTree)
-> (IO () -> TestTree -> TestTree) -> IO () -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> TestTree -> TestTree
after

-- | specialize withResource to just acquire a resource
acquire :: (MonadIO m) => IO a -> (m a -> TestTree) -> TestTree
acquire :: forall (m :: * -> *) a.
MonadIO m =>
IO a -> (m a -> TestTree) -> TestTree
acquire IO a
f m a -> TestTree
g = IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource IO a
f (IO () -> a -> IO ()
forall a b. a -> b -> a
const (IO () -> a -> IO ()) -> IO () -> a -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (m a -> TestTree
g (m a -> TestTree) -> (IO a -> m a) -> IO a -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO)

-- | Acquire a resource and expose its value through the resource callback.
acquirePure :: IO a -> (a -> TestTree) -> TestTree
acquirePure :: forall a. IO a -> (a -> TestTree) -> TestTree
acquirePure IO a
f a -> TestTree
g = IO a -> (IO a -> TestTree) -> TestTree
forall (m :: * -> *) a.
MonadIO m =>
IO a -> (m a -> TestTree) -> TestTree
acquire IO a
f ((IO a -> TestTree) -> TestTree) -> (IO a -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ a -> TestTree
g (a -> TestTree) -> (IO a -> a) -> IO a -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> a
forall a. IO a -> a
unsafePerformIO

-- | Acquire a constructor-based scenario in IO and adapt it to Tasty.
testBehaviorIO
    :: (Typeable t, MonadIO m, TestableMonad m)
    => String
    -- ^ test name
    -> IO (BDDPreparing m t ())
    -- ^ bdd test definition
    -> TestTree
    -- ^ resulting tasty test
testBehaviorIO :: forall t (m :: * -> *).
(Typeable t, MonadIO m, TestableMonad m) =>
String -> IO (BDDPreparing m t ()) -> TestTree
testBehaviorIO String
s IO (BDDPreparing m t ())
f = IO (BDDPreparing m t ())
-> (BDDPreparing m t () -> TestTree) -> TestTree
forall a. IO a -> (a -> TestTree) -> TestTree
acquirePure IO (BDDPreparing m t ())
f (String -> BDDPreparing m t () -> TestTree
forall (m :: * -> *) t.
(MonadIO m, TestableMonad m, Typeable t) =>
String -> BDDPreparing m t () -> TestTree
testBehavior String
s)

-- | default test runner fail-fast aware
failFastTester :: TestTree -> IO ()
failFastTester :: TestTree -> IO ()
failFastTester = [Ingredient] -> TestTree -> IO ()
defaultMainWithIngredients [Ingredient]
failFastIngredients

-- | basic ingredients fail-fast aware
failFastIngredients :: [Ingredient]
failFastIngredients :: [Ingredient]
failFastIngredients = [Ingredient
listingTests, Ingredient -> Ingredient
failFast Ingredient
consoleTestReporter]