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/src/Graphula.hs b/src/Graphula.hs index 3b60d3c..edd8539 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 #-} @@ -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 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 () ```