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

src/Graphula.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingStrategies #-}
@@ -133,6 +134,9 @@ module Graphula
   , NodeOptions
   , GenerateKey
   , NoConstraint
+#if MIN_VERSION_base(4,20,0)
+  , GraphulaSeed(..)
+#endif
   ) where
 
 import Prelude hiding (readFile)
@@ -168,7 +172,23 @@ 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)
+
+#if MIN_VERSION_base(4,20,0)
+import Control.Exception (addExceptionContext)
+import Control.Exception.Annotation (ExceptionAnnotation(..))
+
+newtype GraphulaSeed = GraphulaSeed Int
+  deriving stock (Show)
+
+instance ExceptionAnnotation GraphulaSeed
+
+addSeedContext :: Int -> SomeException -> SomeException
+addSeedContext seed = addExceptionContext $ GraphulaSeed seed
+#else
+addSeedContext :: Int -> SomeException -> SomeException
+addSeedContext _ = id
+#endif
 
 -- | A constraint over lists of nodes for 'MonadGraphula', and 'GraphulaNode'.
 --
@@ -262,12 +282,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
+    . addSeedContext seed
+    . whenException (prefixHUnitFailure ("Graphula with seed: " <> show seed))
+
+prefixHUnitFailure :: String -> HUnitFailure -> HUnitFailure
+prefixHUnitFailure message (HUnitFailure l r) =
+  HUnitFailure l . Reason $ message ++ "\n\n" ++ formatFailureReason r
 
-rethrowHUnitWith :: MonadIO m => String -> HUnitFailure -> m a
-rethrowHUnitWith message (HUnitFailure l r) =
-  throwIO . 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

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