{-# OPTIONS_HADDOCK not-home #-}
module Test.Cleveland.Internal.Actions.TransferFailurePredicate
( module Test.Cleveland.Internal.Actions.TransferFailurePredicate
) where
import Data.Either.Validation (Validation(..))
import Fmt (Builder, build)
import Lorentz
(CustomError(..), ErrorTagMap, IsError, Label, MText, MustHaveErrorArg, errorTagToMText,
errorToVal, errorToValNumeric, toVal)
import Lorentz.Constraints
import Morley.Micheline (Expression, fromExpression, toExpression)
import Morley.Michelson.Printer.Util (buildRenderDoc)
import Morley.Michelson.Typed (Constrained(..), SomeConstant)
import Morley.Michelson.Typed qualified as T
import Test.Cleveland.Internal.Abstract
import Test.Cleveland.Lorentz.Types
data TransferFailurePredicate
= TransferFailurePredicate
(TransferFailure -> Validation Builder ())
| AndPredicate (NonEmpty TransferFailurePredicate)
| OrPredicate (NonEmpty TransferFailurePredicate)
instance Boolean TransferFailurePredicate where
AndPredicate NonEmpty TransferFailurePredicate
l && :: TransferFailurePredicate
-> TransferFailurePredicate -> TransferFailurePredicate
&& AndPredicate NonEmpty TransferFailurePredicate
r = NonEmpty TransferFailurePredicate -> TransferFailurePredicate
AndPredicate (NonEmpty TransferFailurePredicate -> TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate -> TransferFailurePredicate
forall a b. (a -> b) -> a -> b
$ NonEmpty TransferFailurePredicate
l NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
forall a. Semigroup a => a -> a -> a
<> NonEmpty TransferFailurePredicate
r
AndPredicate NonEmpty TransferFailurePredicate
l && TransferFailurePredicate
r = NonEmpty TransferFailurePredicate -> TransferFailurePredicate
AndPredicate (NonEmpty TransferFailurePredicate -> TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate -> TransferFailurePredicate
forall a b. (a -> b) -> a -> b
$ NonEmpty TransferFailurePredicate
l NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
forall a. Semigroup a => a -> a -> a
<> OneItem (NonEmpty TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate
forall x. One x => OneItem x -> x
one OneItem (NonEmpty TransferFailurePredicate)
TransferFailurePredicate
r
TransferFailurePredicate
l && AndPredicate NonEmpty TransferFailurePredicate
r = NonEmpty TransferFailurePredicate -> TransferFailurePredicate
AndPredicate (NonEmpty TransferFailurePredicate -> TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate -> TransferFailurePredicate
forall a b. (a -> b) -> a -> b
$ OneItem (NonEmpty TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate
forall x. One x => OneItem x -> x
one OneItem (NonEmpty TransferFailurePredicate)
TransferFailurePredicate
l NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
forall a. Semigroup a => a -> a -> a
<> NonEmpty TransferFailurePredicate
r
TransferFailurePredicate
l && TransferFailurePredicate
r = NonEmpty TransferFailurePredicate -> TransferFailurePredicate
AndPredicate (NonEmpty TransferFailurePredicate -> TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate -> TransferFailurePredicate
forall a b. (a -> b) -> a -> b
$ OneItem (NonEmpty TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate
forall x. One x => OneItem x -> x
one OneItem (NonEmpty TransferFailurePredicate)
TransferFailurePredicate
l NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
forall a. Semigroup a => a -> a -> a
<> OneItem (NonEmpty TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate
forall x. One x => OneItem x -> x
one OneItem (NonEmpty TransferFailurePredicate)
TransferFailurePredicate
r
OrPredicate NonEmpty TransferFailurePredicate
l || :: TransferFailurePredicate
-> TransferFailurePredicate -> TransferFailurePredicate
|| OrPredicate NonEmpty TransferFailurePredicate
r = NonEmpty TransferFailurePredicate -> TransferFailurePredicate
OrPredicate (NonEmpty TransferFailurePredicate -> TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate -> TransferFailurePredicate
forall a b. (a -> b) -> a -> b
$ NonEmpty TransferFailurePredicate
l NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
forall a. Semigroup a => a -> a -> a
<> NonEmpty TransferFailurePredicate
r
OrPredicate NonEmpty TransferFailurePredicate
l || TransferFailurePredicate
r = NonEmpty TransferFailurePredicate -> TransferFailurePredicate
OrPredicate (NonEmpty TransferFailurePredicate -> TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate -> TransferFailurePredicate
forall a b. (a -> b) -> a -> b
$ NonEmpty TransferFailurePredicate
l NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
forall a. Semigroup a => a -> a -> a
<> OneItem (NonEmpty TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate
forall x. One x => OneItem x -> x
one OneItem (NonEmpty TransferFailurePredicate)
TransferFailurePredicate
r
TransferFailurePredicate
l || OrPredicate NonEmpty TransferFailurePredicate
r = NonEmpty TransferFailurePredicate -> TransferFailurePredicate
OrPredicate (NonEmpty TransferFailurePredicate -> TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate -> TransferFailurePredicate
forall a b. (a -> b) -> a -> b
$ OneItem (NonEmpty TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate
forall x. One x => OneItem x -> x
one OneItem (NonEmpty TransferFailurePredicate)
TransferFailurePredicate
l NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
forall a. Semigroup a => a -> a -> a
<> NonEmpty TransferFailurePredicate
r
TransferFailurePredicate
l || TransferFailurePredicate
r = NonEmpty TransferFailurePredicate -> TransferFailurePredicate
OrPredicate (NonEmpty TransferFailurePredicate -> TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate -> TransferFailurePredicate
forall a b. (a -> b) -> a -> b
$ OneItem (NonEmpty TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate
forall x. One x => OneItem x -> x
one OneItem (NonEmpty TransferFailurePredicate)
TransferFailurePredicate
l NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
forall a. Semigroup a => a -> a -> a
<> OneItem (NonEmpty TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate
forall x. One x => OneItem x -> x
one OneItem (NonEmpty TransferFailurePredicate)
TransferFailurePredicate
r
transferFailureReasonPredicate
:: (TransferFailureReason -> Validation Builder ())
-> TransferFailurePredicate
transferFailureReasonPredicate :: (TransferFailureReason -> Validation Builder ())
-> TransferFailurePredicate
transferFailureReasonPredicate TransferFailureReason -> Validation Builder ()
p = (TransferFailure -> Validation Builder ())
-> TransferFailurePredicate
TransferFailurePredicate ((TransferFailure -> Validation Builder ())
-> TransferFailurePredicate)
-> (TransferFailure -> Validation Builder ())
-> TransferFailurePredicate
forall a b. (a -> b) -> a -> b
$
\(TransferFailure AddressAndAlias
_ TransferFailureReason
reason) -> TransferFailureReason -> Validation Builder ()
p TransferFailureReason
reason
shiftOverflow :: TransferFailurePredicate
shiftOverflow :: TransferFailurePredicate
shiftOverflow = (TransferFailureReason -> Validation Builder ())
-> TransferFailurePredicate
transferFailureReasonPredicate \case
TransferFailureReason
ShiftOverflow -> Validation Builder ()
forall (f :: * -> *). Applicative f => f ()
pass
TransferFailureReason
_ -> Builder -> Validation Builder ()
forall e a. e -> Validation e a
Failure Builder
"Contract failed due to an overflow error"
emptyTransaction :: TransferFailurePredicate
emptyTransaction :: TransferFailurePredicate
emptyTransaction = (TransferFailureReason -> Validation Builder ())
-> TransferFailurePredicate
transferFailureReasonPredicate \case
TransferFailureReason
EmptyTransaction -> Validation Builder ()
forall (f :: * -> *). Applicative f => f ()
pass
TransferFailureReason
_ -> Builder -> Validation Builder ()
forall e a. e -> Validation e a
Failure Builder
"Attempted to transfer 0tz to a simple address"
badParameter :: TransferFailurePredicate
badParameter :: TransferFailurePredicate
badParameter = (TransferFailureReason -> Validation Builder ())
-> TransferFailurePredicate
transferFailureReasonPredicate \case
TransferFailureReason
BadParameter -> Validation Builder ()
forall (f :: * -> *). Applicative f => f ()
pass
TransferFailureReason
_ -> Builder -> Validation Builder ()
forall e a. e -> Validation e a
Failure Builder
"Attempted to call a contract with a parameter of the wrong type"
gasExhaustion :: TransferFailurePredicate
gasExhaustion :: TransferFailurePredicate
gasExhaustion = (TransferFailureReason -> Validation Builder ())
-> TransferFailurePredicate
transferFailureReasonPredicate \case
TransferFailureReason
GasExhaustion -> Validation Builder ()
forall (f :: * -> *). Applicative f => f ()
pass
TransferFailureReason
_ -> Builder -> Validation Builder ()
forall e a. e -> Validation e a
Failure Builder
"Execution failed due to gas exhaustion"
failedWith :: SomeConstant -> TransferFailurePredicate
failedWith :: SomeConstant -> TransferFailurePredicate
failedWith SomeConstant
expectedFailWithVal = (TransferFailureReason -> Validation Builder ())
-> TransferFailurePredicate
transferFailureReasonPredicate \case
FailedWith (EOTVExpression Expression
actualFailWithExpr) Maybe ErrorSrcPos
_
| Expression
actualFailWithExpr Expression -> SomeConstant -> Bool
`isEq` SomeConstant
expectedFailWithVal -> Validation Builder ()
forall (f :: * -> *). Applicative f => f ()
pass
FailedWith (EOTVTypedValue Value t
actualFailWithVal) Maybe ErrorSrcPos
_
| Value t -> Expression
forall a. ToExpression a => a -> Expression
toExpression Value t
actualFailWithVal Expression -> SomeConstant -> Bool
`isEq` SomeConstant
expectedFailWithVal -> Validation Builder ()
forall (f :: * -> *). Applicative f => f ()
pass
TransferFailureReason
_ -> Builder -> Validation Builder ()
forall e a. e -> Validation e a
Failure (Builder -> Validation Builder ())
-> Builder -> Validation Builder ()
forall a b. (a -> b) -> a -> b
$ Builder
"Contract failed with: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> SomeConstant -> Builder
forall a. RenderDoc a => a -> Builder
buildRenderDoc SomeConstant
expectedFailWithVal
where
isEq :: Expression -> SomeConstant -> Bool
isEq :: Expression -> SomeConstant -> Bool
isEq Expression
expr (SomeConstant (Value t
v :: T.Value t)) =
(FromExpressionError -> Bool)
-> (Value t -> Bool)
-> Either FromExpressionError (Value t)
-> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> FromExpressionError -> Bool
forall a b. a -> b -> a
const Bool
False) (Value t -> Value t -> Bool
forall a. Eq a => a -> a -> Bool
== Value t
v) (forall a.
FromExp RegularExp a =>
Expression -> Either FromExpressionError a
fromExpression @(T.Value t) Expression
expr)
addressIs
:: ToAddress addr
=> addr
-> TransferFailurePredicate
addressIs :: forall addr. ToAddress addr => addr -> TransferFailurePredicate
addressIs (addr -> Address
forall a. ToAddress a => a -> Address
toAddress -> Address
expectedAddr) = (TransferFailure -> Validation Builder ())
-> TransferFailurePredicate
TransferFailurePredicate \TransferFailure
err -> do
let TransferFailure AddressAndAlias
addrAndAlias TransferFailureReason
_ = TransferFailure
err
Bool -> Validation Builder () -> Validation Builder ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AddressAndAlias -> Address
forall a. ToAddress a => a -> Address
toAddress AddressAndAlias
addrAndAlias Address -> Address -> Bool
forall a. Eq a => a -> a -> Bool
/= Address
expectedAddr) (Validation Builder () -> Validation Builder ())
-> Validation Builder () -> Validation Builder ()
forall a b. (a -> b) -> a -> b
$
Builder -> Validation Builder ()
forall e a. e -> Validation e a
Failure (Builder -> Validation Builder ())
-> Builder -> Validation Builder ()
forall a b. (a -> b) -> a -> b
$ Builder
"Failure occurred in contract with address: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Address -> Builder
forall p. Buildable p => p -> Builder
build Address
expectedAddr
constant :: forall err. NiceConstant err => err -> SomeConstant
constant :: forall err. NiceConstant err => err -> SomeConstant
constant err
err = Value (ToT err) -> SomeConstant
forall (t :: T). ConstantScope t => Value t -> SomeConstant
SomeConstant (Value (ToT err) -> SomeConstant)
-> Value (ToT err) -> SomeConstant
forall a b. (a -> b) -> a -> b
$ err -> Value (ToT err)
forall a. IsoValue a => a -> Value (ToT a)
toVal err
err
lerror :: forall err. IsError err => err -> SomeConstant
lerror :: forall err. IsError err => err -> SomeConstant
lerror err
err = err
-> (forall (t :: T). ConstantScope t => Value t -> SomeConstant)
-> SomeConstant
forall e r.
IsError e =>
e -> (forall (t :: T). ErrorScope t => Value t -> r) -> r
errorToVal err
err forall (t :: T). ConstantScope t => Value t -> SomeConstant
SomeConstant
customError
:: forall arg tag. (IsError (CustomError tag), MustHaveErrorArg tag (MText, arg))
=> Label tag -> arg -> SomeConstant
customError :: forall arg (tag :: Symbol).
(IsError (CustomError tag), MustHaveErrorArg tag (MText, arg)) =>
Label tag -> arg -> SomeConstant
customError Label tag
tag arg
arg =
CustomError tag -> SomeConstant
forall err. IsError err => err -> SomeConstant
lerror (CustomError tag -> SomeConstant)
-> CustomError tag -> SomeConstant
forall a b. (a -> b) -> a -> b
$ Label tag -> CustomErrorRep tag -> CustomError tag
forall (tag :: Symbol).
Label tag -> CustomErrorRep tag -> CustomError tag
CustomError Label tag
tag (Label tag -> MText
forall (tag :: Symbol). Label tag -> MText
errorTagToMText Label tag
tag, arg
arg)
customError_
:: (IsError (CustomError tag), MustHaveErrorArg tag (MText, ()))
=> Label tag -> SomeConstant
customError_ :: forall (tag :: Symbol).
(IsError (CustomError tag), MustHaveErrorArg tag (MText, ())) =>
Label tag -> SomeConstant
customError_ Label tag
tag = Label tag -> () -> SomeConstant
forall arg (tag :: Symbol).
(IsError (CustomError tag), MustHaveErrorArg tag (MText, arg)) =>
Label tag -> arg -> SomeConstant
customError Label tag
tag ()
customErrorNoArg
:: (IsError (CustomError tag), MustHaveErrorArg tag MText)
=> Label tag -> SomeConstant
customErrorNoArg :: forall (tag :: Symbol).
(IsError (CustomError tag), MustHaveErrorArg tag MText) =>
Label tag -> SomeConstant
customErrorNoArg Label tag
tag =
CustomError tag -> SomeConstant
forall err. IsError err => err -> SomeConstant
lerror (CustomError tag -> SomeConstant)
-> CustomError tag -> SomeConstant
forall a b. (a -> b) -> a -> b
$ Label tag -> CustomErrorRep tag -> CustomError tag
forall (tag :: Symbol).
Label tag -> CustomErrorRep tag -> CustomError tag
CustomError Label tag
tag (Label tag -> MText
forall (tag :: Symbol). Label tag -> MText
errorTagToMText Label tag
tag)
numericError :: forall err. IsError err => ErrorTagMap -> err -> SomeConstant
numericError :: forall err. IsError err => ErrorTagMap -> err -> SomeConstant
numericError ErrorTagMap
tagMap err
err = ErrorTagMap
-> err
-> (forall (t :: T). ConstantScope t => Value t -> SomeConstant)
-> SomeConstant
forall e r.
IsError e =>
ErrorTagMap
-> e -> (forall (t :: T). ConstantScope t => Value t -> r) -> r
errorToValNumeric ErrorTagMap
tagMap err
err forall (t :: T). ConstantScope t => Value t -> SomeConstant
SomeConstant