[#3843] Make arbitrary instance for actions in quickcheck-dynamic dep…

…end on their sizing (#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 <m.algehed@gmail.com>

marlowe/test/Spec/Marlowe/Marlowe.hs

@@ -95,7 +95,7 @@ bob = w2
 
 
 zeroCouponBondTest :: TestTree
-zeroCouponBondTest = checkPredicateOptions (defaultCheckOptions & maxSlot .~ 250) "Zero Coupon Bond Contract"
+zeroCouponBondTest = checkPredicateOptions defaultCheckOptions "Zero Coupon Bond Contract"
     (assertNoFailedTransactions
     -- T..&&. emulatorLog (const False) ""
     T..&&. assertDone marlowePlutusContract (Trace.walletInstanceTag alice) (const True) "contract should close"
@@ -136,7 +136,7 @@ zeroCouponBondTest = checkPredicateOptions (defaultCheckOptions & maxSlot .~ 250
 
 
 errorHandlingTest :: TestTree
-errorHandlingTest = checkPredicateOptions (defaultCheckOptions & maxSlot .~ 250) "Error handling"
+errorHandlingTest = checkPredicateOptions defaultCheckOptions "Error handling"
     (assertAccumState marlowePlutusContract (Trace.walletInstanceTag alice)
     (\case (SomeError (TransitionError _)) -> True
            _                               -> False
@@ -167,7 +167,7 @@ errorHandlingTest = checkPredicateOptions (defaultCheckOptions & maxSlot .~ 250)
 
 
 trustFundTest :: TestTree
-trustFundTest = checkPredicateOptions (defaultCheckOptions & maxSlot .~ 200) "Trust Fund Contract"
+trustFundTest = checkPredicateOptions defaultCheckOptions "Trust Fund Contract"
     (assertNoFailedTransactions
     -- T..&&. emulatorLog (const False) ""
     T..&&. assertNotDone marlowePlutusContract (Trace.walletInstanceTag alice) "contract should not have any errors"

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

@@ -60,7 +60,6 @@ module Plutus.Contract.Test(
     , CheckOptions
     , defaultCheckOptions
     , minLogLevel
-    , maxSlot
     , emulatorConfig
     -- * Etc
     , goldenPir
@@ -130,7 +129,7 @@ import           Wallet.Emulator.Chain                 (ChainEvent)
 import           Wallet.Emulator.Folds                 (EmulatorFoldErr (..), Outcome (..), describeError, postMapM)
 import qualified Wallet.Emulator.Folds                 as Folds
 import           Wallet.Emulator.Stream                (filterLogLevel, foldEmulatorStreamM, initialChainState,
-                                                        initialDist, takeUntilSlot)
+                                                        initialDist)
 
 type TracePredicate = FoldM (Eff '[Reader InitialDistribution, Error EmulatorFoldErr, Writer (Doc Void)]) EmulatorEvent Bool
 
@@ -146,7 +145,6 @@ not = fmap Prelude.not
 data CheckOptions =
     CheckOptions
         { _minLogLevel    :: LogLevel -- ^ Minimum log level for emulator log messages to be included in the test output (printed if the test fails)
-        , _maxSlot        :: Slot -- ^ When to stop the emulator
         , _emulatorConfig :: EmulatorConfig
         } deriving (Eq, Show)
 
@@ -156,7 +154,6 @@ defaultCheckOptions :: CheckOptions
 defaultCheckOptions =
     CheckOptions
         { _minLogLevel = Info
-        , _maxSlot = 125
         , _emulatorConfig = def
         }
 
@@ -189,10 +186,10 @@ checkPredicateInner :: forall m.
     -> (String -> m ()) -- ^ Print out debug information in case of test failures
     -> (Bool -> m ()) -- ^ assert
     -> m ()
-checkPredicateInner CheckOptions{_minLogLevel, _maxSlot, _emulatorConfig} predicate action annot assert = do
+checkPredicateInner CheckOptions{_minLogLevel, _emulatorConfig} predicate action annot assert = do
     let dist = _emulatorConfig ^. initialChainState . to initialDist
         theStream :: forall effs. S.Stream (S.Of (LogMessage EmulatorEvent)) (Eff effs) ()
-        theStream = takeUntilSlot _maxSlot $ runEmulatorStream _emulatorConfig action
+        theStream = S.void $ runEmulatorStream _emulatorConfig action
         consumeStream :: forall a. S.Stream (S.Of (LogMessage EmulatorEvent)) (Eff TestEffects) a -> Eff TestEffects (S.Of Bool a)
         consumeStream = foldEmulatorStreamM @TestEffects predicate
     result <- runM

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

@@ -204,15 +204,14 @@ type HandleFun state = forall w schema err. (Typeable w, Typeable schema, Typeab
 --   * the amount that has been minted (`minted`)
 data ModelState state = ModelState
         { _currentSlot    :: Slot
-        , _lastSlot       :: Slot
         , _balanceChanges :: Map Wallet Value
         , _minted         :: Value
         , _contractState  :: state
         }
   deriving (Show)
 
 dummyModelState :: state -> ModelState state
-dummyModelState s = ModelState 0 0 Map.empty mempty s
+dummyModelState s = ModelState 0 Map.empty mempty s
 
 -- | The `Spec` monad is a state monad over the `ModelState`. It is used exclusively by the
 --   `nextState` function to model the effects of an action on the blockchain.
@@ -520,15 +519,13 @@ instance ContractModel state => StateModel (ModelState state) where
     shrinkAction s (ContractAction a) = [ Some @() (ContractAction a') | a' <- shrinkAction s a ]
 
     initialState = ModelState { _currentSlot    = 0
-                              , _lastSlot       = 125        -- Set by propRunActions
                               , _balanceChanges = Map.empty
                               , _minted         = mempty
                               , _contractState  = initialState }
 
     nextState s (ContractAction cmd) _v = runSpec (nextState cmd) s
 
-    precondition s (ContractAction cmd) = s ^. currentSlot < s ^. lastSlotL - 10 -- No commands if < 10 slots left
-                                          && precondition s cmd
+    precondition s (ContractAction cmd) = precondition s cmd
 
     perform s (ContractAction cmd) _env = () <$ runEmulator (\ h -> perform (handle h) s cmd)
 
@@ -1006,8 +1003,7 @@ propRunActionsWithOptions ::
 propRunActionsWithOptions opts handleSpecs predicate actions' =
     monadic (flip State.evalState mempty) $ finalChecks opts finalPredicate $ do
         QC.run $ setHandles $ activateWallets handleSpecs
-        let initState = StateModel.initialState { _lastSlot = opts ^. maxSlot }
-        void $ runActionsInState initState actions
+        void $ runActionsInState StateModel.initialState actions
     where
         finalState     = stateAfter actions
         finalPredicate = predicate finalState .&&. checkBalances finalState

plutus-contract/test/Spec/Contract.hs

@@ -52,70 +52,70 @@ import           Plutus.Contract.Trace.RequestHandler (maybeToHandler)
 
 tests :: TestTree
 tests =
-    let run :: Slot -> String -> TracePredicate -> EmulatorTrace () -> _
-        run sl = checkPredicateOptions (defaultCheckOptions & maxSlot .~ sl & minLogLevel .~ Debug)
+    let run :: String -> TracePredicate -> EmulatorTrace () -> _
+        run = checkPredicateOptions (defaultCheckOptions & minLogLevel .~ Debug)
 
-        check :: Slot -> String -> Contract () Schema ContractError () -> _ -> _
-        check sl nm contract pred = run sl nm (pred contract) (void $ activateContract w1 contract tag)
+        check :: String -> Contract () Schema ContractError () -> _ -> _
+        check nm contract pred = run nm (pred contract) (void $ activateContract w1 contract tag)
 
         tag :: ContractInstanceTag
         tag = "instance 1"
 
     in
     testGroup "contracts"
-        [ check 1 "awaitSlot" (void $ awaitSlot 10) $ \con ->
+        [ check "awaitSlot" (void $ awaitSlot 10) $ \con ->
             waitingForSlot con tag 10
 
-        , check 1 "selectEither" (void $ awaitPromise $ selectEither (isSlot 10) (isSlot 5)) $ \con ->
+        , check "selectEither" (void $ awaitPromise $ selectEither (isSlot 10) (isSlot 5)) $ \con ->
             waitingForSlot con tag 5
 
-        , check 1 "both" (void $ awaitPromise $ Con.both (isSlot 10) (isSlot 20)) $ \con ->
+        , check "both" (void $ awaitPromise $ Con.both (isSlot 10) (isSlot 20)) $ \con ->
             waitingForSlot con tag 10
 
-        , check 1 "both (2)" (void $ awaitPromise $ Con.both (isSlot 10) (isSlot 20)) $ \con ->
+        , check "both (2)" (void $ awaitPromise $ Con.both (isSlot 10) (isSlot 20)) $ \con ->
             waitingForSlot con tag 20
 
-        , check 1 "watchAddressUntilSlot" (void $ watchAddressUntilSlot someAddress 5) $ \con ->
+        , check "watchAddressUntilSlot" (void $ watchAddressUntilSlot someAddress 5) $ \con ->
             waitingForSlot con tag 5
 
-        , check 1 "endpoint" (void $ awaitPromise $ endpoint @"ep" pure) $ \con ->
+        , check "endpoint" (void $ awaitPromise $ endpoint @"ep" pure) $ \con ->
             endpointAvailable @"ep" con tag
 
-        , check 1 "forever" (forever $ awaitPromise $ endpoint @"ep" pure) $ \con ->
+        , check "forever" (forever $ awaitPromise $ endpoint @"ep" pure) $ \con ->
             endpointAvailable @"ep" con tag
 
         , let
             oneTwo :: Promise () Schema ContractError Int = endpoint @"1" pure .> endpoint @"2" pure .> endpoint @"4" pure
             oneThree :: Promise () Schema ContractError Int = endpoint @"1" pure .> endpoint @"3" pure .> endpoint @"4" pure
             con = selectList [void oneTwo, void oneThree]
           in
-            run 1 "alternative"
+            run "alternative"
                 (endpointAvailable @"2" con tag
                     .&&. not (endpointAvailable @"3" con tag))
                 $ do
                     hdl <- activateContract w1 con tag
                     callEndpoint @"1" hdl 1
 
         , let theContract :: Contract () Schema ContractError () = void $ awaitPromise $ endpoint @"1" @Int pure .> endpoint @"2" @Int pure
-          in run 1 "call endpoint (1)"
+          in run "call endpoint (1)"
                 (endpointAvailable @"1" theContract tag)
                 (void $ activateContract w1 theContract tag)
 
         , let theContract :: Contract () Schema ContractError () = void $ awaitPromise $ endpoint @"1" @Int pure .> endpoint @"2" @Int pure
-          in run 1 "call endpoint (2)"
+          in run "call endpoint (2)"
                 (endpointAvailable @"2" theContract tag
                     .&&. not (endpointAvailable @"1" theContract tag))
                 (activateContract w1 theContract tag >>= \hdl -> callEndpoint @"1" hdl 1)
 
         , let theContract :: Contract () Schema ContractError () = void $ awaitPromise $ endpoint @"1" @Int pure .> endpoint @"2" @Int pure
-          in run 1 "call endpoint (3)"
+          in run "call endpoint (3)"
                 (not (endpointAvailable @"2" theContract tag)
                     .&&. not (endpointAvailable @"1" theContract tag))
                 (activateContract w1 theContract tag >>= \hdl -> callEndpoint @"1" hdl 1 >> callEndpoint @"2" hdl 2)
 
         , let theContract :: Contract () Schema ContractError [ActiveEndpoint] = awaitPromise $ endpoint @"5" @[ActiveEndpoint] pure
               expected = ActiveEndpoint{ aeDescription = EndpointDescription "5", aeMetadata = Nothing}
-          in run 5 "active endpoints"
+          in run "active endpoints"
                 (assertDone theContract tag ((==) [expected]) "should be done")
                 $ do
                     hdl <- activateContract w1 theContract tag
@@ -124,13 +124,13 @@ tests =
                     void $ callEndpoint @"5" hdl eps
 
         , let theContract :: Contract () Schema ContractError () = void $ submitTx mempty >> watchAddressUntilSlot someAddress 20
-          in run 1 "submit tx"
+          in run "submit tx"
                 (waitingForSlot theContract tag 20)
                 (void $ activateContract w1 theContract tag)
 
         , let smallTx = Constraints.mustPayToPubKey (Crypto.pubKeyHash $ walletPubKey w2) (Ada.lovelaceValueOf 10)
               theContract :: Contract () Schema ContractError () = submitTx smallTx >>= awaitTxConfirmed . Ledger.txId >> submitTx smallTx >>= awaitTxConfirmed . Ledger.txId
-          in run 3 "handle several blockchain events"
+          in run "handle several blockchain events"
                 (walletFundsChange w1 (Ada.lovelaceValueOf (-20))
                     .&&. assertNoFailedTransactions
                     .&&. assertDone theContract tag (const True) "all blockchain events should be processed")
@@ -139,28 +139,28 @@ tests =
         , let l = endpoint @"1" pure .> endpoint @"2" pure
               r = endpoint @"3" pure .> endpoint @"4" pure
               theContract :: Contract () Schema ContractError () = void . awaitPromise $ selectEither l r
-          in run 1 "select either"
+          in run "select either"
                 (assertDone theContract tag (const True) "left branch should finish")
                 (activateContract w1 theContract tag >>= (\hdl -> callEndpoint @"1" hdl 1 >> callEndpoint @"2" hdl 2))
 
         , let theContract :: Contract () Schema ContractError () = void $ loopM (\_ -> fmap Left . awaitPromise $ endpoint @"1" @Int pure) 0
-          in run 1 "loopM"
+          in run "loopM"
                 (endpointAvailable @"1" theContract tag)
                 (void $ activateContract w1 theContract tag >>= \hdl -> callEndpoint @"1" hdl 1)
 
         , let theContract :: Contract () Schema ContractError () = void $ throwing Con._ContractError $ OtherError "error"
-          in run 1 "throw an error"
+          in run "throw an error"
                 (assertContractError theContract tag (\case { OtherError "error" -> True; _ -> False}) "failed to throw error")
                 (void $ activateContract w1 theContract tag)
 
-        , run 2 "pay to wallet"
+        , run "pay to wallet"
             (walletFundsChange w1 (Ada.lovelaceValueOf (-200))
                 .&&. walletFundsChange w2 (Ada.lovelaceValueOf 200)
                 .&&. assertNoFailedTransactions)
             (void $ Trace.payToWallet w1 w2 (Ada.lovelaceValueOf 200))
 
         , let theContract :: Contract () Schema ContractError () = void $ awaitUtxoProduced (walletAddress w2)
-          in run 2 "await utxo produced"
+          in run "await utxo produced"
             (assertDone theContract tag (const True) "should receive a notification")
             (void $ do
                 activateContract w1 theContract tag
@@ -169,7 +169,7 @@ tests =
             )
 
         , let theContract :: Contract () Schema ContractError () = void (utxosAt (walletAddress w1) >>= awaitUtxoSpent . fst . head . Map.toList)
-          in run 2 "await txout spent"
+          in run "await txout spent"
             (assertDone theContract tag (const True) "should receive a notification")
             (void $ do
                 activateContract w1 theContract tag
@@ -178,25 +178,25 @@ tests =
             )
 
         , let theContract :: Contract () Schema ContractError PubKey = ownPubKey
-          in run 1 "own public key"
+          in run "own public key"
                 (assertDone theContract tag (== walletPubKey w2) "should return the wallet's public key")
                 (void $ activateContract w2 (void theContract) tag)
 
         , let payment = Constraints.mustPayToPubKey (Crypto.pubKeyHash $ walletPubKey w2) (Ada.lovelaceValueOf 10)
               theContract :: Contract () Schema ContractError () = submitTx payment >>= awaitTxConfirmed . Ledger.txId
-          in run 2 "await tx confirmed"
+          in run "await tx confirmed"
             (assertDone theContract tag (const True) "should be done")
             (activateContract w1 theContract tag >> void (Trace.waitNSlots 1))
 
-        , run 1 "checkpoints"
+        , run "checkpoints"
             (not (endpointAvailable @"2" checkpointContract tag) .&&. endpointAvailable @"1" checkpointContract tag)
             (void $ activateContract w1 checkpointContract tag >>= \hdl -> callEndpoint @"1" hdl 1 >> callEndpoint @"2" hdl 1)
 
-        , run 1 "error handling & checkpoints"
+        , run "error handling & checkpoints"
             (assertDone errorContract tag (\i -> i == 11) "should finish")
             (void $ activateContract w1 (void errorContract) tag >>= \hdl -> callEndpoint @"1" hdl 1 >> callEndpoint @"2" hdl 10 >> callEndpoint @"3" hdl 11)
 
-        , run 1 "loop checkpoint"
+        , run "loop checkpoint"
             (assertDone loopCheckpointContract tag (\i -> i == 4) "should finish"
             .&&. assertResumableResult loopCheckpointContract tag DoShrink (null . view responses) "should collect garbage"
             .&&. assertResumableResult loopCheckpointContract tag DontShrink ((==) 4 . length . view responses) "should keep everything"
@@ -211,7 +211,7 @@ tests =
                   case _cilMessage . EM._eteEvent <$> lgs of
                             [ Started, ContractLog "waiting for endpoint 1", CurrentRequests [_], ReceiveEndpointCall{}, ContractLog "Received value: 27", HandledRequest _, CurrentRequests [], StoppedNoError ] -> True
                             _ -> False
-          in run 1 "contract logs"
+          in run "contract logs"
                 (assertInstanceLog tag matchLogs)
                 (void $ activateContract w1 theContract tag >>= \hdl -> callEndpoint @"1" hdl 27)
 
@@ -221,7 +221,7 @@ tests =
                   case EM._eteEvent <$> lgs of
                             [ UserLog "Received contract state", UserLog "Final state: Right Nothing"] -> True
                             _                                                                          -> False
-          in run 4 "contract state"
+          in run "contract state"
                 (assertUserLog matchLogs)
                 $ do
                     hdl <- Trace.activateContractWallet w1 theContract

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

@@ -10,7 +10,6 @@
 module Spec.Crowdfunding(tests) where
 
 import qualified Control.Foldl                         as L
-import           Control.Lens                          ((&), (.~))
 import           Control.Monad                         (void)
 import           Control.Monad.Freer                   (run)
 import           Control.Monad.Freer.Extras.Log        (LogLevel (..))
@@ -52,7 +51,7 @@ tests = testGroup "crowdfunding"
             slotCfg <- Trace.getSlotConfig
             void (Trace.activateContractWallet w1 $ theContract $ TimeSlot.scSlotZeroTime slotCfg)
 
-    , checkPredicateOptions (defaultCheckOptions & maxSlot .~ 20) "make contribution"
+    , checkPredicateOptions defaultCheckOptions "make contribution"
         (walletFundsChange w1 (Ada.lovelaceValueOf (-100)))
         $ let contribution = Ada.lovelaceValueOf 100
           in makeContribution w1 contribution >> void Trace.nextSlot