-- 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(..), Doc)

import Lorentz
  (CustomError(..), ErrorTagMap, IsError, Label, MText, MustHaveErrorArg, errorTagToMText,
  errorToVal, errorToValNumeric, toVal)
import Lorentz.Constraints
import Morley.Micheline (Expression, fromExpression, toExpression)
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 -> Doc
_tfpdDescription :: Doc
  }

makeLenses ''TransferFailurePredicateDesc

instance Buildable TransferFailurePredicateDesc where
  build :: TransferFailurePredicateDesc -> Doc
build TransferFailurePredicateDesc{Bool
Doc
_tfpdDescription :: Doc
_tfpdNegated :: Bool
_tfpdDescription :: TransferFailurePredicateDesc -> Doc
_tfpdNegated :: TransferFailurePredicateDesc -> Bool
..}
    | Bool
_tfpdNegated = Doc
"NOT (" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
forall a. Buildable a => a -> Doc
build Doc
_tfpdDescription Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
")"
    | Bool
otherwise = Doc -> Doc
forall a. Buildable a => a -> Doc
build Doc
_tfpdDescription

instance IsString TransferFailurePredicateDesc where
  fromString :: String -> TransferFailurePredicateDesc
fromString = Doc -> TransferFailurePredicateDesc
tfpd (Doc -> TransferFailurePredicateDesc)
-> (String -> Doc) -> String -> TransferFailurePredicateDesc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
forall a. IsString a => String -> a
fromString

tfpd :: Doc -> TransferFailurePredicateDesc
tfpd :: Doc -> TransferFailurePredicateDesc
tfpd = Bool -> Doc -> 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
  :: Doc
  -> (TransferFailureReason -> Bool)
  -> TransferFailurePredicate
transferFailureReasonPredicate :: Doc -> (TransferFailureReason -> Bool) -> TransferFailurePredicate
transferFailureReasonPredicate Doc
b TransferFailureReason -> Bool
p = TransferFailurePredicateDesc
-> (TransferFailure -> Bool) -> TransferFailurePredicate
TransferFailurePredicate (Doc -> TransferFailurePredicateDesc
tfpd Doc
b) (TransferFailureReason -> Bool
p (TransferFailureReason -> Bool)
-> (TransferFailure -> TransferFailureReason)
-> TransferFailure
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransferFailure -> TransferFailureReason
tfReason)

-- | Asserts that interpretation of a contract failed due to an overflow error.
shiftOverflow :: TransferFailurePredicate
shiftOverflow :: TransferFailurePredicate
shiftOverflow = Doc -> (TransferFailureReason -> Bool) -> TransferFailurePredicate
transferFailureReasonPredicate
  Doc
"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 = Doc -> (TransferFailureReason -> Bool) -> TransferFailurePredicate
transferFailureReasonPredicate
  Doc
"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 = Doc -> (TransferFailureReason -> Bool) -> TransferFailurePredicate
transferFailureReasonPredicate
  Doc
"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 = Doc -> (TransferFailureReason -> Bool) -> TransferFailurePredicate
transferFailureReasonPredicate
  Doc
"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 = Doc -> (Expression -> Bool) -> TransferFailurePredicate
failedWithPredicate
  (Doc
"Contract failed with: " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> SomeConstant -> Doc
forall a. Buildable a => a -> Doc
build 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 :: Doc -> (Expression -> Bool) -> TransferFailurePredicate
failedWithPredicate :: Doc -> (Expression -> Bool) -> TransferFailurePredicate
failedWithPredicate Doc
msg Expression -> Bool
valPredicate = Doc -> (TransferFailureReason -> Bool) -> TransferFailurePredicate
transferFailureReasonPredicate Doc
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
  (Doc -> TransferFailurePredicateDesc
tfpd (Doc -> TransferFailurePredicateDesc)
-> Doc -> TransferFailurePredicateDesc
forall a b. (a -> b) -> a -> b
$ Doc
"Failure occurred in contract with address: " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Address -> Doc
forall a. Buildable a => a -> Doc
build Address
expectedAddr)
  \TransferFailure{TransferFailureReason
CallSequence
AddressAndAlias
tfCallSeqence :: TransferFailure -> CallSequence
tfAddressAndAlias :: TransferFailure -> AddressAndAlias
tfReason :: TransferFailureReason
tfCallSeqence :: CallSequence
tfAddressAndAlias :: AddressAndAlias
tfReason :: TransferFailure -> TransferFailureReason
..} -> AddressAndAlias -> Address
forall a. ToAddress a => a -> Address
toAddress AddressAndAlias
tfAddressAndAlias 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