Skip to content

Commit cc20eb1

Browse files
awkureMaximilianAlgehed
awkure
and
MaximilianAlgehed
authored
[IntersectMBO#3843] Make arbitrary instance for actions in quickcheck-dynamic depend on their sizing (IntersectMBO#3901)
* Remove _lastSlot from quickcheck-dynamic ModelState to fix a bug with arbitrary action generation * we no longer have to care about max slots * fix compilation errors in marlowe tests Co-authored-by: Maximilian Algehed <[email protected]>
1 parent 2c5bda2 commit cc20eb1

File tree

5 files changed

+41
-49
lines changed

5 files changed

+41
-49
lines changed

‎marlowe/test/Spec/Marlowe/Marlowe.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -95,7 +95,7 @@ bob = w2
9595

9696

9797
zeroCouponBondTest :: TestTree
98-
zeroCouponBondTest = checkPredicateOptions (defaultCheckOptions & maxSlot .~ 250) "Zero Coupon Bond Contract"
98+
zeroCouponBondTest = checkPredicateOptions defaultCheckOptions "Zero Coupon Bond Contract"
9999
(assertNoFailedTransactions
100100
-- T..&&. emulatorLog (const False) ""
101101
T..&&. assertDone marlowePlutusContract (Trace.walletInstanceTag alice) (const True) "contract should close"
@@ -136,7 +136,7 @@ zeroCouponBondTest = checkPredicateOptions (defaultCheckOptions & maxSlot .~ 250
136136

137137

138138
errorHandlingTest :: TestTree
139-
errorHandlingTest = checkPredicateOptions (defaultCheckOptions & maxSlot .~ 250) "Error handling"
139+
errorHandlingTest = checkPredicateOptions defaultCheckOptions "Error handling"
140140
(assertAccumState marlowePlutusContract (Trace.walletInstanceTag alice)
141141
(\case (SomeError (TransitionError _)) -> True
142142
_ -> False
@@ -167,7 +167,7 @@ errorHandlingTest = checkPredicateOptions (defaultCheckOptions & maxSlot .~ 250)
167167

168168

169169
trustFundTest :: TestTree
170-
trustFundTest = checkPredicateOptions (defaultCheckOptions & maxSlot .~ 200) "Trust Fund Contract"
170+
trustFundTest = checkPredicateOptions defaultCheckOptions "Trust Fund Contract"
171171
(assertNoFailedTransactions
172172
-- T..&&. emulatorLog (const False) ""
173173
T..&&. assertNotDone marlowePlutusContract (Trace.walletInstanceTag alice) "contract should not have any errors"

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

Lines changed: 3 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -60,7 +60,6 @@ module Plutus.Contract.Test(
6060
, CheckOptions
6161
, defaultCheckOptions
6262
, minLogLevel
63-
, maxSlot
6463
, emulatorConfig
6564
-- * Etc
6665
, goldenPir
@@ -130,7 +129,7 @@ import Wallet.Emulator.Chain (ChainEvent)
130129
import Wallet.Emulator.Folds (EmulatorFoldErr (..), Outcome (..), describeError, postMapM)
131130
import qualified Wallet.Emulator.Folds as Folds
132131
import Wallet.Emulator.Stream (filterLogLevel, foldEmulatorStreamM, initialChainState,
133-
initialDist, takeUntilSlot)
132+
initialDist)
134133

135134
type TracePredicate = FoldM (Eff '[Reader InitialDistribution, Error EmulatorFoldErr, Writer (Doc Void)]) EmulatorEvent Bool
136135

@@ -146,7 +145,6 @@ not = fmap Prelude.not
146145
data CheckOptions =
147146
CheckOptions
148147
{ _minLogLevel :: LogLevel -- ^ Minimum log level for emulator log messages to be included in the test output (printed if the test fails)
149-
, _maxSlot :: Slot -- ^ When to stop the emulator
150148
, _emulatorConfig :: EmulatorConfig
151149
} deriving (Eq, Show)
152150

@@ -156,7 +154,6 @@ defaultCheckOptions :: CheckOptions
156154
defaultCheckOptions =
157155
CheckOptions
158156
{ _minLogLevel = Info
159-
, _maxSlot = 125
160157
, _emulatorConfig = def
161158
}
162159

@@ -189,10 +186,10 @@ checkPredicateInner :: forall m.
189186
-> (String -> m ()) -- ^ Print out debug information in case of test failures
190187
-> (Bool -> m ()) -- ^ assert
191188
-> m ()
192-
checkPredicateInner CheckOptions{_minLogLevel, _maxSlot, _emulatorConfig} predicate action annot assert = do
189+
checkPredicateInner CheckOptions{_minLogLevel, _emulatorConfig} predicate action annot assert = do
193190
let dist = _emulatorConfig ^. initialChainState . to initialDist
194191
theStream :: forall effs. S.Stream (S.Of (LogMessage EmulatorEvent)) (Eff effs) ()
195-
theStream = takeUntilSlot _maxSlot $ runEmulatorStream _emulatorConfig action
192+
theStream = S.void $ runEmulatorStream _emulatorConfig action
196193
consumeStream :: forall a. S.Stream (S.Of (LogMessage EmulatorEvent)) (Eff TestEffects) a -> Eff TestEffects (S.Of Bool a)
197194
consumeStream = foldEmulatorStreamM @TestEffects predicate
198195
result <- runM

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

Lines changed: 3 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -204,15 +204,14 @@ type HandleFun state = forall w schema err. (Typeable w, Typeable schema, Typeab
204204
-- * the amount that has been minted (`minted`)
205205
data ModelState state = ModelState
206206
{ _currentSlot :: Slot
207-
, _lastSlot :: Slot
208207
, _balanceChanges :: Map Wallet Value
209208
, _minted :: Value
210209
, _contractState :: state
211210
}
212211
deriving (Show)
213212

214213
dummyModelState :: state -> ModelState state
215-
dummyModelState s = ModelState 0 0 Map.empty mempty s
214+
dummyModelState s = ModelState 0 Map.empty mempty s
216215

217216
-- | The `Spec` monad is a state monad over the `ModelState`. It is used exclusively by the
218217
-- `nextState` function to model the effects of an action on the blockchain.
@@ -520,15 +519,13 @@ instance ContractModel state => StateModel (ModelState state) where
520519
shrinkAction s (ContractAction a) = [ Some @() (ContractAction a') | a' <- shrinkAction s a ]
521520

522521
initialState = ModelState { _currentSlot = 0
523-
, _lastSlot = 125 -- Set by propRunActions
524522
, _balanceChanges = Map.empty
525523
, _minted = mempty
526524
, _contractState = initialState }
527525

528526
nextState s (ContractAction cmd) _v = runSpec (nextState cmd) s
529527

530-
precondition s (ContractAction cmd) = s ^. currentSlot < s ^. lastSlotL - 10 -- No commands if < 10 slots left
531-
&& precondition s cmd
528+
precondition s (ContractAction cmd) = precondition s cmd
532529

533530
perform s (ContractAction cmd) _env = () <$ runEmulator (\ h -> perform (handle h) s cmd)
534531

@@ -1006,8 +1003,7 @@ propRunActionsWithOptions ::
10061003
propRunActionsWithOptions opts handleSpecs predicate actions' =
10071004
monadic (flip State.evalState mempty) $ finalChecks opts finalPredicate $ do
10081005
QC.run $ setHandles $ activateWallets handleSpecs
1009-
let initState = StateModel.initialState { _lastSlot = opts ^. maxSlot }
1010-
void $ runActionsInState initState actions
1006+
void $ runActionsInState StateModel.initialState actions
10111007
where
10121008
finalState = stateAfter actions
10131009
finalPredicate = predicate finalState .&&. checkBalances finalState

‎plutus-contract/test/Spec/Contract.hs‎

Lines changed: 31 additions & 31 deletions
Original file line numberDiff line numberDiff line change
@@ -52,70 +52,70 @@ import Plutus.Contract.Trace.RequestHandler (maybeToHandler)
5252

5353
tests :: TestTree
5454
tests =
55-
let run :: Slot -> String -> TracePredicate -> EmulatorTrace () -> _
56-
run sl = checkPredicateOptions (defaultCheckOptions & maxSlot .~ sl & minLogLevel .~ Debug)
55+
let run :: String -> TracePredicate -> EmulatorTrace () -> _
56+
run = checkPredicateOptions (defaultCheckOptions & minLogLevel .~ Debug)
5757

58-
check :: Slot -> String -> Contract () Schema ContractError () -> _ -> _
59-
check sl nm contract pred = run sl nm (pred contract) (void $ activateContract w1 contract tag)
58+
check :: String -> Contract () Schema ContractError () -> _ -> _
59+
check nm contract pred = run nm (pred contract) (void $ activateContract w1 contract tag)
6060

6161
tag :: ContractInstanceTag
6262
tag = "instance 1"
6363

6464
in
6565
testGroup "contracts"
66-
[ check 1 "awaitSlot" (void $ awaitSlot 10) $ \con ->
66+
[ check "awaitSlot" (void $ awaitSlot 10) $ \con ->
6767
waitingForSlot con tag 10
6868

69-
, check 1 "selectEither" (void $ awaitPromise $ selectEither (isSlot 10) (isSlot 5)) $ \con ->
69+
, check "selectEither" (void $ awaitPromise $ selectEither (isSlot 10) (isSlot 5)) $ \con ->
7070
waitingForSlot con tag 5
7171

72-
, check 1 "both" (void $ awaitPromise $ Con.both (isSlot 10) (isSlot 20)) $ \con ->
72+
, check "both" (void $ awaitPromise $ Con.both (isSlot 10) (isSlot 20)) $ \con ->
7373
waitingForSlot con tag 10
7474

75-
, check 1 "both (2)" (void $ awaitPromise $ Con.both (isSlot 10) (isSlot 20)) $ \con ->
75+
, check "both (2)" (void $ awaitPromise $ Con.both (isSlot 10) (isSlot 20)) $ \con ->
7676
waitingForSlot con tag 20
7777

78-
, check 1 "watchAddressUntilSlot" (void $ watchAddressUntilSlot someAddress 5) $ \con ->
78+
, check "watchAddressUntilSlot" (void $ watchAddressUntilSlot someAddress 5) $ \con ->
7979
waitingForSlot con tag 5
8080

81-
, check 1 "endpoint" (void $ awaitPromise $ endpoint @"ep" pure) $ \con ->
81+
, check "endpoint" (void $ awaitPromise $ endpoint @"ep" pure) $ \con ->
8282
endpointAvailable @"ep" con tag
8383

84-
, check 1 "forever" (forever $ awaitPromise $ endpoint @"ep" pure) $ \con ->
84+
, check "forever" (forever $ awaitPromise $ endpoint @"ep" pure) $ \con ->
8585
endpointAvailable @"ep" con tag
8686

8787
, let
8888
oneTwo :: Promise () Schema ContractError Int = endpoint @"1" pure .> endpoint @"2" pure .> endpoint @"4" pure
8989
oneThree :: Promise () Schema ContractError Int = endpoint @"1" pure .> endpoint @"3" pure .> endpoint @"4" pure
9090
con = selectList [void oneTwo, void oneThree]
9191
in
92-
run 1 "alternative"
92+
run "alternative"
9393
(endpointAvailable @"2" con tag
9494
.&&. not (endpointAvailable @"3" con tag))
9595
$ do
9696
hdl <- activateContract w1 con tag
9797
callEndpoint @"1" hdl 1
9898

9999
, let theContract :: Contract () Schema ContractError () = void $ awaitPromise $ endpoint @"1" @Int pure .> endpoint @"2" @Int pure
100-
in run 1 "call endpoint (1)"
100+
in run "call endpoint (1)"
101101
(endpointAvailable @"1" theContract tag)
102102
(void $ activateContract w1 theContract tag)
103103

104104
, let theContract :: Contract () Schema ContractError () = void $ awaitPromise $ endpoint @"1" @Int pure .> endpoint @"2" @Int pure
105-
in run 1 "call endpoint (2)"
105+
in run "call endpoint (2)"
106106
(endpointAvailable @"2" theContract tag
107107
.&&. not (endpointAvailable @"1" theContract tag))
108108
(activateContract w1 theContract tag >>= \hdl -> callEndpoint @"1" hdl 1)
109109

110110
, let theContract :: Contract () Schema ContractError () = void $ awaitPromise $ endpoint @"1" @Int pure .> endpoint @"2" @Int pure
111-
in run 1 "call endpoint (3)"
111+
in run "call endpoint (3)"
112112
(not (endpointAvailable @"2" theContract tag)
113113
.&&. not (endpointAvailable @"1" theContract tag))
114114
(activateContract w1 theContract tag >>= \hdl -> callEndpoint @"1" hdl 1 >> callEndpoint @"2" hdl 2)
115115

116116
, let theContract :: Contract () Schema ContractError [ActiveEndpoint] = awaitPromise $ endpoint @"5" @[ActiveEndpoint] pure
117117
expected = ActiveEndpoint{ aeDescription = EndpointDescription "5", aeMetadata = Nothing}
118-
in run 5 "active endpoints"
118+
in run "active endpoints"
119119
(assertDone theContract tag ((==) [expected]) "should be done")
120120
$ do
121121
hdl <- activateContract w1 theContract tag
@@ -124,13 +124,13 @@ tests =
124124
void $ callEndpoint @"5" hdl eps
125125

126126
, let theContract :: Contract () Schema ContractError () = void $ submitTx mempty >> watchAddressUntilSlot someAddress 20
127-
in run 1 "submit tx"
127+
in run "submit tx"
128128
(waitingForSlot theContract tag 20)
129129
(void $ activateContract w1 theContract tag)
130130

131131
, let smallTx = Constraints.mustPayToPubKey (Crypto.pubKeyHash $ walletPubKey w2) (Ada.lovelaceValueOf 10)
132132
theContract :: Contract () Schema ContractError () = submitTx smallTx >>= awaitTxConfirmed . Ledger.txId >> submitTx smallTx >>= awaitTxConfirmed . Ledger.txId
133-
in run 3 "handle several blockchain events"
133+
in run "handle several blockchain events"
134134
(walletFundsChange w1 (Ada.lovelaceValueOf (-20))
135135
.&&. assertNoFailedTransactions
136136
.&&. assertDone theContract tag (const True) "all blockchain events should be processed")
@@ -139,28 +139,28 @@ tests =
139139
, let l = endpoint @"1" pure .> endpoint @"2" pure
140140
r = endpoint @"3" pure .> endpoint @"4" pure
141141
theContract :: Contract () Schema ContractError () = void . awaitPromise $ selectEither l r
142-
in run 1 "select either"
142+
in run "select either"
143143
(assertDone theContract tag (const True) "left branch should finish")
144144
(activateContract w1 theContract tag >>= (\hdl -> callEndpoint @"1" hdl 1 >> callEndpoint @"2" hdl 2))
145145

146146
, let theContract :: Contract () Schema ContractError () = void $ loopM (\_ -> fmap Left . awaitPromise $ endpoint @"1" @Int pure) 0
147-
in run 1 "loopM"
147+
in run "loopM"
148148
(endpointAvailable @"1" theContract tag)
149149
(void $ activateContract w1 theContract tag >>= \hdl -> callEndpoint @"1" hdl 1)
150150

151151
, let theContract :: Contract () Schema ContractError () = void $ throwing Con._ContractError $ OtherError "error"
152-
in run 1 "throw an error"
152+
in run "throw an error"
153153
(assertContractError theContract tag (\case { OtherError "error" -> True; _ -> False}) "failed to throw error")
154154
(void $ activateContract w1 theContract tag)
155155

156-
, run 2 "pay to wallet"
156+
, run "pay to wallet"
157157
(walletFundsChange w1 (Ada.lovelaceValueOf (-200))
158158
.&&. walletFundsChange w2 (Ada.lovelaceValueOf 200)
159159
.&&. assertNoFailedTransactions)
160160
(void $ Trace.payToWallet w1 w2 (Ada.lovelaceValueOf 200))
161161

162162
, let theContract :: Contract () Schema ContractError () = void $ awaitUtxoProduced (walletAddress w2)
163-
in run 2 "await utxo produced"
163+
in run "await utxo produced"
164164
(assertDone theContract tag (const True) "should receive a notification")
165165
(void $ do
166166
activateContract w1 theContract tag
@@ -169,7 +169,7 @@ tests =
169169
)
170170

171171
, let theContract :: Contract () Schema ContractError () = void (utxosAt (walletAddress w1) >>= awaitUtxoSpent . fst . head . Map.toList)
172-
in run 2 "await txout spent"
172+
in run "await txout spent"
173173
(assertDone theContract tag (const True) "should receive a notification")
174174
(void $ do
175175
activateContract w1 theContract tag
@@ -178,25 +178,25 @@ tests =
178178
)
179179

180180
, let theContract :: Contract () Schema ContractError PubKey = ownPubKey
181-
in run 1 "own public key"
181+
in run "own public key"
182182
(assertDone theContract tag (== walletPubKey w2) "should return the wallet's public key")
183183
(void $ activateContract w2 (void theContract) tag)
184184

185185
, let payment = Constraints.mustPayToPubKey (Crypto.pubKeyHash $ walletPubKey w2) (Ada.lovelaceValueOf 10)
186186
theContract :: Contract () Schema ContractError () = submitTx payment >>= awaitTxConfirmed . Ledger.txId
187-
in run 2 "await tx confirmed"
187+
in run "await tx confirmed"
188188
(assertDone theContract tag (const True) "should be done")
189189
(activateContract w1 theContract tag >> void (Trace.waitNSlots 1))
190190

191-
, run 1 "checkpoints"
191+
, run "checkpoints"
192192
(not (endpointAvailable @"2" checkpointContract tag) .&&. endpointAvailable @"1" checkpointContract tag)
193193
(void $ activateContract w1 checkpointContract tag >>= \hdl -> callEndpoint @"1" hdl 1 >> callEndpoint @"2" hdl 1)
194194

195-
, run 1 "error handling & checkpoints"
195+
, run "error handling & checkpoints"
196196
(assertDone errorContract tag (\i -> i == 11) "should finish")
197197
(void $ activateContract w1 (void errorContract) tag >>= \hdl -> callEndpoint @"1" hdl 1 >> callEndpoint @"2" hdl 10 >> callEndpoint @"3" hdl 11)
198198

199-
, run 1 "loop checkpoint"
199+
, run "loop checkpoint"
200200
(assertDone loopCheckpointContract tag (\i -> i == 4) "should finish"
201201
.&&. assertResumableResult loopCheckpointContract tag DoShrink (null . view responses) "should collect garbage"
202202
.&&. assertResumableResult loopCheckpointContract tag DontShrink ((==) 4 . length . view responses) "should keep everything"
@@ -211,7 +211,7 @@ tests =
211211
case _cilMessage . EM._eteEvent <$> lgs of
212212
[ Started, ContractLog "waiting for endpoint 1", CurrentRequests [_], ReceiveEndpointCall{}, ContractLog "Received value: 27", HandledRequest _, CurrentRequests [], StoppedNoError ] -> True
213213
_ -> False
214-
in run 1 "contract logs"
214+
in run "contract logs"
215215
(assertInstanceLog tag matchLogs)
216216
(void $ activateContract w1 theContract tag >>= \hdl -> callEndpoint @"1" hdl 27)
217217

@@ -221,7 +221,7 @@ tests =
221221
case EM._eteEvent <$> lgs of
222222
[ UserLog "Received contract state", UserLog "Final state: Right Nothing"] -> True
223223
_ -> False
224-
in run 4 "contract state"
224+
in run "contract state"
225225
(assertUserLog matchLogs)
226226
$ do
227227
hdl <- Trace.activateContractWallet w1 theContract

‎plutus-use-cases/test/Spec/Crowdfunding.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,6 @@
1010
module Spec.Crowdfunding(tests) where
1111

1212
import qualified Control.Foldl as L
13-
import Control.Lens ((&), (.~))
1413
import Control.Monad (void)
1514
import Control.Monad.Freer (run)
1615
import Control.Monad.Freer.Extras.Log (LogLevel (..))
@@ -52,7 +51,7 @@ tests = testGroup "crowdfunding"
5251
slotCfg <- Trace.getSlotConfig
5352
void (Trace.activateContractWallet w1 $ theContract $ TimeSlot.scSlotZeroTime slotCfg)
5453

55-
, checkPredicateOptions (defaultCheckOptions & maxSlot .~ 20) "make contribution"
54+
, checkPredicateOptions defaultCheckOptions "make contribution"
5655
(walletFundsChange w1 (Ada.lovelaceValueOf (-100)))
5756
$ let contribution = Ada.lovelaceValueOf 100
5857
in makeContribution w1 contribution >> void Trace.nextSlot

0 commit comments

Comments
 (0)