ExceptionHandling.hs

-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | Exception handling
module Test.Cleveland.Internal.Actions.ExceptionHandling
  ( module Test.Cleveland.Internal.Actions.ExceptionHandling
  ) where

import Data.Either.Validation (Validation(..))
import Data.List.NonEmpty qualified as NE
import Fmt (Builder, build, indentF, nameF, pretty, unlinesF)

import Lorentz (CustomError(..), ErrorTagMap, IsError, Label, MText, MustHaveErrorArg)
import Lorentz.Constraints
import Test.Cleveland.Internal.Abstract
import Test.Cleveland.Internal.Actions.Assertions
import Test.Cleveland.Internal.Actions.Helpers
import Test.Cleveland.Internal.Actions.Misc
import Test.Cleveland.Internal.Actions.TransferFailurePredicate
import Test.Cleveland.Internal.Client qualified as Client (TestError(..))
import Test.Cleveland.Internal.Exceptions (WithCallStack(..))
import Test.Cleveland.Internal.Pure as Pure (TestError(..))

-- | Attempt to run an action and return its result or, if interpretation fails, an error.
attempt
  :: forall e caps m a. (HasCallStack, MonadCleveland caps m, Exception e)
  => m a -> m (Either e a)
attempt action = do
  caps <- ask
  let action' :: ClevelandBaseMonad caps a = runReaderT action caps
  lift $ cmiAttempt (getMiscCap caps) action'

-- | Asserts that a transfer should fail, and returns the exception.
catchTransferFailure :: (HasCallStack, MonadCleveland caps m) => m a -> m TransferFailure
catchTransferFailure action =
  attempt action >>= \case
    Left err -> return err
    Right _ -> runIO $ throwM UnexpectedSuccess

-- | Asserts that a transfer should fail, and runs some 'TransferFailurePredicate's over the
-- exception.
--
-- > expectTransferFailure (failedWith (constant @MText "NOT_ADMIN")) $
-- >   call contractAddr (Call @"Ep") arg
--
-- > call contractAddr (Call @"Ep") arg & expectTransferFailure
-- >   ( failedWith (customError #tag 3) &&
-- >     addressIs contractAddr
-- >   )
expectTransferFailure :: (HasCallStack, MonadCleveland caps m) => TransferFailurePredicate -> m a -> m ()
expectTransferFailure predicate act = do
  err <- catchTransferFailure act
  checkTransferFailure err predicate

-- | Check whether a given predicate holds for a given 'TransferFailure'.
checkTransferFailure :: (HasCallStack, MonadCleveland caps m) => TransferFailure -> TransferFailurePredicate -> m ()
checkTransferFailure err predicate =
  case go predicate of
    Success () -> pass
    Failure expectedOutcome -> failure $ unlinesF
      [ "Expected transfer to fail with an error such that:"
      , ""
      , indentF 2 $ unlinesF expectedOutcome
      , ""
      , "But these conditions were not met."
      , "Actual transfer error:"
      , indentF 2 $ build err
      ]
  where
    go :: TransferFailurePredicate -> Validation (NonEmpty Builder) ()
    go = \case
      AndPredicate ps ->
        first (fmtExpectedOutcomes "AND") (traverse_ go ps)
      OrPredicate ps ->
        case traverse_ go ps of
          Success () -> Success ()
          Failure expectedOutcomes ->
            if length expectedOutcomes == length ps
              -- If all sub-predicates failed, then this predicate failed.
              then Failure $ fmtExpectedOutcomes "OR" expectedOutcomes
              -- If at least 1 sub-predicate succeeded, then this predicate succeeded.
              else Success ()
      TransferFailurePredicate p -> first one $ p err

    fmtExpectedOutcomes :: Builder -> NonEmpty Builder -> NonEmpty Builder
    fmtExpectedOutcomes delimiter = \case
      expectedOutcome :| [] -> one expectedOutcome
      expectedOutcomes ->
        one $ unlinesF
          [ "("
          , indentF 2 $ unlinesF $ NE.intersperse delimiter expectedOutcomes
          , ")"
          ]

-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given constant
-- value.
expectFailedWith
  :: forall err a caps m
   . (HasCallStack, MonadCleveland caps m, NiceConstant err)
  => err -> m a -> m ()
expectFailedWith err = expectTransferFailure $ failedWith (constant err)

-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz
-- error.
expectError
  :: forall err a caps m
   . (HasCallStack, MonadCleveland caps m, IsError err)
  => err -> m a -> m ()
expectError err = expectTransferFailure $ failedWith (lerror err)

-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given custom
-- lorentz error.
expectCustomError
  :: forall arg a tag caps m
   . ( HasCallStack, MonadCleveland caps m
     , IsError (CustomError tag)
     , MustHaveErrorArg tag (MText, arg)
     )
  => Label tag -> arg -> m a -> m ()
expectCustomError tag arg = expectTransferFailure $ failedWith (customError tag arg)

-- | Version of 'expectCustomError' for error with @unit@ argument.
expectCustomError_
  :: ( HasCallStack, MonadCleveland caps m
     , IsError (CustomError tag)
     , MustHaveErrorArg tag (MText, ())
     )
  => Label tag -> m a -> m ()
expectCustomError_ tag = expectCustomError tag ()

-- | Version of 'expectCustomError' specialized for expecting @NoErrorArg@s.
expectCustomErrorNoArg
  :: ( HasCallStack, MonadCleveland caps m
     , IsError (CustomError tag)
     , MustHaveErrorArg tag MText
     )
  => Label tag -> m a -> m ()
expectCustomErrorNoArg tag = expectTransferFailure $ failedWith (customErrorNoArg tag)

-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz
-- numeric error.
expectNumericError
  :: forall err a caps m
   . (HasCallStack, MonadCleveland caps m, IsError err)
  => ErrorTagMap -> err -> m a -> m ()
expectNumericError tagMap err = expectTransferFailure $ failedWith (numericError tagMap err)

-- | Prefix /scenario-custom/ error messages (i.e. @CustomTestError@ either from pure or non-pure
-- implementation), potentially thrown from the given code block.
--
-- The prefix will be put at a separate line before the main text, if text is multiline, otherwise
-- it will be separated from the main text with @: @.
--
-- This affects errors produced by functions like 'failure', 'assert', '@==', etc.
-- Errors related to events in the chain will not be touched.
--
-- Example:
--
-- > for [1..10] \i -> clarifyErrors ("For i=" +| i |+ "") $
-- >   askContract i @@== i * 2
clarifyErrors :: forall caps m a. (MonadCleveland caps m)
              => Builder -> m a -> m a
clarifyErrors message action = do
  attempt action >>= \case
    Left (e :: SomeException) -> withCap getMiscCap \cap -> cmiThrow cap (handle e)
    Right val -> pure val
  where
  handle :: SomeException -> SomeException
  handle e = fromMaybe e $
        wrap testClientErrorHandler e
    <|> wrap testPureErrorHandler e
    <|> wrap withCallStackErrorHandler e

  wrap f = fmap (toException . f) . fromException

  addPrefix = pretty . nameF message . build

  testClientErrorHandler :: Client.TestError -> Client.TestError
  testClientErrorHandler = \case
    Client.CustomTestError msg -> Client.CustomTestError $ addPrefix msg

  testPureErrorHandler :: Pure.TestError -> Pure.TestError
  testPureErrorHandler = \case
    Pure.CustomTestError msg -> Pure.CustomTestError $ addPrefix msg
    err -> err

  withCallStackErrorHandler :: WithCallStack -> WithCallStack
  withCallStackErrorHandler (WithCallStack cst e) = WithCallStack cst $ handle e