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

{-# OPTIONS_HADDOCK not-home #-}

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

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

import Lorentz
  (CustomError(..), ErrorTagMap, IsError, Label, MText, MustHaveErrorArg, errorTagToMText)
import Lorentz.Constraints
import Morley.Micheline.Class (fromExpression)
import Morley.Michelson.Untyped qualified as U
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.Exceptions

-- | 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 :: forall e caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Exception e) =>
m a -> m (Either e a)
attempt m a
action = do
  caps
caps <- m caps
forall r (m :: * -> *). MonadReader r m => m r
ask
  let ClevelandBaseMonad caps a
action' :: ClevelandBaseMonad caps a = ReaderT caps (ClevelandBaseMonad caps) a
-> caps -> ClevelandBaseMonad caps a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT m a
ReaderT caps (ClevelandBaseMonad caps) a
action caps
caps
  ClevelandBaseMonad caps (Either e a)
-> ReaderT caps (ClevelandBaseMonad caps) (Either e a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ClevelandBaseMonad caps (Either e a)
 -> ReaderT caps (ClevelandBaseMonad caps) (Either e a))
-> ClevelandBaseMonad caps (Either e a)
-> ReaderT caps (ClevelandBaseMonad caps) (Either e a)
forall a b. (a -> b) -> a -> b
$ ClevelandMiscImpl (ClevelandBaseMonad caps)
-> forall a e.
   (Exception e, HasCallStack) =>
   ClevelandBaseMonad caps a -> ClevelandBaseMonad caps (Either e a)
forall (m :: * -> *).
ClevelandMiscImpl m
-> forall a e. (Exception e, HasCallStack) => m a -> m (Either e a)
cmiAttempt (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap caps
caps) ClevelandBaseMonad caps a
action'

-- | Asserts that a transfer should fail, and returns the exception.
catchTransferFailure :: (HasCallStack, MonadCleveland caps m) => m a -> m TransferFailure
catchTransferFailure :: forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
m a -> m TransferFailure
catchTransferFailure m a
action =
  m a -> m (Either TransferFailure a)
forall e caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Exception e) =>
m a -> m (Either e a)
attempt m a
action m (Either TransferFailure a)
-> (Either TransferFailure a -> m TransferFailure)
-> m TransferFailure
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left TransferFailure
err -> TransferFailure -> m TransferFailure
forall (m :: * -> *) a. Monad m => a -> m a
return TransferFailure
err
    Right a
_ -> IO TransferFailure -> m TransferFailure
forall caps (m :: * -> *) res.
(HasCallStack, MonadCleveland caps m) =>
IO res -> m res
runIO (IO TransferFailure -> m TransferFailure)
-> IO TransferFailure -> m TransferFailure
forall a b. (a -> b) -> a -> b
$ GenericTestError -> IO TransferFailure
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM GenericTestError
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 :: forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
TransferFailurePredicate -> m a -> m ()
expectTransferFailure TransferFailurePredicate
predicate m a
act = do
  TransferFailure
err <- m a -> m TransferFailure
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
m a -> m TransferFailure
catchTransferFailure m a
act
  TransferFailure -> TransferFailurePredicate -> m ()
forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
TransferFailure -> TransferFailurePredicate -> m ()
checkTransferFailure TransferFailure
err TransferFailurePredicate
predicate

-- | Check whether a given predicate holds for a given 'TransferFailure'.
checkTransferFailure :: (HasCallStack, MonadCleveland caps m) => TransferFailure -> TransferFailurePredicate -> m ()
checkTransferFailure :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
TransferFailure -> TransferFailurePredicate -> m ()
checkTransferFailure TransferFailure
err TransferFailurePredicate
predicate =
  case TransferFailurePredicate -> Maybe Builder
go TransferFailurePredicate
predicate of
    Maybe Builder
Nothing -> m ()
forall (f :: * -> *). Applicative f => f ()
pass
    Just Builder
expectedOutcome -> Builder -> m ()
forall a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Builder -> m a
failure (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
      [ Builder
"Expected transfer to fail with an error such that:"
      , Builder
""
      , Int -> Builder -> Builder
indentF Int
2 Builder
expectedOutcome
      , Builder
""
      , Builder
"But these conditions were not met."
      , Builder
"Actual transfer error:"
      , Int -> Builder -> Builder
indentF Int
2 (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ TransferFailure -> Builder
forall p. Buildable p => p -> Builder
build TransferFailure
err
      ]
  where
    -- Collect descriptions of all failed predicates
    -- Note that 'Nothing' signifies success here, and Just is a failure description.
    go :: TransferFailurePredicate -> Maybe Builder
    go :: TransferFailurePredicate -> Maybe Builder
go = \case
      AndPredicate NonEmpty TransferFailurePredicate
ps -> (NonEmpty Builder -> Builder)
-> Maybe (NonEmpty Builder) -> Maybe Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Builder -> NonEmpty Builder -> Builder
fmtExpectedOutcomes Builder
"AND") (Maybe (NonEmpty Builder) -> Maybe Builder)
-> ([TransferFailurePredicate] -> Maybe (NonEmpty Builder))
-> [TransferFailurePredicate]
-> Maybe Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder] -> Maybe (NonEmpty Builder)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Builder] -> Maybe (NonEmpty Builder))
-> ([TransferFailurePredicate] -> [Builder])
-> [TransferFailurePredicate]
-> Maybe (NonEmpty Builder)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TransferFailurePredicate -> Maybe Builder)
-> [TransferFailurePredicate] -> [Builder]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TransferFailurePredicate -> Maybe Builder
go ([TransferFailurePredicate] -> Maybe Builder)
-> [TransferFailurePredicate] -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ NonEmpty TransferFailurePredicate
-> [Element (NonEmpty TransferFailurePredicate)]
forall t. Container t => t -> [Element t]
toList NonEmpty TransferFailurePredicate
ps
        -- if all results are successful, i.e. 'Nothing', the result is 'Nothing'
      OrPredicate NonEmpty TransferFailurePredicate
ps -> Builder -> NonEmpty Builder -> Builder
fmtExpectedOutcomes Builder
"OR" (NonEmpty Builder -> Builder)
-> Maybe (NonEmpty Builder) -> Maybe Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TransferFailurePredicate -> Maybe Builder)
-> NonEmpty TransferFailurePredicate -> Maybe (NonEmpty Builder)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TransferFailurePredicate -> Maybe Builder
go NonEmpty TransferFailurePredicate
ps
        -- if there is at least one success, i.e. 'Nothing', the result is 'Nothing'
      TransferFailurePredicate TransferFailurePredicateDesc
desc TransferFailure -> Bool
p
        | TransferFailure -> Bool
p TransferFailure
err -> Maybe Builder
forall a. Maybe a
Nothing
        | Bool
otherwise -> Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ TransferFailurePredicateDesc -> Builder
forall p. Buildable p => p -> Builder
build TransferFailurePredicateDesc
desc

    fmtExpectedOutcomes :: Builder -> NonEmpty Builder -> Builder
    fmtExpectedOutcomes :: Builder -> NonEmpty Builder -> Builder
fmtExpectedOutcomes Builder
delimiter = \case
      Builder
expectedOutcome :| [] -> Builder
expectedOutcome
      NonEmpty Builder
expectedOutcomes ->
        [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
          [ Builder
"("
          , Int -> Builder -> Builder
indentF Int
2 (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ NonEmpty Builder -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF (NonEmpty Builder -> Builder) -> NonEmpty Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> NonEmpty Builder -> NonEmpty Builder
forall a. a -> NonEmpty a -> NonEmpty a
NE.intersperse Builder
delimiter NonEmpty Builder
expectedOutcomes
          , Builder
")"
          ]

-- | 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 :: forall err a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, NiceConstant err) =>
err -> m a -> m ()
expectFailedWith err
err = TransferFailurePredicate -> m a -> m ()
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
TransferFailurePredicate -> m a -> m ()
expectTransferFailure (TransferFailurePredicate -> m a -> m ())
-> TransferFailurePredicate -> m a -> m ()
forall a b. (a -> b) -> a -> b
$ SomeConstant -> TransferFailurePredicate
failedWith (err -> SomeConstant
forall err. NiceConstant err => err -> SomeConstant
constant err
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 :: forall err a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, IsError err) =>
err -> m a -> m ()
expectError err
err = TransferFailurePredicate -> m a -> m ()
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
TransferFailurePredicate -> m a -> m ()
expectTransferFailure (TransferFailurePredicate -> m a -> m ())
-> TransferFailurePredicate -> m a -> m ()
forall a b. (a -> b) -> a -> b
$ SomeConstant -> TransferFailurePredicate
failedWith (err -> SomeConstant
forall err. IsError err => err -> SomeConstant
lerror err
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 :: forall arg a (tag :: Symbol) caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, IsError (CustomError tag),
 MustHaveErrorArg tag (MText, arg)) =>
Label tag -> arg -> m a -> m ()
expectCustomError Label tag
tag arg
arg = TransferFailurePredicate -> m a -> m ()
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
TransferFailurePredicate -> m a -> m ()
expectTransferFailure (TransferFailurePredicate -> m a -> m ())
-> TransferFailurePredicate -> m a -> m ()
forall a b. (a -> b) -> a -> b
$ SomeConstant -> TransferFailurePredicate
failedWith (Label tag -> arg -> SomeConstant
forall arg (tag :: Symbol).
(IsError (CustomError tag), MustHaveErrorArg tag (MText, arg)) =>
Label tag -> arg -> SomeConstant
customError Label tag
tag arg
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_ :: forall caps (m :: * -> *) (tag :: Symbol) a.
(HasCallStack, MonadCleveland caps m, IsError (CustomError tag),
 MustHaveErrorArg tag (MText, ())) =>
Label tag -> m a -> m ()
expectCustomError_ Label tag
tag = Label tag -> () -> m a -> m ()
forall arg a (tag :: Symbol) caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, IsError (CustomError tag),
 MustHaveErrorArg tag (MText, arg)) =>
Label tag -> arg -> m a -> m ()
expectCustomError Label tag
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 :: forall caps (m :: * -> *) (tag :: Symbol) a.
(HasCallStack, MonadCleveland caps m, IsError (CustomError tag),
 MustHaveErrorArg tag MText) =>
Label tag -> m a -> m ()
expectCustomErrorNoArg Label tag
tag = TransferFailurePredicate -> m a -> m ()
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
TransferFailurePredicate -> m a -> m ()
expectTransferFailure (TransferFailurePredicate -> m a -> m ())
-> TransferFailurePredicate -> m a -> m ()
forall a b. (a -> b) -> a -> b
$ SomeConstant -> TransferFailurePredicate
failedWith (Label tag -> SomeConstant
forall (tag :: Symbol).
(IsError (CustomError tag), MustHaveErrorArg tag MText) =>
Label tag -> SomeConstant
customErrorNoArg Label tag
tag)

-- | Version of 'expectCustomError' that ignores the argument (or whether it
-- even exists) and only checks the tag.
expectCustomErrorAnyArg
  :: ( HasCallStack, MonadCleveland caps m )
  => Label tag -> m a -> m ()
expectCustomErrorAnyArg :: forall caps (m :: * -> *) (tag :: Symbol) a.
(HasCallStack, MonadCleveland caps m) =>
Label tag -> m a -> m ()
expectCustomErrorAnyArg Label tag
tag = TransferFailurePredicate -> m a -> m ()
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
TransferFailurePredicate -> m a -> m ()
expectTransferFailure (TransferFailurePredicate -> m a -> m ())
-> TransferFailurePredicate -> m a -> m ()
forall a b. (a -> b) -> a -> b
$ Builder -> (Expression -> Bool) -> TransferFailurePredicate
failedWithPredicate
  (Builder
"Contract failed with any custom error tagged with \"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MText -> Builder
forall p. Buildable p => p -> Builder
build MText
expectedTag Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\"")
  \Expression
expr ->
    -- the more "proper" way to handle this would be to go over all possible cases
    -- of 'CustomErrorArgRep', but it's polymorphic, and we don't have a wildcard
    -- in the typed representation, so we'd have to try to run 'fromExpression's
    -- for all possible argument types, and that's just not worth it.  So we use
    -- our knowledge of the untyped representation instead. -- @lierdakil
    (MText -> Maybe MText
forall a. a -> Maybe a
Just MText
expectedTag Maybe MText -> Maybe MText -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe MText -> Bool) -> Maybe MText -> Bool
forall a b. (a -> b) -> a -> b
$ forall a.
FromExp RegularExp a =>
Expression -> Either FromExpressionError a
fromExpression @U.Value Expression
expr Either FromExpressionError Value
-> (Either FromExpressionError Value -> Maybe Value) -> Maybe Value
forall a b. a -> (a -> b) -> b
& Either FromExpressionError Value -> Maybe Value
forall l r. Either l r -> Maybe r
rightToMaybe Maybe Value -> (Value -> Maybe MText) -> Maybe MText
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      U.ValueString MText
text -> MText -> Maybe MText
forall a. a -> Maybe a
Just MText
text
      U.ValuePair (U.ValueString MText
text) Value
_ -> MText -> Maybe MText
forall a. a -> Maybe a
Just MText
text
      -- right combs can be represented as sequences of at least two elements
      U.ValueSeq (U.ValueString MText
text :| Value
_ : [Value]
_) -> MText -> Maybe MText
forall a. a -> Maybe a
Just MText
text
      Value
_ -> Maybe MText
forall a. Maybe a
Nothing
  where
    expectedTag :: MText
expectedTag = Label tag -> MText
forall (tag :: Symbol). Label tag -> MText
errorTagToMText Label tag
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 :: forall err a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, IsError err) =>
ErrorTagMap -> err -> m a -> m ()
expectNumericError ErrorTagMap
tagMap err
err = TransferFailurePredicate -> m a -> m ()
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
TransferFailurePredicate -> m a -> m ()
expectTransferFailure (TransferFailurePredicate -> m a -> m ())
-> TransferFailurePredicate -> m a -> m ()
forall a b. (a -> b) -> a -> b
$ SomeConstant -> TransferFailurePredicate
failedWith (ErrorTagMap -> err -> SomeConstant
forall err. IsError err => ErrorTagMap -> err -> SomeConstant
numericError ErrorTagMap
tagMap err
err)

-- | Prefix error messages 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 :: forall caps (m :: * -> *) a.
MonadCleveland caps m =>
Builder -> m a -> m a
clarifyErrors Builder
message m a
action =
  m a -> m (Either SomeException a)
forall e caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Exception e) =>
m a -> m (Either e a)
attempt m a
action m (Either SomeException a)
-> (Either SomeException a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left SomeException
e -> (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps a)
-> ReaderT caps (ClevelandBaseMonad caps) a
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> forall a.
   HasCallStack =>
   SomeException -> ClevelandBaseMonad caps a
forall (m :: * -> *).
ClevelandMiscImpl m
-> forall a. HasCallStack => SomeException -> m a
cmiThrow ClevelandMiscImpl (ClevelandBaseMonad caps)
cap (SomeException -> ClevelandBaseMonad caps a)
-> SomeException -> ClevelandBaseMonad caps a
forall a b. (a -> b) -> a -> b
$
      ErrorsClarification -> SomeException -> SomeException
forall ann.
(Semigroup ann, ExceptionAnnotation ann) =>
ann -> SomeException -> SomeException
insertAnnEx ([Builder] -> ErrorsClarification
ErrorsClarification [Builder
message]) SomeException
e
    Right a
val -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val