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

{-# OPTIONS_HADDOCK not-home #-}

-- | 'TransferFailure' Predicates
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

-- | A predicate that checks whether a transfer operation failed for the expected reason.
--
-- Predicates can be combined using the '&&' and '||' operators.
data TransferFailurePredicate
  = TransferFailurePredicate -- ^ Predicate with a description
      TransferFailurePredicateDesc -- ^ The explanation of the expected outcome.
      (TransferFailure -> Bool) -- ^ The predicate itself.
  | 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

-- | Asserts that interpretation of a contract failed due to an overflow error.
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)

-- | Asserts that an action failed due to an attempt to transfer 0tz towards a simple address.
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)

-- | Asserts that an action failed due to an attempt to call a contract with an invalid parameter.
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)

-- | Asserts that interpretation of a contract failed due to gas exhaustion.
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)

-- | Asserts that interpretation of a contract ended with @FAILWITH@, throwing the given error.
--
-- This function should be used together with one of the "@FAILWITH@ constructors"
-- (e.g. 'constant', 'customError').
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

-- | Asserts that interpretation of a contract ended with @FAILWITH@, and the
-- error satisfies the given predicate.
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

-- | Asserts that the error occurred while interpreting the contract with the given address.
addressIs
  :: ToAddress addr
  => addr -- ^ The expected address.
  -> 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

----------------------------------------------------------------------------
-- 'FAILWITH' errors
----------------------------------------------------------------------------

-- | A constant michelson value that a contract threw with @FAILWITH@.
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

-- | A lorentz error.
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

-- | A custom lorentz error.
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)

-- | A custom lorentz error with a @unit@ argument.
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 ()

-- | A custom lorentz error with no argument.
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)

-- | A lorentz numeric error.
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