-- 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
  , newAddresses
  , newFreshAddress
  , enumAliases
  , 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
  , getMinBlockTime
  , 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, toNum)
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.Address.Alias (Alias(..))
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 :: forall a.
(ClevelandOpsImpl ClevelandOpsBatch -> ClevelandOpsBatch a)
-> ClevelandOpsBatch a
withOpsCap ClevelandOpsImpl ClevelandOpsBatch -> ClevelandOpsBatch a
mkAction = ClevelandOpsImpl ClevelandOpsBatch -> ClevelandOpsBatch a
mkAction ClevelandOpsImpl ClevelandOpsBatch
batchedOpsImpl

instance (HasClevelandCaps caps, ClevelandBaseMonad caps ~ m) => MonadOps (ReaderT caps m) where
  withOpsCap :: forall a.
(ClevelandOpsImpl (ReaderT caps m) -> ReaderT caps m a)
-> ReaderT caps m a
withOpsCap ClevelandOpsImpl (ReaderT caps m) -> ReaderT caps m a
mkAction = do
    ClevelandOpsImpl m
opsCap :: ClevelandOpsImpl m <- (caps -> ClevelandOpsImpl m) -> ReaderT caps m (ClevelandOpsImpl m)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks caps -> ClevelandOpsImpl m
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandOpsImpl (ClevelandBaseMonad caps)
getOpsCap
    let ClevelandOpsImpl (ReaderT caps m)
opsCap' :: ClevelandOpsImpl (ReaderT caps m) =
          ClevelandOpsImpl :: forall (m :: * -> *).
(HasCallStack =>
 [OperationInfo ClevelandInput] -> m [OperationInfo Result])
-> ClevelandOpsImpl m
ClevelandOpsImpl
            { coiRunOperationBatch :: HasCallStack =>
[OperationInfo ClevelandInput]
-> ReaderT caps m [OperationInfo Result]
coiRunOperationBatch =  m [OperationInfo Result] -> ReaderT caps m [OperationInfo Result]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [OperationInfo Result] -> ReaderT caps m [OperationInfo Result])
-> ([OperationInfo ClevelandInput] -> m [OperationInfo Result])
-> [OperationInfo ClevelandInput]
-> ReaderT caps m [OperationInfo Result]
forall a b c. SuperComposition a b c => a -> b -> c
... ClevelandOpsImpl m
-> HasCallStack =>
   [OperationInfo ClevelandInput] -> m [OperationInfo Result]
forall (m :: * -> *).
ClevelandOpsImpl m
-> HasCallStack =>
   [OperationInfo ClevelandInput] -> m [OperationInfo Result]
coiRunOperationBatch ClevelandOpsImpl m
opsCap
            }
    ClevelandOpsImpl (ReaderT caps m) -> ReaderT caps m a
mkAction ClevelandOpsImpl (ReaderT caps m)
opsCap'

-- | Update the current sender on whose behalf transfers and originations are
-- invoked.
withSender :: MonadCleveland caps m => Address -> m a -> m a
withSender :: forall caps (m :: * -> *) a.
MonadCleveland caps m =>
Address -> m a -> m a
withSender Address
addr =
  (caps -> caps) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter caps caps Sender Sender -> Sender -> caps -> caps
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter caps caps Sender Sender
forall caps. HasClevelandCaps caps => Lens' caps Sender
senderL (Address -> Sender
Sender Address
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 :: forall caps (m :: * -> *) a.
MonadCleveland caps m =>
Address -> m a -> m a
withMoneybag Address
addr =
  (caps -> caps) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter caps caps Moneybag Moneybag -> Moneybag -> caps -> caps
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter caps caps Moneybag Moneybag
forall caps. HasClevelandCaps caps => Lens' caps Moneybag
moneybagL (Address -> Moneybag
Moneybag Address
addr))

-- | Runs an 'IO' action.
runIO :: (HasCallStack, MonadCleveland caps m) => IO res -> m res
runIO :: forall caps (m :: * -> *) res.
(HasCallStack, MonadCleveland caps m) =>
IO res -> m res
runIO IO res
io = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps res)
-> ReaderT caps (ClevelandBaseMonad caps) res
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> forall res.
   HasCallStack =>
   IO res -> ClevelandBaseMonad caps res
forall (m :: * -> *).
ClevelandMiscImpl m -> forall res. HasCallStack => IO res -> m res
cmiRunIO ClevelandMiscImpl (ClevelandBaseMonad caps)
cap IO res
io

-- | Get the address of the implicit account / contract associated with the given alias.
resolveAddress
  :: (HasCallStack, MonadCleveland caps m)
  => Alias -> m Address
resolveAddress :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Alias -> m Address
resolveAddress Alias
alias = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps Address)
-> ReaderT caps (ClevelandBaseMonad caps) Address
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> HasCallStack => Alias -> ClevelandBaseMonad caps Address
forall (m :: * -> *).
ClevelandMiscImpl m -> HasCallStack => Alias -> m Address
cmiResolveAddress ClevelandMiscImpl (ClevelandBaseMonad caps)
cap Alias
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 :: forall caps (m :: * -> *).
MonadCleveland caps m =>
m Address -> m Address
refillable m Address
action = do
  Address
addr <- m Address
action
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps ())
-> ReaderT caps (ClevelandBaseMonad caps) ()
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> Address -> ClevelandBaseMonad caps ()
forall (m :: * -> *). ClevelandMiscImpl m -> Address -> m ()
cmiMarkAddressRefillable ClevelandMiscImpl (ClevelandBaseMonad caps)
cap Address
addr
  pure Address
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'.
--     > do
--     >   addr1 <- newAddress "alias"
--     >   addr2 <- resolveAddress $ mkAlias "prefix.alias"
--     >   addr1 @== addr2
newAddress :: (HasCallStack, MonadCleveland caps m) => SpecificOrDefaultAlias -> m Address
newAddress :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
SpecificOrDefaultAlias -> m Address
newAddress SpecificOrDefaultAlias
alias = do
  SizedList' ('S 'Z) Address
addrs <- SizedList 1 SpecificOrDefaultAlias -> m (SizedList 1 Address)
forall (n :: Nat) (n' :: Peano) caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, IsoNatPeano n n') =>
SizedList n SpecificOrDefaultAlias -> m (SizedList n Address)
newAddresses (SizedList 1 SpecificOrDefaultAlias -> m (SizedList 1 Address))
-> SizedList 1 SpecificOrDefaultAlias -> m (SizedList 1 Address)
forall a b. (a -> b) -> a -> b
$ SpecificOrDefaultAlias
alias SpecificOrDefaultAlias
-> SizedList' 'Z SpecificOrDefaultAlias
-> SizedList' ('S 'Z) SpecificOrDefaultAlias
forall a (n1 :: Peano).
a -> SizedList' n1 a -> SizedList' ('S n1) a
:< SizedList' 'Z SpecificOrDefaultAlias
forall a. SizedList' 'Z a
Nil
  case SizedList' ('S 'Z) Address
addrs of
    Address
addr :< SizedList' n1 Address
Nil -> Address -> m Address
forall (f :: * -> *) a. Applicative f => a -> f a
pure Address
addr

-- | Batched version of `newAddress`
newAddresses
  :: forall n n' caps m.
    (HasCallStack, MonadCleveland caps m, IsoNatPeano n n')
  => SizedList n SpecificOrDefaultAlias
  -> m (SizedList n Address)
newAddresses :: forall (n :: Nat) (n' :: Peano) caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, IsoNatPeano n n') =>
SizedList n SpecificOrDefaultAlias -> m (SizedList n Address)
newAddresses SizedList n SpecificOrDefaultAlias
aliases = do
  SizedList' n' Address
addrs <- (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps (SizedList' n' Address))
-> ReaderT caps (ClevelandBaseMonad caps) (SizedList' n' Address)
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> (SpecificOrDefaultAlias -> ClevelandBaseMonad caps Address)
-> SizedList' n' SpecificOrDefaultAlias
-> ClevelandBaseMonad caps (SizedList' n' Address)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (ClevelandMiscImpl (ClevelandBaseMonad caps)
-> HasCallStack =>
   SpecificOrDefaultAlias -> ClevelandBaseMonad caps Address
forall (m :: * -> *).
ClevelandMiscImpl m
-> HasCallStack => SpecificOrDefaultAlias -> m Address
cmiGenKey ClevelandMiscImpl (ClevelandBaseMonad caps)
cap) SizedList' n' SpecificOrDefaultAlias
SizedList n SpecificOrDefaultAlias
aliases
  Moneybag Address
moneybag <- Getting Moneybag caps Moneybag -> m Moneybag
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Moneybag caps Moneybag
forall caps. HasClevelandCaps caps => Lens' caps Moneybag
moneybagL

  -- Addresses may exist from previous scenarios runs and have sufficient
  -- balance for the sake of testing; if so, we can save some time
  SizedList' n' Mutez
balances <- (Address -> m Mutez)
-> SizedList' n' Address -> m (SizedList' n' Mutez)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Address -> m Mutez
forall caps (m :: * -> *) addr.
(HasCallStack, MonadCleveland caps m, ToAddress addr) =>
addr -> m Mutez
getBalance SizedList' n' Address
addrs
  Address -> m () -> m ()
forall caps (m :: * -> *) a.
MonadCleveland caps m =>
Address -> m a -> m a
withSender Address
moneybag do
    ClevelandOpsBatch () -> m ()
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
ClevelandOpsBatch a -> m a
inBatch do
      SizedList' (MinPeano n' n') (ClevelandOpsBatch ())
-> ClevelandOpsBatch ()
forall t (f :: * -> *) a.
(Container t, Applicative f, Element t ~ f a) =>
t -> f ()
sequenceA_ (SizedList' (MinPeano n' n') (ClevelandOpsBatch ())
 -> ClevelandOpsBatch ())
-> SizedList' (MinPeano n' n') (ClevelandOpsBatch ())
-> ClevelandOpsBatch ()
forall a b. (a -> b) -> a -> b
$
        (Address -> Mutez -> ClevelandOpsBatch ())
-> SizedList' n' Address
-> SizedList' n' Mutez
-> SizedList' (MinPeano n' n') (ClevelandOpsBatch ())
forall a b c (n :: Peano) (m :: Peano).
(a -> b -> c)
-> SizedList' n a -> SizedList' m b -> SizedList' (MinPeano n m) c
SL.zipWith Address -> Mutez -> ClevelandOpsBatch ()
forall (m :: * -> *).
(HasCallStack, Applicative m, MonadOps m) =>
Address -> Mutez -> m ()
refillIfLowBalance SizedList' n' Address
addrs SizedList' n' Mutez
balances

  pure SizedList' n' Address
addrs

refillIfLowBalance :: (HasCallStack, Applicative m, MonadOps m) => Address -> Mutez -> m ()
refillIfLowBalance :: forall (m :: * -> *).
(HasCallStack, Applicative m, MonadOps m) =>
Address -> Mutez -> m ()
refillIfLowBalance Address
addr Mutez
balance =
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Mutez
balance Mutez -> Mutez -> Bool
forall a. Ord a => a -> a -> Bool
< Mutez
0.5_e6) do  -- < 0.5 XTZ
    Address -> Mutez -> m ()
forall (m :: * -> *) addr.
(HasCallStack, MonadOps m, ToAddress addr) =>
addr -> Mutez -> m ()
transferMoney Address
addr Mutez
0.9_e6 -- 0.9 XTZ

-- | 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) => SpecificOrDefaultAlias -> m Address
newFreshAddress :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
SpecificOrDefaultAlias -> m Address
newFreshAddress SpecificOrDefaultAlias
alias = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps Address)
-> ReaderT caps (ClevelandBaseMonad caps) Address
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> HasCallStack =>
   SpecificOrDefaultAlias -> ClevelandBaseMonad caps Address
forall (m :: * -> *).
ClevelandMiscImpl m
-> HasCallStack => SpecificOrDefaultAlias -> m Address
cmiGenFreshKey ClevelandMiscImpl (ClevelandBaseMonad caps)
cap SpecificOrDefaultAlias
alias

-- | Get the signature of the preapplied operation.
signBytes :: (HasCallStack, MonadCleveland caps m) => ByteString -> Address -> m Signature
signBytes :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
ByteString -> Address -> m Signature
signBytes ByteString
bytes Address
signer = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps Signature)
-> ReaderT caps (ClevelandBaseMonad caps) Signature
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> HasCallStack =>
   ByteString -> Address -> ClevelandBaseMonad caps Signature
forall (m :: * -> *).
ClevelandMiscImpl m
-> HasCallStack => ByteString -> Address -> m Signature
cmiSignBytes ClevelandMiscImpl (ClevelandBaseMonad caps)
cap ByteString
bytes Address
signer

-- | Create a list of similarly named 'SpecificAlias'es.
--
-- For example,
--
-- >>> enumAliases @2 "operator" `isEquivalentTo` "operator-0" :< "operator-1" :< Nil
-- True
enumAliases
  :: forall n n'.
     (SingIPeano n, IsoNatPeano n n')
  => Alias -> SizedList n SpecificOrDefaultAlias
enumAliases :: forall (n :: Nat) (n' :: Peano).
(SingIPeano n, IsoNatPeano n n') =>
Alias -> SizedList n SpecificOrDefaultAlias
enumAliases (Alias Text
pfx) = Alias -> SpecificOrDefaultAlias
SpecificAlias (Alias -> SpecificOrDefaultAlias)
-> SizedList' n' Alias -> SizedList' n' SpecificOrDefaultAlias
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (n :: Nat) (n' :: Peano) a.
(SingIPeano n, IsoNatPeano n n') =>
(Natural -> a) -> SizedList n a
SL.generate @n (\Natural
n -> Text -> Alias
Alias (Text -> Alias) -> Text -> Alias
forall a b. (a -> b) -> a -> b
$ Text
pfx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Natural -> Text
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show Natural
n)

-- | Type-safer version of 'signBytes'.
signBinary :: (HasCallStack, BytesLike bs, MonadCleveland caps m) => bs -> Address -> m (TSignature bs)
signBinary :: forall bs caps (m :: * -> *).
(HasCallStack, BytesLike bs, MonadCleveland caps m) =>
bs -> Address -> m (TSignature bs)
signBinary bs
bs Address
addr = Signature -> TSignature bs
forall a. Signature -> TSignature a
TSignature (Signature -> TSignature bs) -> m Signature -> m (TSignature bs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Address -> m Signature
forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
ByteString -> Address -> m Signature
signBytes (bs -> ByteString
forall bs. BytesLike bs => bs -> ByteString
toBytes bs
bs) Address
addr

-- | Originate a new raw Michelson contract with given data.
originateUntyped :: (HasCallStack, MonadOps m) => UntypedOriginateData -> m Address
originateUntyped :: forall (m :: * -> *).
(HasCallStack, MonadOps m) =>
UntypedOriginateData -> m Address
originateUntyped UntypedOriginateData
uod = (ClevelandOpsImpl m -> m Address) -> m Address
forall (m :: * -> *) a.
MonadOps m =>
(ClevelandOpsImpl m -> m a) -> m a
withOpsCap \ClevelandOpsImpl m
opsCap ->
  ClevelandOpsImpl m
-> Text
-> OperationInfo ClevelandInput
-> (OperationInfo Result -> Maybe Address)
-> m Address
forall (m :: * -> *) a.
(HasCallStack, Functor m) =>
ClevelandOpsImpl m
-> Text
-> OperationInfo ClevelandInput
-> (OperationInfo Result -> Maybe a)
-> m a
runSingleOperation ClevelandOpsImpl m
opsCap Text
"origination" (OriginationInfo ClevelandInput -> OperationInfo ClevelandInput
forall i. OriginationInfo i -> OperationInfo i
OpOriginate OriginationInfo ClevelandInput
UntypedOriginateData
uod) \case
    OpOriginate OriginationInfo Result
addr -> Address -> Maybe Address
forall a. a -> Maybe a
Just Address
OriginationInfo Result
addr
    OperationInfo Result
_ -> Maybe Address
forall a. Maybe a
Nothing

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

-- | 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 :: forall cp st vd (m :: * -> *).
(HasCallStack, MonadOps m) =>
OriginateData cp st vd -> m (ContractHandle cp st vd)
originate dat :: OriginateData cp st vd
dat@OriginateData{ odContract :: forall param st vd.
OriginateData param st vd -> Contract param st vd
odContract = Contract{}, st
Mutez
Alias
odStorage :: forall param st vd. OriginateData param st vd -> st
odBalance :: forall param st vd. OriginateData param st vd -> Mutez
odName :: forall param st vd. OriginateData param st vd -> Alias
odStorage :: st
odBalance :: Mutez
odName :: Alias
.. } = do
  Address
addr <- UntypedOriginateData -> m Address
forall (m :: * -> *).
(HasCallStack, MonadOps m) =>
UntypedOriginateData -> m Address
originateUntyped (OriginateData cp st vd -> UntypedOriginateData
forall param st vd.
OriginateData param st vd -> UntypedOriginateData
originateDataToUntyped OriginateData cp st vd
dat)
  pure $ Text -> Address -> ContractHandle cp st vd
forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd) =>
Text -> Address -> ContractHandle cp st vd
ContractHandle (Alias -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty Alias
odName) Address
addr

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

-- | 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
     )
  => Alias -> st -> T.Contract (T.ToT cp) (T.ToT st) -> m (ContractHandle cp st vd)
originateTypedSimple :: forall cp st vd (m :: * -> *).
(HasCallStack, MonadOps m, NiceParameter cp, NiceStorage st,
 NiceViewsDescriptor vd) =>
Alias
-> st -> Contract (ToT cp) (ToT st) -> m (ContractHandle cp st vd)
originateTypedSimple Alias
name st
storage contract :: Contract (ToT cp) (ToT st)
contract@T.Contract{} = do
  Address
addr <- Alias -> Value -> Contract -> m Address
forall (m :: * -> *).
(HasCallStack, MonadOps m) =>
Alias -> Value -> Contract -> m Address
originateUntypedSimple Alias
name (st -> Value
forall st. NiceStorage st => st -> Value
untypeHelper st
storage) (Contract (ToT cp) (ToT st) -> Contract
forall (param :: T) (store :: T). Contract param store -> Contract
convertContract Contract (ToT cp) (ToT st)
contract)
  pure $ Text -> Address -> ContractHandle cp st vd
forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd) =>
Text -> Address -> ContractHandle cp st vd
ContractHandle (Alias -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty Alias
name) Address
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 :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
UntypedOriginateData -> m Address
originateLargeUntyped UntypedOriginateData
uod = do
  Sender
sender <- Getting Sender caps Sender -> m Sender
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Sender caps Sender
forall caps. HasClevelandCaps caps => Lens' caps Sender
senderL
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps Address)
-> ReaderT caps (ClevelandBaseMonad caps) Address
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> HasCallStack =>
   Sender -> UntypedOriginateData -> ClevelandBaseMonad caps Address
forall (m :: * -> *).
ClevelandMiscImpl m
-> HasCallStack => Sender -> UntypedOriginateData -> m Address
cmiOriginateLargeUntyped ClevelandMiscImpl (ClevelandBaseMonad caps)
cap Sender
sender UntypedOriginateData
uod

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

-- | 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 :: forall param st vd (m :: * -> *) caps.
(HasCallStack, MonadCleveland caps m) =>
OriginateData param st vd -> m (ContractHandle param st vd)
originateLarge dat :: OriginateData param st vd
dat@OriginateData{ odContract :: forall param st vd.
OriginateData param st vd -> Contract param st vd
odContract = Contract{}, st
Mutez
Alias
odStorage :: st
odBalance :: Mutez
odName :: Alias
odStorage :: forall param st vd. OriginateData param st vd -> st
odBalance :: forall param st vd. OriginateData param st vd -> Mutez
odName :: forall param st vd. OriginateData param st vd -> Alias
.. } = do
  Address
addr <- UntypedOriginateData -> m Address
forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
UntypedOriginateData -> m Address
originateLargeUntyped (OriginateData param st vd -> UntypedOriginateData
forall param st vd.
OriginateData param st vd -> UntypedOriginateData
originateDataToUntyped OriginateData param st vd
dat)
  pure $ Text -> Address -> ContractHandle param st vd
forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd) =>
Text -> Address -> ContractHandle cp st vd
ContractHandle (Alias -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty Alias
odName) Address
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
     )
  => Alias
  -> st
  -> Contract param st vd
  -> m (ContractHandle param st vd)
originateLargeSimple :: forall param st vd (m :: * -> *) caps.
(HasCallStack, MonadCleveland caps m) =>
Alias
-> st -> Contract param st vd -> m (ContractHandle param st vd)
originateLargeSimple Alias
odName st
odStorage Contract param st vd
odContract = do
  let odBalance :: Mutez
odBalance = Mutez
zeroMutez
  OriginateData param st vd -> m (ContractHandle param st vd)
forall param st vd (m :: * -> *) caps.
(HasCallStack, MonadCleveland caps m) =>
OriginateData param st vd -> m (ContractHandle param st vd)
originateLarge OriginateData :: forall param st vd.
Alias
-> Mutez -> st -> Contract param st vd -> OriginateData param st vd
OriginateData{st
Mutez
Contract param st vd
Alias
odBalance :: Mutez
odContract :: Contract param st vd
odStorage :: st
odName :: Alias
odStorage :: st
odBalance :: Mutez
odName :: Alias
odContract :: Contract param st vd
..}

-- | 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 :: forall (m :: * -> *).
(HasCallStack, MonadOps m) =>
TransferData -> m ()
transfer TransferData
td = (ClevelandOpsImpl m -> m ()) -> m ()
forall (m :: * -> *) a.
MonadOps m =>
(ClevelandOpsImpl m -> m a) -> m a
withOpsCap \ClevelandOpsImpl m
opsCap ->
  ClevelandOpsImpl m
-> Text
-> OperationInfo ClevelandInput
-> (OperationInfo Result -> Maybe ())
-> m ()
forall (m :: * -> *) a.
(HasCallStack, Functor m) =>
ClevelandOpsImpl m
-> Text
-> OperationInfo ClevelandInput
-> (OperationInfo Result -> Maybe a)
-> m a
runSingleOperation ClevelandOpsImpl m
opsCap Text
"transfer" (TransferInfo ClevelandInput -> OperationInfo ClevelandInput
forall i. TransferInfo i -> OperationInfo i
OpTransfer TransferInfo ClevelandInput
TransferData
td) \case
    OpTransfer () -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
    OperationInfo Result
_ -> Maybe ()
forall a. Maybe a
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 :: forall (m :: * -> *) addr.
(HasCallStack, MonadOps m, ToAddress addr) =>
addr -> Mutez -> m ()
transferMoney addr
to Mutez
amount = TransferData -> m ()
forall (m :: * -> *).
(HasCallStack, MonadOps m) =>
TransferData -> m ()
transfer TransferData :: forall v addr.
(NiceParameter v, ToAddress addr) =>
addr -> Mutez -> EpName -> v -> TransferData
TransferData
  { tdTo :: addr
tdTo = addr
to
  , tdAmount :: Mutez
tdAmount = Mutez
amount
  , tdEntrypoint :: EpName
tdEntrypoint = EpName
DefEpName
  , tdParameter :: ()
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 :: 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 addr
to epRef
epRef epArg
param =
  case forall {k} (cp :: k) name arg.
HasEntrypointArg cp name arg =>
name -> (Dict (ParameterScope (ToT arg)), EpName)
forall cp name arg.
HasEntrypointArg cp name arg =>
name -> (Dict (ParameterScope (ToT arg)), EpName)
useHasEntrypointArg @param @epRef @epArg epRef
epRef of
    (Dict (ParameterScope (ToT epArg))
Dict, EpName
epName) ->
      TransferData -> m ()
forall (m :: * -> *).
(HasCallStack, MonadOps m) =>
TransferData -> m ()
transfer TransferData :: forall v addr.
(NiceParameter v, ToAddress addr) =>
addr -> Mutez -> EpName -> v -> TransferData
TransferData
        { tdTo :: Address
tdTo = TAddress param vd -> Address
forall a. ToAddress a => a -> Address
toAddress (TAddress param vd -> Address) -> TAddress param vd -> Address
forall a b. (a -> b) -> a -> b
$ forall cp vd a. ToTAddress cp vd a => a -> TAddress cp vd
toTAddress @param @vd @addr addr
to
        , tdAmount :: Mutez
tdAmount = Mutez
zeroMutez
        , tdEntrypoint :: EpName
tdEntrypoint = EpName
epName
        , tdParameter :: epArg
tdParameter = epArg
param
        }

-- | Import an untyped contract from file.
importUntypedContract :: (HasCallStack, MonadCleveland caps m) => FilePath -> m U.Contract
importUntypedContract :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
FilePath -> m Contract
importUntypedContract = IO Contract -> m Contract
forall caps (m :: * -> *) res.
(HasCallStack, MonadCleveland caps m) =>
IO res -> m res
runIO (IO Contract -> m Contract)
-> (FilePath -> IO Contract) -> FilePath -> m Contract
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO Contract
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 :: forall param st vd caps (m :: * -> *).
(HasCallStack, NiceParameter param, NiceStorage st,
 NiceViewsDescriptor vd, DemoteViewsDescriptor vd,
 MonadCleveland caps m) =>
FilePath -> m (Contract param st vd)
importContract = IO (Contract param st vd) -> m (Contract param st vd)
forall caps (m :: * -> *) res.
(HasCallStack, MonadCleveland caps m) =>
IO res -> m res
runIO (IO (Contract param st vd) -> m (Contract param st vd))
-> (FilePath -> IO (Contract param st vd))
-> FilePath
-> m (Contract param st vd)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO (Contract param st vd)
forall cp st vd.
(NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd,
 DemoteViewsDescriptor vd) =>
FilePath -> IO (Contract cp st vd)
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 :: forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
ClevelandOpsBatch a -> m a
inBatch ClevelandOpsBatch a
batch = do
  (caps -> ClevelandOpsImpl (ClevelandBaseMonad caps))
-> (ClevelandOpsImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps a)
-> ReaderT caps (ClevelandBaseMonad caps) a
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandOpsImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandOpsImpl (ClevelandBaseMonad caps)
getOpsCap \ClevelandOpsImpl (ClevelandBaseMonad caps)
cap -> ClevelandOpsImpl (ClevelandBaseMonad caps)
-> ClevelandOpsBatch a -> ClevelandBaseMonad caps a
forall (m :: * -> *) a.
(HasCallStack, Functor m) =>
ClevelandOpsImpl m -> ClevelandOpsBatch a -> m a
runBatched ClevelandOpsImpl (ClevelandBaseMonad caps)
cap ClevelandOpsBatch a
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 :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Text -> m ()
comment Text
cmt = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps ())
-> ReaderT caps (ClevelandBaseMonad caps) ()
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> HasCallStack => Text -> ClevelandBaseMonad caps ()
forall (m :: * -> *).
ClevelandMiscImpl m -> HasCallStack => Text -> m ()
cmiComment ClevelandMiscImpl (ClevelandBaseMonad caps)
cap Text
cmt

-- | Get the balance of the given address.
getBalance :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m Mutez
getBalance :: forall caps (m :: * -> *) addr.
(HasCallStack, MonadCleveland caps m, ToAddress addr) =>
addr -> m Mutez
getBalance addr
addr = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps Mutez)
-> ReaderT caps (ClevelandBaseMonad caps) Mutez
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> HasCallStack => Address -> ClevelandBaseMonad caps Mutez
forall (m :: * -> *).
ClevelandMiscImpl m -> HasCallStack => Address -> m Mutez
cmiGetBalance ClevelandMiscImpl (ClevelandBaseMonad caps)
cap (addr -> Address
forall a. ToAddress a => a -> Address
toAddress addr
addr)

-- | Get the delegate for the given contract. Fails on implicit contracts.
getDelegate :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m (Maybe KeyHash)
getDelegate :: forall caps (m :: * -> *) addr.
(HasCallStack, MonadCleveland caps m, ToAddress addr) =>
addr -> m (Maybe KeyHash)
getDelegate addr
addr = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps (Maybe KeyHash))
-> ReaderT caps (ClevelandBaseMonad caps) (Maybe KeyHash)
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> HasCallStack =>
   Address -> ClevelandBaseMonad caps (Maybe KeyHash)
forall (m :: * -> *).
ClevelandMiscImpl m -> HasCallStack => Address -> m (Maybe KeyHash)
cmiGetDelegate ClevelandMiscImpl (ClevelandBaseMonad caps)
cap (addr -> Address
forall a. ToAddress a => a -> Address
toAddress addr
addr)

-- | Register the given address as a valid delegate.
registerDelegate :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m ()
registerDelegate :: forall caps (m :: * -> *) addr.
(HasCallStack, MonadCleveland caps m, ToAddress addr) =>
addr -> m ()
registerDelegate addr
addr = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps ())
-> ReaderT caps (ClevelandBaseMonad caps) ()
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> HasCallStack => Address -> ClevelandBaseMonad caps ()
forall (m :: * -> *).
ClevelandMiscImpl m -> HasCallStack => Address -> m ()
cmiRegisterDelegate ClevelandMiscImpl (ClevelandBaseMonad caps)
cap (addr -> Address
forall a. ToAddress a => a -> Address
toAddress addr
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 :: forall st addr caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, ToStorageType st addr,
 IsoValue (AsRPC st)) =>
addr -> m (AsRPC st)
getStorage addr
contract = do
  SomeAnnotatedValue
someSt <- addr -> m SomeAnnotatedValue
forall addr caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, ToAddress addr) =>
addr -> m SomeAnnotatedValue
getSomeStorage addr
contract
  case SomeAnnotatedValue
someSt SomeAnnotatedValue
-> Getting (First (AsRPC st)) SomeAnnotatedValue (AsRPC st)
-> Maybe (AsRPC st)
forall s a. s -> Getting (First a) s a -> Maybe a
^? forall v1 v2.
(IsoValue v1, IsoValue v2) =>
Prism
  SomeAnnotatedValue
  SomeAnnotatedValue
  (AnnotatedValue v1)
  (AnnotatedValue v2)
castTo @(AsRPC st) ((AnnotatedValue (AsRPC st)
  -> Const (First (AsRPC st)) (AnnotatedValue (AsRPC st)))
 -> SomeAnnotatedValue
 -> Const (First (AsRPC st)) SomeAnnotatedValue)
-> ((AsRPC st -> Const (First (AsRPC st)) (AsRPC st))
    -> AnnotatedValue (AsRPC st)
    -> Const (First (AsRPC st)) (AnnotatedValue (AsRPC st)))
-> Getting (First (AsRPC st)) SomeAnnotatedValue (AsRPC st)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AsRPC st -> Const (First (AsRPC st)) (AsRPC st))
-> AnnotatedValue (AsRPC st)
-> Const (First (AsRPC st)) (AnnotatedValue (AsRPC st))
forall v. IsoValue v => Lens' (AnnotatedValue v) v
value of
    Just AsRPC st
st -> AsRPC st -> m (AsRPC st)
forall (f :: * -> *) a. Applicative f => a -> f a
pure AsRPC st
st
    Maybe (AsRPC st)
Nothing -> Builder -> m (AsRPC st)
forall a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Builder -> m a
failure (Builder -> m (AsRPC st)) -> Builder -> m (AsRPC st)
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
      [ Builder
"Expected storage to be of type:"
      , Int -> Builder -> Builder
indentF Int
2 (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ T -> Builder
forall p. Buildable p => p -> Builder
build (T -> Builder) -> T -> Builder
forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: T). (SingKind T, SingI a) => Demote T
demote @(T.ToT (AsRPC st))
      , Builder
"But its type was:"
      , Int -> Builder -> Builder
indentF Int
2 (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ T -> Builder
forall p. Buildable p => p -> Builder
build (T -> Builder) -> T -> Builder
forall a b. (a -> b) -> a -> b
$ SomeAnnotatedValue -> T
getT SomeAnnotatedValue
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 :: forall st addr caps (m :: * -> *).
(HasCallStack, MonadEmulated caps m, ToStorageType st addr) =>
addr -> m st
getFullStorage addr
contract = do
  (caps -> EmulatedImpl (ClevelandBaseMonad caps))
-> (EmulatedImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps st)
-> ReaderT caps (ClevelandBaseMonad caps) st
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> EmulatedImpl (ClevelandBaseMonad caps)
forall caps.
HasEmulatedCaps caps =>
caps -> EmulatedImpl (ClevelandBaseMonad caps)
getEmulatedCap \EmulatedImpl (ClevelandBaseMonad caps)
cap -> EmulatedImpl (ClevelandBaseMonad caps)
-> forall st addr.
   (HasCallStack, ToStorageType st addr) =>
   addr -> ClevelandBaseMonad caps st
forall (m :: * -> *).
EmulatedImpl m
-> forall st addr.
   (HasCallStack, ToStorageType st addr) =>
   addr -> m st
eiGetStorage EmulatedImpl (ClevelandBaseMonad caps)
cap addr
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 :: forall addr caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, ToAddress addr) =>
addr -> m SomeAnnotatedValue
getSomeStorage addr
contract = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps SomeAnnotatedValue)
-> ReaderT caps (ClevelandBaseMonad caps) SomeAnnotatedValue
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> HasCallStack =>
   Address -> ClevelandBaseMonad caps SomeAnnotatedValue
forall (m :: * -> *).
ClevelandMiscImpl m
-> HasCallStack => Address -> m SomeAnnotatedValue
cmiGetSomeStorage ClevelandMiscImpl (ClevelandBaseMonad caps)
cap (addr -> Address
forall a. ToAddress a => a -> Address
toAddress addr
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 :: forall k v caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, NiceComparable k,
 NicePackedValue k, NiceUnpackedValue v) =>
BigMapId k v -> k -> m (Maybe v)
getBigMapValueMaybe BigMapId k v
bmId k
key = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps (Maybe v))
-> ReaderT caps (ClevelandBaseMonad caps) (Maybe v)
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> forall k v.
   (HasCallStack, NiceComparable k, NicePackedValue k,
    NiceUnpackedValue v) =>
   BigMapId k v -> k -> ClevelandBaseMonad caps (Maybe v)
forall (m :: * -> *).
ClevelandMiscImpl m
-> forall k v.
   (HasCallStack, NiceComparable k, NicePackedValue k,
    NiceUnpackedValue v) =>
   BigMapId k v -> k -> m (Maybe v)
cmiGetBigMapValueMaybe ClevelandMiscImpl (ClevelandBaseMonad caps)
cap BigMapId k v
bmId k
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 :: forall k v caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, NiceComparable k,
 NicePackedValue k, NiceUnpackedValue v, Buildable k) =>
BigMapId k v -> k -> m v
getBigMapValue BigMapId k v
bmId k
k =
  BigMapId k v -> k -> m (Maybe v)
forall k v caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, NiceComparable k,
 NicePackedValue k, NiceUnpackedValue v) =>
BigMapId k v -> k -> m (Maybe v)
getBigMapValueMaybe BigMapId k v
bmId k
k m (Maybe v) -> (Maybe v -> m v) -> m v
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just v
v -> v -> m v
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
v
    Maybe v
Nothing -> Builder -> m v
forall a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Builder -> m a
failure (Builder -> m v) -> Builder -> m v
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF @_ @Builder
      [ Builder
"Either:"
      , Builder
"  1. A big_map with ID '" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| BigMapId k v
bmId BigMapId k v -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"' does not exist, or"
      , Builder
"  2. It exists, but does not contain the key '" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| k
k k -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"'."
      ]

-- | 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 :: forall k v caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, NiceComparable k,
 NiceUnpackedValue v) =>
BigMapId k v -> m (Maybe [v])
getAllBigMapValuesMaybe BigMapId k v
bmId = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps (Maybe [v]))
-> ReaderT caps (ClevelandBaseMonad caps) (Maybe [v])
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> forall k v.
   (HasCallStack, NiceComparable k, NiceUnpackedValue v) =>
   BigMapId k v -> ClevelandBaseMonad caps (Maybe [v])
forall (m :: * -> *).
ClevelandMiscImpl m
-> forall k v.
   (HasCallStack, NiceComparable k, NiceUnpackedValue v) =>
   BigMapId k v -> m (Maybe [v])
cmiGetAllBigMapValuesMaybe ClevelandMiscImpl (ClevelandBaseMonad caps)
cap BigMapId k v
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 :: forall k v caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, NiceComparable k,
 NiceUnpackedValue v) =>
BigMapId k v -> m [v]
getAllBigMapValues BigMapId k v
bmId =
  BigMapId k v -> m (Maybe [v])
forall k v caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, NiceComparable k,
 NiceUnpackedValue v) =>
BigMapId k v -> m (Maybe [v])
getAllBigMapValuesMaybe BigMapId k v
bmId m (Maybe [v]) -> (Maybe [v] -> m [v]) -> m [v]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just [v]
vs -> [v] -> m [v]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [v]
vs
    Maybe [v]
Nothing -> Builder -> m [v]
forall a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Builder -> m a
failure (Builder -> m [v]) -> Builder -> m [v]
forall a b. (a -> b) -> a -> b
$ Builder
"A big map with ID '" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| BigMapId k v
bmId BigMapId k v -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"' 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 :: forall k v caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, NiceComparable k,
 NiceUnpackedValue v) =>
BigMapId k v -> m (Maybe Natural)
getBigMapSizeMaybe BigMapId k v
bmId =
    (Maybe [v] -> Maybe Natural) -> m (Maybe [v]) -> m (Maybe Natural)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([v] -> Natural) -> Maybe [v] -> Maybe Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (HasCallStack, Integral a, Integral b) => a -> b
Unsafe.fromIntegral @Int @Natural (Int -> Natural) -> ([v] -> Int) -> [v] -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v] -> Int
forall t. Container t => t -> Int
length)) (BigMapId k v -> m (Maybe [v])
forall k v caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, NiceComparable k,
 NiceUnpackedValue v) =>
BigMapId k v -> m (Maybe [v])
getAllBigMapValuesMaybe BigMapId k v
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 :: forall k v caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, NiceComparable k,
 NiceUnpackedValue v) =>
BigMapId k v -> m Natural
getBigMapSize BigMapId k v
bmId =
  forall a b. (HasCallStack, Integral a, Integral b) => a -> b
Unsafe.fromIntegral @Int @Natural (Int -> Natural) -> ([v] -> Int) -> [v] -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v] -> Int
forall t. Container t => t -> Int
length ([v] -> Natural) -> m [v] -> m Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BigMapId k v -> m [v]
forall k v caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, NiceComparable k,
 NiceUnpackedValue v) =>
BigMapId k v -> m [v]
getAllBigMapValues BigMapId k v
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 :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Address -> m PublicKey
getPublicKey Address
addr = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps PublicKey)
-> ReaderT caps (ClevelandBaseMonad caps) PublicKey
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> HasCallStack => Address -> ClevelandBaseMonad caps PublicKey
forall (m :: * -> *).
ClevelandMiscImpl m -> HasCallStack => Address -> m PublicKey
cmiGetPublicKey ClevelandMiscImpl (ClevelandBaseMonad caps)
cap Address
addr

-- | Get the chain's @ChainId@.
getChainId :: (HasCallStack, MonadCleveland caps m) => m ChainId
getChainId :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
m ChainId
getChainId = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps ChainId)
-> ReaderT caps (ClevelandBaseMonad caps) ChainId
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> HasCallStack => ClevelandBaseMonad caps ChainId
forall (m :: * -> *).
ClevelandMiscImpl m -> HasCallStack => m ChainId
cmiGetChainId ClevelandMiscImpl (ClevelandBaseMonad caps)
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 :: forall (unit :: Rat) caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, KnownDivRat unit Second) =>
Time unit -> m ()
advanceTime Time unit
time = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps ())
-> ReaderT caps (ClevelandBaseMonad caps) ()
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> forall (unit :: Rat).
   (HasCallStack, KnownDivRat unit Second) =>
   Time unit -> ClevelandBaseMonad caps ()
forall (m :: * -> *).
ClevelandMiscImpl m
-> forall (unit :: Rat).
   (HasCallStack, KnownDivRat unit Second) =>
   Time unit -> m ()
cmiAdvanceTime ClevelandMiscImpl (ClevelandBaseMonad caps)
cap Time unit
time

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

-- | Wait till the provided level is reached.
advanceToLevel
  :: forall caps m
  . (HasCallStack, MonadCleveland caps m)
  => Natural -> m ()
advanceToLevel :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Natural -> m ()
advanceToLevel Natural
target = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps ())
-> ReaderT caps (ClevelandBaseMonad caps) ()
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> HasCallStack =>
   (Natural -> Natural) -> ClevelandBaseMonad caps ()
forall (m :: * -> *).
ClevelandMiscImpl m -> HasCallStack => (Natural -> Natural) -> m ()
cmiAdvanceToLevel ClevelandMiscImpl (ClevelandBaseMonad caps)
cap (Natural -> Natural -> Natural
forall a b. a -> b -> a
const Natural
target)

-- | Get the timestamp observed by the last block to be baked.
getNow :: (HasCallStack, MonadCleveland caps m) => m Timestamp
getNow :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
m Timestamp
getNow = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps Timestamp)
-> ReaderT caps (ClevelandBaseMonad caps) Timestamp
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> HasCallStack => ClevelandBaseMonad caps Timestamp
forall (m :: * -> *).
ClevelandMiscImpl m -> HasCallStack => m Timestamp
cmiGetNow ClevelandMiscImpl (ClevelandBaseMonad caps)
cap

-- | Get the current level observed by the last block to be baked.
getLevel :: (HasCallStack, MonadCleveland caps m) => m Natural
getLevel :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
m Natural
getLevel = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps Natural)
-> ReaderT caps (ClevelandBaseMonad caps) Natural
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> HasCallStack => ClevelandBaseMonad caps Natural
forall (m :: * -> *).
ClevelandMiscImpl m -> HasCallStack => m Natural
cmiGetLevel ClevelandMiscImpl (ClevelandBaseMonad caps)
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 :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
m (Time Second)
getApproximateBlockInterval = do
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps (Time (1 :% 1)))
-> ReaderT caps (ClevelandBaseMonad caps) (Time (1 :% 1))
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> HasCallStack => ClevelandBaseMonad caps (Time Second)
forall (m :: * -> *).
ClevelandMiscImpl m -> HasCallStack => m (Time Second)
cmiGetApproximateBlockInterval ClevelandMiscImpl (ClevelandBaseMonad caps)
cap

-- | Get minimal block delay in seconds. This is essentially the same as
-- 'getApproximateBlockInterval', but returns a 'Natural' instead of @Time
-- Second@.
--
-- Can be useful when testing code using @MIN_BLOCK_TIME@ instruction.
getMinBlockTime :: (HasCallStack, MonadCleveland caps m) => m Natural
getMinBlockTime :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
m Natural
getMinBlockTime = forall (unitTo :: Rat) n (unit :: Rat).
(KnownDivRat unit unitTo, Num n) =>
Time unit -> n
toNum @Second (Time (1 :% 1) -> Natural) -> m (Time (1 :% 1)) -> m Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Time (1 :% 1))
forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
m (Time Second)
getApproximateBlockInterval

-- | 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 :: forall caps (m :: * -> *) st cp vd.
(HasCallStack, MonadCleveland caps m, HasRPCRepr st,
 IsoValue (AsRPC st)) =>
RunCode cp st vd -> m (AsRPC st)
runCode RunCode cp st vd
rc = do
  Sender
sender <- Getting Sender caps Sender -> m Sender
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Sender caps Sender
forall caps. HasClevelandCaps caps => Lens' caps Sender
senderL
  (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps (AsRPC st))
-> ReaderT caps (ClevelandBaseMonad caps) (AsRPC st)
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> forall cp st vd.
   (HasCallStack, HasRPCRepr st, IsoValue (AsRPC st)) =>
   Sender -> RunCode cp st vd -> ClevelandBaseMonad caps (AsRPC st)
forall (m :: * -> *).
ClevelandMiscImpl m
-> forall cp st vd.
   (HasCallStack, HasRPCRepr st, IsoValue (AsRPC st)) =>
   Sender -> RunCode cp st vd -> m (AsRPC st)
cmiRunCode ClevelandMiscImpl (ClevelandBaseMonad caps)
cap Sender
sender RunCode cp st vd
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 :: forall caps (m :: * -> *).
MonadEmulated caps m =>
[(Text, m ())] -> m ()
branchout [(Text, m ())]
branches = do
  caps
caps <- m caps
forall r (m :: * -> *). MonadReader r m => m r
ask
  let [(Text, ClevelandBaseMonad caps ())]
branches' :: [(Text, ClevelandBaseMonad caps ())] = (ReaderT caps (ClevelandBaseMonad caps) ()
 -> ClevelandBaseMonad caps ())
-> (Text, ReaderT caps (ClevelandBaseMonad caps) ())
-> (Text, ClevelandBaseMonad caps ())
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((ReaderT caps (ClevelandBaseMonad caps) ()
 -> caps -> ClevelandBaseMonad caps ())
-> caps
-> ReaderT caps (ClevelandBaseMonad caps) ()
-> ClevelandBaseMonad caps ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT caps (ClevelandBaseMonad caps) ()
-> caps -> ClevelandBaseMonad caps ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT caps
caps) ((Text, ReaderT caps (ClevelandBaseMonad caps) ())
 -> (Text, ClevelandBaseMonad caps ()))
-> [(Text, ReaderT caps (ClevelandBaseMonad caps) ())]
-> [(Text, ClevelandBaseMonad caps ())]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, m ())]
[(Text, ReaderT caps (ClevelandBaseMonad caps) ())]
branches
  ClevelandBaseMonad caps ()
-> ReaderT caps (ClevelandBaseMonad caps) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ClevelandBaseMonad caps ()
 -> ReaderT caps (ClevelandBaseMonad caps) ())
-> ClevelandBaseMonad caps ()
-> ReaderT caps (ClevelandBaseMonad caps) ()
forall a b. (a -> b) -> a -> b
$ EmulatedImpl (ClevelandBaseMonad caps)
-> [(Text, ClevelandBaseMonad caps ())]
-> ClevelandBaseMonad caps ()
forall (m :: * -> *). EmulatedImpl m -> [(Text, m ())] -> m ()
eiBranchout (caps -> EmulatedImpl (ClevelandBaseMonad caps)
forall caps.
HasEmulatedCaps caps =>
caps -> EmulatedImpl (ClevelandBaseMonad caps)
getEmulatedCap caps
caps) [(Text, ClevelandBaseMonad 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 :: forall caps (m :: * -> *).
MonadEmulated caps m =>
Text -> m () -> m ()
offshoot Text
branchName m ()
branch = [(Text, m ())] -> m ()
forall caps (m :: * -> *).
MonadEmulated caps m =>
[(Text, m ())] -> m ()
branchout [(Text
branchName, m ()
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 :: forall a caps (m :: * -> *).
MonadEmulated caps m =>
m a -> m (LogsInfo, a)
getMorleyLogs m a
action = do
  caps
caps <- m caps
forall r (m :: * -> *). MonadReader r m => m r
ask
  let ClevelandBaseMonad caps a
action' :: ClevelandBaseMonad caps a = ReaderT caps (ClevelandBaseMonad caps) a
-> caps -> ClevelandBaseMonad caps a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT m a
ReaderT caps (ClevelandBaseMonad caps) a
action caps
caps
  ClevelandBaseMonad caps (LogsInfo, a)
-> ReaderT caps (ClevelandBaseMonad caps) (LogsInfo, a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ClevelandBaseMonad caps (LogsInfo, a)
 -> ReaderT caps (ClevelandBaseMonad caps) (LogsInfo, a))
-> ClevelandBaseMonad caps (LogsInfo, a)
-> ReaderT caps (ClevelandBaseMonad caps) (LogsInfo, a)
forall a b. (a -> b) -> a -> b
$ EmulatedImpl (ClevelandBaseMonad caps)
-> forall a.
   ClevelandBaseMonad caps a -> ClevelandBaseMonad caps (LogsInfo, a)
forall (m :: * -> *).
EmulatedImpl m -> forall a. m a -> m (LogsInfo, a)
eiGetMorleyLogs (caps -> EmulatedImpl (ClevelandBaseMonad caps)
forall caps.
HasEmulatedCaps caps =>
caps -> EmulatedImpl (ClevelandBaseMonad caps)
getEmulatedCap caps
caps) ClevelandBaseMonad caps a
action'

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

-- | Updates voting power accessible via @VOTING_POWER@ and similar
-- instructions.
setVotingPowers :: MonadEmulated caps m => VotingPowers -> m ()
setVotingPowers :: forall caps (m :: * -> *).
MonadEmulated caps m =>
VotingPowers -> m ()
setVotingPowers VotingPowers
vp = do
  (caps -> EmulatedImpl (ClevelandBaseMonad caps))
-> (EmulatedImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps ())
-> ReaderT caps (ClevelandBaseMonad caps) ()
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> EmulatedImpl (ClevelandBaseMonad caps)
forall caps.
HasEmulatedCaps caps =>
caps -> EmulatedImpl (ClevelandBaseMonad caps)
getEmulatedCap \EmulatedImpl (ClevelandBaseMonad caps)
cap -> EmulatedImpl (ClevelandBaseMonad caps)
-> VotingPowers -> ClevelandBaseMonad caps ()
forall (m :: * -> *). EmulatedImpl m -> VotingPowers -> m ()
eiSetVotingPowers EmulatedImpl (ClevelandBaseMonad caps)
cap VotingPowers
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 :: forall caps (m :: * -> *).
MonadCleveland caps m =>
(forall caps1 (m1 :: * -> *).
 (EqBaseMonad caps caps1, MonadEmulated caps1 m1) =>
 m1 ())
-> m ()
whenEmulation forall caps1 (m1 :: * -> *).
(EqBaseMonad caps caps1, MonadEmulated caps1 m1) =>
m1 ()
action = (forall caps1 (m1 :: * -> *).
 (EqBaseMonad caps caps1, MonadEmulated caps1 m1) =>
 m1 ())
-> (forall caps1 (m1 :: * -> *).
    (EqBaseMonad caps caps1, MonadCleveland caps1 m1) =>
    m1 ())
-> m ()
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 forall caps1 (m1 :: * -> *).
(EqBaseMonad caps caps1, MonadEmulated caps1 m1) =>
m1 ()
action forall caps1 (m1 :: * -> *).
(EqBaseMonad caps caps1, MonadCleveland caps1 m1) =>
m1 ()
forall (f :: * -> *). Applicative f => f ()
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 :: forall caps (m :: * -> *).
MonadCleveland caps m =>
(forall caps1 (m1 :: * -> *).
 (EqBaseMonad caps caps1, MonadCleveland caps1 m1) =>
 m1 ())
-> m ()
whenNetwork forall caps1 (m1 :: * -> *).
(EqBaseMonad caps caps1, MonadCleveland caps1 m1) =>
m1 ()
action = (forall caps1 (m1 :: * -> *).
 (EqBaseMonad caps caps1, MonadEmulated caps1 m1) =>
 m1 ())
-> (forall caps1 (m1 :: * -> *).
    (EqBaseMonad caps caps1, MonadCleveland caps1 m1) =>
    m1 ())
-> m ()
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 forall caps1 (m1 :: * -> *).
(EqBaseMonad caps caps1, MonadEmulated caps1 m1) =>
m1 ()
forall (f :: * -> *). Applicative f => f ()
pass forall caps1 (m1 :: * -> *).
(EqBaseMonad caps caps1, MonadCleveland caps1 m1) =>
m1 ()
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 :: 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 forall caps1 (m1 :: * -> *).
(EqBaseMonad caps caps1, MonadEmulated caps1 m1) =>
m1 a
onEmu forall caps1 (m1 :: * -> *).
(EqBaseMonad caps caps1, MonadCleveland caps1 m1) =>
m1 a
onNet = (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad
         caps (Maybe (EmulatedImpl (ClevelandBaseMonad caps))))
-> ReaderT
     caps
     (ClevelandBaseMonad caps)
     (Maybe (EmulatedImpl (ClevelandBaseMonad caps)))
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap ClevelandMiscImpl (ClevelandBaseMonad caps)
-> ClevelandBaseMonad
     caps (Maybe (EmulatedImpl (ClevelandBaseMonad caps)))
forall (m :: * -> *).
ClevelandMiscImpl m -> m (Maybe (EmulatedImpl m))
cmiEmulatedImpl ReaderT
  caps
  (ClevelandBaseMonad caps)
  (Maybe (EmulatedImpl (ClevelandBaseMonad caps)))
-> (Maybe (EmulatedImpl (ClevelandBaseMonad caps))
    -> ReaderT caps (ClevelandBaseMonad caps) a)
-> ReaderT caps (ClevelandBaseMonad caps) a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe (EmulatedImpl (ClevelandBaseMonad caps))
Nothing -> ReaderT caps (ClevelandBaseMonad caps) a
forall caps1 (m1 :: * -> *).
(EqBaseMonad caps caps1, MonadCleveland caps1 m1) =>
m1 a
onNet
  Just EmulatedImpl (ClevelandBaseMonad caps)
impl -> (caps -> ClevelandCaps (ClevelandBaseMonad caps))
-> (ClevelandCaps (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps a)
-> ReaderT caps (ClevelandBaseMonad caps) a
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap (Getting
  (ClevelandCaps (ClevelandBaseMonad caps))
  caps
  (ClevelandCaps (ClevelandBaseMonad caps))
-> caps -> ClevelandCaps (ClevelandBaseMonad caps)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (ClevelandCaps (ClevelandBaseMonad caps))
  caps
  (ClevelandCaps (ClevelandBaseMonad caps))
forall caps.
HasClevelandCaps caps =>
Lens' caps (ClevelandCaps (ClevelandBaseMonad caps))
clevelandCapsL) (ReaderT
  (EmulatedCaps (ClevelandBaseMonad caps))
  (ClevelandBaseMonad caps)
  a
-> EmulatedCaps (ClevelandBaseMonad caps)
-> ClevelandBaseMonad caps a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT
  (EmulatedCaps (ClevelandBaseMonad caps))
  (ClevelandBaseMonad caps)
  a
forall caps1 (m1 :: * -> *).
(EqBaseMonad caps caps1, MonadEmulated caps1 m1) =>
m1 a
onEmu (EmulatedCaps (ClevelandBaseMonad caps)
 -> ClevelandBaseMonad caps a)
-> (ClevelandCaps (ClevelandBaseMonad caps)
    -> EmulatedCaps (ClevelandBaseMonad caps))
-> ClevelandCaps (ClevelandBaseMonad caps)
-> ClevelandBaseMonad caps a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmulatedImpl (ClevelandBaseMonad caps)
-> ClevelandCaps (ClevelandBaseMonad caps)
-> EmulatedCaps (ClevelandBaseMonad caps)
forall (m :: * -> *).
EmulatedImpl m -> ClevelandCaps m -> EmulatedCaps m
EmulatedCaps EmulatedImpl (ClevelandBaseMonad caps)
impl)

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

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

-- | Fails the test with the given error message if the given condition is false.
assert :: (HasCallStack, MonadCleveland caps m) => Bool -> Builder -> m ()
assert :: forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Bool -> Builder -> m ()
assert Bool
b Builder
errMsg =
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Builder -> m ()
forall a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Builder -> m a
failure Builder
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 ()
a
actual @== :: forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Eq a, Buildable a) =>
a -> a -> m ()
@== a
expected =
  Bool -> Builder -> m ()
forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Bool -> Builder -> m ()
assert (a
actual a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
expected) (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$
    [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
      [ Builder
"Failed comparison"
      , Builder
"━━ Expected (rhs) ━━"
      , a -> Builder
forall p. Buildable p => p -> Builder
build a
expected
      , Builder
"━━ Got (lhs) ━━"
      , a -> Builder
forall p. Buildable p => p -> Builder
build a
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
a @/= :: forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Eq a, Buildable a) =>
a -> a -> m ()
@/= a
b =
  Bool -> Builder -> m ()
forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Bool -> Builder -> m ()
assert (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
b) (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$
    [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
      [ Builder
"The two values are equal:"
      , a -> Builder
forall p. Buildable p => p -> Builder
build a
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 ()
m a
getActual @@== :: forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Eq a, Buildable a) =>
m a -> a -> m ()
@@== a
expected = do
  a
actual <- m a
getActual
  a
actual a -> a -> m ()
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Eq a, Buildable a) =>
a -> a -> m ()
@== a
expected
infix 1 @@==

-- | Monadic version of '@/='.
--
-- > getBalance addr @@/= 10
(@@/=)
  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)
  => m a -> a -> m ()
m a
getA @@/= :: forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Eq a, Buildable a) =>
m a -> a -> m ()
@@/= a
b =  do
  a
a <- m a
getA
  a
a a -> a -> m ()
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Eq a, Buildable a) =>
a -> a -> m ()
@/= 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 :: forall a b caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, Buildable a, Buildable b) =>
a -> (a -> b -> Bool) -> b -> m ()
checkCompares a
a a -> b -> Bool
f b
b = (a -> Text) -> a -> (a -> b -> Bool) -> (b -> Text) -> b -> m ()
forall a b caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
(a -> Text) -> a -> (a -> b -> Bool) -> (b -> Text) -> b -> m ()
checkComparesWith a -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty a
a a -> b -> Bool
f b -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty b
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 :: forall a b caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
(a -> Text) -> a -> (a -> b -> Bool) -> (b -> Text) -> b -> m ()
checkComparesWith a -> Text
showA a
a a -> b -> Bool
f b -> Text
showB b
b =
  Bool -> Builder -> m ()
forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Bool -> Builder -> m ()
assert (a -> b -> Bool
f a
a b
b) (Builder -> m ()) -> Builder -> m ()
forall a b. (a -> b) -> a -> b
$
    [Text] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
      [ Text
"Failed"
      , Text
"━━ lhs ━━"
      , a -> Text
showA a
a
      , Text
"━━ rhs ━━"
      , b -> Text
showB b
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 :: forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
Builder -> Maybe a -> m a
evalJust Builder
err = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Builder -> m a
forall a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Builder -> m a
failure Builder
err) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
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 :: forall caps (m :: * -> *) a b.
(HasCallStack, MonadCleveland caps m) =>
(a -> Builder) -> Either a b -> m b
evalRight a -> Builder
mkErr = (a -> m b) -> (b -> m b) -> Either a b -> m b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Builder -> m b
forall a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
Builder -> m a
failure (Builder -> m b) -> (a -> Builder) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Builder
mkErr) b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
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 :: forall e caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Exception e) =>
m a -> m (Either e a)
attempt m a
action = do
  caps
caps <- m caps
forall r (m :: * -> *). MonadReader r m => m r
ask
  let ClevelandBaseMonad caps a
action' :: ClevelandBaseMonad caps a = ReaderT caps (ClevelandBaseMonad caps) a
-> caps -> ClevelandBaseMonad caps a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT m a
ReaderT caps (ClevelandBaseMonad caps) a
action caps
caps
  ClevelandBaseMonad caps (Either e a)
-> ReaderT caps (ClevelandBaseMonad caps) (Either e a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ClevelandBaseMonad caps (Either e a)
 -> ReaderT caps (ClevelandBaseMonad caps) (Either e a))
-> ClevelandBaseMonad caps (Either e a)
-> ReaderT caps (ClevelandBaseMonad caps) (Either e a)
forall a b. (a -> b) -> a -> b
$ ClevelandMiscImpl (ClevelandBaseMonad caps)
-> forall a e.
   (Exception e, HasCallStack) =>
   ClevelandBaseMonad caps a -> ClevelandBaseMonad caps (Either e a)
forall (m :: * -> *).
ClevelandMiscImpl m
-> forall a e. (Exception e, HasCallStack) => m a -> m (Either e a)
cmiAttempt (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap caps
caps) ClevelandBaseMonad caps a
action'

-- | Asserts that a transfer should fail, and returns the exception.
catchTransferFailure :: (HasCallStack, MonadCleveland caps m) => m a -> m TransferFailure
catchTransferFailure :: forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
m a -> m TransferFailure
catchTransferFailure m a
action =
  m a -> m (Either TransferFailure a)
forall e caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Exception e) =>
m a -> m (Either e a)
attempt m a
action m (Either TransferFailure a)
-> (Either TransferFailure a -> m TransferFailure)
-> m TransferFailure
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left TransferFailure
err -> TransferFailure -> m TransferFailure
forall (m :: * -> *) a. Monad m => a -> m a
return TransferFailure
err
    Right a
_ -> IO TransferFailure -> m TransferFailure
forall caps (m :: * -> *) res.
(HasCallStack, MonadCleveland caps m) =>
IO res -> m res
runIO (IO TransferFailure -> m TransferFailure)
-> IO TransferFailure -> m TransferFailure
forall a b. (a -> b) -> a -> b
$ GenericTestError -> IO TransferFailure
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM GenericTestError
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 :: forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
TransferFailurePredicate -> m a -> m ()
expectTransferFailure TransferFailurePredicate
predicate m a
act = do
  TransferFailure
err <- m a -> m TransferFailure
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
m a -> m TransferFailure
catchTransferFailure m a
act
  TransferFailure -> TransferFailurePredicate -> m ()
forall caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m) =>
TransferFailure -> TransferFailurePredicate -> m ()
checkTransferFailure TransferFailure
err TransferFailurePredicate
predicate

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

    fmtExpectedOutcomes :: Builder -> NonEmpty Builder -> NonEmpty Builder
    fmtExpectedOutcomes :: Builder -> NonEmpty Builder -> NonEmpty Builder
fmtExpectedOutcomes Builder
delimiter = \case
      Builder
expectedOutcome :| [] -> OneItem (NonEmpty Builder) -> NonEmpty Builder
forall x. One x => OneItem x -> x
one Builder
OneItem (NonEmpty Builder)
expectedOutcome
      NonEmpty Builder
expectedOutcomes ->
        OneItem (NonEmpty Builder) -> NonEmpty Builder
forall x. One x => OneItem x -> x
one (OneItem (NonEmpty Builder) -> NonEmpty Builder)
-> OneItem (NonEmpty Builder) -> NonEmpty Builder
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
          [ Builder
"("
          , Int -> Builder -> Builder
indentF Int
2 (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ NonEmpty Builder -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF (NonEmpty Builder -> Builder) -> NonEmpty Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> NonEmpty Builder -> NonEmpty Builder
forall a. a -> NonEmpty a -> NonEmpty a
NE.intersperse Builder
delimiter NonEmpty Builder
expectedOutcomes
          , Builder
")"
          ]

-- | 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 :: forall err a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, NiceConstant err) =>
err -> m a -> m ()
expectFailedWith err
err = TransferFailurePredicate -> m a -> m ()
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
TransferFailurePredicate -> m a -> m ()
expectTransferFailure (TransferFailurePredicate -> m a -> m ())
-> TransferFailurePredicate -> m a -> m ()
forall a b. (a -> b) -> a -> b
$ SomeConstant -> TransferFailurePredicate
failedWith (err -> SomeConstant
forall err. NiceConstant err => err -> SomeConstant
constant err
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 :: forall err a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, IsError err) =>
err -> m a -> m ()
expectError err
err = TransferFailurePredicate -> m a -> m ()
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
TransferFailurePredicate -> m a -> m ()
expectTransferFailure (TransferFailurePredicate -> m a -> m ())
-> TransferFailurePredicate -> m a -> m ()
forall a b. (a -> b) -> a -> b
$ SomeConstant -> TransferFailurePredicate
failedWith (err -> SomeConstant
forall err. IsError err => err -> SomeConstant
lerror err
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 :: forall arg a (tag :: Symbol) caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, IsError (CustomError tag),
 MustHaveErrorArg tag (MText, arg)) =>
Label tag -> arg -> m a -> m ()
expectCustomError Label tag
tag arg
arg = TransferFailurePredicate -> m a -> m ()
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
TransferFailurePredicate -> m a -> m ()
expectTransferFailure (TransferFailurePredicate -> m a -> m ())
-> TransferFailurePredicate -> m a -> m ()
forall a b. (a -> b) -> a -> b
$ SomeConstant -> TransferFailurePredicate
failedWith (Label tag -> arg -> SomeConstant
forall arg (tag :: Symbol).
(IsError (CustomError tag), MustHaveErrorArg tag (MText, arg)) =>
Label tag -> arg -> SomeConstant
customError Label tag
tag arg
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_ :: forall caps (m :: * -> *) (tag :: Symbol) a.
(HasCallStack, MonadCleveland caps m, IsError (CustomError tag),
 MustHaveErrorArg tag (MText, ())) =>
Label tag -> m a -> m ()
expectCustomError_ Label tag
tag = Label tag -> () -> m a -> m ()
forall arg a (tag :: Symbol) caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, IsError (CustomError tag),
 MustHaveErrorArg tag (MText, arg)) =>
Label tag -> arg -> m a -> m ()
expectCustomError Label tag
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 :: forall caps (m :: * -> *) (tag :: Symbol) a.
(HasCallStack, MonadCleveland caps m, IsError (CustomError tag),
 MustHaveErrorArg tag MText) =>
Label tag -> m a -> m ()
expectCustomErrorNoArg Label tag
tag = TransferFailurePredicate -> m a -> m ()
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
TransferFailurePredicate -> m a -> m ()
expectTransferFailure (TransferFailurePredicate -> m a -> m ())
-> TransferFailurePredicate -> m a -> m ()
forall a b. (a -> b) -> a -> b
$ SomeConstant -> TransferFailurePredicate
failedWith (Label tag -> SomeConstant
forall (tag :: Symbol).
(IsError (CustomError tag), MustHaveErrorArg tag MText) =>
Label tag -> SomeConstant
customErrorNoArg Label tag
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 :: forall err a caps (m :: * -> *).
(HasCallStack, MonadCleveland caps m, IsError err) =>
ErrorTagMap -> err -> m a -> m ()
expectNumericError ErrorTagMap
tagMap err
err = TransferFailurePredicate -> m a -> m ()
forall caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m) =>
TransferFailurePredicate -> m a -> m ()
expectTransferFailure (TransferFailurePredicate -> m a -> m ())
-> TransferFailurePredicate -> m a -> m ()
forall a b. (a -> b) -> a -> b
$ SomeConstant -> TransferFailurePredicate
failedWith (ErrorTagMap -> err -> SomeConstant
forall err. IsError err => ErrorTagMap -> err -> SomeConstant
numericError ErrorTagMap
tagMap err
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 :: forall caps (m :: * -> *) a.
MonadCleveland caps m =>
Builder -> m a -> m a
clarifyErrors Builder
message m a
action = do
  m a -> m (Either SomeException a)
forall e caps (m :: * -> *) a.
(HasCallStack, MonadCleveland caps m, Exception e) =>
m a -> m (Either e a)
attempt m a
action m (Either SomeException a)
-> (Either SomeException a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left (SomeException
e :: SomeException) -> (caps -> ClevelandMiscImpl (ClevelandBaseMonad caps))
-> (ClevelandMiscImpl (ClevelandBaseMonad caps)
    -> ClevelandBaseMonad caps a)
-> ReaderT caps (ClevelandBaseMonad caps) a
forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
forall caps.
HasClevelandCaps caps =>
caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap \ClevelandMiscImpl (ClevelandBaseMonad caps)
cap -> ClevelandMiscImpl (ClevelandBaseMonad caps)
-> forall a.
   HasCallStack =>
   SomeException -> ClevelandBaseMonad caps a
forall (m :: * -> *).
ClevelandMiscImpl m
-> forall a. HasCallStack => SomeException -> m a
cmiThrow ClevelandMiscImpl (ClevelandBaseMonad caps)
cap (SomeException -> SomeException
handle SomeException
e)
    Right a
val -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val
  where
  handle :: SomeException -> SomeException
  handle :: SomeException -> SomeException
handle SomeException
e = SomeException -> Maybe SomeException -> SomeException
forall a. a -> Maybe a -> a
fromMaybe SomeException
e (Maybe SomeException -> SomeException)
-> Maybe SomeException -> SomeException
forall a b. (a -> b) -> a -> b
$
        (TestError -> TestError) -> SomeException -> Maybe SomeException
forall {b} {a}.
(Exception b, Exception a) =>
(a -> b) -> SomeException -> Maybe SomeException
wrap TestError -> TestError
testClientErrorHandler SomeException
e
    Maybe SomeException -> Maybe SomeException -> Maybe SomeException
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (TestError -> TestError) -> SomeException -> Maybe SomeException
forall {b} {a}.
(Exception b, Exception a) =>
(a -> b) -> SomeException -> Maybe SomeException
wrap TestError -> TestError
testPureErrorHandler SomeException
e
    Maybe SomeException -> Maybe SomeException -> Maybe SomeException
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (WithCallStack -> WithCallStack)
-> SomeException -> Maybe SomeException
forall {b} {a}.
(Exception b, Exception a) =>
(a -> b) -> SomeException -> Maybe SomeException
wrap WithCallStack -> WithCallStack
withCallStackErrorHandler SomeException
e

  wrap :: (a -> b) -> SomeException -> Maybe SomeException
wrap a -> b
f = (a -> SomeException) -> Maybe a -> Maybe SomeException
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> SomeException
forall e. Exception e => e -> SomeException
toException (b -> SomeException) -> (a -> b) -> a -> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) (Maybe a -> Maybe SomeException)
-> (SomeException -> Maybe a)
-> SomeException
-> Maybe SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Maybe a
forall e. Exception e => SomeException -> Maybe e
fromException

  addPrefix :: Text -> Text
addPrefix = Builder -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Builder -> Text) -> (Text -> Builder) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder -> Builder
nameF Builder
message (Builder -> Builder) -> (Text -> Builder) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
forall p. Buildable p => p -> Builder
build

  testClientErrorHandler :: Client.TestError -> Client.TestError
  testClientErrorHandler :: TestError -> TestError
testClientErrorHandler = \case
    Client.CustomTestError Text
msg -> Text -> TestError
Client.CustomTestError (Text -> TestError) -> Text -> TestError
forall a b. (a -> b) -> a -> b
$ Text -> Text
addPrefix Text
msg

  testPureErrorHandler :: Pure.TestError -> Pure.TestError
  testPureErrorHandler :: TestError -> TestError
testPureErrorHandler = \case
    Pure.CustomTestError Text
msg -> Text -> TestError
Pure.CustomTestError (Text -> TestError) -> Text -> TestError
forall a b. (a -> b) -> a -> b
$ Text -> Text
addPrefix Text
msg
    TestError
err -> TestError
err

  withCallStackErrorHandler :: WithCallStack -> WithCallStack
  withCallStackErrorHandler :: WithCallStack -> WithCallStack
withCallStackErrorHandler (WithCallStack CallStack
cst SomeException
e) = CallStack -> SomeException -> WithCallStack
WithCallStack CallStack
cst (SomeException -> WithCallStack) -> SomeException -> WithCallStack
forall a b. (a -> b) -> a -> b
$ SomeException -> SomeException
handle SomeException
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 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 Address
_ 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 Address
actualAddr TransferFailureReason
_ = TransferFailure
err
  Bool -> Validation Builder () -> Validation Builder ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Address
actualAddr 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 =
  (NiceConstant err :- ConstantScope (ToT err))
-> (ConstantScope (ToT err) => SomeConstant) -> SomeConstant
forall (c :: Constraint) e r. HasDict c e => e -> (c => r) -> r
withDict (forall a. NiceConstant a :- ConstantScope (ToT a)
niceConstantEvi @err) ((ConstantScope (ToT err) => SomeConstant) -> SomeConstant)
-> (ConstantScope (ToT err) => SomeConstant) -> SomeConstant
forall a b. (a -> b) -> a -> b
$
    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

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

withCap :: Monad m => (caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap :: forall (m :: * -> *) caps cap a.
Monad m =>
(caps -> cap) -> (cap -> m a) -> ReaderT caps m a
withCap caps -> cap
getCap cap -> m a
useCap = do
  cap
cap <- (caps -> cap) -> ReaderT caps m cap
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks caps -> cap
getCap
  m a -> ReaderT caps m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT caps m a) -> m a -> ReaderT caps m a
forall a b. (a -> b) -> a -> b
$ cap -> m a
useCap cap
cap

-- | Common conversion function from 'OriginateData' to 'UntypedOriginateData'
originateDataToUntyped :: OriginateData param st vd -> UntypedOriginateData
originateDataToUntyped :: forall param st vd.
OriginateData param st vd -> UntypedOriginateData
originateDataToUntyped OriginateData{ odContract :: forall param st vd.
OriginateData param st vd -> Contract param st vd
odContract = contract :: Contract param st vd
contract@Contract{}, st
Mutez
Alias
odStorage :: st
odBalance :: Mutez
odName :: Alias
odStorage :: forall param st vd. OriginateData param st vd -> st
odBalance :: forall param st vd. OriginateData param st vd -> Mutez
odName :: forall param st vd. OriginateData param st vd -> Alias
.. } =
  UntypedOriginateData :: Alias -> Mutez -> Value -> Contract -> UntypedOriginateData
UntypedOriginateData
  { uodName :: Alias
uodName = Alias
odName
  , uodBalance :: Mutez
uodBalance = Mutez
odBalance
  , uodStorage :: Value
uodStorage = st -> Value
forall st. NiceStorage st => st -> Value
untypeHelper st
odStorage
  , uodContract :: Contract
uodContract = Contract (ToT param) (ToT st) -> Contract
forall (param :: T) (store :: T). Contract param store -> Contract
convertContract (Contract (ToT param) (ToT st) -> Contract)
-> Contract (ToT param) (ToT st) -> Contract
forall a b. (a -> b) -> a -> b
$ Contract param st vd -> Contract (ToT param) (ToT st)
forall cp st vd. Contract cp st vd -> Contract (ToT cp) (ToT st)
toMichelsonContract Contract param st vd
contract
  }

untypeHelper :: forall st. NiceStorage st => st -> U.Value
untypeHelper :: forall st. NiceStorage st => st -> Value
untypeHelper = Value' Instr (ToT st) -> Value
forall (t :: T). HasNoOp t => Value' Instr t -> Value
untypeValue (Value' Instr (ToT st) -> Value)
-> (st -> Value' Instr (ToT st)) -> st -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. st -> Value' Instr (ToT st)
forall a. IsoValue a => a -> Value (ToT a)
toVal (StorageScope (ToT st) => st -> Value)
-> (NiceStorage st :- StorageScope (ToT st)) -> st -> Value
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall a. NiceStorage a :- StorageScope (ToT a)
niceStorageEvi @st