Add contract instance tags to identify instances

plutus-contract/src/Plutus/Trace/Emulator.hs

@@ -86,7 +86,7 @@ import           Plutus.Trace.Emulator.ContractInstance          (ContractInstan
 import           Plutus.Trace.Emulator.System                    (launchSystemThreads)
 import           Plutus.Trace.Emulator.Types                     (ContractConstraints, ContractHandle (..), Emulator,
                                                                   EmulatorGlobal (..), EmulatorLocal (..),
-                                                                  EmulatorMessage (..), EmulatorThreads)
+                                                                  EmulatorMessage (..), EmulatorThreads, ContractInstanceTag)
 import qualified Plutus.Trace.Emulator.Types                     as Types
 import           Plutus.Trace.Types
 
@@ -143,6 +143,7 @@ runTraceBackend conf =
     . subsume @(State EmulatorState)
     . raiseEnd6
 
+-- | A stream of 'e's that may terminate with an 'a'
 newtype Stream a e = Stream { unStream :: (Either a (Stream a e, e)) }
     deriving (Functor, Foldable, Traversable)
 
@@ -163,6 +164,8 @@ runStream = f . run . runC where
             Done a -> Stream $ Left a
             Continue e cont -> Stream $ Right (f $ run $ cont (), e)
 
+-- | Turn an emulator trace into a potentially infinite 'Stream' of emulator
+--   log messages.
 runTraceStream :: 
     EmulatorConfig
     -> Eff '[ State EmulatorState
@@ -254,7 +257,7 @@ emRunLocal :: forall b effs.
     -> EmulatorLocal b
     -> Eff (Yield (SystemCall effs EmulatorMessage) (Maybe EmulatorMessage) ': effs) b
 emRunLocal wllt = \case
-    ActivateContract con -> activate wllt con
+    ActivateContract tag con -> activate wllt tag con
     CallEndpointEm p h v -> callEndpoint p h v
     PayToWallet target vl -> payToWallet wllt target vl
     SetSigningProcess sp -> setSigningProcess wllt sp
@@ -286,11 +289,12 @@ activate :: forall s e effs.
     , Member (LogMsg EmulatorEvent') effs
     )
     => Wallet
+    -> ContractInstanceTag
     -> Contract s e ()
     -> Eff (Yield (SystemCall effs EmulatorMessage) (Maybe EmulatorMessage) ': effs) (ContractHandle s e)
-activate wllt con = do
+activate wllt tag con = do
     i <- nextId
-    let handle = ContractHandle{chContract=con, chInstanceId = i}
+    let handle = ContractHandle{chContract=con, chInstanceId = i, chInstanceTag = tag}
     _ <- fork @effs @EmulatorMessage System High (runReader wllt $ interpret (mapLog InstanceEvent) $ reinterpret (mapLog InstanceEvent) $ contractThread handle)
     pure handle
 

plutus-contract/src/Plutus/Trace/Emulator/ContractInstance.hs

@@ -94,12 +94,12 @@ contractThread :: forall s e effs.
     )
     => ContractHandle s e
     -> Eff (EmulatorAgentThreadEffs effs) ()
-contractThread ContractHandle{chInstanceId, chContract} = do
+contractThread ContractHandle{chInstanceId, chContract, chInstanceTag} = do
     ask @ThreadId >>= registerInstance chInstanceId
     handleContractRuntime @effs
         $ runReader chInstanceId
         $ evalState (emptyInstanceState chContract)
-        $ interpret (mapLog (\m -> ContractInstanceLog m chInstanceId))
+        $ interpret (mapLog (\m -> ContractInstanceLog m chInstanceId chInstanceTag))
         $ do
             logInfo Started
             msg <- mkSysCall @effs @EmulatorMessage Low Suspend

plutus-contract/src/Plutus/Trace/Emulator/Types.hs

@@ -18,6 +18,7 @@ module Plutus.Trace.Emulator.Types(
     , EmulatorThreads(..)
     , instanceIdThreads
     , EmulatorAgentThreadEffs
+    , ContractInstanceTag(..)
     , ContractHandle(..)
     , Emulator
     , EmulatorLocal(..)
@@ -47,9 +48,11 @@ import           Control.Monad.Freer.Reader         (Reader)
 import           Data.Aeson                         (FromJSON, ToJSON)
 import qualified Data.Aeson                         as JSON
 import           Data.Map                           (Map)
+import Data.String (IsString)
 import           Data.Proxy                         (Proxy (..))
 import qualified Data.Row.Internal                  as V
 import           GHC.Generics                       (Generic)
+import Data.Text (Text)
 import           Language.Plutus.Contract           (Contract, HasBlockchainActions, HasEndpoint)
 import           Language.Plutus.Contract.Resumable (Request (..), Requests (..), Response (..))
 import           Language.Plutus.Contract.Schema    (Input, Output)
@@ -100,15 +103,16 @@ type EmulatorAgentThreadEffs effs =
 
 data Emulator
 
--- | A reference to an installed contract in the emulator.
+-- | A reference to a running contract in the emulator.
 data ContractHandle s e =
     ContractHandle
-        { chContract   :: Contract s e ()
-        , chInstanceId :: ContractInstanceId
+        { chContract    :: Contract s e ()
+        , chInstanceId  :: ContractInstanceId
+        , chInstanceTag :: ContractInstanceTag
         }
 
 data EmulatorLocal r where
-    ActivateContract :: ContractConstraints s => Contract s e () -> EmulatorLocal (ContractHandle s e)
+    ActivateContract :: ContractConstraints s => ContractInstanceTag -> Contract s e () -> EmulatorLocal (ContractHandle s e)
     CallEndpointEm :: forall l ep s e. (ContractConstraints s, HasEndpoint l ep s) => Proxy l -> ContractHandle s e -> ep -> EmulatorLocal ()
     PayToWallet :: Wallet -> Value -> EmulatorLocal ()
     SetSigningProcess :: SigningProcess -> EmulatorLocal ()
@@ -125,8 +129,8 @@ instance TraceBackend Emulator where
 
 type EmulatorTrace a = Eff '[Trace Emulator] a
 
-activateContract :: forall s e. ContractConstraints s => Wallet -> Contract s e () -> EmulatorTrace (ContractHandle s e)
-activateContract wallet = send @(Trace Emulator) . RunLocal wallet . ActivateContract
+activateContract :: forall s e. ContractConstraints s => Wallet -> ContractInstanceTag -> Contract s e () -> EmulatorTrace (ContractHandle s e)
+activateContract wallet tag = send @(Trace Emulator) . RunLocal wallet . ActivateContract tag
 
 callEndpoint :: forall l ep s e. (ContractConstraints s, HasEndpoint l ep s) => Wallet -> ContractHandle s e -> ep -> EmulatorTrace ()
 callEndpoint wallet hdl = send @(Trace Emulator) . RunLocal wallet . CallEndpointEm (Proxy @l) hdl
@@ -154,6 +158,13 @@ data ContractInstanceError =
     deriving stock (Eq, Ord, Show, Generic)
     deriving anyclass (ToJSON, FromJSON)
 
+-- | A user-defined tag for a contract instance. Used to find the instance's
+--   log messages in the emulator log.
+newtype ContractInstanceTag = ContractInstanceTag { unContractInstanceTag :: Text }
+    deriving stock (Eq, Ord, Show, Generic)
+    deriving anyclass (ToJSON, FromJSON)
+    deriving newtype IsString
+
 data ContractInstanceMsg =
     Started
     | Stopped
@@ -169,6 +180,7 @@ data ContractInstanceLog =
     ContractInstanceLog
         { _cilMessage :: ContractInstanceMsg
         , _cilId      :: ContractInstanceId
+        , _cilTag     :: ContractInstanceTag
         }
     deriving stock (Eq, Ord, Show, Generic)
     deriving anyclass (ToJSON, FromJSON)