Abstract.hs

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

-- | Abstract cleveland interface not bound to a particular
-- implementation.
--
-- The interface may look a bit untyped and unsafe in some places.
-- For example, in order to call a contract one should supply a
-- simple address rather than a contract ref, so it is easy to pass
-- a value of wrong type. Also it is easy to call a non-existing entrypoint.
--
-- Subjectively, it makes writing test scenarios easier because you
-- have to prove less to the compiler. It also makes implementation of
-- cleveland engine a bit easier. Of course, it also makes it easier
-- to make certain mistakes. However, we expect users of this interface
-- to also use the functionality of the "Test.Cleveland.Internal.Pure" module
-- and convert cleveland scenarios to purely testable scenarios for
-- integrational testing engine. In this case errors should be detected
-- almost as quickly as they would reported by the compiler, at least
-- before trying to run scenario on a live network.
--
-- Also this interface uses 'Address' rather than 'EpAddress'.
-- I (\@gromak) concluded that 'EpAddress' can not be passed to @tezos-client@.
-- For key addresses it just does not make sense and for contract addresses
-- I get such errors:
--
-- @
--   bad contract notation
--   Invalid contract notation "KT1VrFpBPwBTm3hsK7DB7SPmY8fTHJ3vY6sJ%mint"
-- @
module Test.Cleveland.Internal.Abstract
  ( ContractHandle (..)
  , OriginateData (..)
  , TransferData (..)
  , Sender (..)
  , Moneybag (..)
  , UntypedOriginateData (..)
  , RunCode(..)
  , ClevelandInput

  , DefaultAliasCounter (..)
  , SpecificOrDefaultAlias (..)

  -- * Actions
  , ClevelandOpsImpl (..)
  , ClevelandMiscImpl (..)
  , EmulatedImpl(..)

  , mapClevelandOpsImplExceptions
  , mapClevelandMiscImplExceptions

  -- * Batching
  , BatchResultMismatch(..)
  , ClevelandOpsBatch
  , runBatched
  , batchedOpsImpl
  , runOperationBatchM
  , runSingleOperation

  -- * Validation
  , TransferFailure (..)
  , TransferFailureReason (..)
  , FailedInBranch (..)
  , ScenarioBranchName(..)
  , GenericTestError (..)
  , ExpressionOrTypedValue (..)

  -- * Helpers
  , auto
  , ep
  , mkDefaultAlias

  -- * Morley client re-exports
  , Alias

  -- * Capability records
  , ClevelandCaps(..)
  , EmulatedCaps(..)
  , HasClevelandCaps(..)
  , senderL
  , moneybagL
  , getMiscCap
  , getOpsCap
  , HasEmulatedCaps(..)

  , MonadCleveland
  , MonadEmulated
  , ClevelandT
  , EmulatedT

  -- * Log utilities
  , LogsInfo
  , ScenarioLogs(..)
  , slAddr
  , slLog
  , logsL
  , filterLogsByAddrL
  , logsForAddress
  , collectLogs
  ) where

import Control.Lens (Each, each, filtered, makeLenses, makeLensesFor)
import Data.Default (Default(..))
import Data.Type.Equality (pattern Refl)
import Data.Typeable (cast)
import Fmt (Buildable(..), Builder, pretty, (+|), (|+))
import Prelude hiding (Each)
import Time (KnownDivRat, Second, Time)

import Lorentz (Contract(..))
import Lorentz.Constraints
import Morley.AsRPC (HasRPCRepr(AsRPC), MaybeRPC)
import Morley.Client (Result)
import Morley.Client.Types
import Morley.Micheline (Expression, fromExpression)
import Morley.Michelson.ErrorPos (ErrorSrcPos)
import Morley.Michelson.Interpret (MorleyLogs(..))
import Morley.Michelson.Runtime (VotingPowers)
import Morley.Michelson.Typed (BigMapId)
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Typed.AnnotatedValue (SomeAnnotatedValue)
import Morley.Michelson.Typed.Entrypoints
import Morley.Michelson.Typed.Scope (ConstantScope)
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Morley.Tezos.Address.Alias (Alias(..))
import Morley.Tezos.Core (ChainId, Mutez, Timestamp)
import Morley.Tezos.Crypto
import Morley.Tezos.Crypto qualified as Crypto
import Morley.Util.Batching
import Morley.Util.Sing (eqI)
import Morley.Util.TypeLits
import Test.Cleveland.Internal.Exceptions (WithCallStack(..))
import Test.Cleveland.Lorentz.Types

data OriginateData param st vd =
  OriginateData
  { odName :: Alias
  -- ^ Alias for the originated contract.
  , odBalance :: Mutez
  -- ^ Initial balance.
  , odStorage :: st
  -- ^ Initial storage.
  , odContract :: Contract param st vd
  -- ^ The contract itself.
  --
  -- We are using Lorentz version here which is convenient. However, keep in
  -- mind that if someone wants to test a contract from @.tz@ file, they should use
  -- 'UntypedOriginateData'.
  }

-- | Untyped version of OriginateData. It can be used for interaction with raw
-- Michelson contracts
data UntypedOriginateData = UntypedOriginateData
  { uodName :: Alias
  -- ^ Alias for the originated contract.
  , uodBalance :: Mutez
  -- ^ Initial balance.
  , uodStorage :: U.Value
  -- ^ Initial storage.
  , uodContract :: U.Contract
  -- ^ The contract itself.
  }

-- | Information about transfer operation.
data TransferData =
  forall v addr. (NiceParameter v, ToAddress addr) => TransferData
  { tdTo :: addr
  -- ^ Receiver address for this transaction.
  , tdAmount :: Mutez
  -- ^ Amount to be transferred.
  , tdEntrypoint :: EpName
  -- ^ An entrypoint to be called. Consider using 'ep' in testing
  -- scenarios.
  , tdParameter :: v
  -- ^ Parameter that will be used for a contract call. Set to @()@
  -- for transfers to key addresses.
  }

-- | Designates an operation input.
data ClevelandInput
instance OperationInfoDescriptor ClevelandInput where
  type TransferInfo ClevelandInput = TransferData
  type OriginationInfo ClevelandInput = UntypedOriginateData
  type RevealInfo ClevelandInput = PublicKey

-- | A batch returned invalid output, e.g. origination address when transaction
-- was supplied.
data BatchResultMismatch
  = BatchResultMismatch Text  -- ^ Carries expected operation type in lowercase

instance Buildable BatchResultMismatch where
  build = \case
    BatchResultMismatch expected ->
      "For " +| expected |+ " operation received inappropriate result"

-- | Designates the special sender address.
--
-- Transfers and some other operations will occur on behalf of this address.
-- This is initialized to @moneybag@ address and then can be locally modified.
--
-- Operations in `ClevelandOpsImpl` are affected by this address.
newtype Sender = Sender { unSender :: Address }

-- | Designates the address that gifts money to new addresses.
--
-- Once a new address is allocated in a test scenario, we have to transfer some
-- money to it so that it is able to serve as transactions sender. 'Moneybag'
-- serves as a source of that money.
--
-- We do not use 'Sender' for this purpose because in most situations changing
-- moneybag is not necessary. If a user wraps a large piece of their script with
-- 'Test.Cleveland.withSender' call and that changes the moneybag - this behaviour may be
-- undesired and unexpected to the user.
newtype Moneybag = Moneybag { unMoneybag :: Address }

-- | An alias with default value that can be used to define unique alias
-- automatically.
data SpecificOrDefaultAlias
  = SpecificAlias Alias
  | DefaultAlias
  deriving stock (Show)

instance IsString SpecificOrDefaultAlias where
  fromString = SpecificAlias . Alias . fromString

instance Default SpecificOrDefaultAlias where
  def = DefaultAlias

mkDefaultAlias :: Natural -> Alias
mkDefaultAlias counter =
  Alias . fromString $ ("default_cleveland_alias" <> show counter)

-- | Helper to use automatically determined unique alias.
auto :: SpecificOrDefaultAlias
auto = def

-- | Counter which is used to provide different default aliases.
newtype DefaultAliasCounter = DefaultAliasCounter {unDefaultAliasCounter :: Natural}
  deriving stock (Eq, Show)

-- | A record data type with operations creating primitives.
data ClevelandOpsImpl m = ClevelandOpsImpl
  { coiRunOperationBatch
      :: HasCallStack => [OperationInfo ClevelandInput] -> m [OperationInfo Result]
  -- ^ Perform a batch of operations.
  }

-- | A record data type with all base methods one can use during a cleveland test.
data ClevelandMiscImpl m = ClevelandMiscImpl
  { cmiRunIO :: forall res. HasCallStack => IO res -> m res
  -- ^ Runs an 'IO' action.
  , cmiResolveAddress :: HasCallStack => Alias -> m Address
  -- ^ Get the address of the implicit account / contract associated with the given alias.
  , cmiGenKey :: HasCallStack => SpecificOrDefaultAlias -> m Address
  -- ^ Generate a secret key and store it with given alias.
  -- If a key with this alias already exists, the corresponding address
  -- will be returned and no state will be changed.
  , cmiGenFreshKey :: HasCallStack => SpecificOrDefaultAlias -> m Address
  -- ^ Generate a secret key and store it with given alias.
  -- Unlike 'cmiGenKey' this function overwrites the existing key when
  -- given alias is already stored.
  , cmiSignBytes :: HasCallStack => ByteString -> Address -> m Crypto.Signature
  -- ^ Get the signature of the preapplied operation.
  , cmiOriginateLargeUntyped :: HasCallStack => Sender -> UntypedOriginateData -> m Address
  -- ^ Originate a new raw Michelson contract that doesn't fit into the
  -- origination size limit, by executing multiple operation steps.
  --
  -- Note that this is not part of 'ClevelandOpsImpl' because large origination is
  -- _not_ a primitive operation. Also, it cannot appear in a batch (it simply
  -- may not fit).
  , cmiComment :: HasCallStack => Text -> m ()
  -- ^ Print the given string verbatim as a comment.
  -- At the moment, this is a no-op in emulator tests.
  , cmiGetBalance :: HasCallStack => Address -> m Mutez
  -- ^ Get the balance of the given address.
  , cmiGetSomeStorage :: HasCallStack => Address -> m SomeAnnotatedValue
  -- Retrieves the contract's storage.
  , cmiGetBigMapValueMaybe
      :: forall k v. (HasCallStack, NiceComparable k, NicePackedValue k, NiceUnpackedValue v)
      => BigMapId k v -> k -> m (Maybe v)
  -- ^ 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.
  , cmiGetAllBigMapValuesMaybe
      :: forall k v. (HasCallStack, NiceComparable k, NiceUnpackedValue v)
      => BigMapId k v -> m (Maybe [v])
  -- ^ Retrieve all big_map values, given a big_map ID.
  -- Returns 'Nothing' when the big_map ID does not exist.
  , cmiGetPublicKey :: HasCallStack => Address -> m Crypto.PublicKey
  -- ^ Get the public key associated with the given address.
  -- Fail if the given address is not an implicit account.
  , cmiGetDelegate :: HasCallStack => Address -> m (Maybe Crypto.KeyHash)
  -- ^ Get the delegate for the given contract. Fails on implicit contracts.
  , cmiRegisterDelegate :: HasCallStack => Address -> m ()
  -- ^ Register the given address as a valid delegate.
  , cmiGetChainId :: HasCallStack => m ChainId
  -- ^ Get the chain's @ChainId@.
  , cmiAdvanceTime :: forall unit. (HasCallStack, KnownDivRat unit Second) => Time unit -> m ()
  -- ^ 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.
  , cmiAdvanceToLevel :: HasCallStack => (Natural -> Natural) -> m ()
  -- ^ Advance at least to the level returned by the callback, accepting current level.
  , cmiGetNow :: HasCallStack => m Timestamp
  -- ^ Get the timestamp observed by the last block to be baked.
  , cmiGetLevel :: HasCallStack => m Natural
  -- ^ Get the current level observed by the last block to be baked.
  , cmiFailure :: forall a. HasCallStack => Builder -> m a
  -- ^ Fails the test with the given error message.
  , cmiThrow :: forall a. HasCallStack => SomeException -> m a
  -- ^ Rethrow arbitrary error without affecting the call stack. Used
  -- internally. You probably want to use 'cmiFailure'
  , cmiGetApproximateBlockInterval :: HasCallStack => m (Time Second)
  -- ^ Get approximate block interval in seconds. Note, that this value
  -- is minimal bound and real intervals can be larger.
  , cmiAttempt :: forall a e. (Exception e, HasCallStack) => m a -> m (Either e a)
  -- ^ Attempts to perform an action, returning either the result of the action or an exception.
  , cmiMarkAddressRefillable :: Address -> m ()
  -- ^ Marks a given address as "refillable", i.e. if the address lacks funds for the next operation,
  -- some funds will automatically be transferred to it.
  , cmiEmulatedImpl :: m (Maybe (EmulatedImpl m))
  -- ^ Produce 'EmulatedImpl' if possible. Used to run emulated actions in polymorphic context.
  , cmiRunCode
      :: forall cp st vd. (HasCallStack, HasRPCRepr st, T.IsoValue (AsRPC st))
      => Sender -> RunCode cp st vd -> m (AsRPC st)
  -- ^ Execute a contract's code without originating it.
  -- The chain's state will not be modified.
  }

-- | The data needed to call the @/run_code@ RPC endpoint.
data RunCode cp st vd = RunCode
  { rcContract :: Contract cp st vd
  , rcStorage :: MaybeRPC st
  , rcParameter :: MaybeRPC cp
  , rcAmount :: Mutez
  -- ^ The value that will be returned by the @AMOUNT@ instruction.
  , rcLevel :: Maybe Natural
  -- ^ The value that will be returned by the @LEVEL@ instruction.
  , rcNow :: Maybe Timestamp
  -- ^ The value that will be returned by the @NOW@ instruction.
  , rcBalance :: Mutez
  -- ^ The balance that will be returned by the @BALANCE@ instruction.
  , rcSource :: Maybe Address
  -- ^ The value that will be returned by the @SOURCE@ instruction.
  }

-- | A record data type with all base methods one can use during cleveland, but which are available
-- only when running on an emulated environment (e.g. "Morley.Michelson.Runtime") and not on a real network.
data EmulatedImpl m = EmulatedImpl
  { eiBranchout :: [(Text, m ())] -> m ()
  -- ^ Execute multiple testing scenarios independently.
  --
  -- * Actions performed before 'eiBranchout' will be observed by all branches.
  -- * Actions performed in branches will _not_ be observed by any actions performed after 'eiBranchout'.
  -- * 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.
  , eiGetStorage
      :: forall st addr. (HasCallStack, ToStorageType st addr)
      => addr -> m st
  -- ^ Retrieve a contract's full storage, including the contents of its big_maps.
  -- This function can only be used in emulator-only tests.
  , eiGetMorleyLogs :: forall a. m a -> m (LogsInfo, a)
  -- ^ Returns the result of the action with the logs it produced
  , eiSetVotingPowers :: VotingPowers -> m ()
  -- ^ Change voting power distribution.
  }

----------------------------------------------------------------------------
-- Log helpers
----------------------------------------------------------------------------

data ScenarioLogs = ScenarioLogs
  { _slAddr :: Address
  , _slLog :: MorleyLogs
  } deriving stock (Eq, Show)

type LogsInfo = [ScenarioLogs]

makeLenses ''ScenarioLogs

-- | An alias for 'slLog' with a clearer name
logsL :: Lens' ScenarioLogs MorleyLogs
logsL = slLog

-- | Lens combinator specified for filtering logs by address from 'LogsInfo'
filterLogsByAddrL
  :: (ToAddress addr, Applicative f)
  => addr
  -> (MorleyLogs -> f MorleyLogs)
  -> ScenarioLogs
  -> f ScenarioLogs
filterLogsByAddrL (toAddress -> addr) = filtered (\(ScenarioLogs a _) -> a == addr) . logsL

-- | Get logs for a given address from 'LogsInfo'
logsForAddress
  :: ( Each s s ScenarioLogs ScenarioLogs
     , ToAddress addr
     )
  => addr
  -> s
  -> [MorleyLogs]
logsForAddress addr = (^.. each . filterLogsByAddrL addr)

-- | Collect logs produced by all contracts into the single list
collectLogs :: LogsInfo -> MorleyLogs
collectLogs = foldMap _slLog

----------------------------------------------------------------------------
-- Batched operations
----------------------------------------------------------------------------

-- | Where the batched operations occur.
--
-- Note that this is not a 'Monad', rather an 'Applicative' - use
-- @-XApplicativeDo@ extension for nicer experience.
newtype ClevelandOpsBatch a = ClevelandOpsBatch
  { unClevelandOpsBatch
      :: BatchingM (OperationInfo ClevelandInput) (OperationInfo Result) Void a
  } deriving newtype (Functor, Applicative)

instance
  TypeError
  ( 'Text "Attempt to use monad capabilities within a batch" ':$$:
    'Text "In case you are using a do-block, make sure that" ':$$:
    'Text "• `ApplicativeDo` extension is enabled" ':$$:
    'Text "• there is a return statement in the end" ':$$:
    'Text "• returned value picks variables in the order in which they are defined"
  ) =>
  Monad ClevelandOpsBatch where
    (>>=) = error "impossible"

{- | Run a series of operations within a batch.

Example:

@
contract <- runBatched impl $ do
  -- this block is executed within 'ClevelandOpsBatch'
  contract <- runSingleOperation batchedOpsImpl "origination" ...
  for_ [1..3] \i ->
    runSingleOperation batchedOpsImpl "transfer" ...
  return contract
@

See 'ClevelandOpsBatch' for some precautions.
-}
runBatched
  :: (HasCallStack, Functor m)
  => ClevelandOpsImpl m
  -> ClevelandOpsBatch a
  -> m a
runBatched impl =
  runOperationBatchM (Proxy @Void) impl . unClevelandOpsBatch

-- | 'ClevelandOpsImpl' suitable for methods executed within a batch.
batchedOpsImpl :: ClevelandOpsImpl ClevelandOpsBatch
batchedOpsImpl = ClevelandOpsImpl
  { coiRunOperationBatch = ClevelandOpsBatch . traverse (`submitThenParse` pure)
  }

-- | Version of 'coiRunOperationBatch' that uses 'BatchingM'.
--
-- This is an internal function.
--
-- Invariant: all errors described by @e@ must be internal and should not occur
-- in practice (we require @e@ type to be specified explicitly to hinder
-- incorrect usage).
runOperationBatchM
  :: (HasCallStack, Buildable e, Functor m)
  => Proxy e
  -> ClevelandOpsImpl m
  -> BatchingM (OperationInfo ClevelandInput) (OperationInfo Result) e a
  -> m a
runOperationBatchM _ impl =
  fmap snd . unsafeRunBatching (fmap ((), ) . coiRunOperationBatch impl)

-- | Helper that runs a single operation using 'ClevelandOpsImpl'.
runSingleOperation
  :: (HasCallStack, Functor m)
  => ClevelandOpsImpl m
  -> Text
  -> OperationInfo ClevelandInput
  -> (OperationInfo Result -> Maybe a)
  -> m a
runSingleOperation impl desc opData parseRes =
  runOperationBatchM (Proxy @BatchResultMismatch) impl $
    opData `submitThenParse` maybeToRight (BatchResultMismatch desc) . parseRes

----------------------------------------------------------------------------
-- Validation
----------------------------------------------------------------------------

-- | Representation of Expression we got from the RPC or a typed value we
-- got from the emulator.
data ExpressionOrTypedValue where
  EOTVExpression :: Expression -> ExpressionOrTypedValue
  EOTVTypedValue :: (T.SingI t, ConstantScope t) => T.Value t -> ExpressionOrTypedValue

deriving stock instance Show ExpressionOrTypedValue
instance Eq ExpressionOrTypedValue where
  (==) (EOTVExpression x) (EOTVExpression y) = x == y
  (==) (EOTVTypedValue (x :: T.Value t)) (EOTVTypedValue (y :: T.Value u))
    = case eqI @t @u of
      Just Refl -> x == y
      Nothing -> False
  (==) _ _ = False

instance Buildable ExpressionOrTypedValue where
  build = \case
    EOTVExpression e -> either (const $ build e) build $ fromExpression @U.Value e
    EOTVTypedValue v -> build v

-- | Failures that could be expected in the execution of a transfer.
-- These can be caught and handled with 'Test.Cleveland.attempt'.
data TransferFailure = TransferFailure
  { tfAddress :: Address
  , tfReason :: TransferFailureReason
  } deriving stock (Show, Eq)

data TransferFailureReason
  = FailedWith ExpressionOrTypedValue (Maybe ErrorSrcPos)
  -- ^ Expect that interpretation of contract with the given address ended
  -- with @FAILWITH@.
  | EmptyTransaction
  -- ^ Expect failure due to an attempt to transfer 0tz towards a simple address.
  | BadParameter
  -- ^ Expect failure due to an attempt to call a contract with an invalid parameter.
  | MutezArithError T.MutezArithErrorType
  -- ^ Expect failure due to an arithmetic over-/underflow
  | ShiftOverflow
  -- ^ Expect that interpretation of contract with the given address ended
  -- with an overflow error.
  | GasExhaustion
  -- TODO: [#284] add more errors here!
  deriving stock (Show, Eq)

-- | When an exception is thrown in a 'Test.Cleveland.branchout' branch, we wrap it in this
-- constructor to remember in _which_ branch it was thrown.
-- We use this information to provide better error messages when a test fails.
data FailedInBranch = FailedInBranch ScenarioBranchName SomeException
  deriving stock (Show)

-- | When using 'Test.Cleveland.branchout' function for building test scenarios - names
-- of branches we are currently within.
newtype ScenarioBranchName = ScenarioBranchName { unTestBranch :: [Text] }
  deriving stock (Show, Eq)

instance Buildable ScenarioBranchName where
  build = mconcat . intersperse "/" . map build . unTestBranch

instance Buildable TransferFailure where
  build (TransferFailure addr reason) = case reason of
    EmptyTransaction -> reason |+ ": " +| addr |+ ""
    BadParameter -> "Attempted to call contract " +| addr |+ " with a " +| reason |+ ""
    FailedWith{} -> "Contract: " +| addr |+ " " +| reason |+ ""
    _ -> "Contract: " +| addr |+ " failed due to a " +| reason |+ ""

instance Buildable TransferFailureReason where
  build = \case
    FailedWith expr loc -> "failed with: " +| expr |+ maybe "" ((" at " +|) . build) loc
    EmptyTransaction -> "Attempted to transfer 0tz to a simple address"
    BadParameter -> "parameter of the wrong type"
    MutezArithError typ -> "mutez " +| typ |+ ""
    ShiftOverflow -> "overflow error"
    GasExhaustion -> "gas exhaustion"

instance Buildable FailedInBranch where
  build (FailedInBranch branchName (SomeException err)) = "In '" +| branchName |+
    "' branch:\n" +| (build $ displayException err)

data GenericTestError
  = UnexpectedSuccess
  deriving stock Show

instance Buildable GenericTestError where
  build = \case
    UnexpectedSuccess ->
      "Expected an exception to be thrown, but it wasn't"

instance Exception TransferFailure where
  displayException = pretty
  fromException someEx@(SomeException ex) =
    cast @_ @TransferFailure ex
    <|>
    ( do
        WithCallStack _ exInner <- fromException @WithCallStack someEx
        fromException exInner
    )
    <|>
    ( do
        FailedInBranch _ exInner <- fromException @FailedInBranch someEx
        fromException exInner
    )


instance Exception FailedInBranch where
  displayException = pretty

instance Exception GenericTestError where
  displayException = pretty

----------------------------------------------------------------------------
-- Other helpers
----------------------------------------------------------------------------

-- | A short partial constructor for 'EpName'. It is supposed to be
-- applied to string constants, so programmer is responsible for
-- validity. And this code is for tests anyway, so each failure is a
-- programmer mistake.
--
-- It is intentionally here and not in some deeper module because the
-- name is really short and more suitable for writing scenarios.
ep :: HasCallStack => Text -> EpName
ep = unsafe . U.buildEpName

-- | Runs a handler over every action.
mapClevelandOpsImplExceptions
  :: (forall a. HasCallStack => m a -> m a)
  -> ClevelandOpsImpl m -> ClevelandOpsImpl m
mapClevelandOpsImplExceptions f ClevelandOpsImpl{..} = ClevelandOpsImpl
    { coiRunOperationBatch = \op -> f $ coiRunOperationBatch op
    }

-- | Runs a handler over every action (except 'cmiAttempt' and 'cmiThrow'),
-- possibly transforming exceptions thrown by those actions.
mapClevelandMiscImplExceptions
  :: (forall a. HasCallStack => m a -> m a)
  -> ClevelandMiscImpl m -> ClevelandMiscImpl m
mapClevelandMiscImplExceptions f ClevelandMiscImpl{..} = ClevelandMiscImpl
    { cmiRunIO = \action -> f $ cmiRunIO action
    , cmiResolveAddress = \address -> f $ cmiResolveAddress address
    , cmiSignBytes = \bs alias -> f $ cmiSignBytes bs alias
    , cmiGenKey = \alias -> f $ cmiGenKey alias
    , cmiGenFreshKey = \alias -> f $ cmiGenFreshKey alias
    , cmiOriginateLargeUntyped = \sender uodata -> f $ cmiOriginateLargeUntyped sender uodata
    , cmiComment = \t -> f $ cmiComment t
    , cmiGetBalance = \addr -> f $ cmiGetBalance addr
    , cmiGetSomeStorage = \addr -> f $ cmiGetSomeStorage addr
    , cmiGetBigMapValueMaybe = \bmId k -> f $ cmiGetBigMapValueMaybe bmId k
    , cmiGetAllBigMapValuesMaybe = \bmId -> f $ cmiGetAllBigMapValuesMaybe bmId
    , cmiGetPublicKey = \addr -> f $ cmiGetPublicKey addr
    , cmiGetDelegate = f <$> cmiGetDelegate
    , cmiRegisterDelegate = f <$> cmiRegisterDelegate
    , cmiGetChainId = f $ cmiGetChainId
    , cmiAdvanceTime = \time -> f $ cmiAdvanceTime time
    , cmiAdvanceToLevel = \level -> f $ cmiAdvanceToLevel level
    , cmiGetNow = f $ cmiGetNow
    , cmiGetLevel = f $ cmiGetLevel
    , cmiFailure = \builder -> f $ cmiFailure builder
    , cmiGetApproximateBlockInterval = f $ cmiGetApproximateBlockInterval
    , cmiAttempt = \action -> cmiAttempt action
    , cmiMarkAddressRefillable = f . cmiMarkAddressRefillable
    , cmiThrow = cmiThrow
    , cmiEmulatedImpl = f $ cmiEmulatedImpl
    , cmiRunCode = f ... cmiRunCode
    }

-- | A record with all the capabilities available to any cleveland test.
data ClevelandCaps m = ClevelandCaps
  { ccSender :: Sender
  , ccMoneybag :: Moneybag
  , ccMiscCap :: ClevelandMiscImpl m
  , ccOpsCap :: Sender -> ClevelandOpsImpl m
  }

-- | A record with all the capabilities available to a cleveland test on the emulator.
data EmulatedCaps m = EmulatedCaps
  { ecEmulatedCap :: EmulatedImpl m
  , ecClevelandCaps :: ClevelandCaps m
  }

makeLensesFor [("ccSender", "ccSenderL"), ("ccMoneybag", "ccMoneybagL")] ''ClevelandCaps
makeLensesFor [("ecClevelandCaps", "ecClevelandCapsL")] ''EmulatedCaps

-- | A proof that the given @caps@ record contains
-- the basic cleveland capabilities.
class Monad (ClevelandBaseMonad caps) => HasClevelandCaps caps where
  -- | This will be either @PureM@ or @ClientM@.
  type ClevelandBaseMonad caps :: Type -> Type
  clevelandCapsL :: Lens' caps (ClevelandCaps (ClevelandBaseMonad caps))

-- | A proof that the given @caps@ record contains
-- the basic cleveland capabilities + the emulator capabiilities.
class HasClevelandCaps caps => HasEmulatedCaps caps where
  getEmulatedCap :: caps -> EmulatedImpl (ClevelandBaseMonad caps)

instance Monad m => HasClevelandCaps (ClevelandCaps m) where
  type ClevelandBaseMonad (ClevelandCaps m) = m
  clevelandCapsL = id

instance Monad m => HasClevelandCaps (EmulatedCaps m) where
  type ClevelandBaseMonad (EmulatedCaps m) = m
  clevelandCapsL = ecClevelandCapsL

senderL :: HasClevelandCaps caps => Lens' caps Sender
senderL = clevelandCapsL . ccSenderL

moneybagL :: HasClevelandCaps caps => Lens' caps Moneybag
moneybagL = clevelandCapsL . ccMoneybagL

getMiscCap :: HasClevelandCaps caps => caps -> ClevelandMiscImpl (ClevelandBaseMonad caps)
getMiscCap = ccMiscCap . view clevelandCapsL

getOpsCap :: HasClevelandCaps caps => caps -> ClevelandOpsImpl (ClevelandBaseMonad caps)
getOpsCap r = ccOpsCap (r ^. clevelandCapsL) (r ^. senderL)

instance Monad m => HasEmulatedCaps (EmulatedCaps m) where
  getEmulatedCap = ecEmulatedCap

-- | Constraint for a monad in which we can do cleveland actions.
type MonadCleveland caps m =
  ( m ~ ReaderT caps (ClevelandBaseMonad caps)
  , HasClevelandCaps caps
  )

-- | Constraint for a monad in which we can do cleveland actions that can't be run on a real network.
-- It requires the 'EmulatedImpl' capability.
type MonadEmulated caps m =
  ( MonadCleveland caps m
  , HasEmulatedCaps caps
  )

-- | Monad transformer that adds only the 'ClevelandCaps' capabilities.
type ClevelandT m = ReaderT (ClevelandCaps m) m

-- | Monad transformer that adds both 'ClevelandCaps' and 'EmulatedCaps' capabilities.
type EmulatedT m = ReaderT (EmulatedCaps m) m