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 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
  { _tfpdNegated :: Bool
  , _tfpdDescription :: Doc
  }

makeLenses ''TransferFailurePredicateDesc

instance Buildable TransferFailurePredicateDesc where
  build TransferFailurePredicateDesc{..}
    | _tfpdNegated = "NOT (" <> build _tfpdDescription <> ")"
    | otherwise = build _tfpdDescription

instance IsString TransferFailurePredicateDesc where
  fromString = tfpd . fromString

tfpd :: Doc -> TransferFailurePredicateDesc
tfpd = TransferFailurePredicateDesc False

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

  not = \case
    TransferFailurePredicate msg p -> TransferFailurePredicate (msg & tfpdNegated %~ not) (not . p)
    AndPredicate xs -> OrPredicate $ not <$> xs
    OrPredicate xs -> AndPredicate $ not <$> xs

transferFailureReasonPredicate
  :: Doc
  -> (TransferFailureReason -> Bool)
  -> TransferFailurePredicate
transferFailureReasonPredicate b p = TransferFailurePredicate (tfpd b) (p . tfReason)

-- | Asserts that interpretation of a contract failed due to an overflow error.
shiftOverflow :: TransferFailurePredicate
shiftOverflow = transferFailureReasonPredicate
  "Contract failed due to an overflow error"
  (== ShiftOverflow)

-- | Asserts that an action failed due to an attempt to transfer 0tz towards a simple address.
emptyTransaction :: TransferFailurePredicate
emptyTransaction = transferFailureReasonPredicate
  "Attempted to transfer 0tz to a simple address"
  (== EmptyTransaction)

-- | Asserts that an action failed due to an attempt to call a contract with an invalid parameter.
badParameter :: TransferFailurePredicate
badParameter = transferFailureReasonPredicate
  "Attempted to call a contract with a parameter of the wrong type"
  (== BadParameter)

-- | Asserts that interpretation of a contract failed due to gas exhaustion.
gasExhaustion :: TransferFailurePredicate
gasExhaustion = transferFailureReasonPredicate
  "Execution failed due to gas exhaustion"
  (== 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 expectedFailWithVal = failedWithPredicate
  ("Contract failed with: " <> build expectedFailWithVal)
  (isEq expectedFailWithVal)
  where
    isEq :: SomeConstant -> Expression -> Bool
    isEq (SomeConstant v) = either (const False) (== v) . fromExpression

-- | Asserts that interpretation of a contract ended with @FAILWITH@, and the
-- error satisfies the given predicate.
failedWithPredicate :: Doc -> (Expression -> Bool) -> TransferFailurePredicate
failedWithPredicate msg valPredicate = transferFailureReasonPredicate msg $ \case
  FailedWith eotv _ -> valPredicate $ case eotv of
    EOTVExpression expr -> expr
    EOTVTypedValue tv -> toExpression tv
  _ -> False

-- | 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
  (tfpd $ "Failure occurred in contract with address: " <> build expectedAddr)
  \TransferFailure{..} -> toAddress tfAddressAndAlias == 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