{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}

module Hedgehog.Extras.Test.MonadAssertion
  ( MonadAssertion(..)
  , assertFailure
  , assertFailure_
  , tryAssertion
  ) where

import           Control.Applicative (Applicative(..))
import           Control.Monad
import           Control.Monad.Trans.Class
import           Data.Either
import           Data.Function
import           Data.Functor ((<$>))
import           Data.Monoid
import           GHC.Stack (HasCallStack)
import           Hedgehog (MonadTest(..))
import           Hedgehog.Extras.Test.Prim
import           Text.Show (Show(..))

import qualified Control.Monad.Trans.Except as E
import qualified Control.Monad.Trans.Resource as IO
import qualified Control.Monad.Trans.Resource.Internal as IO
import qualified GHC.Stack as GHC
import qualified Hedgehog as H
import qualified Hedgehog.Internal.Property as H

class Monad m => MonadAssertion m where
  throwAssertion :: H.Failure -> m a
  catchAssertion :: m a -> (H.Failure -> m a) -> m a

instance Monad m => MonadAssertion (H.TestT m) where
  throwAssertion :: forall a. Failure -> TestT m a
throwAssertion Failure
f = Test a -> TestT m a
forall a. Test a -> TestT m a
forall (m :: * -> *) a. MonadTest m => Test a -> m a
H.liftTest (Test a -> TestT m a) -> Test a -> TestT m a
forall a b. (a -> b) -> a -> b
$ (Either Failure a, Journal) -> Test a
forall a. (Either Failure a, Journal) -> Test a
H.mkTest (Failure -> Either Failure a
forall a b. a -> Either a b
Left Failure
f, Journal
forall a. Monoid a => a
mempty)
  catchAssertion :: forall a. TestT m a -> (Failure -> TestT m a) -> TestT m a
catchAssertion TestT m a
g Failure -> TestT m a
h = ExceptT Failure (WriterT Journal m) a -> TestT m a
forall (m :: * -> *) a.
ExceptT Failure (WriterT Journal m) a -> TestT m a
H.TestT (ExceptT Failure (WriterT Journal m) a -> TestT m a)
-> ExceptT Failure (WriterT Journal m) a -> TestT m a
forall a b. (a -> b) -> a -> b
$ ExceptT Failure (WriterT Journal m) a
-> (Failure -> ExceptT Failure (WriterT Journal m) a)
-> ExceptT Failure (WriterT Journal m) a
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
E.catchE (TestT m a -> ExceptT Failure (WriterT Journal m) a
forall (m :: * -> *) a.
TestT m a -> ExceptT Failure (WriterT Journal m) a
H.unTest TestT m a
g) (TestT m a -> ExceptT Failure (WriterT Journal m) a
forall (m :: * -> *) a.
TestT m a -> ExceptT Failure (WriterT Journal m) a
H.unTest (TestT m a -> ExceptT Failure (WriterT Journal m) a)
-> (Failure -> TestT m a)
-> Failure
-> ExceptT Failure (WriterT Journal m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure -> TestT m a
h)

instance MonadAssertion m => MonadAssertion (IO.ResourceT m) where
  throwAssertion :: forall a. Failure -> ResourceT m a
throwAssertion = m a -> ResourceT m a
forall (m :: * -> *) a. Monad m => m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ResourceT m a)
-> (Failure -> m a) -> Failure -> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure -> m a
forall a. Failure -> m a
forall (m :: * -> *) a. MonadAssertion m => Failure -> m a
throwAssertion
  catchAssertion :: forall a.
ResourceT m a -> (Failure -> ResourceT m a) -> ResourceT m a
catchAssertion ResourceT m a
r Failure -> ResourceT m a
h = (IORef ReleaseMap -> m a) -> ResourceT m a
forall (m :: * -> *) a. (IORef ReleaseMap -> m a) -> ResourceT m a
IO.ResourceT ((IORef ReleaseMap -> m a) -> ResourceT m a)
-> (IORef ReleaseMap -> m a) -> ResourceT m a
forall a b. (a -> b) -> a -> b
$ \IORef ReleaseMap
i -> ResourceT m a -> IORef ReleaseMap -> m a
forall (m :: * -> *) a. ResourceT m a -> IORef ReleaseMap -> m a
IO.unResourceT ResourceT m a
r IORef ReleaseMap
i m a -> (Failure -> m a) -> m a
forall a. m a -> (Failure -> m a) -> m a
forall (m :: * -> *) a.
MonadAssertion m =>
m a -> (Failure -> m a) -> m a
`catchAssertion` \Failure
e -> ResourceT m a -> IORef ReleaseMap -> m a
forall (m :: * -> *) a. ResourceT m a -> IORef ReleaseMap -> m a
IO.unResourceT (Failure -> ResourceT m a
h Failure
e) IORef ReleaseMap
i

deriving instance Monad m => MonadAssertion (H.PropertyT m)

-- | Attempt to run a function that may assert, returning either a failure or the result of the assertion.
tryAssertion :: ()
  => MonadAssertion m
  => m a
  -> m (Either H.Failure a)
tryAssertion :: forall (m :: * -> *) a.
MonadAssertion m =>
m a -> m (Either Failure a)
tryAssertion m a
m =
  m (Either Failure a)
-> (Failure -> m (Either Failure a)) -> m (Either Failure a)
forall a. m a -> (Failure -> m a) -> m a
forall (m :: * -> *) a.
MonadAssertion m =>
m a -> (Failure -> m a) -> m a
catchAssertion (a -> Either Failure a
forall a b. b -> Either a b
Right (a -> Either Failure a) -> m a -> m (Either Failure a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
m) (Either Failure a -> m (Either Failure a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Failure a -> m (Either Failure a))
-> (Failure -> Either Failure a) -> Failure -> m (Either Failure a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure -> Either Failure a
forall a b. a -> Either a b
Left)

-- | Run the given action and succeed if the action fails, but fail if it succeeds.
assertFailure :: ()
  => HasCallStack
  => Show a
  => MonadAssertion m
  => MonadTest m
  => m a
  -> m H.Failure
assertFailure :: forall a (m :: * -> *).
(HasCallStack, Show a, MonadAssertion m, MonadTest m) =>
m a -> m Failure
assertFailure m a
f = do
  Either Failure a
result <- m a -> m (Either Failure a)
forall (m :: * -> *) a.
MonadAssertion m =>
m a -> m (Either Failure a)
tryAssertion m a
f
  case Either Failure a
result of
    Left Failure
e -> Failure -> m Failure
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Failure
e
    Right a
a -> CallStack -> String -> m Failure
forall (m :: * -> *) a. MonadTest m => CallStack -> String -> m a
failMessage CallStack
HasCallStack => CallStack
GHC.callStack (String -> m Failure) -> String -> m Failure
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
a

-- | Run the given action and succeed if the action fails, but fail if it succeeds.
assertFailure_ :: ()
  => HasCallStack
  => Show a
  => MonadAssertion m
  => MonadTest m
  => m a
  -> m ()
assertFailure_ :: forall a (m :: * -> *).
(HasCallStack, Show a, MonadAssertion m, MonadTest m) =>
m a -> m ()
assertFailure_ m a
f =
  (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
    m Failure -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Failure -> m ()) -> m Failure -> m ()
forall a b. (a -> b) -> a -> b
$ m a -> m Failure
forall a (m :: * -> *).
(HasCallStack, Show a, MonadAssertion m, MonadTest m) =>
m a -> m Failure
assertFailure m a
f