Improve performance of semantics transaction generators

marlowe-test/src/Spec/Marlowe/Plutus/Arbitrary.hs

@@ -25,7 +25,6 @@ module Spec.Marlowe.Plutus.Arbitrary
 
 import Language.Marlowe.Core.V1.Semantics (MarloweData(..), MarloweParams(..))
 import Language.Marlowe.Scripts (MarloweTxInput(..))
-import Plutus.V1.Ledger.Value (gt)
 import Plutus.V2.Ledger.Api
   ( BuiltinData(..)
   , Data(..)
@@ -57,6 +56,7 @@ import Test.Tasty.QuickCheck (Arbitrary(..), Gen, chooseInt, frequency, resize,
 
 import qualified Data.ByteString as BS (ByteString, pack)
 import qualified Data.ByteString.Char8 as BS8 (pack)
+import qualified PlutusTx.AssocMap as AM
 
 
 instance Arbitrary BS.ByteString where
@@ -170,8 +170,7 @@ instance Arbitrary TxInInfo where
 
 
 instance Arbitrary TxOut where
-  arbitrary = TxOut <$> arbitrary <*> arbitrary `suchThat` (`gt` mempty) <*> (OutputDatumHash <$> arbitrary) <*> pure Nothing
-
+  arbitrary = TxOut <$> arbitrary <*> genValue arbitraryPositiveInteger `suchThat` (not . AM.null . getValue) <*> (OutputDatumHash <$> arbitrary) <*> pure Nothing
 
 instance Arbitrary TxOutRef where
   arbitrary = TxOutRef <$> arbitrary <*> arbitraryPositiveInteger
@@ -182,7 +181,10 @@ instance Arbitrary a => Arbitrary (UpperBound a) where
 
 
 instance Arbitrary Value where
-  arbitrary = Value <$> arbitraryAssocMap arbitrary (arbitraryAssocMap arbitrary arbitrary)
+  arbitrary = genValue arbitrary
+
+genValue :: Gen Integer -> Gen Value
+genValue genQuantity = Value <$> arbitraryAssocMap arbitrary (arbitraryAssocMap arbitrary genQuantity)
 
 instance Arbitrary MarloweParams where
   arbitrary = MarloweParams <$> arbitrary

marlowe-test/src/Spec/Marlowe/Plutus/Specification.hs

@@ -55,7 +55,7 @@ import Plutus.V1.Ledger.Value (flattenValue, valueOf)
 import Plutus.V2.Ledger.Api
   ( Address(Address)
   , BuiltinData(BuiltinData)
-  , Credential(PubKeyCredential)
+  , Credential(PubKeyCredential, ScriptCredential)
   , Data(B, Constr, List)
   , Datum(..)
   , DatumHash(DatumHash)
@@ -67,7 +67,7 @@ import Plutus.V2.Ledger.Api
   , ToData(..)
   , TokenName
   , TxInInfo(TxInInfo, txInInfoResolved)
-  , TxOut(TxOut, txOutValue)
+  , TxOut(TxOut, txOutAddress, txOutValue)
   , ValidatorHash
   , Value
   , adaSymbol
@@ -82,11 +82,10 @@ import Spec.Marlowe.Plutus.Transaction
   ( ArbitraryTransaction
   , arbitraryPayoutTransaction
   , arbitrarySemanticsTransaction
-  , isScriptTxIn
   , merkleize
   , noModify
   , noVeto
-  , shuffle
+  , shuffleTransaction
   )
 import Spec.Marlowe.Plutus.Types
   ( PayoutTransaction
@@ -127,7 +126,6 @@ import qualified PlutusTx.AssocMap as AM (Map, fromList, insert, keys, null, toL
 import qualified Test.Tasty.QuickCheck as Q (shuffle)
 
 
--- | Conditionally check Plutus trace log messages.
 
 checkPlutusLog :: Bool
 #ifdef TRACE_PLUTUS
@@ -365,7 +363,7 @@ checkDoubleInput referencePaths =
         infoInputs <>= [inScript]
         -- Add the new datum and its hash.
         infoData <>= AM.fromList [(inDatumHash, inDatum)]
-        shuffle
+        shuffleTransaction
   in
     checkSemanticsTransaction ["w"] referencePaths noModify modifyAfter noVeto False False False
 
@@ -418,7 +416,7 @@ checkMultipleOutput referencePaths =
             | otherwise                   = pure txOut
         -- Update the outputs with the split script output.
         infoOutputs %= concatMap splitOwnOutput
-        shuffle
+        shuffleTransaction
   in
     checkSemanticsTransaction ["o"] referencePaths noModify modifyAfter notCloses False False False
 
@@ -436,7 +434,7 @@ checkCloseOutput referencePaths =
         inScript <- infoInputs `uses` filter matchOwnInput
         -- Add a clone of the script input as output.
         infoOutputs <>= (txInInfoResolved <$> inScript)
-        shuffle
+        shuffleTransaction
   in
     checkSemanticsTransaction ["c"] referencePaths noModify modifyAfter doesClose False False False
 
@@ -567,10 +565,18 @@ checkOtherValidators referencePaths =
   let
     modifyAfter =
       -- Add an extra script input.
-      infoInputs <><~ lift (listOf1 $ arbitrary `suchThat` isScriptTxIn)
+      infoInputs <><~ lift (listOf1 $ makeScriptTxIn =<< arbitrary)
   in
     checkSemanticsTransaction ["z"] referencePaths noModify modifyAfter hasPayouts False False False
 
+makeScriptTxIn :: TxInInfo -> Gen TxInInfo
+makeScriptTxIn (TxInInfo outRef out) = TxInInfo outRef <$> makeScriptTxOut out
+
+makeScriptTxOut :: TxOut -> Gen TxOut
+makeScriptTxOut out = do
+  address' <- Address <$> (ScriptCredential <$> arbitrary) <*> arbitrary
+  pure $ out { txOutAddress = address' }
+
 
 -- | Check that parameters in the datum are not changed by the transaction.
 checkParamsOutput :: [ReferencePath] -> Property

marlowe-test/src/Spec/Marlowe/Plutus/Transaction.hs

@@ -25,7 +25,7 @@ module Spec.Marlowe.Plutus.Transaction
     -- * Modification
   , merkleize
   , noModify
-  , shuffle
+  , shuffleTransaction
     -- * Conditions
   , isScriptTxIn
   , noVeto
@@ -36,7 +36,7 @@ import Control.Lens (Lens', use, uses, (.=), (<>=), (<~))
 import Control.Monad (when)
 import Control.Monad.State (StateT, execStateT, lift)
 import Data.Bifunctor (bimap, second)
-import Data.List (nub, permutations)
+import Data.List (nub)
 import Language.Marlowe.Core.V1.Semantics
   ( MarloweData(MarloweData)
   , MarloweParams(..)
@@ -110,11 +110,12 @@ import Spec.Marlowe.Reference (ReferencePath, arbitraryReferenceTransaction)
 import Spec.Marlowe.Semantics.Arbitrary (arbitraryGoldenTransaction, arbitraryPositiveInteger)
 import Spec.Marlowe.Semantics.Golden (GoldenTransaction)
 import Spec.Marlowe.Semantics.Merkle (deepMerkleize, merkleizeInputs)
-import Test.Tasty.QuickCheck (Arbitrary(..), Gen, elements, frequency, listOf, suchThat)
+import Test.Tasty.QuickCheck (Arbitrary(..), Gen, frequency, listOf, suchThat)
 
 import qualified Language.Marlowe.Core.V1.Semantics.Types as M (Party(Address))
 import qualified Plutus.V1.Ledger.Value as V (adaSymbol, adaToken, singleton)
 import qualified PlutusTx.AssocMap as AM (fromList, toList)
+import Test.QuickCheck (shuffle)
 
 
 -- | An arbitrary Plutus transaction.
@@ -353,7 +354,7 @@ validSemanticsTransaction noisy =
     when noisy addNoise
 
     -- Shuffle.
-    shuffle
+    shuffleTransaction
 
 
 -- | Generate an arbitrary, valid Marlowe semantics transaction: datum, redeemer, and script context.
@@ -476,7 +477,7 @@ validPayoutTransaction noisy =
     when noisy addNoise'
 
     -- Shuffle.
-    shuffle
+    shuffleTransaction
 
 
 -- | Check that an address is not for a script.
@@ -524,16 +525,16 @@ addNoise' =
 
 
 -- | Shuffle the order of inputs, outputs, data, and signatories in a Plutus transaction.
-shuffle :: ArbitraryTransaction a ()
-shuffle =
+shuffleTransaction :: ArbitraryTransaction a ()
+shuffleTransaction =
   do
     let
       go :: Lens' (PlutusTransaction a) [b] -> ArbitraryTransaction a ()
-      go field = field <~ (lift . elements . permutations =<< use field)
+      go field = field <~ (lift . shuffle =<< use field)
     go infoInputs
     go infoOutputs
     go infoSignatories
-    infoData <~ (lift . fmap AM.fromList . elements . permutations . AM.toList =<< use infoData)
+    infoData <~ (lift . fmap AM.fromList . shuffle . AM.toList =<< use infoData)
 
 
 -- | Merkleize a transaction.

marlowe-test/src/Spec/Marlowe/Plutus/Value.hs

@@ -26,10 +26,11 @@ import Plutus.V2.Ledger.Api (CurrencySymbol, TokenName, Value(..), singleton)
 import PlutusTx.Numeric (zero)
 import Spec.Marlowe.Plutus.Arbitrary ()
 import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.QuickCheck (Arbitrary(..), Gen, Property, chooseInt, forAll, property, testProperty, (===))
+import Test.Tasty.QuickCheck (Arbitrary(..), Property, forAll, property, testProperty, (===))
 
 import qualified PlutusTx.AssocMap as AM (empty, fromList, toList)
 import qualified PlutusTx.Eq as P ((==))
+import Test.QuickCheck (shuffle)
 
 
 -- | Run tests.
@@ -97,26 +98,6 @@ checkEq =
           in
             (x P.== y) == (all check . foldl1 union $ tokens <$> [x, y])
 
--- Produces a list containing the elements of the first in a random order.
-shuffle :: [a] -> Gen [a]
-shuffle xs = go [] (length xs) xs
-  where
-    go acc 0 _ = pure acc
-    go acc len xs' = do
-      ix <- chooseInt (0, len - 1)
-      (before, after) <- pure $ breakAt ix xs'
-      case after of
-        [] -> error "Chosen index out of range"
-        (x : after') -> go (x : acc) (len - 1) $ before <> after'
-
-breakAt :: Int -> [a] -> ([a], [a])
-breakAt = go []
-  where
-    go acc 0 xs = (reverse acc, xs)
-    go acc _ [] = (reverse acc, [])
-    go acc n (x : xs) = go (x : acc) (n - 1) xs
-
-
 -- | Check that `leq` is a partial ordering requiring that quantity of each token in the first
 --   operand is less than or equal to quanity of the corresponding token in the second operand,
 --   where a missing token in one operand represents a zero quantity.