{-# 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       #-}

-- | A version of 'Plutus.Trace.Effects.RunContract' for use in the
--   playground.
module Plutus.Trace.Effects.RunContractPlayground(
    RunContractPlayground
    , callEndpoint
    , launchContract
    , handleRunContractPlayground
    ) where

import Cardano.Api (NetworkId)
import Control.Lens
import Control.Monad (void)
import Control.Monad.Freer (Eff, Member, type (~>))
import Control.Monad.Freer.Coroutine (Yield (..))
import Control.Monad.Freer.Error (Error, throwError)
import Control.Monad.Freer.Extras.Log (LogMsg (..))
import Control.Monad.Freer.Reader (ask)
import Control.Monad.Freer.State (State, gets, modify)
import Control.Monad.Freer.TH (makeEffect)
import Data.Aeson qualified as JSON
import Data.Map (Map)
import Plutus.Contract (Contract (..), ContractInstanceId, EndpointDescription (..))
import Plutus.Contract.Effects (PABResp (ExposeEndpointResp))
import Plutus.Trace.Effects.ContractInstanceId (ContractInstanceIdEff, nextId)
import Plutus.Trace.Effects.RunContract (startContractThread)
import Plutus.Trace.Emulator.ContractInstance (EmulatorRuntimeError, getThread)
import Plutus.Trace.Emulator.Types (ContractConstraints, ContractHandle (..), EmulatorMessage (..),
                                    EmulatorRuntimeError (..), EmulatorThreads, walletInstanceTag)
import Plutus.Trace.Scheduler (EmSystemCall, MessageCall (Message), Priority (..), ThreadId, fork, mkSysCall)
import Wallet.Emulator.MultiAgent (EmulatorEvent' (..), MultiAgentEffect)
import Wallet.Emulator.Wallet (Wallet)
import Wallet.Types (EndpointValue (..))

{- Note [Wallet contract instances]

In the Playground we have a single 'Contract' that we are testing, and each
wallet runs exactly one instance of this contract. As a result,

1. The 'RunContractPlayground' effect, which governs interactions with contract
   instances, only needs a 'Wallet' to identify the contract instance.
2. We don't need an @ActivateContract@ action, we can just start all the
   instances at the beginning of the simulation, using 'launchContract'

-}

data RunContractPlayground r where
    LaunchContract :: Wallet -> RunContractPlayground ()
    CallEndpoint :: Wallet -> String -> JSON.Value -> RunContractPlayground ()

makeEffect ''RunContractPlayground

-- | Handle the 'RunContractPlayground' effect.
handleRunContractPlayground ::
    forall w s e effs effs2 a.
    ( ContractConstraints s
    , Show e
    , JSON.ToJSON e
    , JSON.ToJSON w
    , Monoid w
    , Member ContractInstanceIdEff effs
    , Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
    , Member (LogMsg EmulatorEvent') effs2
    , Member (Error EmulatorRuntimeError) effs2
    , Member (State EmulatorThreads) effs2
    , Member MultiAgentEffect effs2
    , Member (State (Map Wallet ContractInstanceId)) effs2
    , Member (State (Map Wallet ContractInstanceId)) effs
    )
    => NetworkId
    -> Contract w s e ()
    -> RunContractPlayground
    ~> Eff effs
handleRunContractPlayground :: NetworkId -> Contract w s e () -> RunContractPlayground ~> Eff effs
handleRunContractPlayground NetworkId
networkId Contract w s e ()
contract = \case
    CallEndpoint Wallet
wallet String
ep Value
vl -> Wallet -> String -> Value -> Eff effs ()
forall (effs :: [* -> *]) (effs2 :: [* -> *]) a.
(Member (State (Map Wallet ContractInstanceId)) effs2,
 Member (Error EmulatorRuntimeError) effs2,
 Member
   (Yield
      (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage))
   effs,
 Member (State EmulatorThreads) effs2) =>
Wallet -> String -> Value -> Eff effs ()
handleCallEndpoint @effs @effs2 @a Wallet
wallet String
ep Value
vl
    LaunchContract Wallet
wllt       -> NetworkId -> Contract w s e () -> Wallet -> Eff effs ()
forall w (s :: Row *) e (effs :: [* -> *]) (effs2 :: [* -> *]) a.
(ContractConstraints s, Show e, ToJSON e, ToJSON w, Monoid w,
 Member
   (Yield
      (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage))
   effs,
 Member ContractInstanceIdEff effs,
 Member (LogMsg EmulatorEvent') effs2,
 Member (Error EmulatorRuntimeError) effs2,
 Member (State EmulatorThreads) effs2,
 Member MultiAgentEffect effs2,
 Member (State (Map Wallet ContractInstanceId)) effs) =>
NetworkId -> Contract w s e () -> Wallet -> Eff effs ()
handleLaunchContract @w @s @e @effs @effs2 @a NetworkId
networkId Contract w s e ()
contract Wallet
wllt

handleLaunchContract ::
    forall w s e effs effs2 a.
    ( ContractConstraints s
    , Show e
    , JSON.ToJSON e
    , JSON.ToJSON w
    , Monoid w
    , Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
    , Member ContractInstanceIdEff effs
    , Member (LogMsg EmulatorEvent') effs2
    , Member (Error EmulatorRuntimeError) effs2
    , Member (State EmulatorThreads) effs2
    , Member MultiAgentEffect effs2
    , Member (State (Map Wallet ContractInstanceId)) effs
    )
    => NetworkId
    -> Contract w s e ()
    -> Wallet
    -> Eff effs ()
handleLaunchContract :: NetworkId -> Contract w s e () -> Wallet -> Eff effs ()
handleLaunchContract NetworkId
networkId Contract w s e ()
contract Wallet
wllt = 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 ()
contract, chInstanceId :: ContractInstanceId
chInstanceId = ContractInstanceId
i, chInstanceTag :: ContractInstanceTag
chInstanceTag = Wallet -> ContractInstanceTag
walletInstanceTag Wallet
wllt, 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
    (Map Wallet ContractInstanceId -> Map Wallet ContractInstanceId)
-> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
(s -> s) -> Eff effs ()
modify @(Map Wallet ContractInstanceId) (ASetter
  (Map Wallet ContractInstanceId)
  (Map Wallet ContractInstanceId)
  (Maybe ContractInstanceId)
  (Maybe ContractInstanceId)
-> Maybe ContractInstanceId
-> Map Wallet ContractInstanceId
-> Map Wallet ContractInstanceId
forall s t a b. ASetter s t a b -> b -> s -> t
set (Index (Map Wallet ContractInstanceId)
-> Lens'
     (Map Wallet ContractInstanceId)
     (Maybe (IxValue (Map Wallet ContractInstanceId)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Wallet ContractInstanceId)
Wallet
wllt) (ContractInstanceId -> Maybe ContractInstanceId
forall a. a -> Maybe a
Just ContractInstanceId
i))

handleCallEndpoint ::
    forall effs effs2 a.
    ( Member (State (Map Wallet ContractInstanceId)) effs2
    , Member (Error EmulatorRuntimeError) effs2
    , Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
    , Member (State EmulatorThreads) effs2
    )
    => Wallet
    -> String
    -> JSON.Value
    -> Eff effs ()
handleCallEndpoint :: Wallet -> String -> Value -> Eff effs ()
handleCallEndpoint Wallet
wllt String
endpointName Value
endpointValue = do
    let desc :: EndpointDescription
desc = String -> EndpointDescription
EndpointDescription String
endpointName
        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
desc (EndpointValue Value -> PABResp) -> EndpointValue Value -> PABResp
forall a b. (a -> b) -> a -> b
$ Value -> EndpointValue Value
forall a. a -> EndpointValue a
EndpointValue Value
endpointValue
        thr :: Eff
  (Reader ThreadId
     : Yield
         (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
     : effs2)
  ()
thr = do
            ThreadId
threadId <- Wallet
-> Eff
     (Reader ThreadId
        : Yield
            (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
        : effs2)
     ContractInstanceId
forall (effs :: [* -> *]).
(Member (State (Map Wallet ContractInstanceId)) effs,
 Member (Error EmulatorRuntimeError) effs) =>
Wallet -> Eff effs ContractInstanceId
getInstance Wallet
wllt Eff
  (Reader ThreadId
     : Yield
         (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
     : effs2)
  ContractInstanceId
-> (ContractInstanceId
    -> Eff
         (Reader ThreadId
            : Yield
                (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
            : effs2)
         ThreadId)
-> Eff
     (Reader ThreadId
        : Yield
            (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
        : effs2)
     ThreadId
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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
            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 (String -> EndpointDescription
EndpointDescription String
endpointName) 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
"call endpoint" Priority
Normal Eff
  (Reader ThreadId
     : Yield
         (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)
     : effs2)
  ()
thr

getInstance ::
    ( Member (State (Map Wallet ContractInstanceId)) effs
    , Member (Error EmulatorRuntimeError) effs
    )
    => Wallet
    -> Eff effs ContractInstanceId
getInstance :: Wallet -> Eff effs ContractInstanceId
getInstance Wallet
wllt = do
    Maybe ContractInstanceId
r <- (Map Wallet ContractInstanceId -> Maybe ContractInstanceId)
-> Eff effs (Maybe ContractInstanceId)
forall s a (effs :: [* -> *]).
Member (State s) effs =>
(s -> a) -> Eff effs a
gets @(Map Wallet ContractInstanceId) (Getting
  (Maybe ContractInstanceId)
  (Map Wallet ContractInstanceId)
  (Maybe ContractInstanceId)
-> Map Wallet ContractInstanceId -> Maybe ContractInstanceId
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Index (Map Wallet ContractInstanceId)
-> Lens'
     (Map Wallet ContractInstanceId)
     (Maybe (IxValue (Map Wallet ContractInstanceId)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Wallet ContractInstanceId)
Wallet
wllt))
    case Maybe ContractInstanceId
r of
        Maybe ContractInstanceId
Nothing -> EmulatorRuntimeError -> Eff effs ContractInstanceId
forall e (effs :: [* -> *]) a.
Member (Error e) effs =>
e -> Eff effs a
throwError (Wallet -> EmulatorRuntimeError
InstanceIdNotFound Wallet
wllt)
        Just ContractInstanceId
i  -> ContractInstanceId -> Eff effs ContractInstanceId
forall (f :: * -> *) a. Applicative f => a -> f a
pure ContractInstanceId
i