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)
 
 -- | A constraint over lists of nodes for 'MonadGraphula', and 'GraphulaNode'.
 --
@@ -262,12 +263,23 @@ 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 =
+  throwWithGraphulaExceptionContext (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,47 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DerivingStrategies #-}
+
+module Graphula.ExceptionContext
+  ( GraphulaExceptionContext (..)
+  , 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 (ExceptionWithContext (..), someExceptionContext)
+import Control.Exception.Annotation (ExceptionAnnotation)
+import Control.Exception.Context (addExceptionAnnotation)
+#endif
+
+newtype GraphulaExceptionContext = GraphulaExceptionContext
+  { graphulaExceptionContextSeed :: Int
+  }
+  deriving stock (Show)
+
+#if MIN_VERSION_base(4,20,0)
+instance ExceptionAnnotation GraphulaExceptionContext
+#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
+  -> 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
@@ -192,6 +200,57 @@ 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
+
+```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
@@ -225,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