Is it possible with HSpec (or HUnit) to attach further information to assertions that get printed in and only in case of failure?

Question

Similarly to how quickcheck supports counterexamples:

property \x ->
  counterexample ("Foo failed with: " ++ ...) $
    foo x

but in a way that it works with shouldBe, e.g.

failDetails (" details: " ++ baz a) $
  a `shouldBe` 2

And I would like it to print something along the lines of:

expected: 2
 but got: 3
 details: ...

Answer 1

Yes, it seems to be possible:

import Control.Exception
import Test.HUnit.Lang (HUnitFailure(..))

failDetails details assert = do
  assert `catch` \(HUnitFailure loc msg) -> do
    throw $ HUnitFailure loc $ msg ++ "\n" ++ details

We catch the exception thrown by shouldBe, amend the message, and rethrow it.

We can even use it like:

1 `shouldBe` 2
  $> failDetails "foobar"

if we define:

($>) = flip ($)
infixl 0 $>
{-# INLINE ($>) #-}

Answer 2

Inspired by @Wizek's answer, here's a version works with a newer version of HUnit and that is suitable for use with Selenium/WebDriver.

It unpacks and repacks FailureReason's different constructors appropriately

The key difference is the use of Control.Monad.Catch which lets you work with WD as opposed to IO.

Also there's no need to write the $> operator - there's already & from Data.Function

import Test.HUnit.Lang
import Control.Monad.Catch
import qualified Data.Text as Text
import Data.Function ((&))

failDetails :: Text -> WD () -> WD ()
failDetails textMessage expectation =
  expectation `catch` \(HUnitFailure loc reason) ->
    throwM $ HUnitFailure loc $ addMessageTo reason
  where
  message :: String 
  message = Text.unpack textMessage

  addMessageTo :: FailureReason -> FailureReason
  addMessageTo (Reason reason) = Reason $ reason ++ "\n" ++ message
  addMessageTo (ExpectedButGot preface expected actual) = 
    ExpectedButGot newPreface expected actual
    where
    newPreface = 
      case preface of 
      Nothing -> Just message
      Just existingMessage -> Just $ existingMessage ++ "\n" ++ message