Try #2237:

lib/core-integration/cardano-wallet-core-integration.cabal

@@ -29,7 +29,8 @@ library
     ghc-options:
       -Werror
   build-depends:
-      QuickCheck
+      HUnit
+    , QuickCheck
     , aeson
     , aeson-qq
     , async

lib/core-integration/src/Test/Integration/Framework/DSL.hs

@@ -236,11 +236,9 @@ import Control.Concurrent
 import Control.Concurrent.Async
     ( async, race, wait )
 import Control.Exception
-    ( SomeException (..), catch )
+    ( Exception (..), SomeException (..), catch, throwIO )
 import Control.Monad
     ( forM_, join, unless, void )
-import Control.Monad.Fail
-    ( MonadFail (..) )
 import Control.Monad.IO.Class
     ( MonadIO, liftIO )
 import Control.Retry
@@ -289,8 +287,7 @@ import Network.HTTP.Types.Method
     ( Method )
 import Numeric.Natural
     ( Natural )
-import Prelude hiding
-    ( fail )
+import Prelude
 import System.Command
     ( CmdResult, Stderr, Stdout (..), command )
 import System.Directory
@@ -310,6 +307,8 @@ import Test.Hspec
     ( Expectation, HasCallStack, expectationFailure )
 import Test.Hspec.Expectations.Lifted
     ( shouldBe, shouldContain, shouldSatisfy )
+import Test.HUnit.Lang
+    ( FailureReason (..), HUnitFailure (..) )
 import Test.Integration.Faucet
     ( nextTxBuilder, nextWallet )
 import Test.Integration.Framework.Context
@@ -349,7 +348,7 @@ import qualified Network.HTTP.Types.Status as HTTP
 
 -- | Expect an error response, without any further assumptions.
 expectError
-    :: (HasCallStack, MonadIO m, MonadFail m, Show a)
+    :: (HasCallStack, MonadIO m, Show a)
     => (s, Either RequestException a)
     -> m ()
 expectError (_, res) = case res of
@@ -358,22 +357,22 @@ expectError (_, res) = case res of
 
 -- | Expect an error response, without any further assumptions.
 expectErrorMessage
-    :: (HasCallStack, MonadIO m, MonadFail m, Show a)
+    :: (HasCallStack, MonadIO m, Show a)
     => String
     -> (s, Either RequestException a)
     -> m ()
-expectErrorMessage want (_, res) = case res of
+expectErrorMessage want (_, res) = liftIO $ case res of
     Left (DecodeFailure msg)  ->
         BL8.unpack msg `shouldContain` want
     Left (ClientError _)  ->
-        fail "expectErrorMessage: asserting ClientError not supported yet"
+        expectationFailure "expectErrorMessage: asserting ClientError not supported yet"
     Left (HttpException _) ->
-        fail "expectErrorMessage: asserting HttpException not supported yet"
+        expectationFailure "expectErrorMessage: asserting HttpException not supported yet"
     Right a -> wantedErrorButSuccess a
 
 -- | Expect a successful response, without any further assumptions.
 expectSuccess
-    :: (HasCallStack, MonadIO m, MonadFail m)
+    :: (HasCallStack, MonadIO m)
     => (s, Either RequestException a)
     -> m ()
 expectSuccess (_, res) = case res of
@@ -397,7 +396,7 @@ expectResponseCode want (got, a) =
             ]
 
 expectField
-    :: (HasCallStack, MonadIO m, MonadFail m, Show a)
+    :: (HasCallStack, MonadIO m, Show a)
     => Lens' s a
     -> (a -> Expectation)
     -> (HTTP.Status, Either RequestException s)
@@ -409,35 +408,35 @@ expectField getter predicate (_, res) = case res of
         liftIO $ predicate a
 
 expectListField
-    :: (HasCallStack, MonadIO m, MonadFail m, Show a)
+    :: (HasCallStack, MonadIO m, Show a)
     => Int
     -> Lens' s a
     -> (a -> Expectation)
     -> (HTTP.Status, Either RequestException [s])
     -> m ()
-expectListField i getter predicate (c, res) = case res of
+expectListField i getter predicate (c, res) = liftIO $ case res of
     Left e -> wantedSuccessButError e
     Right xs
         | length xs > i ->
             expectField getter predicate (c, Right (xs !! i))
-        | otherwise -> fail $
+        | otherwise -> expectationFailure $
             "expectListField: trying to access the #" <> show i <>
             " element from a list but there's none! "
 
 -- | Expects data list returned by the API to be of certain length
 expectListSize
-    :: (HasCallStack, MonadIO m, MonadFail m, Foldable xs)
+    :: (HasCallStack, MonadIO m, Foldable xs)
     => Int
     -> (HTTP.Status, Either RequestException (xs a))
     -> m ()
-expectListSize l (_, res) = case res of
+expectListSize l (_, res) = liftIO $ case res of
     Left e   -> wantedSuccessButError e
     Right xs -> length (toList xs) `shouldBe` l
 
 -- | Expects wallet UTxO statistics from the request to be equal to
 -- pre-calculated statistics.
 expectWalletUTxO
-    :: (HasCallStack, MonadIO m, MonadFail m)
+    :: (HasCallStack, MonadIO m)
     => [Word64]
     -> Either RequestException ApiUtxoStatistics
     -> m ()
@@ -463,30 +462,31 @@ expectWalletUTxO coins = \case
 -- | Expects a given string to be a valid JSON output corresponding to some
 -- given data-type 'a'. Returns this type if successful.
 expectValidJSON
-    :: forall m a. (HasCallStack, MonadFail m, FromJSON a)
+    :: forall m a. (HasCallStack, FromJSON a, MonadIO m)
     => Proxy a
     -> String
     -> m a
-expectValidJSON _ str =
+expectValidJSON _ str = liftIO $
     case Aeson.eitherDecode @a (BL.fromStrict $ T.encodeUtf8 $ T.pack str) of
-        Left e -> fail $ "expected valid JSON but failed decoding: " <> show e
+        Left e ->
+            expectationFailure' $ "expected valid JSON but failed decoding: " <> show e
         Right a -> return a
 
 expectCliListField
-    :: (HasCallStack, MonadIO m, MonadFail m, Show a)
+    :: (HasCallStack, MonadIO m, Show a)
     => Int
     -> Lens' s a
     -> (a -> Expectation)
     -> [s]
     -> m ()
 expectCliListField i getter predicate xs
         | length xs > i = expectCliField getter predicate (xs !! i)
-        | otherwise = fail $
+        | otherwise = liftIO . expectationFailure $
             "expectCliListField: trying to access the #" <> show i <>
             " element from a list but there's none! "
 
 expectCliField
-    :: (HasCallStack, MonadIO m, MonadFail m, Show a)
+    :: (HasCallStack, MonadIO m, Show a)
     => Lens' s a
     -> (a -> Expectation)
     -> s
@@ -592,14 +592,14 @@ waitForNextEpoch ctx = do
     eventually "waitForNextEpoch: goes to next epoch" $ do
         epoch' <- getFromResponse (#nodeTip . #slotId . #epochNumber) <$>
             request @ApiNetworkInformation ctx Link.getNetworkInfo Default Empty
-        unless (getApiT epoch' > getApiT epoch) $ fail "not yet"
+        unless (getApiT epoch' > getApiT epoch) $ expectationFailure "not yet"
 
 between :: (Ord a, Show a) => (a, a) -> a -> Expectation
 between (min', max') x
     | min' <= x && x <= max'
         = return ()
     | otherwise
-        = fail $ mconcat
+        = expectationFailure $ mconcat
             [ show x
             , " ∉ ["
             , show min'
@@ -612,7 +612,7 @@ x .> bound
     | x > bound
         = return ()
     | otherwise
-        = fail $ mconcat
+        = expectationFailure $ mconcat
             [ show x
             , " does not satisfy (> "
             , show bound
@@ -624,19 +624,20 @@ x .< bound
     | x < bound
         = return ()
     | otherwise
-        = fail $ mconcat
+        = expectationFailure $ mconcat
             [ show x
             , " does not satisfy (< "
             , show bound
             , ")"
             ]
 
+
 (.>=) :: (Ord a, Show a) => a -> a -> Expectation
 a .>= b
     | a >= b
         = return ()
     | otherwise
-        = fail $ mconcat
+        = expectationFailure $ mconcat
             [ show a
             , " does not satisfy (>= "
             , show b
@@ -648,13 +649,20 @@ a .<= b
     | a <= b
         = return ()
     | otherwise
-        = fail $ mconcat
+        = expectationFailure $ mconcat
             [ show a
             , " does not satisfy (<= "
             , show b
             , ")"
             ]
 
+-- | Like @expectationFailure@, but with a @IO a@ return type instead of @IO
+-- ()@.
+expectationFailure' :: HasCallStack => String -> IO a
+expectationFailure' msg = do
+    expectationFailure msg
+    fail "expectationFailure': impossible"
+
 -- Retry the given action a couple of time until it doesn't throw, or until it
 -- has been retried enough.
 --
@@ -687,13 +695,15 @@ eventuallyUsingDelay delay desc io = do
     case winner of
         Left () -> do
             lastError <- readIORef lastErrorRef
-            fail $ mconcat
-                [ "Waited longer than 90s (more than 2 epochs) for an action to resolve. "
-                , "Action: "
-                , show desc
-                , ". Error condition: "
-                , show lastError
-                ]
+            let msg = "Waited longer than 90s (more than 2 epochs) to resolve action: " ++ show desc ++ "."
+            case fromException @HUnitFailure =<< lastError of
+                Just lastError' -> throwIO $ appendFailureReason msg lastError'
+                Nothing ->
+                    expectationFailure' $ mconcat
+                        [ msg
+                        , " Error condition: "
+                        , show lastError
+                        ]
         Right a ->
             return a
   where
@@ -910,7 +920,8 @@ fixtureWalletWithMnemonics ctx = do
     (_, w) <- unsafeRequest @ApiWallet ctx
         (Link.postWallet @'Shelley) payload
     race (threadDelay sixtySeconds) (checkBalance w) >>= \case
-        Left _ -> fail "fixtureWallet: waited too long for initial transaction"
+        Left _ ->
+            expectationFailure' "fixtureWallet: waited too long for initial transaction"
         Right a -> return (a, mnemonics)
   where
     sixtySeconds = 60*oneSecond
@@ -1044,7 +1055,7 @@ fixtureLegacyWallet ctx style mnemonics = do
         (Link.postWallet @'Byron) payload
     race (threadDelay sixtySeconds) (checkBalance w) >>= \case
         Left _ ->
-            fail "fixtureByronWallet: waited too long for initial transaction"
+            expectationFailure' "fixtureByronWallet: waited too long for initial transaction"
         Right a ->
             return a
   where
@@ -1422,22 +1433,54 @@ unsafeCreateDigest s = fromMaybe
     (digestFromByteString $ B8.pack $ T.unpack s)
 
 wantedSuccessButError
-    :: (MonadFail m, Show e)
+    :: (MonadIO m, Show e)
     => e
-    -> m void
-wantedSuccessButError =
-    fail . ("expected a successful response but got an error: " <>) . show
+    -> m ()
+wantedSuccessButError = liftIO
+    . expectationFailure
+    . ("expected a successful response but got an error: " <>)
+    . show
 
 wantedErrorButSuccess
-    :: (MonadFail m, Show a)
+    :: (MonadIO m, Show a)
     => a
-    -> m void
-wantedErrorButSuccess =
-    fail . ("expected an error but got a successful response: " <>) . show
+    -> m ()
+wantedErrorButSuccess = liftIO
+    .  expectationFailure
+    . ("expected an error but got a successful response: " <>)
+    . show
 
 -- | Apply 'a' to all actions in sequence
-verify :: (Monad m) => a -> [a -> m ()] -> m ()
-verify a = mapM_ (a &)
+verify :: Show a => a -> [a -> IO ()] -> IO ()
+verify a = counterexample msg . mapM_ (a &)
+  where
+    msg = "While verifying " ++ show a
+
+-- | Can be used to add context to a @HUnitFailure@.
+--
+-- >>> counterexample (show reponse) (0 `shouldBe` 3)
+-- >>>  (Status {statusCode = 200, statusMessage = "OK"},Right [])
+-- >>>        expected: 3
+-- >>>         but got: 0
+counterexample :: String -> IO a -> IO a
+counterexample msg = (`catch` (throwIO . appendFailureReason msg))
+
+appendFailureReason :: String -> HUnitFailure -> HUnitFailure
+appendFailureReason message = wrap
+  where
+    wrap :: HUnitFailure -> HUnitFailure
+    wrap (HUnitFailure mloc reason) =
+        HUnitFailure mloc (addMessageTo reason)
+
+    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
 
 --
 -- Manipulating endpoints