From 3a67a3a6dbf668a16dbfbe693f325a6b8f3c290a Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Mon, 15 Jun 2026 16:59:17 -0400 Subject: [PATCH 1/4] fix!: include seed on failures do to exceptions By making any `SomeException` an `HUnitFailure`, we can use our `logFailingSeed` function to ensure we include the seed on those failures too. This does break exception handling happening outside of `runGraphulaT`, since any external catches for not-`HUnitFailure` will no longer catch. --- src/Graphula.hs | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/src/Graphula.hs b/src/Graphula.hs index 3b60d3c..49f5279 100755 --- a/src/Graphula.hs +++ b/src/Graphula.hs @@ -13,6 +13,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -168,7 +169,13 @@ import Test.HUnit.Lang ) import Test.QuickCheck (Arbitrary (..)) import Test.QuickCheck.Random (QCGen, mkQCGen) -import UnliftIO.Exception (catch, throwIO) +import UnliftIO.Exception + ( Handler (..) + , SomeException + , catches + , displayException + , throwIO + ) -- | A constraint over lists of nodes for 'MonadGraphula', and 'GraphulaNode'. -- @@ -260,7 +267,14 @@ 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 + `catches` [ Handler $ logFailingSeed seed + , Handler $ + logFailingSeed seed + . HUnitFailure Nothing + . Reason + . displayException @SomeException + ] + logFailingSeed :: MonadIO m => Int -> HUnitFailure -> m a logFailingSeed seed = rethrowHUnitWith ("Graphula with seed: " ++ show seed) From a4b26d4a4b27c8bcd286fdee9edff93688b30064 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Mon, 15 Jun 2026 17:01:12 -0400 Subject: [PATCH 2/4] chore: refactor FailureReason message building Prefixing the text after using `formatFailureReason` erases the fact that the values was a `Reason` vs `ExpectedButGot`. The new approach prepends the text without changing the constructor. I doubt this matters, but it was easy enough and stops disrupting anyone inspecting such values (perhaps our JUnit formatter?). --- src/Graphula.hs | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/src/Graphula.hs b/src/Graphula.hs index 49f5279..d1fcb50 100755 --- a/src/Graphula.hs +++ b/src/Graphula.hs @@ -162,11 +162,7 @@ import Graphula.Logged import Graphula.NoConstraint import Graphula.Node import System.Random (randomIO) -import Test.HUnit.Lang - ( FailureReason (..) - , HUnitFailure (..) - , formatFailureReason - ) +import Test.HUnit.Lang (FailureReason (..), HUnitFailure (..)) import Test.QuickCheck (Arbitrary (..)) import Test.QuickCheck.Random (QCGen, mkQCGen) import UnliftIO.Exception @@ -267,21 +263,27 @@ runGraphulaT mSeed runDB action = do seed <- maybe (liftIO randomIO) pure mSeed qcGen <- liftIO $ newIORef $ mkQCGen seed runReaderT (runGraphulaT' action) (Args (RunDB runDB) qcGen) - `catches` [ Handler $ logFailingSeed seed + `catches` [ Handler $ throwIO . prefixHUnitFailure seed , Handler $ - logFailingSeed seed + throwIO + . prefixHUnitFailure seed . HUnitFailure Nothing . Reason . displayException @SomeException ] +prefixHUnitFailure :: Int -> HUnitFailure -> HUnitFailure +prefixHUnitFailure seed (HUnitFailure l r) = + HUnitFailure l $ prefaceFailureReason ("Graphula with seed: " <> show seed) r -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 +prefaceFailureReason :: String -> FailureReason -> FailureReason +prefaceFailureReason detail = \case + Reason msg -> Reason $ detail <> "\n\n" <> msg + ExpectedButGot mPreface expected actual -> + ExpectedButGot + (Just $ maybe detail ((detail <> ". ") <>) mPreface) + expected + actual type GraphulaNode m a = ( HasDependencies a From 73595f769ac3307500db4d2b003cc635df52490c Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Mon, 15 Jun 2026 17:07:14 -0400 Subject: [PATCH 3/4] chore: update tests for new exceptions --- graphula.cabal | 5 +++-- package.yaml | 1 + test/README.lhs | 10 ++++++---- 3 files changed, 10 insertions(+), 6 deletions(-) diff --git a/graphula.cabal b/graphula.cabal index c609d1a..a588a87 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 @@ -81,7 +81,8 @@ test-suite readme build-tool-depends: markdown-unlit:markdown-unlit build-depends: - QuickCheck + HUnit + , QuickCheck , base <5 , generic-arbitrary , graphula diff --git a/package.yaml b/package.yaml index 50ce2c2..7742ea5 100644 --- a/package.yaml +++ b/package.yaml @@ -63,6 +63,7 @@ tests: - test dependencies: + - HUnit - QuickCheck - generic-arbitrary - graphula diff --git a/test/README.lhs b/test/README.lhs index 343be64..48d19b4 100644 --- a/test/README.lhs +++ b/test/README.lhs @@ -32,17 +32,19 @@ 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) import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger (NoLoggingT) import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Trans.Resource (ResourceT) +import Data.List (isSuffixOf) import Database.Persist.Sqlite import Database.Persist.TH import GHC.Generics (Generic) import Graphula import Test.Hspec +import Test.HUnit.Lang (HUnitFailure (..), formatFailureReason) import Test.QuickCheck import Test.QuickCheck.Arbitrary.Generic @@ -186,9 +188,9 @@ generationFailureSpec = do nodeKeyed @School (entityKey school) () mempty case result of - Left ex -> - displayException @GenerationFailure ex - `shouldBe` "GenerationFailureMaxAttemptsToInsert (Just \"entity already exists by this key\") School" + Left (HUnitFailure _ r) -> + formatFailureReason r + `shouldSatisfy` ("GenerationFailureMaxAttemptsToInsert (Just \"entity already exists by this key\") School" `isSuffixOf`) Right _ -> pure () ``` From b2343d534be238d5a3ca9560cca720400b9784e1 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Mon, 15 Jun 2026 17:08:18 -0400 Subject: [PATCH 4/4] chore: prefix with line breaks --- src/Graphula.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Graphula.hs b/src/Graphula.hs index d1fcb50..edd8539 100755 --- a/src/Graphula.hs +++ b/src/Graphula.hs @@ -281,7 +281,7 @@ prefaceFailureReason detail = \case Reason msg -> Reason $ detail <> "\n\n" <> msg ExpectedButGot mPreface expected actual -> ExpectedButGot - (Just $ maybe detail ((detail <> ". ") <>) mPreface) + (Just $ maybe detail ((detail <> "\n\n") <>) mPreface) expected actual