Decorate exception-based failures with seed

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

package.yaml

@@ -63,6 +63,7 @@ tests:
       - test
 
     dependencies:
+      - HUnit
       - QuickCheck
       - generic-arbitrary
       - graphula

src/Graphula.hs

@@ -13,6 +13,7 @@
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -161,14 +162,16 @@ 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 (catch, throwIO)
+import UnliftIO.Exception
+  ( Handler (..)
+  , SomeException
+  , catches
+  , displayException
+  , throwIO
+  )
 
 -- | A constraint over lists of nodes for 'MonadGraphula', and 'GraphulaNode'.
 --
@@ -260,14 +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)
-    `catch` logFailingSeed seed
+    `catches` [ Handler $ throwIO . prefixHUnitFailure seed
+              , Handler $
+                  throwIO
+                    . prefixHUnitFailure seed
+                    . HUnitFailure Nothing
+                    . Reason
+                    . displayException @SomeException
+              ]
 
-logFailingSeed :: MonadIO m => Int -> HUnitFailure -> m a
-logFailingSeed seed = rethrowHUnitWith ("Graphula with seed: " ++ show seed)
+prefixHUnitFailure :: Int -> HUnitFailure -> HUnitFailure
+prefixHUnitFailure seed (HUnitFailure l r) =
+  HUnitFailure l $ prefaceFailureReason ("Graphula with seed: " <> show seed) r
 
-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 <> "\n\n") <>) mPreface)
+      expected
+      actual
 
 type GraphulaNode m a =
   ( HasDependencies a

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 ()
 ```