From 62ce201e5aaf7219c6673699218b0434fecfb901 Mon Sep 17 00:00:00 2001
From: Chris Martin <chris.martin@renaissance.com>
Date: Wed, 5 Aug 2026 14:22:46 -0600
Subject: [PATCH 1/2] test: add specs for seed exception context

Adds a baseline spec confirming the HUnitFailure seed-prefix still
works, plus two specs asserting the GraphulaExceptionContext seed
annotation is present in someExceptionContext after runGraphulaT
rethrows. Both context specs currently fail: logFailingSeed's
`throwIO . addExceptionContext ctx . whenException f` pattern loses
all context (including one just added) because `throwIO`/`toException`
on a `SomeException` unconditionally resets its context to empty
before re-populating with an automatic backtrace annotation. This
happens regardless of whether the caught exception is an HUnitFailure
or already carried its own context.

Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com>
---
 test/README.lhs | 51 ++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 50 insertions(+), 1 deletion(-)

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.
 
 <!--
 ```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

From ceef3fbf4db4f8da491981a28c3f88b0b4269594 Mon Sep 17 00:00:00 2001
From: Chris Martin <chris.martin@renaissance.com>
Date: Mon, 10 Aug 2026 15:51:02 -0600
Subject: [PATCH 2/2] fix: preserve exception context when rethrowing with the
 seed

throwIO's toException resets a SomeException's context to empty before
re-raising (per its own Haddock, "This drops any attached
ExceptionContext"), and UnliftIO.Exception.throwIO makes this worse by
always routing through toSyncException, converting back to a
SomeException and re-triggering the same reset even if the caller built
a context-preserving value beforehand. Both of these unconditionally
discarded the seed annotation logFailingSeed tried to attach, and any
context the caught exception already had.

throwWithGraphulaExceptionContext fixes this: it pattern-matches the
caught SomeException open to recover the original concrete exception,
wraps *that* in ExceptionWithContext (whose own toException sets the
context directly instead of resetting it, and never needs to
"flatten" a nested SomeException since there isn't one), and throws it
via Control.Exception.throwIO directly, bypassing UnliftIO's wrapper.
All of the base-version-conditional logic, and the only CPP in this
change, lives in Graphula.ExceptionContext; Graphula.hs calls the new
function unconditionally.

Verified against both base-4.20.1.0 (ghc-9.10.3, via stack-lts24.yaml)
and base-4.21.2.0 (ghc-9.12.4, via cabal): all specs pass under both,
including generationFailureSpec, which briefly regressed under
base-4.20.1.0 in an earlier version of this fix that wrapped the
SomeException directly instead of unwrapping it first.

Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com>
---
 src/Graphula.hs                  |  5 ++---
 src/Graphula/ExceptionContext.hs | 35 +++++++++++++++++++++++---------
 2 files changed, 27 insertions(+), 13 deletions(-)

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