feat: add seed via exception context

fourmolu.yaml

@@ -3,13 +3,22 @@ column-limit: 80 # ignored until v12 / ghc-9.6
 function-arrows: leading
 comma-style: leading # default
 import-export-style: leading
+import-grouping: # needs fourmolu >= v0.17
+  - name: "Preludes"
+    rules:
+      - glob: Prelude
+  - name: "Everything else"
+    rules:
+      - match: all
+        priority: 100
 indent-wheres: false # default
 record-brace-space: true
 newlines-between-decls: 1 # default
 haddock-style: single-line
 let-style: mixed
 in-style: left-align
 single-constraint-parens: never # ignored until v12 / ghc-9.6
+trailing-section-operators: false # needs fourmolu >= v0.17
 unicode: never # default
 respectful: true # default
 fixities: [] # default

graphula.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.38.1.
+-- This file has been generated from package.yaml by hpack version 0.39.1.
 --
 -- see: https://github.com/sol/hpack
 
@@ -35,6 +35,7 @@ library
       Graphula.Class
       Graphula.Dependencies
       Graphula.Dependencies.Generic
+      Graphula.ExceptionContext
       Graphula.Idempotent
       Graphula.Key
       Graphula.Logged

src/Graphula.hs

@@ -156,6 +156,7 @@ import qualified Database.Persist as Persist
 import Database.Persist.Sql (SqlBackend)
 import Graphula.Class
 import Graphula.Dependencies
+import Graphula.ExceptionContext
 import Graphula.Idempotent
 import Graphula.Logged
 import Graphula.NoConstraint
@@ -168,7 +169,7 @@ import Test.HUnit.Lang
   )
 import Test.QuickCheck (Arbitrary (..))
 import Test.QuickCheck.Random (QCGen, mkQCGen)
-import UnliftIO.Exception (catch, throwIO)
+import UnliftIO.Exception (Exception (..), SomeException, catch, throwIO)
 
 -- | A constraint over lists of nodes for 'MonadGraphula', and 'GraphulaNode'.
 --
@@ -262,12 +263,24 @@ runGraphulaT mSeed runDB action = do
   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)
+logFailingSeed :: MonadIO m => Int -> SomeException -> m a
+logFailingSeed seed =
+  throwIO
+    . addExceptionContext (GraphulaExceptionContext seed)
+    . whenException (prefixHUnitFailure ("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
+prefixHUnitFailure :: String -> HUnitFailure -> HUnitFailure
+prefixHUnitFailure message (HUnitFailure l r) =
+  HUnitFailure l . Reason $ message ++ "\n\n" ++ formatFailureReason r
+
+-- | Apply a function to a 'SomeException' when it's the expected type
+whenException
+  :: Exception e
+  => (e -> e)
+  -- ^ Function to apply if 'fromException' at this type returns 'Just'
+  -> SomeException
+  -> SomeException
+whenException f ex = maybe ex (toException . f) $ fromException ex
 
 type GraphulaNode m a =
   ( HasDependencies a

src/Graphula/ExceptionContext.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DerivingStrategies #-}
+
+module Graphula.ExceptionContext
+  ( GraphulaExceptionContext (..)
+  , addExceptionContext
+  ) where
+
+import Prelude
+
+#if MIN_VERSION_base(4,20,0)
+import Control.Exception (addExceptionContext)
+import Control.Exception.Annotation (ExceptionAnnotation)
+#else
+import Control.Exception (SomeException)
+#endif
+
+newtype GraphulaExceptionContext = GraphulaExceptionContext
+  { graphulaExceptionContextSeed :: Int
+  }
+  deriving stock (Show)
+
+#if MIN_VERSION_base(4,20,0)
+instance ExceptionAnnotation GraphulaExceptionContext
+#else
+addExceptionContext
+  :: a
+  -- ^ Argument ignored due to @base < 4.20@
+  -> SomeException
+  -> SomeException
+addExceptionContext _ = id
+#endif

test/README.lhs

@@ -192,6 +192,21 @@ generationFailureSpec = do
     Right _ -> pure ()
 ```
 
+## Seed
+
+`HUnitFailure` exceptions will have their reason prefixed by the seed used for
+Graphula's arbitrary data, making it visible in expectation-failure messages.
+Re-supplying this seed to `runGraphulaT` will reproduce the same graph, to
+hopefully reproduce intermittent test failures caused by randomness.
+
+If using `base >= 4.20`, **all** exceptions will also have this seed added to
+the [exception's context][ghc-docs]. This won't be visible anywhere (besides
+`HUnitFailure`) by default, but can be extracted through custom exception
+handling, e.g. in a `SpecHook`. We hope tools like `hspec` make using exception
+context more ergonomic in the future.
+
+[ghc-docs]: https://hackage-content.haskell.org/package/base-4.22.0.0/docs/Control-Exception-Context.html
+
 ## Running It
 
 ```haskell