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

module Hedgehog.Extras.Test.MonadAssertion
  ( MonadAssertion(..)
  ) where

import           Control.Monad
import           Control.Monad.Trans.Class
import           Data.Either
import           Data.Function
import           Data.Monoid (mempty)

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 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)