test and fix: seed exception context does not survive being thrown

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

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

test/README.lhs

@@ -11,6 +11,7 @@ dependencies. We use this interface to generate fixtures for automated testing.
 
 <!--
 ```haskell
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
@@ -32,7 +33,11 @@ dependencies. We use this interface to generate fixtures for automated testing.
 
 module Main (module Main) where
 
-import Control.Exception (try, Exception(..))
+import Control.Exception (try, Exception(..), SomeException)
+#if MIN_VERSION_base(4,20,0)
+import Control.Exception (someExceptionContext)
+import Control.Exception.Context (getExceptionAnnotations)
+#endif
 import Control.Monad.IO.Class
 import Control.Monad.IO.Unlift
 import Control.Monad.Logger (NoLoggingT)
@@ -42,6 +47,9 @@ import Database.Persist.Sqlite
 import Database.Persist.TH
 import GHC.Generics (Generic)
 import Graphula
+#if MIN_VERSION_base(4,20,0)
+import Graphula.ExceptionContext (GraphulaExceptionContext (..))
+#endif
 import Test.Hspec
 import Test.QuickCheck
 import Test.QuickCheck.Arbitrary.Generic
@@ -207,6 +215,42 @@ context more ergonomic in the future.
 
 [ghc-docs]: https://hackage-content.haskell.org/package/base-4.22.0.0/docs/Control-Exception-Context.html
 
+```haskell
+seedPrefixesHUnitFailureSpec :: IO ()
+seedPrefixesHUnitFailureSpec = do
+  result <- try $ runGraphulaT (Just 1) runDB $ do
+    liftIO $ (1 :: Int) `shouldBe` 2
+
+  case result :: Either SomeException () of
+    Left ex -> show ex `shouldContain` "Graphula with seed: 1"
+    Right () -> expectationFailure "expected an exception"
+
+#if MIN_VERSION_base(4,20,0)
+seedExceptionContextSpec :: IO ()
+seedExceptionContextSpec = do
+  result <- try $ runGraphulaT (Just 2) runDB $ do
+    liftIO $ (1 :: Int) `shouldBe` 2
+
+  case result :: Either SomeException () of
+    Left ex -> seedsInContext ex `shouldBe` [2]
+    Right () -> expectationFailure "expected an exception"
+
+seedExceptionContextNonHUnitFailureSpec :: IO ()
+seedExceptionContextNonHUnitFailureSpec = do
+  result <- try $ runGraphulaT (Just 3) runDB $ do
+    liftIO $ ioError $ userError "boom"
+
+  case result :: Either SomeException () of
+    Left ex -> seedsInContext ex `shouldBe` [3]
+    Right () -> expectationFailure "expected an exception"
+
+seedsInContext :: SomeException -> [Int]
+seedsInContext ex =
+  map graphulaExceptionContextSeed
+    $ getExceptionAnnotations (someExceptionContext ex)
+#endif
+```
+
 ## Running It
 
 ```haskell
@@ -240,6 +284,11 @@ main = hspec $
     it "generates and links arbitrary graphs of data" simpleSpec
     it "allows logging graphs" loggingSpec
     it "shows informative generation failures" generationFailureSpec
+    it "prefixes HUnitFailure reasons with the seed" seedPrefixesHUnitFailureSpec
+#if MIN_VERSION_base(4,20,0)
+    it "adds the seed to exception context, for HUnitFailure" seedExceptionContextSpec
+    it "adds the seed to exception context, for other exceptions" seedExceptionContextNonHUnitFailureSpec
+#endif
 
 runDB :: MonadUnliftIO m => ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> m a
 runDB f = runSqlite "test.db" $ do