diff --git a/src/Graphula.hs b/src/Graphula.hs index 14cf9b5..87bde53 100755 --- a/src/Graphula.hs +++ b/src/Graphula.hs @@ -169,7 +169,7 @@ import Test.HUnit.Lang ) import Test.QuickCheck (Arbitrary (..)) import Test.QuickCheck.Random (QCGen, mkQCGen) -import UnliftIO.Exception (Exception (..), SomeException, catch, throwIO) +import UnliftIO.Exception (Exception (..), SomeException, catch) -- | A constraint over lists of nodes for 'MonadGraphula', and 'GraphulaNode'. -- @@ -265,8 +265,7 @@ runGraphulaT mSeed runDB action = do logFailingSeed :: MonadIO m => Int -> SomeException -> m a logFailingSeed seed = - throwIO - . addExceptionContext (GraphulaExceptionContext seed) + throwWithGraphulaExceptionContext (GraphulaExceptionContext seed) . whenException (prefixHUnitFailure ("Graphula with seed: " <> show seed)) prefixHUnitFailure :: String -> HUnitFailure -> HUnitFailure diff --git a/src/Graphula/ExceptionContext.hs b/src/Graphula/ExceptionContext.hs index 88ef433..cd6bacf 100644 --- a/src/Graphula/ExceptionContext.hs +++ b/src/Graphula/ExceptionContext.hs @@ -3,16 +3,18 @@ module Graphula.ExceptionContext ( GraphulaExceptionContext (..) - , addExceptionContext + , throwWithGraphulaExceptionContext ) where import Prelude +import Control.Exception (SomeException (..), throwIO) +import Control.Monad.IO.Class (MonadIO, liftIO) + #if MIN_VERSION_base(4,20,0) -import Control.Exception (addExceptionContext) +import Control.Exception (ExceptionWithContext (..), someExceptionContext) import Control.Exception.Annotation (ExceptionAnnotation) -#else -import Control.Exception (SomeException) +import Control.Exception.Context (addExceptionAnnotation) #endif newtype GraphulaExceptionContext = GraphulaExceptionContext @@ -22,11 +24,24 @@ newtype GraphulaExceptionContext = GraphulaExceptionContext #if MIN_VERSION_base(4,20,0) instance ExceptionAnnotation GraphulaExceptionContext -#else -addExceptionContext - :: a - -- ^ Argument ignored due to @base < 4.20@ - -> SomeException +#endif + +-- | Attach the seed as exception context, then rethrow +-- +-- On @base < 4.20@, where exception context does not exist, this simply +-- rethrows the given exception unchanged. +throwWithGraphulaExceptionContext + :: MonadIO m + => GraphulaExceptionContext -> SomeException -addExceptionContext _ = id + -> m a +#if MIN_VERSION_base(4,20,0) +throwWithGraphulaExceptionContext ctx ex@(SomeException e) = + liftIO + . throwIO + $ ExceptionWithContext + (addExceptionAnnotation ctx (someExceptionContext ex)) + e +#else +throwWithGraphulaExceptionContext _ctx ex = liftIO $ throwIO ex #endif diff --git a/test/README.lhs b/test/README.lhs index 66b82af..53ddd79 100644 --- a/test/README.lhs +++ b/test/README.lhs @@ -11,6 +11,7 @@ dependencies. We use this interface to generate fixtures for automated testing.