-- 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 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

-- | A predicate that checks whether a transfer operation failed for the expected reason.
--
-- Predicates can be combined using the '&&' and '||' operators.
data TransferFailurePredicate
  = TransferFailurePredicate
      (TransferFailure -> Validation Builder ())
      -- ^ A predicate that either returns () or, if it fails,
      -- a message explaining what the expected outcome was.
  | 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

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

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

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

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

-- | 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 = (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)

-- | 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) = (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

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