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

{-# OPTIONS_HADDOCK not-home #-}

-- | 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 @octez-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 (..)
  , TypedOriginateData (..)
  , LargeOrigination (..)
  , TypedContract (..)
  , RunCode (..)
  , ClevelandInput
  , ClevelandResult
  , ContractEvent (..)

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

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

  , mapClevelandOpsImplExceptions
  , mapClevelandMiscImplExceptions

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

  -- * Validation
  , AddressAndAlias(..)
  , TransferFailure (..)
  , TransferFailureReason (..)
  , GenericTestError (..)
  , ExpressionOrTypedValue (..)

  -- * Helpers
  , auto
  , ep
  , mkDefaultAlias

  -- * Morley client re-exports
  , Alias
  , ImplicitAlias
  , ContractAlias
  , KindedAddress
  , ContractAddress
  , ImplicitAddress

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

  , MonadCleveland
  , MonadEmulated
  , MonadNetwork
  , ClevelandT
  , EmulatedT
  , NetworkT

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

  -- * Network environment
  , NetworkEnv(..)
  , neMorleyClientEnvL
  , neSecretKeyL
  , neMoneybagAliasL
  , neExplicitDataDirL
  , neVerbosityL
  ) where

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

import Lorentz (Contract(..))
import Lorentz.Constraints
import Lorentz.Entrypoints.Core (EntrypointRef(..), NiceEntrypointName, eprName)
import Morley.AsRPC (HasRPCRepr(AsRPC))
import Morley.Client (MorleyClientEnv, 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
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.Lens (postfixLFields)
import Morley.Util.Sing (eqI)
import Morley.Util.TypeLits
import Test.Cleveland.Internal.Exceptions
import Test.Cleveland.Lorentz.Types

-- | Whether this contract should be originated in
-- a single origination operation or, if it goes over
-- the origination size limit, in multiple operations.
data LargeOrigination = IsLarge | NotLarge

data OriginateData param st vd (large :: LargeOrigination) =
  OriginateData
  { odName :: ContractAlias
  -- ^ 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'.
  , odDelegate :: Maybe KeyHash
  -- ^ Contract delegate.
  }

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

-- | Untyped version of OriginateData. It can be used for interaction with raw
-- Michelson contracts
data TypedOriginateData cp st vd (large :: LargeOrigination) = TypedOriginateData
  { todName :: ContractAlias
  -- ^ Alias for the originated contract.
  , todBalance :: Mutez
  -- ^ Initial balance.
  , todStorage :: st
  -- ^ Initial storage.
  , todContract :: T.Contract (T.ToT cp) (T.ToT st)
  -- ^ The contract itself.
  , todDelegate :: Maybe KeyHash
  -- ^ Contract delegate.
  }

-- | Information about transfer operation.
data TransferData =
  forall v addr. (NiceParameter v, ToL1Address 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.
  }

-- | A wrapper around t'T.Contract' to reduce awkwardness
data TypedContract cp st vd where
  TypedContract :: T.Contract (T.ToT cp) (T.ToT st) -> TypedContract cp st vd

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

-- | Data structure representing a contract event.
data ContractEvent = ContractEvent
  { ceSource :: ContractAddress
  , ceTag :: Text
  , cePayload :: Maybe SomeAnnotatedValue
  }

-- | Designates an operation result.
data ClevelandResult
instance OperationInfoDescriptor ClevelandResult where
  type TransferInfo ClevelandResult = [ContractEvent]
  type OriginationInfo ClevelandResult = OriginationInfo Result
  type RevealInfo ClevelandResult = RevealInfo Result
  type DelegationInfo ClevelandResult = DelegationInfo Result

-- | 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 :: ImplicitAddress }

-- | 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 :: ImplicitAddress }

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

instance IsString SpecificOrDefaultAlias where
  fromString = SpecificAlias . ImplicitAlias . fromString

instance Default SpecificOrDefaultAlias where
  def = DefaultAlias

mkDefaultAlias :: Natural -> ImplicitAlias
mkDefaultAlias counter =
  ImplicitAlias . 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 ClevelandResult]
  -- ^ 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 :: forall kind. HasCallStack => Alias kind -> m (KindedAddress kind)
  -- ^ Get the address of the implicit account / contract associated with the given alias.
  , cmiGenKey :: HasCallStack => SpecificOrDefaultAlias -> m ImplicitAddress
  -- ^ 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 ImplicitAddress
  -- ^ 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 -> ImplicitAddress -> m Crypto.Signature
  -- ^ Get the signature of the preapplied operation.
  , cmiOriginateLargeUntyped :: HasCallStack => Sender -> UntypedOriginateData 'IsLarge -> m ContractAddress
  -- ^ 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 => L1Address -> m Mutez
  -- ^ Get the balance of the given address.
  , cmiGetSomeStorage :: HasCallStack => ContractAddress -> 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 => ImplicitAddress -> m Crypto.PublicKey
  -- ^ Get the public key associated with the given address.
  -- Fail if the given address is not an implicit account.
  , cmiGetDelegate :: HasCallStack => L1Address -> m (Maybe Crypto.KeyHash)
  -- ^ Get the delegate for the given contract. Fails on implicit contracts.
  , 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 :: ImplicitAddress -> 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.
  , cmiUnderlyingImpl :: m (Either (EmulatedImpl m) NetworkEnv)
  -- ^ Produce underlying implementation specific data. Used to run
  -- emulation-only or network-only actions in a 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
  , rcParameter :: U.Value
  -- ^ The parameter value should have the same "structure" as @cp@, except it _may_ also have big_map IDs.
  -- E.g. if the contract's parameter is @pair (big_map string string) (big_map string string)@,
  -- then 'rcParameter' may be one of:
  --
  -- * @pair (big_map string string) (big_map string string)@
  -- * @pair nat (big_map string string)@
  -- * @pair (big_map string string) nat@
  -- * @pair nat nat@
  --
  -- ... where @nat@ represents a big_map ID.
  , rcStorage :: U.Value
  -- ^ The storage value should have the same "structure" as @st@, except it _may_ also have big_map IDs.
  -- See the documentation of 'rcParameter'.
  , 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 ImplicitAddress
  -- ^ 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.
  }

data NetworkEnv = NetworkEnv
  { neMorleyClientEnv :: MorleyClientEnv
  , neSecretKey :: Maybe Crypto.SecretKey
  , neMoneybagAlias :: ImplicitAlias
  , neExplicitDataDir :: Bool
  , neVerbosity :: Word
  }

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

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

type LogsInfo = [ScenarioLogs]

makeLenses ''ScenarioLogs
makeLensesWith postfixLFields ''NetworkEnv

-- | 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 ClevelandResult) Void a
  } deriving newtype (Functor, Applicative)

instance
  ( Bottom
  , 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
    (>>=) = no

{- | 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 ClevelandResult) 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 ClevelandResult -> 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

data AddressAndAlias = forall kind. AddressAndAlias (KindedAddress kind) (Maybe (Alias kind))

deriving stock instance Show AddressAndAlias

instance Eq AddressAndAlias where
  (AddressAndAlias (addr1 :: KindedAddress kind1) _) ==
    (AddressAndAlias (addr2 :: KindedAddress kind2) _) =
      maybe False (\Refl -> addr1 == addr2) $
        eqI @kind1 @kind2 \\ addressKindSanity addr1 \\ addressKindSanity addr2

instance ToAddress AddressAndAlias where
  toAddress (AddressAndAlias a _) = toAddress a

instance Buildable AddressAndAlias where
  build (AddressAndAlias addr mbAlias) =
    build addr +| maybe "" (\alias -> " (" +| alias |+ ")") mbAlias

-- | Failures that could be expected in the execution of a transfer.
-- These can be caught and handled with 'Test.Cleveland.attempt'.
data TransferFailure = TransferFailure
  { tfAddressAndAlias :: AddressAndAlias
  , 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)

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"

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 = fromPossiblyAnnotatedException

instance Exception GenericTestError where
  displayException = pretty
  fromException = fromPossiblyAnnotatedException

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

class NiceEntrypointName epName => EntrypointNameConstructor (epName :: Symbol) a where
  -- | A short partial constructor for 'EpName' or 'EntrypointRef'. It accepts a
  -- type-level string as its type argument. The programmer is responsible for
  -- validity. And this code is for tests anyway, so each failure is a
  -- programmer mistake.
  --
  -- Note that entrypoint names should be capitalized, e.g.
  --
  -- > ep @"Entrypoint"
  --
  -- corresponds to @entrypoint@, etc.
  --
  -- It is intentionally here and not in some deeper module because the name is
  -- really short and more suitable for writing scenarios.
  --
  -- For 'EpName', an instance is provided accepting a value-level t'Text'
  -- instead of a type-level symbol. This is mostly for cases where the
  -- type-level symbol doesn't work. Note that value-level string will be used
  -- verbatim, hence capitalization is arbitrary.
  --
  -- > ep "entrypoint"
  ep :: a

instance (NiceEntrypointName epName, mname ~ 'Just epName)
  => EntrypointNameConstructor epName (EntrypointRef mname) where
  ep = Call

instance NiceEntrypointName epName => EntrypointNameConstructor epName EpName where
  ep = eprName $ Call @epName

instance (any ~ "", t ~ Text) => EntrypointNameConstructor any (t -> EpName) where
  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
    , 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
    , cmiUnderlyingImpl = f $ cmiUnderlyingImpl
    , 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
  }

-- | A record with all the capabilities available to a cleveland test on the network.
data NetworkCaps m = NetworkCaps
  { ncNetworkEnv :: NetworkEnv
  , ncClevelandCaps :: ClevelandCaps m
  }

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

-- | 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 capabilities.
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

-- | A proof that the given @caps@ record contains
-- the basic cleveland capabilities + the network capabilities.
class HasClevelandCaps caps => HasNetworkCaps caps where
  getNetworkEnvCap :: caps -> NetworkEnv

instance Monad m => HasClevelandCaps (NetworkCaps m) where
  type ClevelandBaseMonad (NetworkCaps m) = m
  clevelandCapsL = ncClevelandCapsL

instance Monad m => HasNetworkCaps (NetworkCaps m) where
  getNetworkEnvCap = ncNetworkEnv

-- | 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 'EmulatedCaps' capability.
type MonadEmulated caps m =
  ( MonadCleveland caps m
  , HasEmulatedCaps caps
  )

-- | Constraint for a monad in which we can do cleveland actions that can only
-- be run on a real network. It requires the 'NetworkCaps' capability.
type MonadNetwork caps m =
  ( MonadCleveland caps m
  , HasNetworkCaps 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

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