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

-- | Emulation of @run_code@.

module Morley.Michelson.Runtime.RunCode
  ( runCode
  , RunCodeParameters(..)
  , runCodeParameters
  , resolveRunCodeBigMaps
  ) where

import Data.Default (def)
import Data.Map qualified as Map

import Morley.Michelson.Interpret (ContractEnv(..), InterpretError(..), assignBigMapIds, interpret)
import Morley.Michelson.Runtime.Dummy
import Morley.Michelson.Runtime.GState
import Morley.Michelson.TypeCheck
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Typed.Operation
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Morley.Tezos.Core (ChainId, Mutez, Timestamp(..), dummyChainId, zeroMutez)
import Morley.Tezos.Crypto (KeyHash)

----------------------------------------------------------------------------
-- Auxiliary types
----------------------------------------------------------------------------

-- | Data required for calling 'runCode'.
type RunCodeParameters :: T.T -> T.T -> T.T -> Type
data RunCodeParameters cp epArg st = RunCodeParameters
  { forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st -> Contract cp st
rcScript :: T.Contract cp st
    -- ^ Contract code to run
  , forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st -> Value st
rcStorage :: T.Value st
    -- ^ Initial contract storage
  , forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st -> Value epArg
rcInput :: T.Value epArg
    -- ^ Parameter to call the contract
  , forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st -> EntrypointCallT cp epArg
rcEntryPoint :: T.EntrypointCallT cp epArg
    -- ^ Entrypoint to call. Use 'T.mkEntrypointCall' to construct.
  , forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st -> Mutez
rcAmount :: Mutez
    -- ^ Transfer amount
  , forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st -> Mutez
rcBalance :: Mutez
    -- ^ Contract initial balance
  , forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st -> ChainId
rcChainId :: ChainId
    -- ^ Chain id
  , forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st -> Timestamp
rcNow :: Timestamp
    -- ^ The result of @NOW@ instruction
  , forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st -> Natural
rcLevel :: Natural
    -- ^ The result of @LEVEL@ instruction
  , forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st -> Natural
rcMinBlockTime :: Natural
    -- ^ The result of @MIN_BLOCK_TIME@ instruction
  , forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st -> L1Address
rcSource :: L1Address
    -- ^ Transfer source
  , forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st -> L1Address
rcSender :: L1Address
    -- ^ Transfer sender
  , forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st -> Map ContractAddress ContractState
rcKnownContracts :: Map ContractAddress ContractState
    -- ^ Known contracts and their state. If you only know parameter types and
    -- don't need to run contract's views, you can use 'dummyContractState' to
    -- construct the state.
  , forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st -> Maybe ContractAddress
rcSelf :: Maybe ContractAddress
    -- ^ Address returned by the @SELF@ instruction, will be auto-generated if
    -- 'Nothing'
  , forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st -> Maybe KeyHash
rcDelegate :: Maybe KeyHash
    -- ^ Contract's delegate
  , forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st -> VotingPowers
rcVotingPowers :: VotingPowers
    -- ^ Voting powers
  }

-- | Construct 'RunCodeParameters' with some reasonable defaults.
--
-- Prepare untyped storage and parameter with 'resolveRunCodeBigMaps'.
--
-- Use 'T.mkEntrypointCall' or 'T.mkDefEntrypointCall' to construct the entrypoint
-- call specification.
runCodeParameters
  :: T.Contract cp st -- ^ Contract to run
  -> T.Value st -- ^ Contract storage
  -> T.EntrypointCallT cp epArg -- ^ Entrypoint call specification
  -> T.Value epArg -- ^ Entrypoint argument
  -> RunCodeParameters cp epArg st
runCodeParameters :: forall (cp :: T) (st :: T) (epArg :: T).
Contract cp st
-> Value st
-> EntrypointCallT cp epArg
-> Value epArg
-> RunCodeParameters cp epArg st
runCodeParameters Contract cp st
rcScript Value st
rcStorage EntrypointCallT cp epArg
rcEntryPoint Value epArg
rcInput = RunCodeParameters :: forall (cp :: T) (epArg :: T) (st :: T).
Contract cp st
-> Value st
-> Value epArg
-> EntrypointCallT cp epArg
-> Mutez
-> Mutez
-> ChainId
-> Timestamp
-> Natural
-> Natural
-> L1Address
-> L1Address
-> Map ContractAddress ContractState
-> Maybe ContractAddress
-> Maybe KeyHash
-> VotingPowers
-> RunCodeParameters cp epArg st
RunCodeParameters
  { rcAmount :: Mutez
rcAmount = Mutez
zeroMutez
  , rcBalance :: Mutez
rcBalance = Mutez
zeroMutez
  , rcChainId :: ChainId
rcChainId = ChainId
dummyChainId
  , rcNow :: Timestamp
rcNow = Timestamp
dummyNow
  , rcLevel :: Natural
rcLevel = Natural
dummyLevel
  , rcMinBlockTime :: Natural
rcMinBlockTime = Natural
dummyMinBlockTime
  , rcSource :: L1Address
rcSource = KindedAddress 'AddressKindImplicit -> L1Address
forall {k} (c :: k -> Constraint) (f :: k -> *) (a :: k).
c a =>
f a -> Constrained c f
Constrained KindedAddress 'AddressKindImplicit
genesisAddress
  , rcSender :: L1Address
rcSender = KindedAddress 'AddressKindImplicit -> L1Address
forall {k} (c :: k -> Constraint) (f :: k -> *) (a :: k).
c a =>
f a -> Constrained c f
Constrained KindedAddress 'AddressKindImplicit
genesisAddress
  , rcKnownContracts :: Map ContractAddress ContractState
rcKnownContracts = Map ContractAddress ContractState
forall a. Monoid a => a
mempty
  , rcSelf :: Maybe ContractAddress
rcSelf = Maybe ContractAddress
forall a. Maybe a
Nothing
  , rcDelegate :: Maybe KeyHash
rcDelegate = Maybe KeyHash
forall a. Maybe a
Nothing
  , rcVotingPowers :: VotingPowers
rcVotingPowers = VotingPowers
dummyVotingPowers
  , EntrypointCallT cp epArg
Contract cp st
Value st
Value epArg
rcInput :: Value epArg
rcEntryPoint :: EntrypointCallT cp epArg
rcStorage :: Value st
rcScript :: Contract cp st
rcEntryPoint :: EntrypointCallT cp epArg
rcInput :: Value epArg
rcStorage :: Value st
rcScript :: Contract cp st
..
  }

-- | Emulate @run_code@ RPC endpoint to an extent. Unlike @runContract@, runs
-- the contract through the emulator directly, without doing any operations.
-- This includes not doing the origination operation, and not applying the
-- operations produced by the transfer.
runCode
  :: RunCodeParameters cp epArg st
  -> Either (InterpretError Void) ([T.Operation], T.Value st)
runCode :: forall (cp :: T) (epArg :: T) (st :: T).
RunCodeParameters cp epArg st
-> Either (InterpretError Void) ([Operation], Value st)
runCode (RunCodeParameters
  -- NB: explicit match to ensure all fields are consumed; ugly, but there are no real alternatives
  rcScript :: Contract cp st
rcScript@T.Contract{}
  Value st
rcStorage
  Value epArg
rcInput
  EntrypointCallT cp epArg
rcEntryPoint
  Mutez
rcAmount
  Mutez
rcBalance
  ChainId
rcChainId
  Timestamp
rcNow
  Natural
rcLevel
  Natural
rcMinBlockTime
  L1Address
rcSource
  L1Address
rcSender
  Map ContractAddress ContractState
rcKnownContracts
  Maybe ContractAddress
rcSelf
  Maybe KeyHash
rcDelegate
  VotingPowers
rcVotingPowers
  ) = (Either (MichelsonFailureWithStack Void) ([Operation], Value st),
 (InterpreterState, MorleyLogs))
-> Either (InterpretError Void) ([Operation], Value st)
forall {p :: * -> * -> *} {ext} {c} {a}.
Bifunctor p =>
(p (MichelsonFailureWithStack ext) c, (a, MorleyLogs))
-> p (InterpretError ext) c
toInterpreterRes ((Either (MichelsonFailureWithStack Void) ([Operation], Value st),
  (InterpreterState, MorleyLogs))
 -> Either (InterpretError Void) ([Operation], Value st))
-> (Either
      (MichelsonFailureWithStack Void) ([Operation], Value st),
    (InterpreterState, MorleyLogs))
-> Either (InterpretError Void) ([Operation], Value st)
forall a b. (a -> b) -> a -> b
$
    Contract cp st
-> EntrypointCallT cp epArg
-> Value epArg
-> Value st
-> GlobalCounter
-> BigMapCounter
-> ContractEnv
-> (Either
      (MichelsonFailureWithStack Void) ([Operation], Value st),
    (InterpreterState, MorleyLogs))
forall (cp :: T) (st :: T) (arg :: T).
Contract cp st
-> EntrypointCallT cp arg
-> Value arg
-> Value st
-> GlobalCounter
-> BigMapCounter
-> ContractEnv
-> ContractReturn st
interpret Contract cp st
rcScript EntrypointCallT cp epArg
rcEntryPoint Value epArg
input Value st
storage GlobalCounter
dummyGlobalCounter BigMapCounter
bigMapCtr ContractEnv
contractEnv
  where
    selfState :: ContractState
selfState = ContractState :: forall (cp :: T) (st :: T).
(ParameterScope cp, StorageScope st) =>
Mutez
-> Contract cp st -> Value st -> Maybe KeyHash -> ContractState
ContractState
      { csBalance :: Mutez
csBalance = Mutez
rcBalance
      , csContract :: Contract cp st
csContract = Contract cp st
rcScript
      , csStorage :: Value st
csStorage = Value st
rcStorage
      , csDelegate :: Maybe KeyHash
csDelegate = Maybe KeyHash
rcDelegate
      }
    dummyOriginationHash :: OperationHash
dummyOriginationHash = OriginationOperation -> OperationHash
mkOriginationOperationHash (OriginationOperation -> OperationHash)
-> OriginationOperation -> OperationHash
forall a b. (a -> b) -> a -> b
$
      Value st -> Contract cp st -> GlobalCounter -> OriginationOperation
forall (cp :: T) (st :: T).
(ParameterScope cp, StorageScope st) =>
Value st -> Contract cp st -> GlobalCounter -> OriginationOperation
dummyOrigination Value st
rcStorage Contract cp st
rcScript GlobalCounter
dummyGlobalCounter
    self :: ContractAddress
self = ContractAddress -> Maybe ContractAddress -> ContractAddress
forall a. a -> Maybe a -> a
fromMaybe
      (OperationHash -> GlobalCounter -> ContractAddress
mkContractAddress OperationHash
dummyOriginationHash GlobalCounter
dummyGlobalCounter)
      Maybe ContractAddress
rcSelf
    ((Value epArg
input, Value st
storage), BigMapCounter
bigMapCtr) = BigMapCounter
-> State BigMapCounter (Value epArg, Value st)
-> ((Value epArg, Value st), BigMapCounter)
forall s a. s -> State s a -> (a, s)
usingState BigMapCounter
dummyBigMapCounter (State BigMapCounter (Value epArg, Value st)
 -> ((Value epArg, Value st), BigMapCounter))
-> State BigMapCounter (Value epArg, Value st)
-> ((Value epArg, Value st), BigMapCounter)
forall a b. (a -> b) -> a -> b
$
      (,) (Value epArg -> Value st -> (Value epArg, Value st))
-> StateT BigMapCounter Identity (Value epArg)
-> StateT
     BigMapCounter Identity (Value st -> (Value epArg, Value st))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Value epArg -> StateT BigMapCounter Identity (Value epArg)
forall (m :: * -> *) (t :: T).
MonadState BigMapCounter m =>
Bool -> Value t -> m (Value t)
assignBigMapIds Bool
False Value epArg
rcInput StateT BigMapCounter Identity (Value st -> (Value epArg, Value st))
-> StateT BigMapCounter Identity (Value st)
-> State BigMapCounter (Value epArg, Value st)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Value st -> StateT BigMapCounter Identity (Value st)
forall (m :: * -> *) (t :: T).
MonadState BigMapCounter m =>
Bool -> Value t -> m (Value t)
assignBigMapIds Bool
False Value st
rcStorage
    toInterpreterRes :: (p (MichelsonFailureWithStack ext) c, (a, MorleyLogs))
-> p (InterpretError ext) c
toInterpreterRes (p (MichelsonFailureWithStack ext) c
eith, (a
_, MorleyLogs
logs)) = (MichelsonFailureWithStack ext -> InterpretError ext)
-> p (MichelsonFailureWithStack ext) c -> p (InterpretError ext) c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((MichelsonFailureWithStack ext, MorleyLogs) -> InterpretError ext
forall ext.
(MichelsonFailureWithStack ext, MorleyLogs) -> InterpretError ext
InterpretError ((MichelsonFailureWithStack ext, MorleyLogs) -> InterpretError ext)
-> (MichelsonFailureWithStack ext
    -> (MichelsonFailureWithStack ext, MorleyLogs))
-> MichelsonFailureWithStack ext
-> InterpretError ext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, MorleyLogs
logs)) p (MichelsonFailureWithStack ext) c
eith
    contractEnv :: ContractEnv
contractEnv = ContractEnv :: Timestamp
-> RemainingSteps
-> Mutez
-> Map ContractAddress ContractState
-> ContractAddress
-> L1Address
-> L1Address
-> Mutez
-> VotingPowers
-> ChainId
-> Maybe OperationHash
-> Natural
-> ErrorSrcPos
-> Natural
-> ContractEnv
ContractEnv
      { ceNow :: Timestamp
ceNow = Timestamp
rcNow
      , ceBalance :: Mutez
ceBalance = Mutez
rcBalance
      , ceSelf :: ContractAddress
ceSelf = ContractAddress
self
      , ceAmount :: Mutez
ceAmount = Mutez
rcAmount
      , ceMinBlockTime :: Natural
ceMinBlockTime = Natural
rcMinBlockTime
      , ceContracts :: Map ContractAddress ContractState
ceContracts = ContractAddress
-> ContractState
-> Map ContractAddress ContractState
-> Map ContractAddress ContractState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ContractAddress
self ContractState
selfState Map ContractAddress ContractState
rcKnownContracts
      , ceMaxSteps :: RemainingSteps
ceMaxSteps = RemainingSteps
dummyMaxSteps
      , ceSource :: L1Address
ceSource = L1Address
rcSource
      , ceSender :: L1Address
ceSender = L1Address
rcSender
      , ceChainId :: ChainId
ceChainId = ChainId
rcChainId
      , ceOperationHash :: Maybe OperationHash
ceOperationHash = Maybe OperationHash
forall a. Maybe a
Nothing
      , ceLevel :: Natural
ceLevel = Natural
rcLevel
      , ceErrorSrcPos :: ErrorSrcPos
ceErrorSrcPos = ErrorSrcPos
forall a. Default a => a
def
      , ceVotingPowers :: VotingPowers
ceVotingPowers = VotingPowers
rcVotingPowers
      }

-- | Given an untyped value, possibly containing @big_map@ ids, typecheck it,
-- resolving ids to the corresponding @big_map@s.
--
-- 'BigMapFinder' can be constructed using 'Morley.Michelson.Runtime.mkBigMapFinder'.
resolveRunCodeBigMaps
  :: T.SingI t => BigMapFinder -> U.Value -> Either TcError (T.Value t)
resolveRunCodeBigMaps :: forall (t :: T).
SingI t =>
BigMapFinder -> Value -> Either TcError (Value t)
resolveRunCodeBigMaps = TypeCheckOptions
-> TypeCheckResult ExpandedOp (Value t) -> Either TcError (Value t)
forall op a.
TypeCheckOptions -> TypeCheckResult op a -> Either (TcError' op) a
typeCheckingWith TypeCheckOptions
forall a. Default a => a
def{tcStrict :: Bool
tcStrict=Bool
False} (TypeCheckResult ExpandedOp (Value t) -> Either TcError (Value t))
-> (BigMapFinder -> Value -> TypeCheckResult ExpandedOp (Value t))
-> BigMapFinder
-> Value
-> Either TcError (Value t)
forall a b c. SuperComposition a b c => a -> b -> c
... BigMapFinder -> Value -> TypeCheckResult ExpandedOp (Value t)
forall (t :: T).
SingI t =>
BigMapFinder -> Value -> TypeCheckResult ExpandedOp (Value t)
typeCheckValueRunCodeCompat