WIP looks like it's working

plutus-contract/src/Language/Plutus/Contract/Test.hs

@@ -47,6 +47,7 @@ import           Control.Monad                                   (guard, unless)
 import           Control.Monad.Freer.Log                         (LogMessage (..))
 import           Control.Monad.Writer                            (MonadWriter (..), Writer, runWriter)
 import qualified Data.Aeson                                      as JSON
+import Control.Monad.Freer (Eff)
 import           Data.Bifunctor                                  (Bifunctor (..))
 import           Data.Foldable                                   (fold, toList)
 import           Data.Functor.Contravariant                      (Contravariant (..), Op (..))
@@ -103,6 +104,7 @@ import qualified Wallet.Emulator.NodeClient                      as EM
 
 import           Language.Plutus.Contract.Schema                 (Event (..), Handlers (..), Input, Output)
 import           Language.Plutus.Contract.Trace                  as X
+import Plutus.Trace (Trace, Emulator)
 
 newtype PredF f a = PredF { unPredF :: a -> f Bool }
     deriving Contravariant via (Op (f Bool))
@@ -153,20 +155,19 @@ checkPredicate
       , Forall (Output s) Unconstrained1
       )
     => String
-    -> Contract s e a
-    -> TracePredicate s (TraceError e) a
-    -> ContractTrace s e a ()
+    -> TracePredicate s (TraceError e) ()
+    -> Eff '[Trace Emulator] ()
     -> TestTree
-checkPredicate nm con predicate action =
-    HUnit.testCaseSteps nm $ \step ->
-        case runTrace con action of
-            (Left err, _) ->
-                HUnit.assertFailure $ "ContractTrace failed. " ++ show err
-            (Right ((), st), ms) -> do
-                let dt = ContractTraceResult ms st
-                    (result, testOutputs) = runWriter $ unPredF predicate (defaultDist, dt)
-                unless result (step . Text.unpack $ renderTraceContext testOutputs st)
-                HUnit.assertBool nm result
+checkPredicate nm predicate action = undefined
+    -- HUnit.testCaseSteps nm $ \step ->
+        -- case runTrace con action of
+        --     (Left err, _) ->
+        --         HUnit.assertFailure $ "ContractTrace failed. " ++ show err
+        --     (Right ((), st), ms) -> do
+        --         let dt = ContractTraceResult ms st
+        --             (result, testOutputs) = runWriter $ unPredF predicate (defaultDist, dt)
+        --         unless result (step . Text.unpack $ renderTraceContext testOutputs st)
+        --         HUnit.assertBool nm result
 
 renderTraceContext
     :: forall s e a ann.

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

@@ -11,32 +11,37 @@
 
 module Plutus.Trace.Emulator(
     Emulator
-    , interpretSimulatorEm
     , ContractHandle(..)
     -- * Constructing Traces
     , Types.activateContract
     , Types.callEndpoint
     , Types.payToWallet
     , Types.waitUntilSlot
+    -- * Running traces
+    , EmulatorConfig(..)
+    , defaultEmulatorConfig
+    , runEmulatorTrace
     -- * Interpreter
+    , interpretEmulatorTrace
     , emInterpreter
     ) where
 
 import           Control.Monad                                   (void)
 import           Control.Monad.Freer
 import           Control.Monad.Freer.Coroutine                   (Yield)
-import           Control.Monad.Freer.Error                       (Error)
-import           Control.Monad.Freer.Extras                      (raiseEnd)
+import           Control.Monad.Freer.Error                       (Error, runError)
+import           Control.Monad.Freer.Extras                      (raiseEnd, wrapError, raiseEnd4)
 import           Control.Monad.Freer.Reader                      (runReader)
-import           Control.Monad.Freer.State                       (State, evalState)
+import           Control.Monad.Freer.State                       (State, evalState, runState)
 import qualified Data.Aeson                                      as JSON
 import           Data.Proxy                                      (Proxy)
 import           Language.Plutus.Contract                        (Contract, HasEndpoint)
 import qualified Language.Plutus.Contract.Effects.ExposeEndpoint as Endpoint
 import           Ledger.Value                                    (Value)
+import qualified Data.Map as Map
 import           Plutus.Trace.Scheduler                          (Priority (..), SysCall (..), SystemCall, fork,
-                                                                  mkSysCall, runThreads, sleep)
-import           Wallet.API                                      (defaultSlotRange, payToPublicKey_)
+                                                                  mkSysCall, runThreads, sleep, ThreadType(..))
+import           Wallet.API                                      (defaultSlotRange, payToPublicKey_, WalletAPIError)
 import qualified Wallet.Emulator                                 as EM
 import           Wallet.Emulator.Chain                           (ChainControlEffect, ChainEffect)
 import           Wallet.Emulator.MultiAgent                      (MultiAgentEffect, walletAction)
@@ -50,79 +55,78 @@ import           Plutus.Trace.Emulator.Types                     (ContractConstr
                                                                   EmulatorLocal (..), EmulatorThreads)
 import qualified Plutus.Trace.Emulator.Types                     as Types
 import           Plutus.Trace.Types
+import Language.Plutus.Contract.Trace (InitialDistribution, defaultDist)
+import qualified Debug.Trace as Trace
 
 
--- runTraceWithInitialStates ::
---     forall s e a b.
---     ( V.AllUniqueLabels (Input s)
---     , V.Forall (Input s) JSON.FromJSON
---     , V.Forall (Output s) V.Unconstrained1
---     )
---     => EmulatorState
---     -> ContractTraceState s (TraceError e) a
---     -> Eff (ContractTraceEffs s e a) b
---     -> (Either (TraceError e) (b, ContractTraceState s (TraceError e) a), EmulatorState)
--- runTraceWithInitialStates initialEmulatorState initialContractState action =
---     EM.runEmulator initialEmulatorState
---         $ runState initialContractState
---         $ interpret (Eff.writeIntoState EM.emulatorLog)
---         $ reinterpret @_ @(Writer [LogMessage EM.EmulatorEvent]) (handleLogWriter _singleton)
---         $ reinterpret @_ @(LogMsg EM.EmulatorEvent) (mapMLog makeTimed)
---         $ reinterpret @_ @(LogMsg EmulatorNotifyLogMsg) (handleEmulatorContractNotify @s @e @a)
---         $ action
-
--- makeTimed :: Member (State EmulatorState) effs => EmulatorNotifyLogMsg -> Eff effs EM.EmulatorEvent
--- makeTimed e = do
---     emulatorTime <- gets (view (EM.chainState . EM.currentSlot))
---     pure $ review (EM.emulatorTimeEvent emulatorTime) (EM.NotificationEvent e)
-
--- -- | Run a trace in the emulator and return the final state alongside the
--- --   result
--- runTraceWithDistribution ::
---     forall s e a b.
---     ( V.AllUniqueLabels (Input s)
---     , V.Forall (Input s) JSON.FromJSON
---     , V.Forall (Output s) V.Unconstrained1
---     )
---     => InitialDistribution
---     -> Contract s e a
---     -> Eff (ContractTraceEffs s e a) b
---     -> (Either (TraceError e) (b, ContractTraceState s (TraceError e) a), EmulatorState)
--- runTraceWithDistribution dist con action =
---     let -- make sure the wallets know about the initial transaction
---         notifyInitial = void (EM.addBlocksAndNotify (Map.keys dist) 1)
---         action' = EM.processEmulated @(TraceError e) notifyInitial >> action
---         con' = mapError TContractError con
---         s = EM.emulatorStateInitialDist (Map.mapKeys EM.walletPubKey dist)
---         c = initState (Map.keys dist) con'
---     in runTraceWithInitialStates s c action'
-
-
--- | Interpret a 'Simulator Emulator' action in the multi agent and emulated
+-- | Run a 'Trace Emulator', returning the final state and possibly an error
+runEmulatorTrace :: EmulatorConfig -> Eff '[Trace Emulator] () -> (Either EmulatorErr (), EM.EmulatorState)
+runEmulatorTrace conf = runTraceBackend conf . interpretEmulatorTrace
+
+data EmulatorErr =
+    WalletErr WalletAPIError
+    | AssertionErr EM.AssertionError
+    | InstanceErr ContractInstanceError
+    deriving (Show)
+
+runTraceBackend ::
+    EmulatorConfig
+    -> Eff '[ MultiAgentEffect
+            , ChainEffect
+            , ChainControlEffect
+            , Error ContractInstanceError
+            ] ()
+    -> (Either EmulatorErr (), EM.EmulatorState)
+runTraceBackend conf =
+    run
+    . runState (initialState conf)
+    . runError
+    . wrapError WalletErr
+    . wrapError AssertionErr
+    . wrapError InstanceErr
+    . EM.processEmulated
+    . raiseEnd4
+
+data EmulatorConfig =
+    EmulatorConfig
+        { emcInitialDistribution :: InitialDistribution
+        }
+
+defaultEmulatorConfig :: EmulatorConfig
+defaultEmulatorConfig =
+    EmulatorConfig
+        { emcInitialDistribution = defaultDist
+        }
+
+initialState :: EmulatorConfig -> EM.EmulatorState
+initialState EmulatorConfig{emcInitialDistribution} = EM.emulatorStateInitialDist (Map.mapKeys EM.walletPubKey emcInitialDistribution)
+
+-- | Interpret a 'Trace Emulator' action in the multi agent and emulated
 --   blockchain effects.
-interpretSimulatorEm :: forall effs.
+interpretEmulatorTrace :: forall effs.
     ( Member MultiAgentEffect effs
     , Member (Error ContractInstanceError) effs
     , Member ChainEffect effs
     , Member ChainControlEffect effs
     )
-    => Eff '[Simulator Emulator] ()
+    => Eff '[Trace Emulator] ()
     -> Eff effs ()
-interpretSimulatorEm action =
+interpretEmulatorTrace action =
     evalState @EmulatorThreads mempty
         $ handleDeterministicIds
         $ runThreads
         $ do
             launchSystemThreads
-            interpret (handleSimulator emInterpreter) $ raiseEnd action
+            interpret (handleTrace emInterpreter) $ raiseEnd action
+
 emInterpreter :: forall effs.
     ( Member ContractInstanceIdEff effs
     , Member (State EmulatorThreads) effs
     , Member MultiAgentEffect effs
     , Member (Error ContractInstanceError) effs
     )
-    => SimulatorInterpreter Emulator effs EmulatorEvent
-emInterpreter = SimulatorInterpreter
+    => TraceInterpreter Emulator effs EmulatorEvent
+emInterpreter = TraceInterpreter
     { _runLocal = emRunLocal
     , _runGlobal = emRunGlobal
     }
@@ -147,7 +151,7 @@ payToWallet :: forall effs.
     -> Wallet
     -> Value
     -> Eff (Yield (SystemCall effs EmulatorEvent) (Maybe EmulatorEvent) ': effs) ()
-payToWallet source target amount = void $ fork @effs @EmulatorEvent High payment
+payToWallet source target amount = void $ fork @effs @EmulatorEvent User High payment
     where payment = walletAction source $ payToPublicKey_ defaultSlotRange amount (EM.walletPubKey target)
 
 activate :: forall s e effs.
@@ -163,7 +167,7 @@ activate :: forall s e effs.
 activate wllt con = do
     i <- nextId
     let handle = ContractHandle{chContract=con, chInstanceId = i}
-    _ <- fork @effs @EmulatorEvent High (runReader wllt $ contractThread handle)
+    _ <- fork @effs @EmulatorEvent System High (runReader wllt $ contractThread handle)
     pure handle
 
 callEndpoint :: forall s l e ep effs.
@@ -180,11 +184,11 @@ callEndpoint _ ContractHandle{chInstanceId} ep = do
     threadId <- getThread chInstanceId
     let epJson = JSON.toJSON $ Endpoint.event @l @ep @s ep
         thr = void $ mkSysCall @effs @EmulatorEvent High (Message threadId $ EndpointCall epJson)
-    void $ fork @effs @EmulatorEvent High thr
+    void $ fork @effs @EmulatorEvent System High thr
 
 emRunGlobal :: forall b effs.
     EmulatorGlobal b
     -> Eff (Yield (SystemCall effs EmulatorEvent) (Maybe EmulatorEvent) ': effs) b
 emRunGlobal = \case
     WaitUntilSlot s -> go where
-        go = sleep @effs Sleeping >>= \case { Just (NewSlot sl) | sl >= s -> pure sl; _ -> go }
+        go = (Trace.trace "wait until slot" (sleep @effs Sleeping)) >>= \case { Just (NewSlot sl) | sl >= s -> pure sl; _ -> go }

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

@@ -115,6 +115,7 @@ getThread t = do
 data ContractInstanceError =
     ThreadIdNotFound ContractInstanceId
     | JSONDecodingError String
+    deriving Show
 
 data ContractInstanceState s e a =
     ContractInstanceState

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

@@ -10,18 +10,19 @@ module Plutus.Trace.Emulator.System(
     launchSystemThreads
     ) where
 
-import           Control.Monad                 (forM_, forever)
+import           Control.Monad                 (forM_, forever, void)
 import           Control.Monad.Freer
 import           Control.Monad.Freer.Coroutine
 import           Data.Foldable                 (traverse_)
 import           Wallet.Emulator.Chain         (ChainControlEffect, ChainEffect, getCurrentSlot, processBlock)
 import           Wallet.Emulator.MultiAgent    (MultiAgentEffect, walletControlAction)
 
 import           Plutus.Trace.Emulator.Types   (EmulatorEvent (..))
-import           Plutus.Trace.Scheduler        (Priority (..), SysCall (..), SystemCall, fork, mkSysCall, sleep)
+import           Plutus.Trace.Scheduler        (Priority (..), SysCall (..), SystemCall, fork, mkSysCall, sleep, ThreadType(..))
 import           Wallet.Emulator.ChainIndex    (chainIndexNotify)
 import           Wallet.Emulator.NodeClient    (ChainClientNotification (..), clientNotify)
 import           Wallet.Emulator.Wallet        (Wallet (..))
+import qualified Debug.Trace as Trace
 
 launchSystemThreads :: forall effs.
     ( Member ChainControlEffect effs
@@ -30,35 +31,37 @@ launchSystemThreads :: forall effs.
     )
     => Eff (Yield (SystemCall effs EmulatorEvent) (Maybe EmulatorEvent) ': effs) ()
 launchSystemThreads = do
+    _ <- Trace.trace "launch system Threads: Sleep" (sleep @effs @EmulatorEvent Sleeping)
     -- 1. Block maker
-    _ <- fork @effs @EmulatorEvent Low (blockMaker @effs)
+    _ <- Trace.trace "starting block maker" (fork @effs @EmulatorEvent System Low (Trace.trace "block maker thread" (blockMaker @effs)))
     -- 2. Threads for updating the agents' states
-    traverse_ (fork @effs @EmulatorEvent Low . agentThread @effs) (Wallet <$> [1..10])
-
--- parameters :: Map Wallet InitialDistribution
+    traverse_ (Trace.trace "starting agent thread" . fork @effs @EmulatorEvent System Low . agentThread @effs) (Wallet <$> [1])
+    Trace.trace ("launchSystemThreads: Done") (pure ())
 
 blockMaker :: forall effs effs2.
     ( Member ChainControlEffect effs2
     , Member ChainEffect effs2
     , Member (Yield (SystemCall effs EmulatorEvent) (Maybe EmulatorEvent)) effs2
     )
     => Eff effs2 ()
-blockMaker = forever go where
+blockMaker = go where
     go = do
-        newBlock <- processBlock
+        _ <- Trace.trace "blockMaker: 1" (mkSysCall @effs High (Broadcast $ BlockAdded []))
+        newBlock <- Trace.trace "process block" processBlock
         _ <- mkSysCall @effs High (Broadcast $ BlockAdded newBlock)
         newSlot <- getCurrentSlot
         mkSysCall @effs Sleeping (Broadcast $ NewSlot newSlot)
+        go
 
 agentThread :: forall effs effs2.
     ( Member MultiAgentEffect effs2
     , Member (Yield (SystemCall effs EmulatorEvent) (Maybe EmulatorEvent)) effs2
     )
     => Wallet
     -> Eff effs2 ()
-agentThread wllt = forever go where
+agentThread wllt = go where
     go = do
-        e <- sleep @effs @EmulatorEvent Sleeping
+        e <- Trace.trace "agent thread" (sleep @effs @EmulatorEvent Sleeping)
         let noti = e >>= \case
                 BlockAdded block -> Just $ BlockValidated block
                 NewSlot slot -> Just $ SlotChanged slot
@@ -68,4 +71,5 @@ agentThread wllt = forever go where
             walletControlAction wllt $ do
                 clientNotify n
                 chainIndexNotify n
+        go
 

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

@@ -42,7 +42,7 @@ import           Ledger.Slot                     (Slot)
 import           Ledger.Tx                       (Tx)
 import           Ledger.Value                    (Value)
 import           Plutus.Trace.Scheduler          (SystemCall, ThreadId)
-import           Plutus.Trace.Types              (Simulator (..), SimulatorBackend (..))
+import           Plutus.Trace.Types              (Trace (..), TraceBackend (..))
 import           Wallet.Emulator.Wallet          (Wallet (..))
 import           Wallet.Types                    (ContractInstanceId, Notification)
 import Wallet.Emulator.SigningProcess (SigningProcess)
@@ -61,7 +61,7 @@ data EmulatorEvent =
     | NewSlot Slot
     | EndpointCall JSON.Value
     | Notify Notification
-    deriving stock Eq
+    deriving stock (Eq, Show)
 
 -- | A map of contract instance ID to thread ID
 newtype EmulatorThreads =
@@ -95,21 +95,21 @@ data EmulatorLocal r where
 data EmulatorGlobal r where
     WaitUntilSlot :: Slot -> EmulatorGlobal Slot
 
-instance SimulatorBackend Emulator where
+instance TraceBackend Emulator where
     type LocalAction Emulator = EmulatorLocal
     type GlobalAction Emulator = EmulatorGlobal
     type Agent Emulator = Wallet
 
-type EmulatorTrace a = Eff '[Simulator Emulator] a
+type EmulatorTrace a = Eff '[Trace Emulator] a
 
 activateContract :: forall s e. ContractConstraints s => Wallet -> Contract s e () -> EmulatorTrace (ContractHandle s e)
-activateContract wallet = send @(Simulator Emulator) . RunLocal wallet . ActivateContract
+activateContract wallet = send @(Trace Emulator) . RunLocal wallet . ActivateContract
 
 callEndpoint :: forall l ep s e. (ContractConstraints s, HasEndpoint l ep s) => Wallet -> ContractHandle s e -> ep -> EmulatorTrace ()
-callEndpoint wallet hdl = send @(Simulator Emulator) . RunLocal wallet . CallEndpointEm (Proxy @l) hdl
+callEndpoint wallet hdl = send @(Trace Emulator) . RunLocal wallet . CallEndpointEm (Proxy @l) hdl
 
 payToWallet :: Wallet -> Wallet -> Value -> EmulatorTrace ()
-payToWallet from_ to_ = send @(Simulator Emulator) . RunLocal from_ . PayToWallet to_
+payToWallet from_ to_ = send @(Trace Emulator) . RunLocal from_ . PayToWallet to_
 
 waitUntilSlot :: Slot -> EmulatorTrace Slot
-waitUntilSlot sl = send @(Simulator Emulator) $ RunGlobal (WaitUntilSlot sl)
+waitUntilSlot sl = send @(Trace Emulator) $ RunGlobal (WaitUntilSlot sl)