QuickCheck ContractModel testing facilities to deal with dynamically …

…created tokens (#194)

create tokens using the `ContractModel` interface and introduces a
`ContractModel` test-suite for the `Plutus.Contracts.Uniswap` contract.

doc/plutus-doc.cabal

@@ -71,6 +71,7 @@ executable doc-doctests
       plutus-contract -any,
       playground-common -any,
       plutus-use-cases -any,
+      quickcheck-dynamic -any,
       prettyprinter -any,
       containers -any,
       freer-extras -any,

doc/plutus/tutorials/GameModel.hs

@@ -35,6 +35,7 @@ import Plutus.Contract.Test.ContractModel
 -- END import ContractModel
 
 import Plutus.Contract.Test.ContractModel as ContractModel
+import Test.QuickCheck.StateModel hiding (Action, Actions)
 
 -- START import Game
 import Plutus.Contracts.GameStateMachine as G
@@ -96,11 +97,15 @@ instance ContractModel GameModel where
 -- END initialState
 
 -- START initialHandleSpecs
-    initialHandleSpecs = [ ContractInstanceSpec (WalletKey w) w G.contract | w <- wallets ]
+    initialInstances = Key . WalletKey <$> wallets
+
+    instanceContract _ _ WalletKey{} = G.contract
+
+    instanceWallet (WalletKey w) = w
 -- END initialHandleSpecs
 
 -- START perform
-    perform handle s cmd = case cmd of
+    perform handle _ s cmd = case cmd of
         Lock w new val -> do
             callEndpoint @"lock" (handle $ WalletKey w)
                          LockArgs{ lockArgsSecret = secretArg new
@@ -197,7 +202,7 @@ prop_Game actions = propRunActions_ actions
 -- START propGame'
 propGame' :: LogLevel -> Actions GameModel -> Property
 propGame' l s = propRunActionsWithOptions
-                    (set minLogLevel l defaultCheckOptions)
+                    (set minLogLevel l defaultCheckOptionsContractModel)
                     defaultCoverageOptions
                     (\ _ -> pure True)
                     s
@@ -222,11 +227,6 @@ shrinkWallet w = [w' | w' <- wallets, w' < w]
 guesses :: [String]
 guesses = ["hello", "secret", "hunter2", "*******"]
 
--- START delay
-delay :: Int -> EmulatorTraceNoStartContract ()
-delay n = void $ waitNSlots (fromIntegral n)
--- END delay
-
 -- Dynamic Logic ----------------------------------------------------------
 
 prop_UnitTest :: Property
@@ -251,9 +251,9 @@ badUnitTest :: DLTest GameModel
 badUnitTest =
     BadPrecondition
       [Witness (1 :: Integer),
-       Do $ Lock w1 "hello" 1,
-       Do $ GiveToken w2]
-      [Action (Guess w2 "hello" "new secret" 3)]
+       Do $ NoBind (Var 1) $ Lock w1 "hello" 1,
+       Do $ NoBind (Var 2) $ GiveToken w2]
+      [Action (NoBind (Var 3) (Guess w2 "hello" "new secret" 3))]
       (GameModel {_gameValue = 1, _hasToken = Just w2, _currentSecret = "hello"})
 -- END badUnitTest
 
@@ -282,7 +282,7 @@ noLockedFunds = do
         monitor $ label "Unlocking funds"
         action $ GiveToken w
         action $ Guess w secret "" val
-    assertModel "Locked funds should be zero" $ isZero . lockedValue
+    assertModel "Locked funds should be zero" $ symIsZero . lockedValue
 -- END noLockedFunds
 
 -- | Check that we can always get the money out of the guessing game (by guessing correctly).
@@ -305,21 +305,21 @@ gameTokenVal =
 
 -- START testLock v1
 testLock :: Property
-testLock = prop_Game $ Actions [Lock w1 "hunter2" 0]
+testLock = prop_Game $ actionsFromList [Lock w1 "hunter2" 0]
 -- END testLock v1
 
 testLockWithMaxSuccess :: ()
 testLockWithMaxSuccess = ()
  where
 -- START testLock withMaxSuccess
  testLock :: Property
- testLock = withMaxSuccess 1 . prop_Game $ Actions [Lock w1 "hunter2" 0]
+ testLock = withMaxSuccess 1 . prop_Game $ actionsFromList [Lock w1 "hunter2" 0]
 -- END testLock withMaxSuccess
 
 -- START testDoubleLock
 testDoubleLock :: Property
 testDoubleLock = prop_Game $
-  Actions
+  actionsFromList
     [Lock w1 "*******" 0,
      Lock w1 "secret" 0]
 -- END testDoubleLock
@@ -382,9 +382,9 @@ v1_model = ()
     precondition s _             = True
 -- END precondition v1
 
-    perform :: HandleFun GameModel -> ModelState GameModel -> Action GameModel -> EmulatorTraceNoStartContract ()
+    perform :: HandleFun GameModel -> (SymToken -> AssetClass) -> ModelState GameModel -> Action GameModel -> SpecificationEmulatorTrace ()
 -- START perform v1
-    perform handle s cmd = case cmd of
+    perform handle _ s cmd = case cmd of
         Lock w new val -> do
             callEndpoint @"lock" (handle $ WalletKey w)
                          LockArgs{ lockArgsSecret = secretArg new
@@ -487,7 +487,7 @@ noLockedFunds_v1 = ()
  noLockedFunds :: DL GameModel ()
  noLockedFunds = do
      anyActions_
-     assertModel "Locked funds should be zero" $ isZero . lockedValue
+     assertModel "Locked funds should be zero" $ symIsZero . lockedValue
 -- END noLockedFunds v1
 
 noLockedFunds_v2 :: ()
@@ -501,7 +501,7 @@ noLockedFunds_v2 = ()
      secret <- viewContractState currentSecret
      val    <- viewContractState gameValue
      action $ Guess w "" secret val
-     assertModel "Locked funds should be zero" $ isZero . lockedValue
+     assertModel "Locked funds should be zero" $ symIsZero . lockedValue
 -- END noLockedFunds v2
 
 noLockedFunds_v3 :: ()
@@ -516,7 +516,7 @@ noLockedFunds_v3 = ()
      val    <- viewContractState gameValue
      when (val > 0) $ do
          action $ Guess w "" secret val
-     assertModel "Locked funds should be zero" $ isZero . lockedValue
+     assertModel "Locked funds should be zero" $ symIsZero . lockedValue
 -- END noLockedFunds v3
 
 noLockedFunds_v4 :: ()
@@ -532,7 +532,7 @@ noLockedFunds_v4 = ()
      when (val > 0) $ do
          action $ GiveToken w
          action $ Guess w "" secret val
-     assertModel "Locked funds should be zero" $ isZero . lockedValue
+     assertModel "Locked funds should be zero" $ symIsZero . lockedValue
 -- END noLockedFunds v4
 
 noLockedFunds_v5 :: ()
@@ -549,7 +549,7 @@ noLockedFunds_v5 = ()
          monitor $ label "Unlocking funds"
          action $ GiveToken w
          action $ Guess w secret "" val
-     assertModel "Locked funds should be zero" $ isZero . lockedValue
+     assertModel "Locked funds should be zero" $ symIsZero . lockedValue
 -- END noLockedFunds v5
 
 typeSignatures :: forall state. ContractModel state => state -> state
@@ -564,7 +564,7 @@ typeSignatures = id
 -- END precondition type
  precondition = ContractModel.precondition
 -- START perform type
- perform :: HandleFun state -> ModelState state -> Action state -> EmulatorTraceNoStartContract ()
+ perform :: HandleFun state -> (SymToken -> AssetClass) -> ModelState state -> Action state -> SpecificationEmulatorTrace ()
 -- END perform type
  perform = ContractModel.perform
 -- START shrinkAction type

doc/plutus/tutorials/contract-testing.rst

@@ -211,17 +211,19 @@ we simply distinguish contract instance keys by the wallet they are running in:
    :start-after: START ContractInstanceKey
    :end-before: END ContractInstanceKey
 
-Once this type is defined, we can construct our :hsobj:`Plutus.Contract.Test.ContractModel.ContractInstanceSpec` by filling
-in the :hsobj:`Plutus.Contract.Test.ContractModel.initialHandleSpecs` field of the ``ContractModel`` class:
+Once this type is defined, we can tell QuickCheck what code to run for a given
+contract by filling in the
+:hsobj:`Plutus.Contract.Test.ContractModel.initialInstances`,
+:hsobj:`Plutus.Contract.Test.ContractModel.instanceWallet`, and
+:hsobj:`Plutus.Contract.Test.ContractModel.instanceContract` fields of the
+``ContractModel`` class:
 
 .. literalinclude:: GameModel.hs
    :start-after: START initialHandleSpecs
    :end-before: END initialHandleSpecs
 
-This specifies (reading from right to left) that we should create one
-contract instance per wallet, running ``G.contract``, the contract
-under test, in emulated wallet ``w``, and distinguished by a
-:hsobj:`Plutus.Contract.Test.ContractModel.ContractInstanceKey` of the form ``WalletKey w``.
+This specifies (reading top to bottom) that we should create one
+contract instance per wallet ``w``, that will run ``G.contract``, in wallet ``w``.
 
 Now we can run tests, although of course they will not yet succeed:
 
@@ -516,7 +518,7 @@ transfer the game :term:`token` from one wallet to another as specified by
    :end-before: END perform v1
 
 Every call to an end-point must be associated with one of the contract
-instances defined in our ``initialHandleSpecs``; the ``handle`` argument to
+instances defined in our ``initialInstances``; the ``handle`` argument to
 :hsobj:`Plutus.Contract.Test.ContractModel.perform` lets us find the contract handle associated with each
 :hsobj:`Plutus.Contract.Test.ContractModel.ContractInstanceKey`.
 
@@ -672,12 +674,6 @@ blockchain. Likewise, we delay one slot after each of the other
 actions. (If the delays we insert are too short, we will discover this
 later via failed tests).
 
-We can cause the emulator to delay a number of slots like this:
-
-.. literalinclude:: GameModel.hs
-   :start-after: START delay
-   :end-before: END delay
-
 We add a call to ``delay`` in each branch of :hsobj:`Plutus.Contract.Test.ContractModel.perform`:
 
 .. literalinclude:: GameModel.hs

plutus-contract/plutus-contract.cabal

@@ -161,6 +161,7 @@ library
             Plutus.Contract.Test.Coverage
             Plutus.Contract.Test.ContractModel
             Plutus.Contract.Test.ContractModel.Internal
+            Plutus.Contract.Test.ContractModel.Symbolics
             Plutus.Contract.Test.ContractModel.CrashTolerance
         build-depends:
             tasty -any,

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE PatternSynonyms #-}
 module Plutus.Contract.Test.ContractModel
     ( -- * Contract models
       --
@@ -11,12 +12,15 @@ module Plutus.Contract.Test.ContractModel
     , balanceChange
     , minted
     , lockedValue
+    , symIsZero
     , GetModelState(..)
     , getContractState
     , askModelState
     , askContractState
     , viewModelState
     , viewContractState
+    , SymToken
+    , symAssetClassValue
     -- ** The Spec monad
     --
     -- $specMonad
@@ -29,8 +33,13 @@ module Plutus.Contract.Test.ContractModel
     , withdraw
     , transfer
     , modifyContractState
+    , createToken
     , ($=)
     , ($~)
+    -- * Helper functions for writing perform functions
+    , SpecificationEmulatorTrace
+    , registerToken
+    , delay
     -- * Test scenarios
     --
     -- $dynamicLogic
@@ -63,11 +72,15 @@ module Plutus.Contract.Test.ContractModel
     --
     -- $runningProperties
     , Actions(..)
+    , Act(..)
+    , pattern Actions
+    , actionsFromList
     -- ** Wallet contract handles
     --
     -- $walletHandles
     , SchemaConstraints
     , ContractInstanceSpec(..)
+    , SomeContractInstanceKey(..)
     , HandleFun
     -- ** Model properties
     , propSanityCheckModel
@@ -82,6 +95,7 @@ module Plutus.Contract.Test.ContractModel
     , propRunActions_
     , propRunActions
     , propRunActionsWithOptions
+    , defaultCheckOptionsContractModel
     -- ** DL properties
     , forAllDL
     -- ** Test cases
@@ -97,6 +111,9 @@ module Plutus.Contract.Test.ContractModel
     -- $noLockedFunds
     , NoLockedFundsProof(..)
     , checkNoLockedFundsProof
+    , checkNoLockedFundsProofFast
+    , checkNoLockedFundsProofWithWiggleRoom
+    , checkNoLockedFundsProofWithWiggleRoomFast
     -- $checkNoPartiality
     , Whitelist
     , whitelistOk