TransferFailurePredicate.hs

-- 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 l && AndPredicate r = AndPredicate $ l <> r
  AndPredicate l && r = AndPredicate $ l <> one r
  l && AndPredicate r = AndPredicate $ one l <> r
  l && r = AndPredicate $ one l <> one r

  OrPredicate l || OrPredicate r = OrPredicate $ l <> r
  OrPredicate l || r = OrPredicate $ l <> one r
  l || OrPredicate r = OrPredicate $ one l <> r
  l || r = OrPredicate $ one l <> one r

transferFailureReasonPredicate
  :: (TransferFailureReason -> Validation Builder ())
  -> TransferFailurePredicate
transferFailureReasonPredicate p = TransferFailurePredicate $
  \(TransferFailure _ reason) -> p reason

-- | Asserts that interpretation of a contract failed due to an overflow error.
shiftOverflow :: TransferFailurePredicate
shiftOverflow = transferFailureReasonPredicate \case
  ShiftOverflow -> pass
  _ -> Failure "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 = transferFailureReasonPredicate \case
  EmptyTransaction -> pass
  _ -> Failure "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 = transferFailureReasonPredicate \case
  BadParameter -> pass
  _ -> Failure "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 = transferFailureReasonPredicate \case
  GasExhaustion -> pass
  _ -> Failure "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 expectedFailWithVal = transferFailureReasonPredicate \case
  FailedWith (EOTVExpression actualFailWithExpr) _
    | actualFailWithExpr `isEq` expectedFailWithVal -> pass
  FailedWith (EOTVTypedValue actualFailWithVal) _
    | toExpression actualFailWithVal `isEq` expectedFailWithVal -> pass
  _ -> Failure $ "Contract failed with: " <> buildRenderDoc expectedFailWithVal
  where
    isEq :: Expression -> SomeConstant -> Bool
    isEq expr (SomeConstant (v :: T.Value t)) =
      either (const False) (== v) (fromExpression @(T.Value t) expr)

-- | Asserts that the error occurred while interpreting the contract with the given address.
addressIs
  :: ToAddress addr
  => addr -- ^ The expected address.
  -> TransferFailurePredicate
addressIs (toAddress -> expectedAddr) = TransferFailurePredicate \err -> do
  let TransferFailure addrAndAlias _ = err
  when (toAddress addrAndAlias /= expectedAddr) $
    Failure $ "Failure occurred in contract with address: " <> build expectedAddr

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

-- | A constant michelson value that a contract threw with @FAILWITH@.
constant :: forall err. NiceConstant err => err -> SomeConstant
constant err = SomeConstant $ toVal err

-- | A lorentz error.
lerror :: forall err. IsError err => err -> SomeConstant
lerror err = errorToVal err SomeConstant

-- | A custom lorentz error.
customError
  :: forall arg tag. (IsError (CustomError tag), MustHaveErrorArg tag (MText, arg))
  => Label tag -> arg -> SomeConstant
customError tag arg =
  lerror $ CustomError tag (errorTagToMText tag, arg)

-- | A custom lorentz error with a @unit@ argument.
customError_
  :: (IsError (CustomError tag), MustHaveErrorArg tag (MText, ()))
  => Label tag -> SomeConstant
customError_ tag = customError tag ()

-- | A custom lorentz error with no argument.
customErrorNoArg
  :: (IsError (CustomError tag), MustHaveErrorArg tag MText)
  => Label tag -> SomeConstant
customErrorNoArg tag =
  lerror $ CustomError tag (errorTagToMText tag)

-- | A lorentz numeric error.
numericError :: forall err. IsError err => ErrorTagMap -> err -> SomeConstant
numericError tagMap err = errorToValNumeric tagMap err SomeConstant