{-# OPTIONS_HADDOCK not-home #-}
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
:: 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'
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
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
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
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
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
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
")"
]
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)
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)
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)
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 ()
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)
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 ->
(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
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
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)
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