From fac44863ea32628b9e527dd1b3444e59342a00d6 Mon Sep 17 00:00:00 2001
From: patrick brisbin <pbrisbin@gmail.com>
Date: Thu, 30 Jul 2026 14:22:58 -0400
Subject: [PATCH] feat: add seed via exception context

When supported (base-4.20), use `addExceptionContext` to add the seed to
the failure. This ensures it happens, not just with expectation failures
(`HUnitFailure`), but also with other thrown-exception failures, and
does so without altering the exception type (as `annotated-exception`
would).

In base lower than 4.20, behavior is unchanged.

Closes #44.

**CAVEAT**: this doesn't work :(

HUnit-based testing libraries (e.g hspec) have not updated themselves to
use or display exception context in their output. They would need to
incorporate it into `formatFailureMessage` for expectation failures.

Even if/when they do, this also doesn't even work for its intended
purpose (non-expectation-failure exceptions) because `hspec` (for
example) uses `show` or (optionally) `displayException`, neither of
which include context (which is wild, IMHO).

So, while it would be nice if we could use exception context for this
information, users would still need to update their test runners somehow
to ensure its displayed.

I know the `hspec` project is not amenable to displaying more
information like this in its output _by default_, but I think they do
plan to add some sort of `--verbose` flag. If/when that existed, I
think we could get them to include any exception context in such output,
and we could instruct our uses to use it if they want to see seed.

But is that how we want it to work? Or should we keep this behavior of
stuffing it into strings that we know are always displayed (and just
give up on #44)? I'm leaning this way.
---
 src/Graphula.hs | 41 ++++++++++++++++++++++++++++-------------
 1 file changed, 28 insertions(+), 13 deletions(-)

diff --git a/src/Graphula.hs b/src/Graphula.hs
index 3b60d3c..1bc4b37 100755
--- a/src/Graphula.hs
+++ b/src/Graphula.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -161,15 +163,35 @@ import Graphula.Logged
 import Graphula.NoConstraint
 import Graphula.Node
 import System.Random (randomIO)
-import Test.HUnit.Lang
-  ( FailureReason (..)
-  , HUnitFailure (..)
-  , formatFailureReason
-  )
 import Test.QuickCheck (Arbitrary (..))
 import Test.QuickCheck.Random (QCGen, mkQCGen)
+
+#if MIN_VERSION_base(4,20,0)
+import Control.Exception (addExceptionContext)
+import Control.Exception.Annotation (ExceptionAnnotation(..))
+import UnliftIO.Exception (mapExceptionM)
+
+newtype GraphulaSeed = GraphulaSeed Int
+  deriving stock (Show)
+  deriving anyclass (ExceptionAnnotation)
+
+addSeedContext :: MonadUnliftIO m => m a -> Int -> m a
+addSeedContext f seed = mapExceptionM (addExceptionContext (GraphulaSeed seed)) f
+#else
+import Test.HUnit.Lang (FailureReason (..) , HUnitFailure (..) , formatFailureReason)
 import UnliftIO.Exception (catch, throwIO)
 
+addSeedContext :: MonadUnliftIO m => m a -> Int -> m a
+addSeedContext f seed = f `catch` logFailingSeed seed
+
+logFailingSeed :: MonadIO m => Int -> HUnitFailure -> m a
+logFailingSeed seed = rethrowHUnitWith ("Graphula with seed: " ++ show seed)
+
+rethrowHUnitWith :: MonadIO m => String -> HUnitFailure -> m a
+rethrowHUnitWith message (HUnitFailure l r) =
+  throwIO . HUnitFailure l . Reason $ message ++ "\n\n" ++ formatFailureReason r
+#endif
+
 -- | A constraint over lists of nodes for 'MonadGraphula', and 'GraphulaNode'.
 --
 -- Helpful for defining utility functions over many nodes.
@@ -260,14 +282,7 @@ runGraphulaT mSeed runDB action = do
   seed <- maybe (liftIO randomIO) pure mSeed
   qcGen <- liftIO $ newIORef $ mkQCGen seed
   runReaderT (runGraphulaT' action) (Args (RunDB runDB) qcGen)
-    `catch` logFailingSeed seed
-
-logFailingSeed :: MonadIO m => Int -> HUnitFailure -> m a
-logFailingSeed seed = rethrowHUnitWith ("Graphula with seed: " ++ show seed)
-
-rethrowHUnitWith :: MonadIO m => String -> HUnitFailure -> m a
-rethrowHUnitWith message (HUnitFailure l r) =
-  throwIO . HUnitFailure l . Reason $ message ++ "\n\n" ++ formatFailureReason r
+    `addSeedContext` seed
 
 type GraphulaNode m a =
   ( HasDependencies a