{-# OPTIONS_HADDOCK not-home #-}
module Test.Cleveland.Internal.Actions.TransferFailurePredicate
( module Test.Cleveland.Internal.Actions.TransferFailurePredicate
) where
import Control.Lens (makeLenses)
import Fmt (Buildable(..), Builder)
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 Test.Cleveland.Internal.Abstract
import Test.Cleveland.Lorentz.Types
data TransferFailurePredicate
= TransferFailurePredicate
TransferFailurePredicateDesc
(TransferFailure -> Bool)
| AndPredicate (NonEmpty TransferFailurePredicate)
| OrPredicate (NonEmpty TransferFailurePredicate)
data TransferFailurePredicateDesc = TransferFailurePredicateDesc
{ TransferFailurePredicateDesc -> Bool
_tfpdNegated :: Bool
, TransferFailurePredicateDesc -> Builder
_tfpdDescription :: Builder
}
makeLenses ''TransferFailurePredicateDesc
instance Buildable TransferFailurePredicateDesc where
build :: TransferFailurePredicateDesc -> Builder
build TransferFailurePredicateDesc{Bool
Builder
_tfpdDescription :: Builder
_tfpdNegated :: Bool
_tfpdDescription :: TransferFailurePredicateDesc -> Builder
_tfpdNegated :: TransferFailurePredicateDesc -> Bool
..}
| Bool
_tfpdNegated = Builder
"NOT (" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
forall p. Buildable p => p -> Builder
build Builder
_tfpdDescription Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")"
| Bool
otherwise = Builder -> Builder
forall p. Buildable p => p -> Builder
build Builder
_tfpdDescription
instance IsString TransferFailurePredicateDesc where
fromString :: String -> TransferFailurePredicateDesc
fromString = Builder -> TransferFailurePredicateDesc
tfpd (Builder -> TransferFailurePredicateDesc)
-> (String -> Builder) -> String -> TransferFailurePredicateDesc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
forall a. IsString a => String -> a
fromString
tfpd :: Builder -> TransferFailurePredicateDesc
tfpd :: Builder -> TransferFailurePredicateDesc
tfpd = Bool -> Builder -> TransferFailurePredicateDesc
TransferFailurePredicateDesc Bool
False
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
not :: TransferFailurePredicate -> TransferFailurePredicate
not = \case
TransferFailurePredicate TransferFailurePredicateDesc
msg TransferFailure -> Bool
p -> TransferFailurePredicateDesc
-> (TransferFailure -> Bool) -> TransferFailurePredicate
TransferFailurePredicate (TransferFailurePredicateDesc
msg TransferFailurePredicateDesc
-> (TransferFailurePredicateDesc -> TransferFailurePredicateDesc)
-> TransferFailurePredicateDesc
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool)
-> TransferFailurePredicateDesc
-> Identity TransferFailurePredicateDesc
Lens' TransferFailurePredicateDesc Bool
tfpdNegated ((Bool -> Identity Bool)
-> TransferFailurePredicateDesc
-> Identity TransferFailurePredicateDesc)
-> (Bool -> Bool)
-> TransferFailurePredicateDesc
-> TransferFailurePredicateDesc
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Bool -> Bool
forall a. Boolean a => a -> a
not) (Bool -> Bool
forall a. Boolean a => a -> a
not (Bool -> Bool)
-> (TransferFailure -> Bool) -> TransferFailure -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransferFailure -> Bool
p)
AndPredicate NonEmpty TransferFailurePredicate
xs -> NonEmpty TransferFailurePredicate -> TransferFailurePredicate
OrPredicate (NonEmpty TransferFailurePredicate -> TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate -> TransferFailurePredicate
forall a b. (a -> b) -> a -> b
$ TransferFailurePredicate -> TransferFailurePredicate
forall a. Boolean a => a -> a
not (TransferFailurePredicate -> TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty TransferFailurePredicate
xs
OrPredicate NonEmpty TransferFailurePredicate
xs -> NonEmpty TransferFailurePredicate -> TransferFailurePredicate
AndPredicate (NonEmpty TransferFailurePredicate -> TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate -> TransferFailurePredicate
forall a b. (a -> b) -> a -> b
$ TransferFailurePredicate -> TransferFailurePredicate
forall a. Boolean a => a -> a
not (TransferFailurePredicate -> TransferFailurePredicate)
-> NonEmpty TransferFailurePredicate
-> NonEmpty TransferFailurePredicate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty TransferFailurePredicate
xs
transferFailureReasonPredicate
:: Builder
-> (TransferFailureReason -> Bool)
-> TransferFailurePredicate
transferFailureReasonPredicate :: Builder
-> (TransferFailureReason -> Bool) -> TransferFailurePredicate
transferFailureReasonPredicate Builder
b TransferFailureReason -> Bool
p = TransferFailurePredicateDesc
-> (TransferFailure -> Bool) -> TransferFailurePredicate
TransferFailurePredicate (Builder -> TransferFailurePredicateDesc
tfpd Builder
b)
\(TransferFailure AddressAndAlias
_ TransferFailureReason
reason) -> TransferFailureReason -> Bool
p TransferFailureReason
reason
shiftOverflow :: TransferFailurePredicate
shiftOverflow :: TransferFailurePredicate
shiftOverflow = Builder
-> (TransferFailureReason -> Bool) -> TransferFailurePredicate
transferFailureReasonPredicate
Builder
"Contract failed due to an overflow error"
(TransferFailureReason -> TransferFailureReason -> Bool
forall a. Eq a => a -> a -> Bool
== TransferFailureReason
ShiftOverflow)
emptyTransaction :: TransferFailurePredicate
emptyTransaction :: TransferFailurePredicate
emptyTransaction = Builder
-> (TransferFailureReason -> Bool) -> TransferFailurePredicate
transferFailureReasonPredicate
Builder
"Attempted to transfer 0tz to a simple address"
(TransferFailureReason -> TransferFailureReason -> Bool
forall a. Eq a => a -> a -> Bool
== TransferFailureReason
EmptyTransaction)
badParameter :: TransferFailurePredicate
badParameter :: TransferFailurePredicate
badParameter = Builder
-> (TransferFailureReason -> Bool) -> TransferFailurePredicate
transferFailureReasonPredicate
Builder
"Attempted to call a contract with a parameter of the wrong type"
(TransferFailureReason -> TransferFailureReason -> Bool
forall a. Eq a => a -> a -> Bool
== TransferFailureReason
BadParameter)
gasExhaustion :: TransferFailurePredicate
gasExhaustion :: TransferFailurePredicate
gasExhaustion = Builder
-> (TransferFailureReason -> Bool) -> TransferFailurePredicate
transferFailureReasonPredicate
Builder
"Execution failed due to gas exhaustion"
(TransferFailureReason -> TransferFailureReason -> Bool
forall a. Eq a => a -> a -> Bool
== TransferFailureReason
GasExhaustion)
failedWith :: SomeConstant -> TransferFailurePredicate
failedWith :: SomeConstant -> TransferFailurePredicate
failedWith SomeConstant
expectedFailWithVal = Builder -> (Expression -> Bool) -> TransferFailurePredicate
failedWithPredicate
(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)
(SomeConstant -> Expression -> Bool
isEq SomeConstant
expectedFailWithVal)
where
isEq :: SomeConstant -> Expression -> Bool
isEq :: SomeConstant -> Expression -> Bool
isEq (SomeConstant Value t
v) = (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) (Either FromExpressionError (Value t) -> Bool)
-> (Expression -> Either FromExpressionError (Value t))
-> Expression
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression -> Either FromExpressionError (Value t)
forall a.
FromExp RegularExp a =>
Expression -> Either FromExpressionError a
fromExpression
failedWithPredicate :: Builder -> (Expression -> Bool) -> TransferFailurePredicate
failedWithPredicate :: Builder -> (Expression -> Bool) -> TransferFailurePredicate
failedWithPredicate Builder
msg Expression -> Bool
valPredicate = Builder
-> (TransferFailureReason -> Bool) -> TransferFailurePredicate
transferFailureReasonPredicate Builder
msg ((TransferFailureReason -> Bool) -> TransferFailurePredicate)
-> (TransferFailureReason -> Bool) -> TransferFailurePredicate
forall a b. (a -> b) -> a -> b
$ \case
FailedWith ExpressionOrTypedValue
eotv Maybe ErrorSrcPos
_ -> Expression -> Bool
valPredicate (Expression -> Bool) -> Expression -> Bool
forall a b. (a -> b) -> a -> b
$ case ExpressionOrTypedValue
eotv of
EOTVExpression Expression
expr -> Expression
expr
EOTVTypedValue Value t
tv -> Value t -> Expression
forall a. ToExpression a => a -> Expression
toExpression Value t
tv
TransferFailureReason
_ -> Bool
False
addressIs
:: ToAddress addr
=> addr
-> TransferFailurePredicate
addressIs :: forall addr. ToAddress addr => addr -> TransferFailurePredicate
addressIs (addr -> Address
forall a. ToAddress a => a -> Address
toAddress -> Address
expectedAddr) = TransferFailurePredicateDesc
-> (TransferFailure -> Bool) -> TransferFailurePredicate
TransferFailurePredicate
(Builder -> TransferFailurePredicateDesc
tfpd (Builder -> TransferFailurePredicateDesc)
-> Builder -> TransferFailurePredicateDesc
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)
\(TransferFailure AddressAndAlias
addrAndAlias TransferFailureReason
_) -> AddressAndAlias -> Address
forall a. ToAddress a => a -> Address
toAddress AddressAndAlias
addrAndAlias Address -> Address -> Bool
forall a. Eq a => a -> a -> Bool
== 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