From 56b5c344cefdb932dbe093d95a50f01edbfaea1f Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Mon, 3 Aug 2026 15:24:29 -0400 Subject: [PATCH 1/3] chore: tweak fourmolu for trailing-separator --- fourmolu.yaml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/fourmolu.yaml b/fourmolu.yaml index ef571e8..afa9418 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -3,6 +3,14 @@ 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 @@ -10,6 +18,7 @@ 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 From 7d9d205e1eea07d18562b06952f2f370f65d2bf0 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Thu, 30 Jul 2026 14:22:58 -0400 Subject: [PATCH 2/3] chore: refactor throw vs exception modification This moves the `throwIO` out of the function that is concretely `HUnitFailure`. This is because I'll next be adding something that needs to occur between those two points. --- src/Graphula.hs | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/src/Graphula.hs b/src/Graphula.hs index 3b60d3c..6ed0abb 100755 --- a/src/Graphula.hs +++ b/src/Graphula.hs @@ -168,7 +168,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 +262,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 = + throwIO + . 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 From 09ca82361a71e0df4c150ad86c66dfe3170978c6 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Mon, 3 Aug 2026 15:30:38 -0400 Subject: [PATCH 3/3] feat: add seed to exception context, if supported When using `base > 4.20` we add exception context that includes the graphula seed. Closes #44 as best we can. The information won't appear anywhere automatically, but can be pulled out (e.g.) via `SpecHook` for those that know (see README). This is a compromise. Given how `hspec` works today, any other method that would make the seed more visible for non-expectation-failure exceptions comes with too many negative trade-offs. --- graphula.cabal | 3 ++- src/Graphula.hs | 2 ++ src/Graphula/ExceptionContext.hs | 32 ++++++++++++++++++++++++++++++++ test/README.lhs | 15 +++++++++++++++ 4 files changed, 51 insertions(+), 1 deletion(-) create mode 100644 src/Graphula/ExceptionContext.hs diff --git a/graphula.cabal b/graphula.cabal index c609d1a..0a5357a 100644 --- a/graphula.cabal +++ b/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 diff --git a/src/Graphula.hs b/src/Graphula.hs index 6ed0abb..14cf9b5 100755 --- a/src/Graphula.hs +++ b/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 @@ -265,6 +266,7 @@ runGraphulaT mSeed runDB action = do logFailingSeed :: MonadIO m => Int -> SomeException -> m a logFailingSeed seed = throwIO + . addExceptionContext (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 new file mode 100644 index 0000000..88ef433 --- /dev/null +++ b/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 diff --git a/test/README.lhs b/test/README.lhs index 343be64..66b82af 100644 --- a/test/README.lhs +++ b/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