{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}
{-

An effect for starting contract instances and calling endpoints on them.

-}
module Plutus.Trace.Effects.RunContract(
    RunContract(..)
    , StartContract(..)
    , ContractConstraints
    , ContractInstanceTag
    , activateContract
    , activateContractWallet
    , callEndpoint
    , getContractState
    , activeEndpoints
    , observableState
    , walletInstanceTag
    , handleRunContract
    , handleStartContract
    , startContractThread
    ) where

import Cardano.Api (NetworkId)
import Control.Lens (preview)
import Control.Monad (void)
import Control.Monad.Freer (Eff, Member, interpret, send, type (~>))
import Control.Monad.Freer.Coroutine (Yield (..))
import Control.Monad.Freer.Error (Error, throwError)
import Control.Monad.Freer.Extras.Log (LogMsg, logError, mapLog)
import Control.Monad.Freer.Reader (Reader, ask)
import Control.Monad.Freer.State (State)
import Control.Monad.Freer.TH (makeEffect)

import Data.Aeson qualified as JSON
import Data.Maybe (mapMaybe)
import Data.Profunctor (Profunctor (..))
import Data.Proxy (Proxy (..))
import Data.Row.Internal qualified as V
import GHC.TypeLits qualified
import Plutus.Contract (Contract, HasEndpoint)
import Plutus.Contract.Effects (ActiveEndpoint, PABResp (ExposeEndpointResp), _ExposeEndpointReq)
import Plutus.Contract.Resumable (Request (rqRequest), Requests (..))
import Plutus.Contract.Schema (Input, Output)
import Plutus.Contract.Types (IsContract (..), ResumableResult (..))
import Plutus.Trace.Effects.ContractInstanceId (ContractInstanceIdEff, nextId)
import Plutus.Trace.Emulator.ContractInstance (contractThread, getThread)
import Plutus.Trace.Emulator.Types (ContractHandle (..), ContractInstanceState (..), ContractInstanceTag,
                                    EmulatorMessage (ContractInstanceStateRequest, ContractInstanceStateResponse, EndpointCall),
                                    EmulatorRuntimeError (EmulatorJSONDecodingError), EmulatorThreads,
                                    UserThreadMsg (UserThreadErr), walletInstanceTag)
import Plutus.Trace.Scheduler (AgentSystemCall, EmSystemCall, MessageCall (Message), Priority (..), Tag, ThreadId, fork,
                               mkSysCall, sleep)
import Wallet.Emulator.MultiAgent (EmulatorEvent' (..), MultiAgentEffect, handleMultiAgentEffects)
import Wallet.Emulator.Wallet (Wallet (..))
import Wallet.Types (EndpointDescription (..), EndpointValue (..))

type ContractConstraints s =
    ( V.Forall (Output s) V.Unconstrained1
    , V.Forall (Input s) V.Unconstrained1
    , V.AllUniqueLabels (Input s)
    , V.AllUniqueLabels (Output s)
    , V.Forall (Input s) JSON.FromJSON
    , V.Forall (Input s) JSON.ToJSON
    , V.Forall (Output s) JSON.FromJSON
    , V.Forall (Output s) JSON.ToJSON
    )

-- | Start a Plutus contract (client side)
data StartContract r where
    ActivateContract :: (IsContract contract, ContractConstraints s, Show e, JSON.FromJSON e, JSON.ToJSON e, JSON.ToJSON w, Monoid w, JSON.FromJSON w) => Wallet -> contract w s e a -> ContractInstanceTag -> StartContract (ContractHandle w s e)

makeEffect ''StartContract

-- | Run a Plutus contract (client side)
data RunContract r where
    CallEndpointP :: forall l ep w s e. (ContractConstraints s, HasEndpoint l ep s, JSON.ToJSON ep) => Proxy l -> ContractHandle w s e -> ep -> RunContract ()
    GetContractState :: forall w s e. (ContractConstraints s, JSON.FromJSON e, JSON.FromJSON w, JSON.ToJSON w) => ContractHandle w s e -> RunContract (ContractInstanceState w s e ())

makeEffect ''RunContract

-- | Call an endpoint on a contract instance.
callEndpoint ::
    forall l ep w s e effs.
    (JSON.ToJSON ep, ContractConstraints s, HasEndpoint l ep s, Member RunContract effs) => ContractHandle w s e -> ep -> Eff effs ()
callEndpoint :: ContractHandle w s e -> ep -> Eff effs ()
callEndpoint ContractHandle w s e
hdl ep
v = Proxy l -> ContractHandle w s e -> ep -> Eff effs ()
forall (l :: Symbol) ep w (s :: Row *) e (effs :: [* -> *]).
(ContractConstraints s, HasEndpoint l ep s, ToJSON ep,
 Member RunContract effs) =>
Proxy l -> ContractHandle w s e -> ep -> Eff effs ()
callEndpointP (Proxy l
forall k (t :: k). Proxy t
Proxy @l) ContractHandle w s e
hdl ep
v

-- | Like 'activateContract', but using 'walletInstanceTag' for the tag.
activateContractWallet
    :: forall contract w s e effs.
    ( IsContract contract
    , ContractConstraints s
    , Show e
    , JSON.ToJSON e
    , JSON.FromJSON e
    , JSON.ToJSON w
    , JSON.FromJSON w
    , Member StartContract effs
    , Monoid w
    )
    => Wallet
    -> contract w s e ()
    -> Eff effs (ContractHandle w s e)
activateContractWallet :: Wallet -> contract w s e () -> Eff effs (ContractHandle w s e)
activateContractWallet Wallet
w contract w s e ()
contract = Wallet
-> contract w s e ()
-> ContractInstanceTag
-> Eff effs (ContractHandle w s e)
forall (contract :: * -> Row * -> * -> * -> *) (s :: Row *) e w a
       (effs :: [* -> *]).
(IsContract contract, ContractConstraints s, Show e, FromJSON e,
 ToJSON e, ToJSON w, Monoid w, FromJSON w,
 Member StartContract effs) =>
Wallet
-> contract w s e a
-> ContractInstanceTag
-> Eff effs (ContractHandle w s e)
activateContract Wallet
w contract w s e ()
contract (Wallet -> ContractInstanceTag
walletInstanceTag Wallet
w)

-- | Handle the 'RunContract' effect by running each contract instance in an
--   emulator thread.
handleRunContract :: forall effs effs2 a.
    ( Member (State EmulatorThreads) effs2
    , Member (Error EmulatorRuntimeError) effs2
    , Member (Error EmulatorRuntimeError) effs
    , Member (LogMsg EmulatorEvent') effs
    , Member (State EmulatorThreads) effs
    , Member (Reader ThreadId) effs
    , Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
    )
    => RunContract
    ~> Eff effs
handleRunContract :: RunContract ~> Eff effs
handleRunContract = \case
    CallEndpointP Proxy l
p ContractHandle w s e
h ep
v -> Proxy l -> ContractHandle w s e -> ep -> Eff effs ()
forall w (s :: Row *) (l :: Symbol) e ep (effs :: [* -> *])
       (effs2 :: [* -> *]) a.
(HasEndpoint l ep s, ToJSON ep,
 Member (State EmulatorThreads) effs2,
 Member (Error EmulatorRuntimeError) effs2,
 Member
   (Yield
      (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage))
   effs) =>
Proxy l -> ContractHandle w s e -> ep -> Eff effs ()
handleCallEndpoint @_ @_ @_ @_ @_ @effs @effs2 @a Proxy l
p ContractHandle w s e
h ep
v
    GetContractState ContractHandle w s e
hdl ->
        (LogMsg UserThreadMsg ~> Eff effs)
-> Eff (LogMsg UserThreadMsg : effs) ~> Eff effs
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret ((UserThreadMsg -> EmulatorEvent')
-> LogMsg UserThreadMsg ~> Eff effs
forall a b (effs :: [* -> *]).
Member (LogMsg b) effs =>
(a -> b) -> LogMsg a ~> Eff effs
mapLog UserThreadMsg -> EmulatorEvent'
UserThreadEvent)
            (Eff (LogMsg UserThreadMsg : effs) (ContractInstanceState w s e ())
 -> Eff effs (ContractInstanceState w s e ()))
-> Eff
     (LogMsg UserThreadMsg : effs) (ContractInstanceState w s e ())
-> Eff effs (ContractInstanceState w s e ())
forall a b. (a -> b) -> a -> b
$ ContractHandle w s e
-> Eff
     (LogMsg UserThreadMsg : effs) (ContractInstanceState w s e ())
forall w (s :: Row *) e (effs :: [* -> *]) (effs2 :: [* -> *]) a.
(Member (State EmulatorThreads) effs,
 Member
   (Yield
      (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage))
   effs,
 Member (Reader ThreadId) effs,
 Member (Error EmulatorRuntimeError) effs, FromJSON e, FromJSON w,
 Member (LogMsg UserThreadMsg) effs) =>
ContractHandle w s e -> Eff effs (ContractInstanceState w s e ())
handleGetContractState @_ @_ @_ @(LogMsg UserThreadMsg ': effs) @effs2 @a ContractHandle w s e
hdl

-- | Handle the 'StartContract' effect by starting each contract instance in an
--   emulator thread.
handleStartContract :: forall effs effs2 a.
    ( Member (State EmulatorThreads) effs2
    , Member (Error EmulatorRuntimeError) effs2
    , Member MultiAgentEffect effs2
    , Member (LogMsg EmulatorEvent') effs2
    , Member ContractInstanceIdEff effs
    , Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
    )
    => NetworkId
    -> StartContract
    ~> Eff effs
handleStartContract :: NetworkId -> StartContract ~> Eff effs
handleStartContract NetworkId
networkId = \case
    ActivateContract Wallet
w contract w s e a
c ContractInstanceTag
t -> NetworkId
-> Wallet
-> ContractInstanceTag
-> Contract w s e ()
-> Eff effs (ContractHandle w s e)
forall w (s :: Row *) e (effs :: [* -> *]) (effs2 :: [* -> *]) a.
(ContractConstraints s, Member ContractInstanceIdEff effs,
 Member (State EmulatorThreads) effs2,
 Member MultiAgentEffect effs2,
 Member (Error EmulatorRuntimeError) effs2,
 Member (LogMsg EmulatorEvent') effs2,
 Member
   (Yield
      (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage))
   effs,
 Show e, ToJSON e, ToJSON w, Monoid w) =>
NetworkId
-> Wallet
-> ContractInstanceTag
-> Contract w s e ()
-> Eff effs (ContractHandle w s e)
handleActivate @_ @_ @_ @effs @effs2 @a NetworkId
networkId Wallet
w ContractInstanceTag
t (Contract w s e a -> Contract w s e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (contract w s e a -> Contract w s e a
forall (c :: * -> Row * -> * -> * -> *) w (s :: Row *) e a.
IsContract c =>
c w s e a -> Contract w s e a
toContract contract w s e a
c))

handleGetContractState ::
    forall w s e effs effs2 a.
    ( Member (State EmulatorThreads) effs
    , Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
    , Member (Reader ThreadId) effs
    , Member (Error EmulatorRuntimeError) effs
    , JSON.FromJSON e
    , JSON.FromJSON w
    , Member (LogMsg UserThreadMsg) effs
    )
    => ContractHandle w s e
    -> Eff effs (ContractInstanceState w s e ())
handleGetContractState :: ContractHandle w s e -> Eff effs (ContractInstanceState w s e ())
handleGetContractState ContractHandle{ContractInstanceId
chInstanceId :: forall w (s :: Row *) e. ContractHandle w s e -> ContractInstanceId
chInstanceId :: ContractInstanceId
chInstanceId} = do
    ThreadId
ownId <- forall (effs :: [* -> *]).
Member (Reader ThreadId) effs =>
Eff effs ThreadId
forall r (effs :: [* -> *]). Member (Reader r) effs => Eff effs r
ask @ThreadId
    ThreadId
threadId <- ContractInstanceId -> Eff effs ThreadId
forall (effs :: [* -> *]).
(Member (State EmulatorThreads) effs,
 Member (Error EmulatorRuntimeError) effs) =>
ContractInstanceId -> Eff effs ThreadId
getThread ContractInstanceId
chInstanceId
    Eff effs (Maybe EmulatorMessage) -> Eff effs ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff effs (Maybe EmulatorMessage) -> Eff effs ())
-> Eff effs (Maybe EmulatorMessage) -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ Priority
-> SysCall effs2 EmulatorMessage a
-> Eff effs (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Priority
-> SysCall effs systemEvent a -> Eff effs2 (Maybe systemEvent)
mkSysCall @effs2 @EmulatorMessage @_ @a Priority
Normal (MessageCall EmulatorMessage -> SysCall effs2 EmulatorMessage a
forall a b. a -> Either a b
Left (MessageCall EmulatorMessage -> SysCall effs2 EmulatorMessage a)
-> MessageCall EmulatorMessage -> SysCall effs2 EmulatorMessage a
forall a b. (a -> b) -> a -> b
$ ThreadId -> EmulatorMessage -> MessageCall EmulatorMessage
forall systemEvent.
ThreadId -> systemEvent -> MessageCall systemEvent
Message ThreadId
threadId (EmulatorMessage -> MessageCall EmulatorMessage)
-> EmulatorMessage -> MessageCall EmulatorMessage
forall a b. (a -> b) -> a -> b
$ ThreadId -> EmulatorMessage
ContractInstanceStateRequest ThreadId
ownId)

    let checkResponse :: Maybe EmulatorMessage -> Eff effs (ContractInstanceState w s e ())
checkResponse = \case
            Just (ContractInstanceStateResponse Value
r) -> do
                case Value -> Result (ContractInstanceState w s e ())
forall a. FromJSON a => Value -> Result a
JSON.fromJSON @(ContractInstanceState w s e ()) Value
r of
                    JSON.Error String
e' -> do
                        let msg :: EmulatorRuntimeError
msg = String -> Value -> EmulatorRuntimeError
EmulatorJSONDecodingError String
e' Value
r
                        UserThreadMsg -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logError (UserThreadMsg -> Eff effs ()) -> UserThreadMsg -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ EmulatorRuntimeError -> UserThreadMsg
UserThreadErr EmulatorRuntimeError
msg
                        EmulatorRuntimeError -> Eff effs (ContractInstanceState w s e ())
forall e (effs :: [* -> *]) a.
Member (Error e) effs =>
e -> Eff effs a
throwError EmulatorRuntimeError
msg
                    JSON.Success ContractInstanceState w s e ()
event' -> ContractInstanceState w s e ()
-> Eff effs (ContractInstanceState w s e ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ContractInstanceState w s e ()
event'
            Maybe EmulatorMessage
_ -> Priority -> Eff effs (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Priority -> Eff effs2 (Maybe systemEvent)
sleep @effs2 @_ @_ @a Priority
Sleeping Eff effs (Maybe EmulatorMessage)
-> (Maybe EmulatorMessage
    -> Eff effs (ContractInstanceState w s e ()))
-> Eff effs (ContractInstanceState w s e ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe EmulatorMessage -> Eff effs (ContractInstanceState w s e ())
checkResponse
    Priority -> Eff effs (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Priority -> Eff effs2 (Maybe systemEvent)
sleep @effs2 @_ @_ @a Priority
Normal Eff effs (Maybe EmulatorMessage)
-> (Maybe EmulatorMessage
    -> Eff effs (ContractInstanceState w s e ()))
-> Eff effs (ContractInstanceState w s e ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe EmulatorMessage -> Eff effs (ContractInstanceState w s e ())
checkResponse

handleActivate :: forall w s e effs effs2 a.
    ( ContractConstraints s
    , Member ContractInstanceIdEff effs
    , Member (State EmulatorThreads) effs2
    , Member MultiAgentEffect effs2
    , Member (Error EmulatorRuntimeError) effs2
    , Member (LogMsg EmulatorEvent') effs2
    , Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
    , Show e
    , JSON.ToJSON e
    , JSON.ToJSON w
    , Monoid w
    )
    => NetworkId
    -> Wallet
    -> ContractInstanceTag
    -> Contract w s e ()
    -> Eff effs (ContractHandle w s e)
handleActivate :: NetworkId
-> Wallet
-> ContractInstanceTag
-> Contract w s e ()
-> Eff effs (ContractHandle w s e)
handleActivate NetworkId
networkId Wallet
wllt ContractInstanceTag
tag Contract w s e ()
con = do
    ContractInstanceId
i <- Eff effs ContractInstanceId
forall (effs :: [* -> *]).
Member ContractInstanceIdEff effs =>
Eff effs ContractInstanceId
nextId
    let handle :: ContractHandle w s e
handle = ContractHandle :: forall w (s :: Row *) e.
Contract w s e ()
-> ContractInstanceId
-> ContractInstanceTag
-> NetworkId
-> ContractHandle w s e
ContractHandle{chContract :: Contract w s e ()
chContract=Contract w s e ()
con, chInstanceId :: ContractInstanceId
chInstanceId = ContractInstanceId
i, chInstanceTag :: ContractInstanceTag
chInstanceTag = ContractInstanceTag
tag, chNetworkId :: NetworkId
chNetworkId = NetworkId
networkId}
    Eff effs (Maybe EmulatorMessage) -> Eff effs ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff effs (Maybe EmulatorMessage) -> Eff effs ())
-> Eff effs (Maybe EmulatorMessage) -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ Wallet -> ContractHandle w s e -> Eff effs (Maybe EmulatorMessage)
forall w (s :: Row *) e (effs :: [* -> *]) (effs2 :: [* -> *]) a.
(Member
   (Yield
      (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage))
   effs,
 Member (State EmulatorThreads) effs2,
 Member MultiAgentEffect effs2,
 Member (Error EmulatorRuntimeError) effs2,
 Member (LogMsg EmulatorEvent') effs2, ContractConstraints s,
 Show e, ToJSON e, ToJSON w, Monoid w) =>
Wallet -> ContractHandle w s e -> Eff effs (Maybe EmulatorMessage)
startContractThread @w @s @e @effs @effs2 @a Wallet
wllt ContractHandle w s e
handle
    ContractHandle w s e -> Eff effs (ContractHandle w s e)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ContractHandle w s e
handle

runningContractInstanceTag :: Tag
runningContractInstanceTag :: Tag
runningContractInstanceTag = Tag
"contract instance"

-- | Start a new thread for a contract instance (given by the handle).
--   The thread runs in the context of the wallet.
startContractThread ::
    forall w s e effs effs2 a.
    ( Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
    , Member (State EmulatorThreads) effs2
    , Member MultiAgentEffect effs2
    , Member (Error EmulatorRuntimeError) effs2
    , Member (LogMsg EmulatorEvent') effs2
    , ContractConstraints s
    , Show e
    , JSON.ToJSON e
    , JSON.ToJSON w
    , Monoid w
    )
    => Wallet
    -> ContractHandle w s e
    -> Eff effs (Maybe EmulatorMessage)
startContractThread :: Wallet -> ContractHandle w s e -> Eff effs (Maybe EmulatorMessage)
startContractThread Wallet
wallet ContractHandle w s e
handle =
    Tag
-> Priority
-> Eff
     (Reader ThreadId
        : Yield
            (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
        : effs2)
     ()
-> Eff effs (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Tag
-> Priority
-> Eff
     (Reader ThreadId
        : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
        : effs)
     ()
-> Eff effs2 (Maybe systemEvent)
fork @effs2 @EmulatorMessage @_ @a Tag
runningContractInstanceTag Priority
Normal
        ((Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
 ~> Eff
      (Reader ThreadId
         : Yield
             (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
         : effs2))
-> Eff
     (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
        : Reader ThreadId
        : Yield
            (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
        : effs2)
   ~> Eff
        (Reader ThreadId
           : Yield
               (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
           : effs2)
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret (Member
  (Yield
     (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage))
  (Reader ThreadId
     : Yield
         (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
     : effs2) =>
Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage) x
-> Eff
     (Reader ThreadId
        : Yield
            (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
        : effs2)
     x
forall (effs :: [* -> *]) (effs2 :: [* -> *]) c a.
Member
  (Yield
     (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage))
  effs =>
Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage) c
-> Eff effs c
mapYieldEm @_ @effs2 @_ @a)
            (Eff
   (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
      : Reader ThreadId
      : Yield
          (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
      : effs2)
   ()
 -> Eff
      (Reader ThreadId
         : Yield
             (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
         : effs2)
      ())
-> Eff
     (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
        : Reader ThreadId
        : Yield
            (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
        : effs2)
     ()
-> Eff
     (Reader ThreadId
        : Yield
            (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
        : effs2)
     ()
forall a b. (a -> b) -> a -> b
$ Wallet
-> Eff
     (EmulatedWalletEffects'
        (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
           : Reader ThreadId
           : Yield
               (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
           : effs2))
   ~> Eff
        (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
           : Reader ThreadId
           : Yield
               (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
           : effs2)
forall (effs :: [* -> *]).
Member MultiAgentEffect effs =>
Wallet -> Eff (EmulatedWalletEffects' effs) ~> Eff effs
handleMultiAgentEffects Wallet
wallet
            (Eff
   (EmulatedWalletEffects'
      (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
         : Reader ThreadId
         : Yield
             (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
         : effs2))
   ()
 -> Eff
      (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
         : Reader ThreadId
         : Yield
             (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
         : effs2)
      ())
-> Eff
     (EmulatedWalletEffects'
        (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
           : Reader ThreadId
           : Yield
               (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
           : effs2))
     ()
-> Eff
     (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
        : Reader ThreadId
        : Yield
            (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
        : effs2)
     ()
forall a b. (a -> b) -> a -> b
$ (LogMsg ContractInstanceLog
 ~> Eff
      (EmulatedWalletEffects'
         (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
            : Reader ThreadId
            : Yield
                (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
            : effs2)))
-> Eff
     (LogMsg ContractInstanceLog
        : EmulatedWalletEffects'
            (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
               : Reader ThreadId
               : Yield
                   (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
               : effs2))
   ~> Eff
        (EmulatedWalletEffects'
           (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
              : Reader ThreadId
              : Yield
                  (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
              : effs2))
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret ((ContractInstanceLog -> EmulatorEvent')
-> LogMsg ContractInstanceLog
   ~> Eff
        (EmulatedWalletEffects'
           (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
              : Reader ThreadId
              : Yield
                  (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
              : effs2))
forall a b (effs :: [* -> *]).
Member (LogMsg b) effs =>
(a -> b) -> LogMsg a ~> Eff effs
mapLog ContractInstanceLog -> EmulatorEvent'
InstanceEvent)
            (Eff
   (LogMsg ContractInstanceLog
      : EmulatedWalletEffects'
          (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
             : Reader ThreadId
             : Yield
                 (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
             : effs2))
   ()
 -> Eff
      (EmulatedWalletEffects'
         (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
            : Reader ThreadId
            : Yield
                (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
            : effs2))
      ())
-> Eff
     (LogMsg ContractInstanceLog
        : EmulatedWalletEffects'
            (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
               : Reader ThreadId
               : Yield
                   (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
               : effs2))
     ()
-> Eff
     (EmulatedWalletEffects'
        (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
           : Reader ThreadId
           : Yield
               (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
           : effs2))
     ()
forall a b. (a -> b) -> a -> b
$ ContractHandle w s e
-> Eff
     (LogMsg ContractInstanceLog
        : EmulatedWalletEffects'
            (Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage)
               : Reader ThreadId
               : Yield
                   (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
               : effs2))
     ()
forall w (s :: Row *) e (effs :: [* -> *]).
(Member (State EmulatorThreads) effs,
 Member (Error EmulatorRuntimeError) effs, ContractConstraints s,
 Show e, ToJSON e, ToJSON w, Monoid w) =>
ContractHandle w s e -> Eff (EmulatorAgentThreadEffs effs) ()
contractThread ContractHandle w s e
handle)

mapYieldEm ::
    forall effs effs2 c a.
    (Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs)
    => Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage) c
    -> Eff effs c
mapYieldEm :: Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage) c
-> Eff effs c
mapYieldEm = (AgentSystemCall EmulatorMessage
 -> EmSystemCall effs2 EmulatorMessage a)
-> (Maybe EmulatorMessage -> Maybe EmulatorMessage)
-> Yield
     (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage) c
-> Eff effs c
forall a a' b b' (effs :: [* -> *]) c.
Member (Yield a' b') effs =>
(a -> a') -> (b' -> b) -> Yield a b c -> Eff effs c
mapYield @_ @(EmSystemCall effs2 EmulatorMessage a) ((MessageCall EmulatorMessage
 -> Either
      (MessageCall EmulatorMessage) (ThreadCall effs2 EmulatorMessage a))
-> AgentSystemCall EmulatorMessage
-> EmSystemCall effs2 EmulatorMessage a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MessageCall EmulatorMessage
-> Either
     (MessageCall EmulatorMessage) (ThreadCall effs2 EmulatorMessage a)
forall a b. a -> Either a b
Left) Maybe EmulatorMessage -> Maybe EmulatorMessage
forall a. a -> a
id

-- | Handle a @Yield a b@ with a @Yield a' b'@ effect.
mapYield ::
    forall a a' b b' effs c.
    (Member (Yield a' b') effs)
    => (a -> a')
    -> (b' -> b)
    -> Yield a b c
    -> Eff effs c
mapYield :: (a -> a') -> (b' -> b) -> Yield a b c -> Eff effs c
mapYield a -> a'
f b' -> b
g = \case
    Yield a
a b -> c
cont -> forall (effs :: [* -> *]) a.
Member (Yield a' b') effs =>
Yield a' b' a -> Eff effs a
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send @(Yield a' b') (Yield a' b' c -> Eff effs c) -> Yield a' b' c -> Eff effs c
forall a b. (a -> b) -> a -> b
$ a' -> (b' -> c) -> Yield a' b' c
forall a b c. a -> (b -> c) -> Yield a b c
Yield (a -> a'
f a
a) ((b' -> b) -> (b -> c) -> b' -> c
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap b' -> b
g b -> c
cont)

handleCallEndpoint :: forall w s l e ep effs effs2 a.
    ( HasEndpoint l ep s
    , JSON.ToJSON ep
    , Member (State EmulatorThreads) effs2
    , Member (Error EmulatorRuntimeError) effs2
    , Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
    )
    => Proxy l
    -> ContractHandle w s e
    -> ep
    -> Eff effs ()
handleCallEndpoint :: Proxy l -> ContractHandle w s e -> ep -> Eff effs ()
handleCallEndpoint Proxy l
p ContractHandle{ContractInstanceId
chInstanceId :: ContractInstanceId
chInstanceId :: forall w (s :: Row *) e. ContractHandle w s e -> ContractInstanceId
chInstanceId} ep
ep = do
    let epJson :: Value
epJson = PABResp -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON (PABResp -> Value) -> PABResp -> Value
forall a b. (a -> b) -> a -> b
$ EndpointDescription -> EndpointValue Value -> PABResp
ExposeEndpointResp EndpointDescription
description (EndpointValue Value -> PABResp) -> EndpointValue Value -> PABResp
forall a b. (a -> b) -> a -> b
$ Value -> EndpointValue Value
forall a. a -> EndpointValue a
EndpointValue (Value -> EndpointValue Value) -> Value -> EndpointValue Value
forall a b. (a -> b) -> a -> b
$ ep -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON ep
ep
        description :: EndpointDescription
description = String -> EndpointDescription
EndpointDescription (String -> EndpointDescription) -> String -> EndpointDescription
forall a b. (a -> b) -> a -> b
$ Proxy l -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
GHC.TypeLits.symbolVal Proxy l
p
        thr :: Eff
  (Reader ThreadId
     : Yield
         (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
     : effs2)
  ()
thr = do
            ThreadId
threadId <- ContractInstanceId
-> Eff
     (Reader ThreadId
        : Yield
            (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
        : effs2)
     ThreadId
forall (effs :: [* -> *]).
(Member (State EmulatorThreads) effs,
 Member (Error EmulatorRuntimeError) effs) =>
ContractInstanceId -> Eff effs ThreadId
getThread ContractInstanceId
chInstanceId
            ThreadId
ownId <- forall (effs :: [* -> *]).
Member (Reader ThreadId) effs =>
Eff effs ThreadId
forall r (effs :: [* -> *]). Member (Reader r) effs => Eff effs r
ask @ThreadId
            Eff
  (Reader ThreadId
     : Yield
         (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
     : effs2)
  (Maybe EmulatorMessage)
-> Eff
     (Reader ThreadId
        : Yield
            (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
        : effs2)
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff
   (Reader ThreadId
      : Yield
          (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
      : effs2)
   (Maybe EmulatorMessage)
 -> Eff
      (Reader ThreadId
         : Yield
             (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
         : effs2)
      ())
-> Eff
     (Reader ThreadId
        : Yield
            (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
        : effs2)
     (Maybe EmulatorMessage)
-> Eff
     (Reader ThreadId
        : Yield
            (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
        : effs2)
     ()
forall a b. (a -> b) -> a -> b
$ Priority
-> SysCall effs2 EmulatorMessage a
-> Eff
     (Reader ThreadId
        : Yield
            (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
        : effs2)
     (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Priority
-> SysCall effs systemEvent a -> Eff effs2 (Maybe systemEvent)
mkSysCall @effs2 @EmulatorMessage @_ @a Priority
Normal (MessageCall EmulatorMessage -> SysCall effs2 EmulatorMessage a
forall a b. a -> Either a b
Left (MessageCall EmulatorMessage -> SysCall effs2 EmulatorMessage a)
-> MessageCall EmulatorMessage -> SysCall effs2 EmulatorMessage a
forall a b. (a -> b) -> a -> b
$ ThreadId -> EmulatorMessage -> MessageCall EmulatorMessage
forall systemEvent.
ThreadId -> systemEvent -> MessageCall systemEvent
Message ThreadId
threadId (EmulatorMessage -> MessageCall EmulatorMessage)
-> EmulatorMessage -> MessageCall EmulatorMessage
forall a b. (a -> b) -> a -> b
$ ThreadId -> EndpointDescription -> Value -> EmulatorMessage
EndpointCall ThreadId
ownId EndpointDescription
description Value
epJson)
    Eff effs (Maybe EmulatorMessage) -> Eff effs ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff effs (Maybe EmulatorMessage) -> Eff effs ())
-> Eff effs (Maybe EmulatorMessage) -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ Tag
-> Priority
-> Eff
     (Reader ThreadId
        : Yield
            (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
        : effs2)
     ()
-> Eff effs (Maybe EmulatorMessage)
forall (effs :: [* -> *]) systemEvent (effs2 :: [* -> *]) a.
Member
  (Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent))
  effs2 =>
Tag
-> Priority
-> Eff
     (Reader ThreadId
        : Yield (EmSystemCall effs systemEvent a) (Maybe systemEvent)
        : effs)
     ()
-> Eff effs2 (Maybe systemEvent)
fork @effs2 @EmulatorMessage @_ @a Tag
callEndpointTag Priority
Normal Eff
  (Reader ThreadId
     : Yield
         (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
     : effs2)
  ()
thr

-- | Get the active endpoints of a contract instance.
activeEndpoints :: forall w s e effs.
    ( Member RunContract effs
    , ContractConstraints s
    , JSON.FromJSON e
    , JSON.FromJSON w
    , JSON.ToJSON w
    )
    => ContractHandle w s e
    -> Eff effs [ActiveEndpoint]
activeEndpoints :: ContractHandle w s e -> Eff effs [ActiveEndpoint]
activeEndpoints ContractHandle w s e
hdl = do
    ContractInstanceState{instContractState :: forall w (s :: Row *) e a.
ContractInstanceState w s e a
-> ResumableResult w e PABResp PABReq a
instContractState=ResumableResult{_requests :: forall w e i o a. ResumableResult w e i o a -> Requests o
_requests=Requests [Request PABReq]
rq}} <- ContractHandle w s e -> Eff effs (ContractInstanceState w s e ())
forall w (s :: Row *) e (effs :: [* -> *]).
(ContractConstraints s, FromJSON e, FromJSON w, ToJSON w,
 Member RunContract effs) =>
ContractHandle w s e -> Eff effs (ContractInstanceState w s e ())
getContractState ContractHandle w s e
hdl
    [ActiveEndpoint] -> Eff effs [ActiveEndpoint]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ActiveEndpoint] -> Eff effs [ActiveEndpoint])
-> [ActiveEndpoint] -> Eff effs [ActiveEndpoint]
forall a b. (a -> b) -> a -> b
$ (Request PABReq -> Maybe ActiveEndpoint)
-> [Request PABReq] -> [ActiveEndpoint]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Getting (First ActiveEndpoint) PABReq ActiveEndpoint
-> PABReq -> Maybe ActiveEndpoint
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First ActiveEndpoint) PABReq ActiveEndpoint
Prism' PABReq ActiveEndpoint
_ExposeEndpointReq (PABReq -> Maybe ActiveEndpoint)
-> (Request PABReq -> PABReq)
-> Request PABReq
-> Maybe ActiveEndpoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request PABReq -> PABReq
forall o. Request o -> o
rqRequest) [Request PABReq]
rq

-- | Get the observable state @w@ of a contract instance.
observableState :: forall w s e effs.
    ( Member RunContract effs
    , ContractConstraints s
    , JSON.FromJSON e
    , JSON.FromJSON w
    , JSON.ToJSON w
    )
    => ContractHandle w s e -> Eff effs w
observableState :: ContractHandle w s e -> Eff effs w
observableState ContractHandle w s e
hdl = do
    ContractInstanceState{instContractState :: forall w (s :: Row *) e a.
ContractInstanceState w s e a
-> ResumableResult w e PABResp PABReq a
instContractState=ResumableResult{w
_observableState :: forall w e i o a. ResumableResult w e i o a -> w
_observableState :: w
_observableState}} <- ContractHandle w s e -> Eff effs (ContractInstanceState w s e ())
forall w (s :: Row *) e (effs :: [* -> *]).
(ContractConstraints s, FromJSON e, FromJSON w, ToJSON w,
 Member RunContract effs) =>
ContractHandle w s e -> Eff effs (ContractInstanceState w s e ())
getContractState ContractHandle w s e
hdl
    w -> Eff effs w
forall (f :: * -> *) a. Applicative f => a -> f a
pure w
_observableState

callEndpointTag :: Tag
callEndpointTag :: Tag
callEndpointTag = Tag
"call endpoint"