Skip to content
This repository was archived by the owner on Dec 2, 2024. It is now read-only.

Commit b411aa5

Browse files
sjoerdvisschersjoerdvisscher
committed
Add evalEmulatorTrace
1 parent 7e699e3 commit b411aa5

File tree

14 files changed

+171
-162
lines changed

14 files changed

+171
-162
lines changed

‎playground-common/src/PSGenerator/Common.hs‎

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -56,7 +56,7 @@ import Plutus.Contract.Resumable (IterationID, Request, RequestID, Response)
5656
import Plutus.Script.Utils.V1.Typed.Scripts (ConnectionError, WrongOutTypeError)
5757
import Plutus.Trace.Emulator.Types (ContractInstanceLog, ContractInstanceMsg, ContractInstanceTag, EmulatorRuntimeError,
5858
UserThreadMsg)
59-
import Plutus.Trace.Scheduler (Priority, SchedulerLog, StopReason, ThreadEvent, ThreadId)
59+
import Plutus.Trace.Scheduler (Priority, SchedulerLog, ThreadEvent, ThreadId)
6060
import Plutus.Trace.Tag (Tag)
6161
import Plutus.V1.Ledger.Api (DatumHash, MintingPolicy, StakeValidator, TxOut, Validator)
6262
import Plutus.V2.Ledger.Tx qualified as PV2
@@ -478,13 +478,12 @@ ledgerTypes =
478478
, equal . genericShow . argonaut $ mkSumType @ContractInstanceMsg
479479
, equal . genericShow . argonaut $ mkSumType @ContractInstanceTag
480480
, equal . genericShow . argonaut $ mkSumType @EmulatorRuntimeError
481-
, equal . genericShow . argonaut $ mkSumType @ThreadEvent
481+
, order . equal . genericShow . argonaut $ mkSumType @ThreadEvent
482482
, equal . genericShow . argonaut $ mkSumType @ThreadId
483483
, equal . genericShow . argonaut $ mkSumType @(Request A)
484484
, equal . genericShow . argonaut $ mkSumType @(Response A)
485485
, order . genericShow . argonaut $ mkSumType @RequestID
486486
, order . equal . genericShow . argonaut $ mkSumType @Priority
487-
, order . equal . genericShow . argonaut $ mkSumType @StopReason
488487
, order . genericShow . argonaut $ mkSumType @IterationID
489488
, equal . genericShow . argonaut $ mkSumType @ExCPU
490489
, equal . genericShow . argonaut $ mkSumType @ExMemory

‎plutus-contract/src/Plutus/Contract/Test/ContractModel/DoubleSatisfaction.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -129,7 +129,7 @@ checkDoubleSatisfactionWithOptions opts covopts acts =
129129
hdl <- activateContract w1 (getEnvContract @()) envContractInstanceTag
130130
void $ callEndpoint @"register-token-env" hdl env
131131

132-
stream :: forall effs. S.Stream (S.Of (LogMessage EmulatorEvent)) (Eff effs) (Maybe EmulatorErr)
132+
stream :: forall effs. S.Stream (S.Of (LogMessage EmulatorEvent)) (Eff effs) (Either EmulatorErr ())
133133
stream = fst <$> runEmulatorStream (opts ^. emulatorConfig) action
134134

135135
(errorResult, events) = S.streamFold (,[]) run (\ (msg S.:> es) -> (fst es, (msg ^. logMessageContent) : snd es)) stream
@@ -138,7 +138,7 @@ checkDoubleSatisfactionWithOptions opts covopts acts =
138138
chainEvents = [ ce | ChainEvent ce <- view eteEvent <$> events ]
139139

140140
case errorResult of
141-
Just err -> do
141+
Left err -> do
142142
QC.monitor $ counterexample (show err)
143143
QC.assert False
144144
_ -> return ()

‎plutus-contract/src/Plutus/Contract/Test/ContractModel/Internal.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1444,11 +1444,11 @@ finalChecks opts copts predicate prop = do
14441444
env <- innerAction
14451445
hdl <- activateContract w1 (getEnvContract @()) envContractInstanceTag
14461446
void $ callEndpoint @"register-token-env" hdl env
1447-
stream :: forall effs. S.Stream (S.Of (LogMessage EmulatorEvent)) (Eff effs) (Maybe EmulatorErr)
1447+
stream :: forall effs. S.Stream (S.Of (LogMessage EmulatorEvent)) (Eff effs) (Either EmulatorErr ())
14481448
stream = fst <$> runEmulatorStream (opts ^. emulatorConfig) action
14491449
(errorResult, events) = S.streamFold (,[]) run (\ (msg S.:> es) -> (fst es, (msg ^. logMessageContent) : snd es)) stream
14501450
case errorResult of
1451-
Just err -> do
1451+
Left err -> do
14521452
QC.monitor $ counterexample (show err)
14531453
QC.assert False
14541454
_ -> return ()

‎plutus-contract/src/Plutus/Trace/Effects/Assert.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -35,8 +35,8 @@ makeEffect ''Assert
3535

3636
-- | Pass 'EmulatorState' to the provided predicate and throw error unless it's true.
3737
handleAssert ::
38-
forall effs effs2.
39-
( Member (Yield (EmSystemCall effs2 EmulatorMessage) (Maybe EmulatorMessage)) effs
38+
forall effs effs2 a.
39+
( Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
4040
, Member (Error EmulatorRuntimeError) effs
4141
, Member (State EmulatorState) effs
4242
)

‎plutus-contract/src/Plutus/Trace/Effects/EmulatorControl.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -74,12 +74,12 @@ data EmulatorControl r where
7474
-- | Interpret the 'EmulatorControl' effect in the 'MultiAgentEffect' and
7575
-- scheduler system calls.
7676
handleEmulatorControl ::
77-
forall effs effs2.
77+
forall effs effs2 a.
7878
( Member (State EmulatorThreads) effs
7979
, Member (State EmulatorState) effs
8080
, Member (Error EmulatorRuntimeError) effs
8181
, Member MultiAgentControlEffect effs
82-
, Member (Yield (EmSystemCall effs2 EmulatorMessage) (Maybe EmulatorMessage)) effs
82+
, Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
8383
)
8484
=> SlotConfig
8585
-> EmulatorControl
@@ -90,11 +90,11 @@ handleEmulatorControl slotCfg = \case
9090
FreezeContractInstance i -> do
9191
threadId <- getThread i
9292
-- see note [Freeze and Thaw]
93-
void $ mkSysCall @effs2 @EmulatorMessage Normal (Left $ Message threadId Freeze)
93+
void $ mkSysCall @effs2 @EmulatorMessage @_ @a Normal (Left $ Message threadId Freeze)
9494
ThawContractInstance i -> do
9595
threadId <- getThread i
9696
-- see note [Freeze and Thaw]
97-
void $ mkSysCall @effs2 @EmulatorMessage Normal (Right $ Thaw threadId)
97+
void $ mkSysCall @effs2 @EmulatorMessage @_ @a Normal (Right $ Thaw threadId)
9898
ChainState -> gets (view EM.chainState)
9999
GetSlotConfig -> return slotCfg
100100
DiscardWallets discard -> modify @EmulatorState $ over EM.walletStates (Map.filterWithKey (\ k _ -> not $ discard k))

‎plutus-contract/src/Plutus/Trace/Effects/RunContract.hs‎

Lines changed: 26 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -120,43 +120,43 @@ activateContractWallet w contract = activateContract w contract (walletInstanceT
120120

121121
-- | Handle the 'RunContract' effect by running each contract instance in an
122122
-- emulator thread.
123-
handleRunContract :: forall effs effs2.
123+
handleRunContract :: forall effs effs2 a.
124124
( Member (State EmulatorThreads) effs2
125125
, Member (Error EmulatorRuntimeError) effs2
126126
, Member (Error EmulatorRuntimeError) effs
127127
, Member (LogMsg EmulatorEvent') effs
128128
, Member (State EmulatorThreads) effs
129129
, Member (Reader ThreadId) effs
130-
, Member (Yield (EmSystemCall effs2 EmulatorMessage) (Maybe EmulatorMessage)) effs
130+
, Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
131131
)
132132
=> RunContract
133133
~> Eff effs
134134
handleRunContract = \case
135-
CallEndpointP p h v -> handleCallEndpoint @_ @_ @_ @_ @_ @effs @effs2 p h v
135+
CallEndpointP p h v -> handleCallEndpoint @_ @_ @_ @_ @_ @effs @effs2 @a p h v
136136
GetContractState hdl ->
137137
interpret (mapLog UserThreadEvent)
138-
$ handleGetContractState @_ @_ @_ @(LogMsg UserThreadMsg ': effs) @effs2 hdl
138+
$ handleGetContractState @_ @_ @_ @(LogMsg UserThreadMsg ': effs) @effs2 @a hdl
139139

140140
-- | Handle the 'StartContract' effect by starting each contract instance in an
141141
-- emulator thread.
142-
handleStartContract :: forall effs effs2.
142+
handleStartContract :: forall effs effs2 a.
143143
( Member (State EmulatorThreads) effs2
144144
, Member (Error EmulatorRuntimeError) effs2
145145
, Member MultiAgentEffect effs2
146146
, Member (LogMsg EmulatorEvent') effs2
147147
, Member ContractInstanceIdEff effs
148-
, Member (Yield (EmSystemCall effs2 EmulatorMessage) (Maybe EmulatorMessage)) effs
148+
, Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
149149
)
150150
=> NetworkId
151151
-> StartContract
152152
~> Eff effs
153153
handleStartContract networkId = \case
154-
ActivateContract w c t -> handleActivate @_ @_ @_ @effs @effs2 networkId w t (void (toContract c))
154+
ActivateContract w c t -> handleActivate @_ @_ @_ @effs @effs2 @a networkId w t (void (toContract c))
155155

156156
handleGetContractState ::
157-
forall w s e effs effs2.
157+
forall w s e effs effs2 a.
158158
( Member (State EmulatorThreads) effs
159-
, Member (Yield (EmSystemCall effs2 EmulatorMessage) (Maybe EmulatorMessage)) effs
159+
, Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
160160
, Member (Reader ThreadId) effs
161161
, Member (Error EmulatorRuntimeError) effs
162162
, JSON.FromJSON e
@@ -168,7 +168,7 @@ handleGetContractState ::
168168
handleGetContractState ContractHandle{chInstanceId} = do
169169
ownId <- ask @ThreadId
170170
threadId <- getThread chInstanceId
171-
void $ mkSysCall @effs2 @EmulatorMessage Normal (Left $ Message threadId $ ContractInstanceStateRequest ownId)
171+
void $ mkSysCall @effs2 @EmulatorMessage @_ @a Normal (Left $ Message threadId $ ContractInstanceStateRequest ownId)
172172

173173
let checkResponse = \case
174174
Just (ContractInstanceStateResponse r) -> do
@@ -178,17 +178,17 @@ handleGetContractState ContractHandle{chInstanceId} = do
178178
logError $ UserThreadErr msg
179179
throwError msg
180180
JSON.Success event' -> pure event'
181-
_ -> sleep @effs2 Sleeping >>= checkResponse
182-
sleep @effs2 Normal >>= checkResponse
181+
_ -> sleep @effs2 @_ @_ @a Sleeping >>= checkResponse
182+
sleep @effs2 @_ @_ @a Normal >>= checkResponse
183183

184-
handleActivate :: forall w s e effs effs2.
184+
handleActivate :: forall w s e effs effs2 a.
185185
( ContractConstraints s
186186
, Member ContractInstanceIdEff effs
187187
, Member (State EmulatorThreads) effs2
188188
, Member MultiAgentEffect effs2
189189
, Member (Error EmulatorRuntimeError) effs2
190190
, Member (LogMsg EmulatorEvent') effs2
191-
, Member (Yield (EmSystemCall effs2 EmulatorMessage) (Maybe EmulatorMessage)) effs
191+
, Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
192192
, Show e
193193
, JSON.ToJSON e
194194
, JSON.ToJSON w
@@ -202,7 +202,7 @@ handleActivate :: forall w s e effs effs2.
202202
handleActivate networkId wllt tag con = do
203203
i <- nextId
204204
let handle = ContractHandle{chContract=con, chInstanceId = i, chInstanceTag = tag, chNetworkId = networkId}
205-
void $ startContractThread @w @s @e @effs @effs2 wllt handle
205+
void $ startContractThread @w @s @e @effs @effs2 @a wllt handle
206206
pure handle
207207

208208
runningContractInstanceTag :: Tag
@@ -211,8 +211,8 @@ runningContractInstanceTag = "contract instance"
211211
-- | Start a new thread for a contract instance (given by the handle).
212212
-- The thread runs in the context of the wallet.
213213
startContractThread ::
214-
forall w s e effs effs2.
215-
( Member (Yield (EmSystemCall effs2 EmulatorMessage) (Maybe EmulatorMessage)) effs
214+
forall w s e effs effs2 a.
215+
( Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
216216
, Member (State EmulatorThreads) effs2
217217
, Member MultiAgentEffect effs2
218218
, Member (Error EmulatorRuntimeError) effs2
@@ -227,18 +227,18 @@ startContractThread ::
227227
-> ContractHandle w s e
228228
-> Eff effs (Maybe EmulatorMessage)
229229
startContractThread wallet handle =
230-
fork @effs2 @EmulatorMessage runningContractInstanceTag Normal
231-
(interpret (mapYieldEm @_ @effs2)
230+
fork @effs2 @EmulatorMessage @_ @a runningContractInstanceTag Normal
231+
(interpret (mapYieldEm @_ @effs2 @_ @a)
232232
$ handleMultiAgentEffects wallet
233233
$ interpret (mapLog InstanceEvent)
234234
$ contractThread handle)
235235

236236
mapYieldEm ::
237-
forall effs effs2 c.
238-
(Member (Yield (EmSystemCall effs2 EmulatorMessage) (Maybe EmulatorMessage)) effs)
237+
forall effs effs2 c a.
238+
(Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs)
239239
=> Yield (AgentSystemCall EmulatorMessage) (Maybe EmulatorMessage) c
240240
-> Eff effs c
241-
mapYieldEm = mapYield @_ @(EmSystemCall effs2 EmulatorMessage) (fmap Left) id
241+
mapYieldEm = mapYield @_ @(EmSystemCall effs2 EmulatorMessage a) (fmap Left) id
242242

243243
-- | Handle a @Yield a b@ with a @Yield a' b'@ effect.
244244
mapYield ::
@@ -251,12 +251,12 @@ mapYield ::
251251
mapYield f g = \case
252252
Yield a cont -> send @(Yield a' b') $ Yield (f a) (lmap g cont)
253253

254-
handleCallEndpoint :: forall w s l e ep effs effs2.
254+
handleCallEndpoint :: forall w s l e ep effs effs2 a.
255255
( HasEndpoint l ep s
256256
, JSON.ToJSON ep
257257
, Member (State EmulatorThreads) effs2
258258
, Member (Error EmulatorRuntimeError) effs2
259-
, Member (Yield (EmSystemCall effs2 EmulatorMessage) (Maybe EmulatorMessage)) effs
259+
, Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
260260
)
261261
=> Proxy l
262262
-> ContractHandle w s e
@@ -268,8 +268,8 @@ handleCallEndpoint p ContractHandle{chInstanceId} ep = do
268268
thr = do
269269
threadId <- getThread chInstanceId
270270
ownId <- ask @ThreadId
271-
void $ mkSysCall @effs2 @EmulatorMessage Normal (Left $ Message threadId $ EndpointCall ownId description epJson)
272-
void $ fork @effs2 @EmulatorMessage callEndpointTag Normal thr
271+
void $ mkSysCall @effs2 @EmulatorMessage @_ @a Normal (Left $ Message threadId $ EndpointCall ownId description epJson)
272+
void $ fork @effs2 @EmulatorMessage @_ @a callEndpointTag Normal thr
273273

274274
-- | Get the active endpoints of a contract instance.
275275
activeEndpoints :: forall w s e effs.

‎plutus-contract/src/Plutus/Trace/Effects/RunContractPlayground.hs‎

Lines changed: 11 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -68,14 +68,14 @@ makeEffect ''RunContractPlayground
6868

6969
-- | Handle the 'RunContractPlayground' effect.
7070
handleRunContractPlayground ::
71-
forall w s e effs effs2.
71+
forall w s e effs effs2 a.
7272
( ContractConstraints s
7373
, Show e
7474
, JSON.ToJSON e
7575
, JSON.ToJSON w
7676
, Monoid w
7777
, Member ContractInstanceIdEff effs
78-
, Member (Yield (EmSystemCall effs2 EmulatorMessage) (Maybe EmulatorMessage)) effs
78+
, Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
7979
, Member (LogMsg EmulatorEvent') effs2
8080
, Member (Error EmulatorRuntimeError) effs2
8181
, Member (State EmulatorThreads) effs2
@@ -88,17 +88,17 @@ handleRunContractPlayground ::
8888
-> RunContractPlayground
8989
~> Eff effs
9090
handleRunContractPlayground networkId contract = \case
91-
CallEndpoint wallet ep vl -> handleCallEndpoint @effs @effs2 wallet ep vl
92-
LaunchContract wllt -> handleLaunchContract @w @s @e @effs @effs2 networkId contract wllt
91+
CallEndpoint wallet ep vl -> handleCallEndpoint @effs @effs2 @a wallet ep vl
92+
LaunchContract wllt -> handleLaunchContract @w @s @e @effs @effs2 @a networkId contract wllt
9393

9494
handleLaunchContract ::
95-
forall w s e effs effs2.
95+
forall w s e effs effs2 a.
9696
( ContractConstraints s
9797
, Show e
9898
, JSON.ToJSON e
9999
, JSON.ToJSON w
100100
, Monoid w
101-
, Member (Yield (EmSystemCall effs2 EmulatorMessage) (Maybe EmulatorMessage)) effs
101+
, Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
102102
, Member ContractInstanceIdEff effs
103103
, Member (LogMsg EmulatorEvent') effs2
104104
, Member (Error EmulatorRuntimeError) effs2
@@ -113,14 +113,14 @@ handleLaunchContract ::
113113
handleLaunchContract networkId contract wllt = do
114114
i <- nextId
115115
let handle = ContractHandle{chContract=contract, chInstanceId = i, chInstanceTag = walletInstanceTag wllt, chNetworkId = networkId}
116-
void $ startContractThread @w @s @e @effs @effs2 wllt handle
116+
void $ startContractThread @w @s @e @effs @effs2 @a wllt handle
117117
modify @(Map Wallet ContractInstanceId) (set (at wllt) (Just i))
118118

119119
handleCallEndpoint ::
120-
forall effs effs2.
120+
forall effs effs2 a.
121121
( Member (State (Map Wallet ContractInstanceId)) effs2
122122
, Member (Error EmulatorRuntimeError) effs2
123-
, Member (Yield (EmSystemCall effs2 EmulatorMessage) (Maybe EmulatorMessage)) effs
123+
, Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
124124
, Member (State EmulatorThreads) effs2
125125
)
126126
=> Wallet
@@ -133,8 +133,8 @@ handleCallEndpoint wllt endpointName endpointValue = do
133133
thr = do
134134
threadId <- getInstance wllt >>= getThread
135135
ownId <- ask @ThreadId
136-
void $ mkSysCall @effs2 @EmulatorMessage Normal (Left $ Message threadId $ EndpointCall ownId (EndpointDescription endpointName) epJson)
137-
void $ fork @effs2 @EmulatorMessage "call endpoint" Normal thr
136+
void $ mkSysCall @effs2 @EmulatorMessage @_ @a Normal (Left $ Message threadId $ EndpointCall ownId (EndpointDescription endpointName) epJson)
137+
void $ fork @effs2 @EmulatorMessage @_ @a "call endpoint" Normal thr
138138

139139
getInstance ::
140140
( Member (State (Map Wallet ContractInstanceId)) effs

‎plutus-contract/src/Plutus/Trace/Effects/Waiting.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -72,13 +72,13 @@ waitNMilliSeconds n = do
7272
waitNSlots (fromIntegral $ TimeSlot.posixTimeToEnclosingSlot slotConfig $ fromMilliSeconds n)
7373

7474
handleWaiting ::
75-
forall effs effs2.
76-
( Member (Yield (EmSystemCall effs2 EmulatorMessage) (Maybe EmulatorMessage)) effs
75+
forall effs effs2 a.
76+
( Member (Yield (EmSystemCall effs2 EmulatorMessage a) (Maybe EmulatorMessage)) effs
7777
)
7878
=> TimeSlot.SlotConfig
7979
-> Waiting
8080
~> Eff effs
8181
handleWaiting slotConfig = \case
8282
GetSlotConfig -> pure slotConfig
8383
WaitUntilSlot s -> go where
84-
go = sleep @effs2 Sleeping >>= \case { Just (NewSlot _ sl) | sl >= s -> pure sl; _ -> go }
84+
go = sleep @effs2 @_ @_ @a Sleeping >>= \case { Just (NewSlot _ sl) | sl >= s -> pure sl; _ -> go }

0 commit comments

Comments
 (0)