Misc improvements and fixes

coop-plutus/test/Coop/Plutus/Test.hs

@@ -1,27 +1,28 @@
 module Coop.Plutus.Test (spec) where
 
-import Plutarch.Prelude (ClosedTerm, PBool (PTrue), PEq ((#==)), pconstant, pconstantData, (#))
-import Test.Hspec (Expectation, Spec, describe, runIO, shouldBe)
+import Plutarch.Prelude (ClosedTerm, PEq ((#==)), pconstant, pconstantData, (#))
+import Test.Hspec (Expectation, Spec, describe, expectationFailure, runIO, shouldBe)
 import Test.Hspec.QuickCheck (prop)
 import Test.QuickCheck (NonEmptyList (getNonEmpty), Positive (getPositive), choose, forAll, generate)
 
 import Codec.Serialise (deserialiseOrFail)
 import Coop.Plutus (certV, exampleConsumer, fsV, mkAuthMp, mkCertMp, mkFsMp, pmustSpendAtLeastAa)
-import Coop.Plutus.Aux (hashTxInputs, pmustBurnOwnSingletonValue)
+import Coop.Plutus.Aux (hashTxInputs, pmustBurnOwnSingletonValue, punit)
 import Coop.Plutus.Test.Generators (distribute, genAaInputs, genCertRdmrAc, genCorrectAuthMpBurningCtx, genCorrectAuthMpMintingCtx, genCorrectCertMpBurningCtx, genCorrectCertMpMintingCtx, genCorrectCertVSpendingCtx, genCorrectConsumerCtx, genCorrectFsMpBurningCtx, genCorrectFsMpMintingCtx, genCorrectFsVSpendingCtx, genCorrectMustBurnOwnSingletonValueCtx, genCorruptAuthMpBurningCtx, genCorruptAuthMpMintingCtx, genCorruptCertMpBurningCtx, genCorruptCertMpMintingCtx, genCorruptCertVSpendingCtx, genCorruptFsMpBurningCtx, genCorruptFsMpMintingCtx, genCorruptFsVSpendingCtx, genCorruptMustBurnOwnSingletonValueCtx, mkScriptContext)
-import Coop.Plutus.Types (PAuthMpParams, PCertMpParams, PFsMpParams)
+import Coop.Plutus.Types (PAuthMpParams, PCertMpParams)
 import Coop.Types (AuthMpParams (AuthMpParams), AuthMpRedeemer (AuthMpBurn, AuthMpMint), AuthParams (AuthParams), CertMpParams (CertMpParams), CertMpRedeemer (CertMpBurn, CertMpMint), FsMpParams (FsMpParams), FsMpRedeemer (FsMpBurn, FsMpMint))
 import Data.ByteString.Lazy qualified as LB
 import Data.Foldable (Foldable (fold))
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Text (Text, unpack)
-import Plutarch (Config (Config, tracingMode), TracingMode (DetTracing), compile, pcon, printScript)
+import Plutarch (Config (Config, tracingMode), TracingMode (DoTracing), compile)
 import Plutarch.Api.V1 (PCurrencySymbol)
 import Plutarch.Builtin (PIsData (pdataImpl))
 import Plutarch.Evaluate (evalScript)
-import Plutarch.Test (pfails, psucceeds)
+import Plutarch.Test (pfails)
 import PlutusLedgerApi.V1.Address (scriptHashAddress)
+import PlutusLedgerApi.V1.Scripts (applyArguments)
 import PlutusLedgerApi.V1.Value (AssetClass, TokenName (TokenName), assetClass, currencySymbol)
 import PlutusLedgerApi.V2 (Address, CurrencySymbol, Script, ScriptPurpose (Minting), ValidatorHash (ValidatorHash), dataToBuiltinData, toData)
 import PlutusTx (Data)
@@ -209,45 +210,29 @@ spec = do
     describe "should-succeed" $ do
       prop "mint $FS" $
         let fsMpParams = FsMpParams coopAc fsVAddr (AuthParams authCs certCs)
+            fsMp = applyArguments (comp mkFsMp) [toData fsMpParams]
          in forAll (genCorrectFsMpMintingCtx fsMpParams fsCs) $
               \ctx ->
-                psucceeds
-                  ( mkFsMp
-                      # pconstantData @PFsMpParams fsMpParams
-                      # pdataImpl (pconstant FsMpMint)
-                      # pconstant ctx
-                  )
+                succeeds $ applyArguments fsMp [toData FsMpMint, toData ctx]
       prop "burn $FS" $
         let fsMpParams = FsMpParams coopAc fsVAddr (AuthParams authCs certCs)
+            fsMp = applyArguments (comp mkFsMp) [toData fsMpParams]
          in forAll (genCorrectFsMpBurningCtx fsMpParams fsCs) $
               \ctx ->
-                psucceeds
-                  ( mkFsMp
-                      # pconstantData @PFsMpParams fsMpParams
-                      # pdataImpl (pconstant FsMpBurn)
-                      # pconstant ctx
-                  )
+                succeeds $ applyArguments fsMp [toData FsMpBurn, toData ctx]
     describe "should-fail" $ do
       prop "mint $FS" $
         let fsMpParams = FsMpParams coopAc fsVAddr (AuthParams authCs certCs)
+            fsMp = applyArguments (comp mkFsMp) [toData fsMpParams]
          in forAll (genCorruptFsMpMintingCtx fsMpParams fsCs) $
               \ctx ->
-                pfails
-                  ( mkFsMp
-                      # pconstantData @PFsMpParams fsMpParams
-                      # pdataImpl (pconstant FsMpMint)
-                      # pconstant ctx
-                  )
+                fails $ applyArguments fsMp [toData FsMpMint, toData ctx]
       prop "burn $FS" $
         let fsMpParams = FsMpParams coopAc fsVAddr (AuthParams authCs certCs)
+            fsMp = applyArguments (comp mkFsMp) [toData fsMpParams]
          in forAll (genCorruptFsMpBurningCtx fsMpParams fsCs) $
               \ctx ->
-                pfails
-                  ( mkFsMp
-                      # pconstantData @PFsMpParams fsMpParams
-                      # pdataImpl (pconstant FsMpBurn)
-                      # pconstant ctx
-                  )
+                fails $ applyArguments fsMp [toData FsMpBurn, toData ctx]
   describe "@FsV" $ do
     describe "should-succeed" $ do
       prop "spend $FS" $
@@ -293,10 +278,13 @@ _ptraces' p traceMap traceMappedShouldBe =
     (Right _, _, traceLog) -> traceMap traceLog `shouldBe` traceMappedShouldBe
 
 comp :: ClosedTerm a -> Script
-comp t = either (error . unpack) id $ compile (Config {tracingMode = DetTracing}) t
+comp t = either (error . unpack) id $ compile (Config {tracingMode = DoTracing}) t
 
 passert :: ClosedTerm a -> Expectation
-passert p = pshouldBe p (pcon PTrue)
+passert p = pshouldBe p punit
+
+psucceeds :: ClosedTerm a -> Expectation
+psucceeds = passert
 
 pshouldBe :: ClosedTerm a -> ClosedTerm b -> Expectation
 pshouldBe x y = do
@@ -314,10 +302,24 @@ pshouldBe x y = do
 -}
 pscriptShouldBe :: Script -> Script -> Expectation
 pscriptShouldBe x y =
-  printScript x `shouldBe` printScript y
+  evalScript x `shouldBe` evalScript y
 
 readPlutusDataCbor :: FilePath -> IO Data
 readPlutusDataCbor fname = do
   cborBytes <- LB.readFile fname
   let errOrDecoded = deserialiseOrFail @Data cborBytes
   either (\err -> error $ "File " <> fname <> " can't be parsed into PlutusData CBOR: " <> show err) return errOrDecoded
+
+-- | Asserts the term evaluates successfully without failing
+succeeds :: Script -> Expectation
+succeeds s =
+  case evalScript s of
+    (Left _, _, t) -> expectationFailure $ "Term failed to evaluate, here's the trace:\n" <> show t
+    (Right _, _, _) -> pure ()
+
+-- | Asserts the term evaluates without success
+fails :: Script -> Expectation
+fails s = do
+  case evalScript s of
+    (Left _, _, _) -> pure ()
+    (Right _, _, t) -> expectationFailure $ "Term succeeded, here's the trace:\n" <> show t

coop-plutus/test/Coop/Plutus/Test/Generators.hs

@@ -21,6 +21,7 @@ import Coop.Types (AuthMpParams (amp'authAuthorityAc, amp'requiredAtLeastAaQ), A
 import PlutusLedgerApi.V1.Interval (interval)
 import PlutusLedgerApi.V2 qualified as Value
 import PlutusTx.Prelude (Group (inv))
+import Test.QuickCheck.Gen qualified as Q
 
 mkScriptContext :: ScriptPurpose -> [TxInInfo] -> [TxInInfo] -> Value -> [TxOut] -> [PubKeyHash] -> ScriptContext
 mkScriptContext purpose ins refs mints outs sigs =
@@ -350,12 +351,13 @@ genCorrectFsMpMintingCtx fsMpParams fsCs = do
   certRefs <- for certIds (genCertInput certVAddr certCs certRdmrAc validity)
   authIns <- for certIds (genAuthInput authCs)
   (otherIns, otherMint, otherOuts) <- genOthers 5
+  gcAfter <- genExtendedTime
   let authsBurned = mconcat [Value.singleton authCs (TokenName certId) (-1) | certId <- certIds]
       fsVOuts =
         [ TxOut
           fsVAddr
           (Value.singleton fsCs (TokenName . toBuiltin $ hashTxInputs [authIn]) 1)
-          (toOutputDatum $ FsDatum (toBuiltinData True) "deadbeef" (Finite 100) submitter)
+          (toOutputDatum $ FsDatum (toBuiltinData True) "deadbeef" gcAfter submitter)
           Nothing
         | authIn <- authIns
         ]
@@ -544,6 +546,11 @@ genTokenName = TokenName <$> genBuiltinByteString "tn-" 32
 genCurrencySymbol :: Gen CurrencySymbol
 genCurrencySymbol = CurrencySymbol <$> genBuiltinByteString "cs-" 28
 
+genExtendedTime :: Gen (Extended POSIXTime)
+genExtendedTime = Q.oneof [return NegInf, return PosInf, genFinite]
+  where
+    genFinite = Finite . POSIXTime <$> chooseInteger (0, 100)
+
 genAuthenticatonId :: Gen BuiltinByteString
 genAuthenticatonId = genBuiltinByteString "authid-" 28