Возможно ли с помощью HSpec (или HUnit) добавить дополнительную информацию к утверждениям, которые выводятся на печать и только в случае сбоя?

Question

Аналогично тому, как quickcheck поддерживает контрпримеры:

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

но таким образом, что это работает с shouldBeнапример,

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

И я хотел бы напечатать что-то вроде:

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

Answer 1

Да, это возможно

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

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

Мы ловим исключение, брошенное shouldBe, исправьте сообщение и сбросьте его.

Мы можем даже использовать это как:

1 `shouldBe` 2
  $> failDetails "foobar"

если мы определим:

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

Answer 2

Вдохновленный ответом @Wizek, здесь версия работает с более новой версией HUnit и подходит для использования с Selenium/WebDriver.

Он соответствующим образом распаковывает и переупаковывает различные конструкторы FailureReason.

Ключевым отличием является использование Control.Monad.Catch, который позволяет работать с WD, а не с IO.

Также нет необходимости писать $> оператор - уже есть & из 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