Pure.hs

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

-- | Integration with integrational testing engine (pun intended).
module Test.Cleveland.Internal.Pure
  ( PureM(..)
  , runClevelandT
  , runEmulatedT

  -- * Capability implementations
  , PureState
  , TestError(..)
  , emulatedImpl
  , clevelandOpsImpl
  , clevelandMiscImpl

  -- * Initial environment for Emulated tests
  , initEnv

  -- * Support functions
  , failedInsideBranch
  , moneybagAlias
  , emptyScenarioBranch

  -- * Optics
  , psAliases
  , psDefaultAliasesCounter
  , psRefillableAddresses
  , psNow
  , psLevel
  , psMinBlockTime
  , psGState
  , psContractsNames
  ) where

import Control.Lens (assign, at, makeLenses, modifying, to, (%=), (.=))
import Control.Lens.Unsound (lensProduct)
import Control.Monad.Catch.Pure (CatchT, runCatchT)
import Control.Monad.Writer (MonadWriter, WriterT, listen, runWriterT, tell)
import Data.Constraint (Dict(..), withDict, (\\))
import Data.Default (def)
import Data.Map qualified as Map
import Data.Monoid (Ap(..))
import Data.Ratio ((%))
import Data.Set qualified as Set
import Data.Singletons (sing)
import Data.Type.Equality (type (:~:)(Refl))
import Fmt (Buildable(..), Builder, build, pretty, unlinesF, (+|), (|+))
import Time (Second, toNum, toUnit)

import Lorentz (Mutez, NiceComparable, pattern DefEpName)
import Lorentz qualified as L
import Lorentz.Entrypoints (HasEntrypointArg, TrustEpName(..), useHasEntrypointArg)
import Morley.AsRPC
  (HasRPCRepr(AsRPC), MaybeRPC(..), notesAsRPC, replaceBigMapIds, rpcStorageScopeEvi, valueAsRPC)
import Morley.Client (OperationInfo(..))
import Morley.Michelson.Interpret
  (InterpretError(..), InterpretResult(..), MichelsonFailed(..), MichelsonFailureWithStack(..))
import Morley.Michelson.Runtime hiding (ExecutorOp(..), transfer)
import Morley.Michelson.Runtime qualified as Runtime (ExecutorOp(..))
import Morley.Michelson.Runtime.Dummy
  (dummyLevel, dummyMaxSteps, dummyMinBlockTime, dummyNow, dummyOrigination)
import Morley.Michelson.Runtime.GState
  (GState(..), asBalance, genesisAddress, genesisSecretKey, gsAddressesL, gsChainIdL, gsCounterL,
  gsVotingPowersL, initGState)
import Morley.Michelson.TypeCheck (TCError(..), typeCheckContractAndStorage, typeCheckingWith)
import Morley.Michelson.Typed
  (BigMapId(..), IsoValue, SingI, SomeAnnotatedValue(..), ToT, Value, Value'(..), castM,
  dfsFoldMapValue, fromVal, requireEq, toVal)
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Typed.Operation (OriginationOperation(..), TransferOperation(..))
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address (Address, detGenKeyAddress)
import Morley.Tezos.Address.Alias (Alias(..))
import Morley.Tezos.Core (Timestamp, timestampPlusSeconds, unsafeSubMutez, zeroMutez)
import Morley.Tezos.Crypto (SecretKey(..), detSecretKey, sign, toPublic)
import Morley.Util.MismatchError
import Morley.Util.Named

import Test.Cleveland.Internal.Abstract
import Test.Cleveland.Internal.Exceptions (addCallStack, catchWithCallStack, throwWithCallStack)
import Test.Cleveland.Lorentz
import Test.Cleveland.Util (ceilingUnit)

data PureState = PureState
  { _psAliases :: Aliases
  , _psDefaultAliasesCounter :: DefaultAliasCounter
  , _psRefillableAddresses :: Set Address
  , _psNow :: Timestamp
  , _psLevel :: Natural
  , _psMinBlockTime :: Natural
  , _psGState :: GState
  , _psContractsNames :: Map Address Text
  -- ^ Map from contracts addresses to human-readable names.
  }
  deriving stock (Eq, Show)

instance MonadState PureState PureM where
  get = ask >>= readIORef
  put = (ask >>=) . flip writeIORef

data AddressName = AddressName (Maybe Text) Address deriving stock (Show)

newtype PureM a = PureM
  { unPureM :: ReaderT (IORef PureState) (CatchT (WriterT LogsInfo IO)) a
  }
  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch,
                    MonadReader (IORef PureState), MonadWriter LogsInfo, MonadFail)

type Aliases = Map Alias AliasData

-- | Datatype to store alias data, we store optional 'SecretKey' in addition
-- to 'Address' in order to support bytes signing.
data AliasData = AliasData
  { adAddress :: Address
  , adMbSecretKey :: Maybe SecretKey
  }
  deriving stock (Eq, Show)

data TestError
  = UnexpectedTypeCheckError TCError
  | UnexpectedStorageType (MismatchError T.T)
  | UnexpectedBigMapKeyType (MismatchError T.T)
  | UnexpectedBigMapValueType (MismatchError T.T)
  | CustomTestError Text
  deriving stock Show

makeLenses ''PureState

instance Buildable AddressName where
  build (AddressName mbName addr) =
    build addr +| maybe "" (\cName -> " (" +|cName |+ ")") mbName

instance Buildable TestError where
  build (UnexpectedTypeCheckError tcErr) =
    "Unexpected type check error. Reason: " +| tcErr |+ ""
  build (UnexpectedStorageType merr) =
    "Unexpected storage type.\n" +| merr |+ ""
  build (UnexpectedBigMapKeyType merr) =
    "Unexpected big map key type.\n" +| merr |+ ""
  build (UnexpectedBigMapValueType merr) =
    "Unexpected big map value type.\n" +| merr |+ ""
  build (CustomTestError msg) = pretty msg

instance Exception TestError where
  displayException = pretty

moneybagAlias :: Alias
moneybagAlias = Alias "moneybag"

runEmulatedT :: Alias -> EmulatedT PureM a -> IO a
runEmulatedT moneybagAlias' scenario =
  runClevelandT moneybagAlias' do
    clevelandCaps <- ask
    lift . runReaderT scenario $ EmulatedCaps emulatedImpl clevelandCaps

runClevelandT :: Alias -> ClevelandT PureM a -> IO a
runClevelandT moneybagAlias' scenario = do
  let caps = ClevelandCaps
        { ccSender = Sender genesisAddress
        , ccMoneybag = Moneybag genesisAddress
        , ccMiscCap = clevelandMiscImpl
        , ccOpsCap = clevelandOpsImpl
        }
  let pureM = runReaderT scenario caps
  env <- newIORef (initEnv moneybagAlias')
  (res, _logs) <- runWriterT $ runCatchT $ runReaderT (unPureM pureM) env
  either throwM pure $ res

emulatedImpl :: EmulatedImpl PureM
emulatedImpl =
  EmulatedImpl
    { eiBranchout = \(scenarios :: [(Text, PureM ())]) ->
        forM_ scenarios $ \(name, scenario) -> do
          aliasesState <- get
          newRef <- newIORef aliasesState
          local (\_ -> newRef) scenario `catchWithCallStack` \originalCallStackMb err ->
            maybe throwM throwWithCallStack originalCallStackMb $ failedInsideBranch name err
      , eiGetStorage = addCallStack . exceptionHandler . getStorageImpl
    , eiGetMorleyLogs = getMorleyLogsImpl
    , eiSetVotingPowers = assign (psGState . gsVotingPowersL)
    }

clevelandOpsImpl :: Sender -> ClevelandOpsImpl PureM
clevelandOpsImpl (Sender sender) =
  mapClevelandOpsImplExceptions (addCallStack . exceptionHandler)
    ClevelandOpsImpl
    { coiRunOperationBatch = mapM \case
        OpOriginate UntypedOriginateData{..} -> do
          ref <- originate uodContract (pretty uodName) uodStorage uodBalance
          OpOriginate <$> saveAlias uodName (toAddress ref) Nothing
        OpTransfer TransferData{..} -> do
          let fromAddr = #from :! sender
          let toAddr = #to :! toAddress tdTo
          refillable <- isAddressRefillable sender
          when refillable $ do
            balance <- getBalance sender
            when (balance < tdAmount) $ do
              let moneybag = #from :! genesisAddress
                  toSender = #to :! sender
              transfer @() moneybag toSender (unsafeSubMutez tdAmount balance)
                (TrustEpName DefEpName) ()
          -- Here @toAddr@ is 'Address', so we can not check anything
          -- about it and assume that entrypoint is correct. We pass
          -- unit as contract parameter because it won't be checked
          -- anyway.
          transfer @() fromAddr toAddr tdAmount
            (TrustEpName tdEntrypoint) tdParameter

          return $ OpTransfer ()
        OpReveal{} -> do
          -- We do not care about reveals in our Morley runtime
          return $ OpReveal ()
    }

clevelandMiscImpl :: ClevelandMiscImpl PureM
clevelandMiscImpl =
  mapClevelandMiscImplExceptions (addCallStack . exceptionHandler)
    ClevelandMiscImpl
    { cmiRunIO = \action -> liftIO (try action) >>= \case
        Right res -> pure res
        Left (err :: SomeException) -> throwM err

    , cmiResolveAddress = resolve

    , cmiSignBytes = \bs addr -> do
        -- TODO [#248]: make sure this performs fast
        alias <- getAlias addr
        aliases <- use psAliases
        let mbMbSk = Map.lookup alias aliases
        mbSk <- maybe (unknownAlias alias) (pure . adMbSecretKey) mbMbSk
        case mbSk of
          Nothing ->
            cmiFailure $
            "Given address doesn't have known associated secret key: " <> build alias
          Just sk -> liftIO $ sign sk bs

    , cmiGenKey = \sodAlias -> do
      alias <- resolveSpecificOrDefaultAlias sodAlias
      smartGenKey Nothing alias

    , cmiGenFreshKey =
        \sodAlias -> do
          alias <- resolveSpecificOrDefaultAlias sodAlias
          aliases <- use psAliases
          let mbSk = Map.lookup alias aliases
          smartGenKey (adAddress <$> mbSk) alias

    , cmiOriginateLargeUntyped = originateUntyped

    -- Comments are not supported by integrational testing engine (yet).
    , cmiComment = const pass
    , cmiGetPublicKey = \addr -> do
        aliases <- use psAliases
        let mbAliasInfo = fmap snd $ find (\(_, AliasData addr' _) -> addr == addr') (Map.toList aliases)
        aliasInfo <- maybe (unknownAddress addr) pure mbAliasInfo
        case adMbSecretKey aliasInfo of
          Nothing ->
            cmiFailure $
            "Given address doesn't have known associated public key: " <> build addr
          Just sk -> pure $ toPublic sk
    , cmiGetDelegate = \addr -> do
        ContractState _ _ _ delegate <- contractStorage addr
        pure delegate
    , cmiRegisterDelegate = const pass
    , cmiGetChainId = use $ psGState . gsChainIdL
    , cmiAdvanceTime = \time -> do
        modifying psNow . flip timestampPlusSeconds $
          toNum @Second @Integer $ ceilingUnit $ toUnit @Second time

    , cmiAdvanceToLevel = \fn ->
        -- do not go back in levels
        modifying psLevel (\cl -> max (fn cl) cl)

    , cmiGetNow = use psNow
    , cmiGetLevel = use psLevel
    , cmiGetApproximateBlockInterval = sec . (% 1) <$> use psMinBlockTime
    , cmiAttempt = try
    , cmiThrow = throwM
    , cmiMarkAddressRefillable = setAddressRefillable
    , cmiGetBalance = getBalance
    , cmiEmulatedImpl = pure $ Just emulatedImpl
    , ..
    }
  where
    cmiFailure :: forall a. Builder -> PureM a
    cmiFailure = throwM . CustomTestError . pretty

    setAddressRefillable addr = psRefillableAddresses %= Set.insert addr

    originateUntyped :: Sender -> UntypedOriginateData -> PureM Address
    originateUntyped _ UntypedOriginateData {..} = do
      ref <- originate uodContract (pretty uodName) uodStorage uodBalance
      saveAlias uodName (toAddress ref) Nothing

    cmiGetBigMapValueMaybe
      :: forall k v.
         (NiceComparable k, IsoValue v)
      => BigMapId k v
      -> k
      -> PureM (Maybe v)
    cmiGetBigMapValueMaybe (BigMapId bmId) k = runMaybeT do
      VBigMap _ bigMap <- findBigMapByIdMaybe @(ToT k) @(ToT v) bmId
      hoistMaybe $ fromVal @v <$> Map.lookup (toVal k) bigMap

    cmiGetAllBigMapValuesMaybe
      :: forall k v.
         (NiceComparable k, IsoValue v)
      => BigMapId k v
      -> PureM (Maybe [v])
    cmiGetAllBigMapValuesMaybe (BigMapId bmId) = runMaybeT do
      VBigMap _ bigMap <- findBigMapByIdMaybe @(ToT k) @(ToT v) bmId
      pure $ fromVal @v <$> Map.elems bigMap

    findBigMapById
      :: forall k v. (SingI v, SingI k)
      => Natural -> PureM (Value ('T.TBigMap k v))
    findBigMapById bigMapId =
      runMaybeT (findBigMapByIdMaybe @k @v bigMapId) >>= maybe notFound pure
      where
        notFound = cmiFailure $ "BigMap with ID " <> build bigMapId <> " not found."


    -- | Traverse storage values of all contracts and looks for a big_map with the given ID.
    -- If multiple big_maps with the given ID are found, it fails with error.
    findBigMapByIdMaybe
      :: forall k v. (SingI v, SingI k)
      => Natural -> MaybeT PureM (Value ('T.TBigMap k v))
    findBigMapByIdMaybe bigMapId = MaybeT do
      addresses <- use $ psGState . gsAddressesL . to Map.elems

      let Ap result =
            flip foldMap addresses \case
              ASContract ContractState{csStorage} ->
                findBigMapInStorage csStorage bigMapId
              ASSimple {} -> Ap $ Right []

      case result of
        -- The RPC does not distinguish between "the bigmap does not exist"
        -- and "the bigmap exists, but the key doesn't", so we mimic the RPC's behaviour here.
        -- We simply return `Nothing` in both cases.
        Right [] -> pure Nothing
        Right [bigMap] -> pure $ Just bigMap
        Right bigMaps ->
          error $ pretty $ unlinesF @_ @Builder
            [ "Expected all big_maps to have unique IDs, but found " +| length bigMaps |+ " big_maps with the ID " +| bigMapId |+ "."
            , "This is most likely a bug."
            ]
        Left (err :: TestError) -> throwM err

    -- | Traverse a storage value and looks for a big_map with the given ID.
    -- If multiple big_maps with the given ID are found, they'll all be returned.
    findBigMapInStorage
      :: forall k v st. (SingI k, SingI v)
      => Value st -> Natural -> Ap (Either TestError) [Value ('T.TBigMap k v)]
    findBigMapInStorage storage bigMapId =
      dfsFoldMapValue
        (\v -> case v of
            VBigMap (Just bigMapId') (_ :: Map (Value k') (Value v'))
              | bigMapId == bigMapId' -> do
                  Refl <- requireEq @k' @k (Ap . Left . UnexpectedBigMapKeyType)
                  Refl <- requireEq @v' @v (Ap . Left . UnexpectedBigMapValueType)
                  pure [v]
            _ -> Ap $ Right []
        )
        storage

    -- | In a real chain, when we retrieve a contract's storage via the Tezos RPC,
    -- the storage expression will have all the big_maps replaced with their respective big_map IDs.
    --
    -- Here, we mimic the RPC's behaviour.
    --
    -- We expect all big_maps in the storage to already have an ID.
    -- IDs are assigned to big_maps by the interpreter/runtime when:
    --   * A contract with big_maps in its storage is originated
    --   * A transfer is made and the parameter contains big_maps
    --   * A contract's code is run and it calls `EMPTY_BIG_MAP`, `DUP` or `DUP n`.
    cmiGetSomeStorage :: Address -> PureM SomeAnnotatedValue
    cmiGetSomeStorage addr = do
      ContractState _ contract (storage :: Value t) _ <- contractStorage addr
      pure $
        SomeAnnotatedValue
          (notesAsRPC $ T.cStoreNotes contract)
          (valueAsRPC storage)
          \\ rpcStorageScopeEvi @t

    getAlias :: Address -> PureM Alias
    getAlias addr = do
      aliases <- use psAliases
      let maybeAlias = (fmap fst . find (\(_, AliasData addr' _) -> addr == addr') . Map.toList) aliases
      maybe (unknownAddress addr) pure maybeAlias

    -- Generate a fresh address which was never generated for given alias.
    -- If the address is not saved, we use the alias as its seed.
    -- Otherwise we concatenate the alias with the saved address.
    smartGenKey :: Maybe Address -> Alias -> PureM Address
    smartGenKey existingAddr alias@(Alias aliasTxt) =
      let
        seed = maybe aliasTxt (mappend aliasTxt . pretty) existingAddr
        sk = detSecretKey (encodeUtf8 seed)
        addr = detGenKeyAddress (encodeUtf8 seed)
       in saveAlias alias addr $ Just sk

    resolveSpecificOrDefaultAlias (SpecificAlias alias) =
      return alias
    resolveSpecificOrDefaultAlias DefaultAlias = do
      DefaultAliasCounter counter <- use psDefaultAliasesCounter
      psDefaultAliasesCounter %= \(DefaultAliasCounter i) -> DefaultAliasCounter $ i + 1
      return $ mkDefaultAlias counter

    cmiRunCode
      :: forall cp st vd. (HasRPCRepr st, T.IsoValue (AsRPC st))
      => Sender -> RunCode cp st vd -> PureM (AsRPC st)
    cmiRunCode (Sender sender) (RunCode rcContract rcStorage rcParameter rcAmount rcLevel rcNow rcBalance rcSource) = do
      -- Pattern match on the contract constructor to reveal
      -- a proof of `NiceParameter cp` and `NiceStorage st`
      L.Contract{} <- pure rcContract
      param <- maybeRPCToVal rcParameter
      storage <- maybeRPCToVal rcStorage
      (now, level) <- use $ psNow `lensProduct` psLevel
      psNow %= maybe id const rcNow
      psLevel %= maybe id const rcLevel
      res <- interpret do
        counter0 <- use $ esGState . gsCounterL
        contractAddr <-
          executeOrigination ! #isGlobalOp True $
            (dummyOrigination storage (L.toMichelsonContract rcContract) counter0) { ooBalance = zeroMutez }
              \\ L.niceStorageEvi @st
              \\ L.niceParameterEvi @cp

        esSourceAddress .= rcSource
        counter1 <- use $ esGState . gsCounterL
        let overrideContractBalance = Just rcBalance
        executeTransfer (#isGlobalOp :! False) overrideContractBalance def $
          TransferOperation
            { toDestination = contractAddr
            , toCounter = counter1
            , toTxData = TxData
              { tdSenderAddress = sender
              , tdParameter = TxTypedParam param \\ L.niceParameterEvi @cp
              , tdEntrypoint = DefEpName
              , tdAmount = rcAmount
              }
            }
        pure contractAddr
      psNow .= now
      psLevel .= level
      case res of
        Left executorError -> throwEE executorError
        Right (executorRes, contractAddr) -> do
          -- Find the storage of the contract and return it in its RPC representation.
          case executorRes ^. erGState . gsAddressesL . at contractAddr of
            Nothing ->
              cmiFailure $ "Internal error: failed to find contract: '" +| contractAddr |+ "'"
            Just (ASSimple {}) ->
              cmiFailure $ "Internal error: expected address to belong to a contract: '" +| contractAddr |+ "'"
            Just (ASContract (ContractState _ _ (finalStorage :: Value actualSt) _)) -> do
              finalStorage' <- castM @actualSt @(ToT st) finalStorage (throwM . UnexpectedStorageType)
              pure $ fromVal $ valueAsRPC finalStorage'
      where
        maybeRPCToVal :: MaybeRPC v -> PureM (Value (ToT v))
        maybeRPCToVal = \case
          NotRPC v -> pure $ toVal v
          IsRPC v -> replaceBigMapIds findBigMapById sing $ toVal v

isAddressRefillable :: Address -> PureM Bool
isAddressRefillable addr = Set.member addr <$> use psRefillableAddresses

getBalance :: Address -> PureM Mutez
getBalance addr = do
  GState{..} <- use psGState
  return $ maybe zeroMutez asBalance $ Map.lookup addr gsAddresses

saveAlias :: Alias -> Address -> Maybe SecretKey -> PureM Address
saveAlias name addr mbSk = do
  psAliases %= Map.insert name (AliasData addr mbSk)
  pure addr

exceptionHandler :: PureM a -> PureM a
exceptionHandler action = try action >>= \case
  Left err -> exceptionToTransferFailure err >>= throwM
  Right res -> return res
  where
    exceptionToTransferFailure :: ExecutorError' AddressName -> PureM TransferFailure
    exceptionToTransferFailure err = case err of
      EEZeroTransaction addr -> return $ TransferFailure (addrNameToAddr addr) EmptyTransaction
      EEIllTypedParameter addr _ -> return $ TransferFailure (addrNameToAddr addr) BadParameter
      EEUnexpectedParameterType addr _ -> return $ TransferFailure (addrNameToAddr addr) BadParameter
      EEInterpreterFailed addr (InterpretError (MichelsonFailureWithStack{..}, _)) ->
        case mfwsFailed of
          MichelsonFailedWith val -> return $ TransferFailure (addrNameToAddr addr) $ FailedWith (EOTVTypedValue val) (Just mfwsErrorSrcPos)
          MichelsonArithError (T.ShiftArithError{}) -> return $ TransferFailure (addrNameToAddr addr) ShiftOverflow
          MichelsonArithError (T.MutezArithError errType _ _) -> return $ TransferFailure (addrNameToAddr addr) $ MutezArithError errType
          MichelsonGasExhaustion -> return $ TransferFailure (addrNameToAddr addr) GasExhaustion
          _ -> throwM err
      _ -> throwM err


getMorleyLogsImpl :: PureM a -> PureM (LogsInfo, a)
getMorleyLogsImpl action = swap <$> listen action

getStorageImpl
  :: forall st addr. (ToStorageType st addr)
  => addr -> PureM st
getStorageImpl addr = do
  withDict (pickNiceStorage @st addr) $ do
    ContractState _ _ (storage :: Value actualT) _ <- contractStorage (toAddress addr)
    val <- castM @actualT @(ToT st) storage (throwM . UnexpectedStorageType)
    pure $ T.fromVal val

-- Attempt to retrieve a ContractState given for the given address. Fails if the
-- address is unknown or the address is a simple address (contract without
-- code and storage).
contractStorage :: Address -> PureM ContractState
contractStorage addr = do
  GState{..} <- use psGState
  case Map.lookup addr gsAddresses of
    Just (ASContract contractState) -> pure contractState
    Just (ASSimple {}) -> throwM . CustomTestError $
      "Expected address to be contract with storage, but it's a simple address: " <> pretty addr
    Nothing -> unknownAddress addr

resolve :: Alias -> PureM Address
resolve name = do
  aliases <- use psAliases
  let maybeAddress = Map.lookup name aliases
  maybe (unknownAlias name) (pure . adAddress) maybeAddress

unknownAddress :: Address -> PureM whatever
unknownAddress =
  throwM . CustomTestError .
  mappend "Unknown address provided: " . pretty

unknownAlias :: Alias -> PureM whatever
unknownAlias =
  throwM . CustomTestError .
  mappend "Unknown address alias: " . pretty

-- | Make branch names for a case when we are not within any branch.
emptyScenarioBranch :: ScenarioBranchName
emptyScenarioBranch = ScenarioBranchName []

-- | Add a new branch element to names provided by inner
-- 'Test.Cleveland.branchout' calls.
appendScenarioBranch :: Text -> ScenarioBranchName -> ScenarioBranchName
appendScenarioBranch brName (ScenarioBranchName branches) =
  ScenarioBranchName (brName : branches)

----------------------------------------------------------------------------
-- Support functions
----------------------------------------------------------------------------

initAliases :: Alias -> Aliases
initAliases alias = one ( alias
                        , AliasData genesisAddress $
                          Just $ genesisSecretKey
                        )

initEnv :: Alias -> PureState
initEnv alias = PureState
  { _psAliases = initAliases alias
  , _psDefaultAliasesCounter = DefaultAliasCounter 0
  , _psRefillableAddresses = Set.empty
  , _psNow = dummyNow
  , _psLevel = dummyLevel
  , _psGState = initGState
  , _psMinBlockTime = dummyMinBlockTime
  , _psContractsNames = Map.empty
  }

failedInsideBranch :: Text -> SomeException -> FailedInBranch
failedInsideBranch name err = case fromException @FailedInBranch err of
  Just (FailedInBranch branch failure) ->
    FailedInBranch (appendScenarioBranch name branch) failure
  Nothing ->
    FailedInBranch (appendScenarioBranch name emptyScenarioBranch) err

----------------------------------------------------------------------------
-- Emulator internals
----------------------------------------------------------------------------

transfer
  :: forall cp vd epRef epArg addr.
     (HasEntrypointArg cp epRef epArg, T.IsoValue epArg, L.ToTAddress cp vd addr)
  => "from" :! Address
  -> "to" :! addr
  -> Mutez
  -> epRef
  -> epArg
  -> PureM ()
transfer (arg #from -> from) (arg #to -> toAddr) money epRef param =
  let L.TAddress to' = L.toTAddress @cp @vd toAddr in
  case useHasEntrypointArg @cp @epRef @epArg epRef of
    (Dict, epName) -> registerInterpretation do
      executeGlobalOperations def $ one $
        Runtime.TransferOp $ TransferOperation
          { toDestination = to'
          , toCounter = 0
          , toTxData = TxData
            { tdSenderAddress = from
            , tdParameter = withDict (T.properParameterEvi @(ToT epArg)) $
                TxTypedParam (T.toVal param)
            , tdEntrypoint = epName
            , tdAmount = money
            }
          }

-- | Originate a contract with given initial storage and balance. Its
-- address is returned.
originate :: U.Contract -> Text -> U.Value -> Mutez -> PureM Address
originate uContract contractName uStorage balance =
  case typeCheckingWith def $ typeCheckContractAndStorage uContract uStorage of
    Left tcErr -> throwM $ UnexpectedTypeCheckError tcErr
    Right (T.SomeContractAndStorage contract storage) -> do
      counter <- gsCounter <$> use psGState
      address <- registerInterpretation . executeGlobalOrigination $
        (dummyOrigination storage contract counter) { ooBalance = balance }

      psContractsNames %= Map.insert address contractName
      return address

throwEE :: ExecutorError -> PureM a
throwEE err = do
  st <- get
  throwM $ flip addrToAddrName st <$> err

-- | Runs a set of operations and updates the engine's state.
registerInterpretation :: ExecutorM a -> PureM a
registerInterpretation action = do
  interpretedResult <- interpret action
  tell $ extractLogs interpretedResult

  case interpretedResult of
    Right (executorRes, res) -> do
      psGState .= _erGState executorRes
      pure res
    Left executorError -> throwEE executorError

  where
    extractLogs :: Either ExecutorError (ExecutorRes, a) -> [ScenarioLogs]
    extractLogs = \case
      Left (EEInterpreterFailed addr (InterpretError e)) -> [ScenarioLogs addr $ snd e]
      Right (res, _) -> res ^. erInterpretResults <&> \(addr, InterpretResult{..}) ->
        ScenarioLogs addr iurMorleyLogs
      _ -> []

-- | Interpret an action and return the result _without_ updating the engine's state.
interpret :: ExecutorM a -> PureM (Either ExecutorError (ExecutorRes, a))
interpret action = do
  now <- use psNow
  level <- use psLevel
  gState <- use psGState
  minBlockTime <- use psMinBlockTime
  pure $ runExecutorM now level minBlockTime dummyMaxSteps gState action

addrToAddrName :: Address -> PureState -> AddressName
addrToAddrName addr iState =
  AddressName (Map.lookup addr (iState ^. psContractsNames)) addr

addrNameToAddr :: AddressName -> Address
addrNameToAddr (AddressName _ addr) = addr