cleveland-0.1.2: src/Test/Cleveland/Internal/Actions.hs

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

-- | Cleveland actions.
module Test.Cleveland.Internal.Actions
  ( MonadOps(..)
  , withSender
  , withMoneybag
  , runIO
  , resolveAddress
  , refillable
  , newAddress
  , newFreshAddress
  , enumAliasHints
  , signBytes
  , signBinary
  , originate
  , originateSimple
  , originateUntyped
  , originateUntypedSimple
  , originateTypedSimple
  , originateLarge
  , originateLargeSimple
  , originateLargeUntyped
  , originateLargeUntypedSimple
  , transfer
  , transferMoney
  , call
  , inBatch
  , importUntypedContract
  , importContract
  , noViews
  , comment
  , getBalance
  , getStorage
  , getFullStorage
  , getSomeStorage
  , getAllBigMapValues
  , getAllBigMapValuesMaybe
  , getBigMapSize
  , getBigMapSizeMaybe
  , getBigMapValueMaybe
  , getBigMapValue
  , getMorleyLogs
  , getMorleyLogs_
  , getPublicKey
  , getChainId
  , advanceTime
  , advanceLevel
  , advanceToLevel
  , getNow
  , getLevel
  , getApproximateBlockInterval
  , runCode
  , branchout
  , offshoot
  , getDelegate
  , registerDelegate
  , setVotingPowers
  , whenEmulation
  , whenNetwork
  , ifEmulation

  -- * Assertions
  , failure
  , assert
  , (@==)
  , (@/=)
  , (@@==)
  , (@@/=)
  , checkCompares
  , checkComparesWith
  , evalJust
  , evalRight

  -- * Exception handling
  , attempt
  , catchTransferFailure
  , checkTransferFailure
  , expectTransferFailure
  , expectFailedWith
  , expectError
  , expectCustomError
  , expectCustomError_
  , expectCustomErrorNoArg
  , expectNumericError
  , clarifyErrors
  -- ** TransferFailure predicates
  , TransferFailurePredicate(..)
  , shiftOverflow
  , emptyTransaction
  , badParameter
  , gasExhaustion
  , failedWith
  , addressIs
  -- ** @FAILWITH@ errors
  , constant
  , lerror
  , customError
  , customError_
  , customErrorNoArg
  , numericError

  -- * Helpers
  , withCap
  ) where

import Data.Constraint (Dict(Dict), (\\))
import Data.Either.Validation (Validation(..))
import Data.List.NonEmpty qualified as NE
import Data.Singletons (demote)
import Fmt (Buildable, Builder, build, indentF, nameF, pretty, unlinesF, (+|), (|+))
import Time (KnownDivRat, Second, Time)
import Unsafe qualified (fromIntegral)

import Lorentz
  (BigMapId, Contract(..), CustomError(..), DemoteViewsDescriptor, ErrorTagMap,
  HasEntrypointArg(useHasEntrypointArg), IsError, IsoValue, Label, MText, MustHaveErrorArg,
  ToTAddress, errorTagToMText, errorToVal, errorToValNumeric, noViews, pattern DefEpName,
  toMichelsonContract, toTAddress, toVal, zeroMutez)
import Lorentz.Bytes
import Lorentz.Constraints
import Morley.AsRPC (HasRPCRepr(..))
import Morley.Client (OperationInfo(..))
import Morley.Micheline (Expression, FromExpression(..), toExpression)
import Morley.Michelson.Printer.Util (buildRenderDoc)
import Morley.Michelson.Runtime (VotingPowers)
import Morley.Michelson.Runtime.Import qualified as Runtime
import Morley.Michelson.Typed
  (SomeAnnotatedValue, SomeConstant, SomeConstrainedValue(..), convertContract, untypeValue)
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Typed.AnnotatedValue (castTo, getT, value)
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address (Address)
import Morley.Tezos.Core (ChainId, Mutez, Timestamp)
import Morley.Tezos.Crypto (KeyHash, PublicKey, Signature)
import Morley.Util.SizedList qualified as SL
import Morley.Util.SizedList.Types
import Test.Cleveland.Internal.Abstract
import Test.Cleveland.Internal.Client qualified as Client (TestError(..))
import Test.Cleveland.Internal.Exceptions (WithCallStack(..))
import Test.Cleveland.Internal.Pure as Pure (TestError(..))
import Test.Cleveland.Lorentz.Import qualified as LorentzImport
import Test.Cleveland.Lorentz.Types

{-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-}

-- $setup
-- >>> :m +Morley.Util.SizedList.Types
-- >>> :{
-- isEquivalentTo :: Show a => a -> a -> Bool
-- isEquivalentTo a b = show a == show b
-- infix 0 `isEquivalentTo`
-- :}

-- | Typeclass for monads where operations-related actions can occur.
--
-- This is implemented for 'MonadCleveland' and batch context.
--
-- Has 'Functor' as a superclass constraint for convenience, all the related methods
-- require it.
class Functor m => MonadOps m where
  -- | Obtain 'ClevelandOpsImpl' suitable for the current \"monad\".
  --
  -- In CPS style, because the \"monad\" can be actually not a monad, so
  -- it can't work like 'ask' for 'ReaderT'.
  withOpsCap :: (ClevelandOpsImpl m -> m a) -> m a

instance MonadOps ClevelandOpsBatch where
  withOpsCap mkAction = mkAction batchedOpsImpl

instance (HasClevelandCaps caps, ClevelandBaseMonad caps ~ m) => MonadOps (ReaderT caps m) where
  withOpsCap mkAction = do
    opsCap :: ClevelandOpsImpl m <- asks getOpsCap
    let opsCap' :: ClevelandOpsImpl (ReaderT caps m) =
          ClevelandOpsImpl
            { coiRunOperationBatch =  lift ... coiRunOperationBatch opsCap
            }
    mkAction opsCap'

-- | Update the current sender on whose behalf transfers and originations are
-- invoked.
withSender :: MonadCleveland caps m => Address -> m a -> m a
withSender addr =
  local (set senderL (Sender addr))

-- | Update the current moneybag that transfers money on the newly created
-- addresses. For the rare occasions when this is necessary.
withMoneybag :: MonadCleveland caps m => Address -> m a -> m a
withMoneybag addr =
  local (set moneybagL (Moneybag addr))

-- | Runs an 'IO' action.
runIO :: (HasCallStack, MonadCleveland caps m) => IO res -> m res
runIO io = do
  withCap getMiscCap \cap -> cmiRunIO cap io

-- | Get the address of the implicit account / contract associated with the given alias hint.
resolveAddress
  :: (HasCallStack, MonadCleveland caps m)
  => AliasHint -> m Address
resolveAddress alias = do
  withCap getMiscCap \cap -> cmiResolveAddress cap alias

-- | Simple combinator that marks address as "refillable".
--
-- If a refillable address lacks funds for the next operation,
-- some funds will automatically be transferred to it.
refillable :: MonadCleveland caps m => m Address -> m Address
refillable action = do
  addr <- action
  withCap getMiscCap \cap -> cmiMarkAddressRefillable cap addr
  pure addr

-- | If the given alias is already associated with an existing address,
-- that address will be reused and returned.
-- Otherwise, generate a new secret key and record it with given alias.
--
-- If the account has too low of a balance, a small amount of XTZ will
-- be transferred to it.
--
-- Notes:
--
-- * By default, the XTZ is transferred from the account associated with the @moneybag@ alias.
--   This can be overriden with the @--cleveland-moneybag-alias@ command line option, the
--   @TASTY_CLEVELAND_MONEYBAG_ALIAS@ env var, or 'withMoneybag'.
-- * Beware that if an "alias prefix" is set, it'll be prepended to the given alias hint.
--   An "alias prefix" can be set using the @--cleveland-alias-prefix@ command line option, the
--   @TASTY_CLEVELAND_ALIAS_PREFIX@ env var, or with 'Test.Cleveland.Tasty.setAliasPrefix'.
--     > do
--     >   addr1 <- newAddress "alias"
--     >   addr2 <- resolveAddress $ mkAlias "prefix.alias"
--     >   addr1 @== addr2
newAddress :: (HasCallStack, MonadCleveland caps m) => SpecificOrDefaultAliasHint -> m Address
newAddress alias = do
  addr <- withCap getMiscCap \cap -> cmiGenKey cap alias
  Moneybag moneybag <- view moneybagL

  -- The address may exist from previous scenarios runs and have sufficient
  -- balance for the sake of testing; if so, we can save some time
  balance <- getBalance addr
  when (balance < 0.5_e6) do  -- < 0.5 XTZ
    withSender moneybag do
      transferMoney addr 0.9_e6 -- 0.9 XTZ
  pure addr

-- | Generate a new secret key and record it with given alias. If the
-- alias is already known, the key will be overwritten. The address is
-- guaranteed to be fresh, i. e. no operations on it have been made.
--
-- Notes:
--
-- * Beware that if an "alias prefix" is set, it'll be prepended to the given alias.
--   An "alias prefix" can be set using the @--cleveland-alias-prefix@ command line option, the
--   @TASTY_CLEVELAND_ALIAS_PREFIX@ env var, or with 'Test.Cleveland.Tasty.setAliasPrefix'.
--     > do
--     >   addr1 <- newFreshAddress "alias"
--     >   addr2 <- resolveAddress $ mkAlias "prefix.alias"
--     >   addr1 @== addr2
newFreshAddress :: (HasCallStack, MonadCleveland caps m) => SpecificOrDefaultAliasHint -> m Address
newFreshAddress aliasHint = do
  withCap getMiscCap \cap -> cmiGenFreshKey cap aliasHint

-- | Get the signature of the preapplied operation.
signBytes :: (HasCallStack, MonadCleveland caps m) => ByteString -> Address -> m Signature
signBytes bytes signer = do
  withCap getMiscCap \cap -> cmiSignBytes cap bytes signer

-- | Create a list of similarly named 'SpecificAliasHint's.
--
-- For example,
--
-- >>> enumAliasHints @2 "operator" `isEquivalentTo` "operator-0" :< "operator-1" :< Nil
-- True
enumAliasHints
  :: forall n n'.
     (SingIPeano n, IsoNatPeano n n')
  => AliasHint -> SizedList n SpecificOrDefaultAliasHint
enumAliasHints pfx = SpecificAliasHint <$> SL.generate @n (\n -> pfx <> "-" <> show n)

-- | Type-safer version of 'signBytes'.
signBinary :: (HasCallStack, BytesLike bs, MonadCleveland caps m) => bs -> Address -> m (TSignature bs)
signBinary bs addr = TSignature <$> signBytes (toBytes bs) addr

-- | Originate a new raw Michelson contract with given data.
originateUntyped :: (HasCallStack, MonadOps m) => UntypedOriginateData -> m Address
originateUntyped uod = withOpsCap \opsCap ->
  runSingleOperation opsCap "origination" (OpOriginate uod) \case
    OpOriginate addr -> Just addr
    _ -> Nothing

-- | A simplified version of the originateUntyped command.
-- The contract will have 0 balance.
originateUntypedSimple
  :: (HasCallStack, MonadOps m) => AliasHint -> U.Value -> U.Contract -> m Address
originateUntypedSimple uodName uodStorage uodContract = do
  let uodBalance = zeroMutez
  originateUntyped UntypedOriginateData{..}

-- | Lorentz version for origination.
--
-- By default, the sender is the account associated with the @moneybag@ alias.
-- This can be overriden with the @--cleveland-moneybag-alias@ command line option, the
-- @TASTY_CLEVELAND_MONEYBAG_ALIAS@ env var, or 'withSender'.
originate
  :: forall cp st vd m.
     (HasCallStack, MonadOps m)
  => OriginateData cp st vd -> m (ContractHandle cp st vd)
originate dat@OriginateData{ odContract = Contract{}, .. } = do
  addr <- originateUntyped (originateDataToUntyped dat)
  pure $ ContractHandle (pretty odName) addr

-- | A simplified version of the originate command.
-- The contract will have 0 balance.
originateSimple
  :: forall cp st vd m.
     ( HasCallStack
     , MonadOps m
     )
  => AliasHint
  -> st
  -> Contract cp st vd
  -> m (ContractHandle cp st vd)
originateSimple odName odStorage odContract = do
  let odBalance = zeroMutez
  originate OriginateData{..}

-- | Like 'originateUntypedSimple', but accepts typed contract and initial storage
-- as a Haskell value.
originateTypedSimple
  :: forall cp st vd m.
     ( HasCallStack
     , MonadOps m
     , NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd
     )
  => AliasHint -> st -> T.Contract (T.ToT cp) (T.ToT st) -> m (ContractHandle cp st vd)
originateTypedSimple name storage contract@T.Contract{} = do
  addr <- originateUntypedSimple name (untypeHelper storage) (convertContract contract)
  pure $ ContractHandle (pretty name) addr

-- | Originate a new Michelson contract that doesn't fit into the
-- origination size limit, by executing multiple operation steps.
--
-- This operation cannot be batched (it simply may not fit).
originateLargeUntyped
  :: (HasCallStack, MonadCleveland caps m) => UntypedOriginateData -> m Address
originateLargeUntyped uod = do
  sender <- view senderL
  withCap getMiscCap \cap -> cmiOriginateLargeUntyped cap sender uod

-- | A simplified version of the originateLargeUntyped command.
-- The contract will have 0 balance.
originateLargeUntypedSimple
  :: (HasCallStack, MonadCleveland caps m)
  => AliasHint -> U.Value -> U.Contract -> m Address
originateLargeUntypedSimple uodName uodStorage uodContract = do
  let uodBalance = zeroMutez
  originateLargeUntyped UntypedOriginateData{..}

-- | Lorentz version for large origination.
originateLarge
  :: forall param st vd m caps.
     (HasCallStack, MonadCleveland caps m)
  => OriginateData param st vd -> m (ContractHandle param st vd)
originateLarge dat@OriginateData{ odContract = Contract{}, .. } = do
  addr <- originateLargeUntyped (originateDataToUntyped dat)
  pure $ ContractHandle (pretty odName) addr

-- | A simplified version of the originateLarge command.
-- The contract will have 0 balance.
originateLargeSimple
  :: forall param st vd m caps.
     ( HasCallStack
     , MonadCleveland caps m
     )
  => AliasHint
  -> st
  -> Contract param st vd
  -> m (ContractHandle param st vd)
originateLargeSimple odName odStorage odContract = do
  let odBalance = zeroMutez
  originateLarge OriginateData{..}

-- | Base method for making a transfer.
--
-- Avoid using this method in favour of 'transferMoney' and 'call', unless
-- you need the semantics of both in one operation.
transfer :: (HasCallStack, MonadOps m) => TransferData -> m ()
transfer td = withOpsCap \opsCap ->
  runSingleOperation opsCap "transfer" (OpTransfer td) \case
    OpTransfer () -> Just ()
    _ -> Nothing

-- | Simply transfer money to an address.
--
-- This assumes that target address is either an implicit address or has
-- a default entrypoint with a unit argument; otherwise the call fails.
transferMoney :: (HasCallStack, MonadOps m, ToAddress addr) => addr -> Mutez -> m ()
transferMoney to amount = transfer TransferData
  { tdTo = to
  , tdAmount = amount
  , tdEntrypoint = DefEpName
  , tdParameter = ()
  }

-- | Call a certain entrypoint of the given contract.
--
-- By default, the sender is the account associated with the @moneybag@ alias.
-- This can be overriden with the @--cleveland-moneybag-alias@ command line option, the
-- @TASTY_CLEVELAND_MONEYBAG_ALIAS@ env var, or 'withSender'.
call
  :: forall param vd addr m epRef epArg.
     (HasCallStack, MonadOps m, ToTAddress param vd addr, HasEntrypointArg param epRef epArg
     , IsoValue epArg, Typeable epArg)
  => addr
  -> epRef
  -> epArg
  -> m ()
call to epRef param =
  case useHasEntrypointArg @param @epRef @epArg epRef of
    (Dict, epName) ->
      transfer TransferData
        { tdTo = toAddress $ toTAddress @param @vd @addr to
        , tdAmount = zeroMutez
        , tdEntrypoint = epName
        , tdParameter = param
        }

-- | Import an untyped contract from file.
importUntypedContract :: (HasCallStack, MonadCleveland caps m) => FilePath -> m U.Contract
importUntypedContract = runIO . Runtime.importUntypedContract

-- | Import a contract from file.
--
-- The compiler must be able to infer the types of parameter, storage and views.
-- In case there are no views or you don't care, you can use 'noViews'.
importContract
  :: ( HasCallStack, NiceParameter param, NiceStorage st
     , NiceViewsDescriptor vd, DemoteViewsDescriptor vd
     , MonadCleveland caps m
     )
  => FilePath -> m (Contract param st vd)
importContract = runIO . LorentzImport.importContract

{- | Run operations in a batch.
Best used with the @ApplicativeDo@ GHC extension.

Example:

@
{-# LANGUAGE ApplicativeDo #-}

contract <- inBatch $ do
  contract <- originate ...
  for_ [1..3] \i ->
    transfer ...
  return contract
@

Batched operations should be applied to chain faster, but note that batches have
their own limits. For instance, at the moment of writing, the gas limit on a
batch is 10x of gas limit applied to a single operation.

A context of a batch is only 'Applicative', not 'Monad'. This means that:

* Return values of one function cannot be passed to another function in the same
  batch, it can only be returned;
* Sometimes the compiler does not recognize that only 'Applicative' context is
  required, in case of any issues with that - follow the error messages.

-}
inBatch :: (HasCallStack, MonadCleveland caps m) => ClevelandOpsBatch a -> m a
inBatch batch = do
  withCap getOpsCap \cap -> runBatched cap batch

-- | Print the given string verbatim as a comment.
-- At the moment, this is a no-op in emulator tests.
comment :: (HasCallStack, MonadCleveland caps m) => Text -> m ()
comment cmt = do
  withCap getMiscCap \cap -> cmiComment cap cmt

-- | Get the balance of the given address.
getBalance :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m Mutez
getBalance addr = do
  withCap getMiscCap \cap -> cmiGetBalance cap (toAddress addr)

-- | Get the delegate for the given contract. Fails on implicit contracts.
getDelegate :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m (Maybe KeyHash)
getDelegate addr = do
  withCap getMiscCap \cap -> cmiGetDelegate cap (toAddress addr)

-- | Register the given address as a valid delegate.
registerDelegate :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m ()
registerDelegate addr = do
  withCap getMiscCap \cap -> cmiRegisterDelegate cap (toAddress addr)

-- | Retrieve a contract's storage in its "RPC representation"
-- (i.e., all its big_maps will be replaced by big_map IDs).
--
-- If the storage is of a user-defined type, then 'Test.Cleveland.deriveRPC' /
-- 'Test.Cleveland.deriveManyRPC' should be used to create an RPC representation of the storage
-- type.
--
-- > data MyStorage = MyStorage { field1 :: Natural, field2 :: BigMap Integer MText }
-- > deriveRPC "MyStorage"
getStorage
  :: forall st addr caps m.
    (HasCallStack, MonadCleveland caps m, ToStorageType st addr, IsoValue (AsRPC st))
  => addr
  -> m (AsRPC st)
getStorage contract = do
  someSt <- getSomeStorage contract
  case someSt ^? castTo @(AsRPC st) . value of
    Just st -> pure st
    Nothing -> failure $ unlinesF
      [ "Expected storage to be of type:"
      , indentF 2 $ build $ demote @(T.ToT (AsRPC st))
      , "But its type was:"
      , indentF 2 $ build $ getT someSt
      ]

-- | Retrieve a contract's full storage, including the contents of its big_maps.
--
-- This function can only be used in emulator-only tests.
getFullStorage
  :: forall st addr caps m.
    (HasCallStack, MonadEmulated caps m, ToStorageType st addr)
  => addr
  -> m st
getFullStorage contract = do
  withCap getEmulatedCap \cap -> eiGetStorage cap contract

-- | Similar to 'getStorage', but doesn't require knowing
-- the storage type in advance.
--
-- Use the optics in 'Morley.Michelson.Typed.AnnotatedValue' to
-- read data from the storage.
getSomeStorage
  :: forall addr caps m.
    (HasCallStack, MonadCleveland caps m, ToAddress addr)
  => addr
  -> m SomeAnnotatedValue
getSomeStorage contract = do
  withCap getMiscCap \cap -> cmiGetSomeStorage cap (toAddress contract)

-- | Retrieve a big_map value, given a big_map ID and a key.
-- Returns 'Nothing' when the big_map ID does not exist, or it exists but
-- does not contain the given key.
getBigMapValueMaybe
  :: forall k v caps m.
   ( HasCallStack, MonadCleveland caps m
   , NiceComparable k, NicePackedValue k, NiceUnpackedValue v
   )
  => BigMapId k v -> k -> m (Maybe v)
getBigMapValueMaybe bmId key = do
  withCap getMiscCap \cap -> cmiGetBigMapValueMaybe cap bmId key

-- | Like 'getBigMapValueMaybe', but fails the tests instead of returning 'Nothing'.
getBigMapValue
  :: forall k v caps m.
   ( HasCallStack, MonadCleveland caps m
   , NiceComparable k, NicePackedValue k, NiceUnpackedValue v
   , Buildable k
   )
  => BigMapId k v -> k -> m v
getBigMapValue bmId k =
  getBigMapValueMaybe bmId k >>= \case
    Just v -> pure v
    Nothing -> failure $ unlinesF @_ @Builder
      [ "Either:"
      , "  1. A big_map with ID '" +| bmId |+ "' does not exist, or"
      , "  2. It exists, but does not contain the key '" +| k |+ "'."
      ]

-- | Retrieve all big_map values, given a big_map ID.
-- Returns 'Nothing' when the big_map ID does not exist.
getAllBigMapValuesMaybe
  :: forall k v caps m.
  ( HasCallStack, MonadCleveland caps m
  , NiceComparable k, NiceUnpackedValue v
  )
  => BigMapId k v -> m (Maybe [v])
getAllBigMapValuesMaybe bmId = do
  withCap getMiscCap \cap -> cmiGetAllBigMapValuesMaybe cap bmId

-- | Like 'getAllBigMapValuesMaybe', but fails the tests instead of returning 'Nothing'.
getAllBigMapValues
  :: forall k v caps m.
  ( HasCallStack, MonadCleveland caps m
  , NiceComparable k, NiceUnpackedValue v
  )
  => BigMapId k v -> m [v]
getAllBigMapValues bmId =
  getAllBigMapValuesMaybe bmId >>= \case
    Just vs -> pure vs
    Nothing -> failure $ "A big map with ID '" +| bmId |+ "' does not exist"

-- | Retrieve a big_map size, given a big_map ID.
-- Returns 'Nothing' when the big_map ID does not exist.
--
-- /O(n)/, because it's implemented with 'Morley.Client.RPC.Getters.getBigMapValues'.
getBigMapSizeMaybe
  :: forall k v caps m.
  ( HasCallStack, MonadCleveland caps m
  , NiceComparable k, NiceUnpackedValue v
  )
  => BigMapId k v -> m (Maybe Natural)
getBigMapSizeMaybe bmId =
    fmap (fmap (Unsafe.fromIntegral @Int @Natural . length)) (getAllBigMapValuesMaybe bmId)

-- | Like 'getBigMapSizeMaybe', but fails the tests instead of returning 'Nothing'.
getBigMapSize
  :: forall k v caps m.
  ( HasCallStack, MonadCleveland caps m
  , NiceComparable k, NiceUnpackedValue v
  )
  => BigMapId k v -> m Natural
getBigMapSize bmId =
  Unsafe.fromIntegral @Int @Natural . length <$> getAllBigMapValues bmId

-- | Get the public key associated with given address.
-- Fail if given address is not an implicit account.
getPublicKey :: (HasCallStack, MonadCleveland caps m) => Address -> m PublicKey
getPublicKey addr = do
  withCap getMiscCap \cap -> cmiGetPublicKey cap addr

-- | Get the chain's @ChainId@.
getChainId :: (HasCallStack, MonadCleveland caps m) => m ChainId
getChainId = do
  withCap getMiscCap \cap -> cmiGetChainId cap

-- | Advance at least the given amount of time, or until a new block is baked,
-- whichever happens last.
--
-- On a real network, this is implemented using @threadDelay@, so it's advisable
-- to use small amounts of time only.
advanceTime
  :: forall unit caps m
  . (HasCallStack, MonadCleveland caps m, KnownDivRat unit Second)
  => Time unit -> m ()
advanceTime time = do
  withCap getMiscCap \cap -> cmiAdvanceTime cap time

-- | Wait till the provided number of levels is past.
advanceLevel
  :: forall caps m
  . (HasCallStack, MonadCleveland caps m)
  => Natural -> m ()
advanceLevel l = do
  withCap getMiscCap \cap -> cmiAdvanceToLevel cap (+ l)

-- | Wait till the provided level is reached.
advanceToLevel
  :: forall caps m
  . (HasCallStack, MonadCleveland caps m)
  => Natural -> m ()
advanceToLevel target = do
  withCap getMiscCap \cap -> cmiAdvanceToLevel cap (const target)

-- | Get the timestamp observed by the last block to be baked.
getNow :: (HasCallStack, MonadCleveland caps m) => m Timestamp
getNow = do
  withCap getMiscCap \cap -> cmiGetNow cap

-- | Get the current level observed by the last block to be baked.
getLevel :: (HasCallStack, MonadCleveland caps m) => m Natural
getLevel = do
  withCap getMiscCap \cap -> cmiGetLevel cap

-- | Get approximate block interval in seconds. Note, that this value
-- is minimal bound and real intervals can be larger, see
-- http://tezos.gitlab.io/active/consensus.html#minimal-block-delay-function
-- for more information about block delays.
getApproximateBlockInterval :: (HasCallStack, MonadCleveland caps m) => m (Time Second)
getApproximateBlockInterval = do
  withCap getMiscCap \cap -> cmiGetApproximateBlockInterval cap

-- | Execute a contract's code without originating it.
-- The chain's state will not be modified.
--
-- Notes:
--
-- * If the contract's code emits operations, they will not be executed.
-- * The sender's account won't be debited.
-- * When running an _originated_ contract, the @BALANCE@ instruction returns the
--   sum of the contract's balance before the transfer operation + the amount of tz being transferred.
--   In other words, this invariant holds: @BALANCE >= AMOUNT@.
--   However, since `runCode` allows overriding the @BALANCE@ instruction,
--   then this invariant no longer holds. It's possible that @BALANCE < AMOUNT@.
runCode
  :: (HasCallStack, MonadCleveland caps m, HasRPCRepr st, IsoValue (AsRPC st))
  => RunCode cp st vd -> m (AsRPC st)
runCode rc = do
  sender <- view senderL
  withCap getMiscCap \cap -> cmiRunCode cap sender rc

-- | Execute multiple testing scenarios independently.
--
-- * Actions performed before 'branchout' will be observed by all branches.
-- * Actions performed in branches will _not_ be observed by any actions performed after 'branchout'.
-- * Actions performed in one branch will _not_ be observed by another branch.
-- * The test succeeds IFF all branches succeed.
-- * If any branch fails, the test ends immediately and the remaining branches
--    won't be executed.
--
-- The following property holds:
--
-- > pre >> branchout [a, b, c] = branchout [pre >> a, pre >> b, pre >> c]
--
-- The list of branches must be non-empty.
branchout :: forall caps m. (MonadEmulated caps m) => [(Text, m ())] -> m ()
branchout branches = do
  caps <- ask
  let branches' :: [(Text, ClevelandBaseMonad caps ())] = second (flip runReaderT caps) <$> branches
  lift $ eiBranchout (getEmulatedCap caps) branches'

-- | Execute one or more actions and roll them back afterwards.
-- Actions performed in 'offshoot' will _not_ be observed by any
-- actions performed after 'offshoot'.
--
-- Similar to 'branchout', but accepts one single branch.
offshoot :: forall caps m. MonadEmulated caps m => Text -> m () -> m ()
offshoot branchName branch = branchout [(branchName, branch)]

{- | Returns the result of the action with the logs it produced. Logs are messages
printed by the Lorentz instruction 'Lorentz.printComment'.

This function can be combined either with lens-based accessors or helper functions to get
more specific information about logs.

Examples:

@
(logsInfo, _) <- getMorleyLogs scenario
logsInfo ^.. each . logsL @== [MorleyLogs ["log"], MorleyLogs ["log2"]]
logsInfo ^.. each . filterLogsByAddrL addr @== [MorleyLogs ["log"]]
@

@
(logsInfo, _) <- getMorleyLogs scenario
collectLogs logsInfo @== MorleyLogs ["log", "log2"]
logsForAddress logsInfo @== [MorleyLogs ["log"]]
@

-}
getMorleyLogs :: forall a caps m. MonadEmulated caps m => m a -> m (LogsInfo, a)
getMorleyLogs action = do
  caps <- ask
  let action' :: ClevelandBaseMonad caps a = runReaderT action caps
  lift $ eiGetMorleyLogs (getEmulatedCap caps) action'

-- | Version of `getMorleyLogs` for actions that don't return a result.
getMorleyLogs_ :: MonadEmulated caps m => m () -> m LogsInfo
getMorleyLogs_ action = fst <$> getMorleyLogs action

-- | Updates voting power accessible via @VOTING_POWER@ and similar
-- instructions.
setVotingPowers :: MonadEmulated caps m => VotingPowers -> m ()
setVotingPowers vp = do
  withCap getEmulatedCap \cap -> eiSetVotingPowers cap vp

-- | A helper constraint synonym to make signatures below a bit shorter
type EqBaseMonad a b = ClevelandBaseMonad a ~ ClevelandBaseMonad b

-- | Perform an action if we are currently in emulation mode.
-- See also 'ifEmulation' note on constraints.
whenEmulation
  :: MonadCleveland caps m
  => (forall caps1 m1. (EqBaseMonad caps caps1, MonadEmulated caps1 m1) => m1 ())
  -> m ()
whenEmulation action = ifEmulation action pass

-- | Perform an action if we are currently in network mode.
-- See also 'ifEmulation' note on constraints.
whenNetwork
  :: MonadCleveland caps m
  => (forall caps1 m1. (EqBaseMonad caps caps1, MonadCleveland caps1 m1) => m1 ())
  -> m ()
whenNetwork action = ifEmulation pass action

{- | Perform one action if we are currently in emulation mode, another otherwise

Functions passed as the first two arguments are universally quantified over
the outer monad, so if additional constraints are required beyond
'MonadEmulated' or 'MonadCleveland', those constraints have to go on the base
monad, e.g.

@
someFunction :: (MonadCleveland caps m, MonadFail (ClevelandBaseMonad caps)) => m ()
someFunction = whenEmulation do
  Just x <- pure (Just 1 :: Maybe Int) -- this would error without MonadFail
  runIO $ print x
@
-}
ifEmulation
  :: forall a caps m
   . MonadCleveland caps m
  => (forall caps1 m1. (EqBaseMonad caps caps1, MonadEmulated caps1 m1) => m1 a)
  -> (forall caps1 m1. (EqBaseMonad caps caps1, MonadCleveland caps1 m1) => m1 a)
  -> m a
ifEmulation onEmu onNet = withCap getMiscCap cmiEmulatedImpl >>= \case
  Nothing -> onNet
  Just impl -> withCap (view clevelandCapsL) (runReaderT onEmu . EmulatedCaps impl)

----------------------------------------------------------------------------
-- Assertions
----------------------------------------------------------------------------

-- | Fails the test with the given error message.
failure :: forall a caps m. (HasCallStack, MonadCleveland caps m) => Builder -> m a
failure msg = do
  withCap getMiscCap \cap -> cmiFailure cap msg

-- | Fails the test with the given error message if the given condition is false.
assert :: (HasCallStack, MonadCleveland caps m) => Bool -> Builder -> m ()
assert b errMsg =
  unless b $ failure errMsg

-- | @x \@== expected@ fails the test if @x@ is not equal to @expected@.
(@==)
  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)
  => a -- ^ The actual value.
  -> a -- ^ The expected value.
  -> m ()
actual @== expected =
  assert (actual == expected) $
    unlinesF
      [ "Failed comparison"
      , "━━ Expected (rhs) ━━"
      , build expected
      , "━━ Got (lhs) ━━"
      , build actual
      ]
infix 1 @==

-- | Fails the test if the two given values are equal.
(@/=)
  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)
  => a -> a -> m ()
a @/= b =
  assert (a /= b) $
    unlinesF
      [ "The two values are equal:"
      , build a
      ]
infix 1 @/=

-- | Monadic version of '@=='.
--
-- > getBalance addr @@== 10
(@@==)
  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)
  => m a -- ^ The actual value.
  -> a -- ^ The expected value.
  -> m ()
getActual @@== expected = do
  actual <- getActual
  actual @== expected
infix 1 @@==

-- | Monadic version of '@/='.
--
-- > getBalance addr @@/= 10
(@@/=)
  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)
  => m a -> a -> m ()
getA @@/= b =  do
  a <- getA
  a @/= b
infix 1 @@/=

-- | Fails the test if the comparison operator fails when applied to the given arguments.
-- Prints an error message with both arguments.
--
-- Example:
--
-- > checkCompares 2 (>) 1
checkCompares
  :: forall a b caps m
   . (HasCallStack, MonadCleveland caps m, Buildable a, Buildable b)
  => a
  -> (a -> b -> Bool)
  -> b
  -> m ()
checkCompares a f b = checkComparesWith pretty a f pretty b

-- | Like 'checkCompares', but with an explicit show function.
-- This function does not have any constraint on the type parameters @a@ and @b@.
--
-- For example, to print with 'Fmt.pretty':
--
-- > checkComparesWith pretty a (<) pretty b
checkComparesWith
  :: forall a b caps m
   . (HasCallStack, MonadCleveland caps m)
  => (a -> Text)
  -> a
  -> (a -> b -> Bool)
  -> (b -> Text)
  -> b
  -> m ()
checkComparesWith showA a f showB b =
  assert (f a b) $
    unlinesF
      [ "Failed"
      , "━━ lhs ━━"
      , showA a
      , "━━ rhs ━━"
      , showB b
      ]

-- | Fails the test if the `Maybe` is `Nothing`, otherwise returns the value in the `Just`.
evalJust :: (HasCallStack, MonadCleveland caps m) => Builder -> Maybe a -> m a
evalJust err = maybe (failure err) pure

-- | Fails the test if the `Either` is `Left`, otherwise returns the value in the `Right`.
evalRight :: (HasCallStack, MonadCleveland caps m) => (a -> Builder) -> Either a b -> m b
evalRight mkErr = either (failure . mkErr) pure

----------------------------------------------------------------------------
-- Exception Handling
----------------------------------------------------------------------------

-- | Attempt to run an action and return its result or, if interpretation fails, an error.
attempt
  :: forall e caps m a. (HasCallStack, MonadCleveland caps m, Exception e)
  => m a -> m (Either e a)
attempt action = do
  caps <- ask
  let action' :: ClevelandBaseMonad caps a = runReaderT action caps
  lift $ cmiAttempt (getMiscCap caps) action'

-- | Asserts that a transfer should fail, and returns the exception.
catchTransferFailure :: (HasCallStack, MonadCleveland caps m) => m a -> m TransferFailure
catchTransferFailure action =
  attempt action >>= \case
    Left err -> return err
    Right _ -> runIO $ throwM UnexpectedSuccess

-- | Asserts that a transfer should fail, and runs some 'TransferFailurePredicate's over the
-- exception.
--
-- > expectTransferFailure (failedWith (constant @MText "NOT_ADMIN")) $
-- >   call contractAddr (Call @"Ep") arg
--
-- > call contractAddr (Call @"Ep") arg & expectTransferFailure
-- >   ( failedWith (customError #tag 3) &&
-- >     addressIs contractAddr
-- >   )
expectTransferFailure :: (HasCallStack, MonadCleveland caps m) => TransferFailurePredicate -> m a -> m ()
expectTransferFailure predicate act = do
  err <- catchTransferFailure act
  checkTransferFailure err predicate

-- | Check whether a given predicate holds for a given 'TransferFailure'.
checkTransferFailure :: (HasCallStack, MonadCleveland caps m) => TransferFailure -> TransferFailurePredicate -> m ()
checkTransferFailure err predicate =
  case go predicate of
    Success () -> pass
    Failure expectedOutcome -> failure $ unlinesF
      [ "Expected transfer to fail with an error such that:"
      , ""
      , indentF 2 $ unlinesF expectedOutcome
      , ""
      , "But these conditions were not met."
      , "Actual transfer error:"
      , indentF 2 $ build err
      ]
  where
    go :: TransferFailurePredicate -> Validation (NonEmpty Builder) ()
    go = \case
      AndPredicate ps ->
        first (fmtExpectedOutcomes "AND") (traverse_ go ps)
      OrPredicate ps ->
        case traverse_ go ps of
          Success () -> Success ()
          Failure expectedOutcomes ->
            if length expectedOutcomes == length ps
              -- If all sub-predicates failed, then this predicate failed.
              then Failure $ fmtExpectedOutcomes "OR" expectedOutcomes
              -- If at least 1 sub-predicate succeeded, then this predicate succeeded.
              else Success ()
      TransferFailurePredicate p -> first one $ p err

    fmtExpectedOutcomes :: Builder -> NonEmpty Builder -> NonEmpty Builder
    fmtExpectedOutcomes delimiter = \case
      expectedOutcome :| [] -> one expectedOutcome
      expectedOutcomes ->
        one $ unlinesF
          [ "("
          , indentF 2 $ unlinesF $ NE.intersperse delimiter expectedOutcomes
          , ")"
          ]

-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given constant
-- value.
expectFailedWith
  :: forall err a caps m
   . (HasCallStack, MonadCleveland caps m, NiceConstant err)
  => err -> m a -> m ()
expectFailedWith err = expectTransferFailure $ failedWith (constant err)

-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz
-- error.
expectError
  :: forall err a caps m
   . (HasCallStack, MonadCleveland caps m, IsError err)
  => err -> m a -> m ()
expectError err = expectTransferFailure $ failedWith (lerror err)

-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given custom
-- lorentz error.
expectCustomError
  :: forall arg a tag caps m
   . ( HasCallStack, MonadCleveland caps m
     , IsError (CustomError tag)
     , MustHaveErrorArg tag (MText, arg)
     )
  => Label tag -> arg -> m a -> m ()
expectCustomError tag arg = expectTransferFailure $ failedWith (customError tag arg)

-- | Version of 'expectCustomError' for error with @unit@ argument.
expectCustomError_
  :: ( HasCallStack, MonadCleveland caps m
     , IsError (CustomError tag)
     , MustHaveErrorArg tag (MText, ())
     )
  => Label tag -> m a -> m ()
expectCustomError_ tag = expectCustomError tag ()

-- | Version of 'expectCustomError' specialized for expecting @NoErrorArg@s.
expectCustomErrorNoArg
  :: ( HasCallStack, MonadCleveland caps m
     , IsError (CustomError tag)
     , MustHaveErrorArg tag MText
     )
  => Label tag -> m a -> m ()
expectCustomErrorNoArg tag = expectTransferFailure $ failedWith (customErrorNoArg tag)

-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz
-- numeric error.
expectNumericError
  :: forall err a caps m
   . (HasCallStack, MonadCleveland caps m, IsError err)
  => ErrorTagMap -> err -> m a -> m ()
expectNumericError tagMap err = expectTransferFailure $ failedWith (numericError tagMap err)

-- | Prefix /scenario-custom/ error messages (i.e. @CustomTestError@ either from pure or non-pure
-- implementation), potentially thrown from the given code block.
--
-- The prefix will be put at a separate line before the main text, if text is multiline, otherwise
-- it will be separated from the main text with @: @.
--
-- This affects errors produced by functions like 'failure', 'assert', '@==', etc.
-- Errors related to events in the chain will not be touched.
--
-- Example:
--
-- > for [1..10] \i -> clarifyErrors ("For i=" +| i |+ "") $
-- >   askContract i @@== i * 2
clarifyErrors :: forall caps m a. (MonadCleveland caps m)
              => Builder -> m a -> m a
clarifyErrors message action = do
  attempt action >>= \case
    Left (e :: SomeException) -> withCap getMiscCap \cap -> cmiThrow cap (handle e)
    Right val -> pure val
  where
  handle :: SomeException -> SomeException
  handle e = fromMaybe e $
        wrap testClientErrorHandler e
    <|> wrap testPureErrorHandler e
    <|> wrap withCallStackErrorHandler e

  wrap f = fmap (toException . f) . fromException

  addPrefix = pretty . nameF message . build

  testClientErrorHandler :: Client.TestError -> Client.TestError
  testClientErrorHandler = \case
    Client.CustomTestError msg -> Client.CustomTestError $ addPrefix msg

  testPureErrorHandler :: Pure.TestError -> Pure.TestError
  testPureErrorHandler = \case
    Pure.CustomTestError msg -> Pure.CustomTestError $ addPrefix msg
    err -> err

  withCallStackErrorHandler :: WithCallStack -> WithCallStack
  withCallStackErrorHandler (WithCallStack cst e) = WithCallStack cst $ handle e

----------------------------------------------------------------------------
-- TransferFailure Predicates
----------------------------------------------------------------------------

-- | 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 actualAddr _ = err
  when (actualAddr /= 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 =
  withDict (niceConstantEvi @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

----------------------------------------------------------------------------
-- Internal helpers
----------------------------------------------------------------------------

withCap :: Monad m => (caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap getCap useCap = do
  cap <- asks getCap
  lift $ useCap cap

-- | Common conversion function from 'OriginateData' to 'UntypedOriginateData'
originateDataToUntyped :: OriginateData param st vd -> UntypedOriginateData
originateDataToUntyped OriginateData{ odContract = contract@Contract{}, .. } =
  UntypedOriginateData
  { uodName = odName
  , uodBalance = odBalance
  , uodStorage = untypeHelper odStorage
  , uodContract = convertContract $ toMichelsonContract contract
  }

untypeHelper :: forall st. NiceStorage st => st -> U.Value
untypeHelper = untypeValue . toVal \\ niceStorageEvi @st