Property tests

.gitignore

@@ -3,3 +3,4 @@ dist-newstyle
 .direnv
 tmp
 .pre-commit-config.yaml
+.vscode/

Makefile

@@ -0,0 +1,33 @@
+
+.PHONY: help
+help:
+	@echo "Usage: make <target>"
+	@echo
+	@echo "Targets:"
+	@echo "  help   -- show this help"
+	@echo "  shell  -- nix develop"
+	@echo "  build  -- cabal build"
+	@echo "  test   -- cabal test"
+	@echo "  clean  -- cabal clean"
+	@echo "  format -- format Haskell source files"
+
+.PHONY: shell
+shell:
+	nix develop
+
+.PHONY: build
+build:
+	cabal build
+
+.PHONY: test
+test:
+	cabal test
+
+.PHONY: clean
+clean:
+	cabal clean
+
+.PHONY: format
+format:
+	fourmolu -i src
+	fourmolu -i test

src/Plutarch/MerkelizedValidator.hs

@@ -71,8 +71,8 @@ withdraw f =
   plam $ \redeemer ctx -> unTermCont $ do
     let red = punsafeCoerce @_ @_ @PWithdrawRedeemer redeemer
     redF <- pletFieldsC @'["inputState", "outputState"] red
-    ctxF <- pletFieldsC @'["txInfo", "purpose"] ctx
-    PRewarding _ <- pmatchC ctxF.purpose
+    let purpose = pfield @"purpose" # ctx
+    PRewarding _ <- pmatchC purpose
     return $
       popaque $
         pif

src/Plutarch/MultiUTxOIndexer.hs

@@ -60,7 +60,6 @@ newtype PIndices (s :: S)
 instance DerivePlutusType PIndices where type DPTStrat _ = PlutusTypeData
 deriving anyclass instance
   PTryFrom PData (PAsData PIndices)
-
 instance PUnsafeLiftDecl PIndices where
   type PLifted PIndices = Indices
 
@@ -156,6 +155,7 @@ withdrawLogic inoutValidator =
           # pcon (PMyInOutAgg (-1) (-1) 0)
           # redF.indices
     PMyInOutAgg _ _ inputIndexCount <- pmatchC inoutAggregated
+
     pure $
       pif
         (scriptInputCount #== inputIndexCount)

src/Plutarch/MultiUTxOIndexerOneToMany.hs

@@ -64,10 +64,8 @@ newtype PIndices (s :: S)
 instance DerivePlutusType PIndices where type DPTStrat _ = PlutusTypeData
 deriving anyclass instance
   PTryFrom PData (PAsData PIndices)
-
 instance PUnsafeLiftDecl PIndices where
   type PLifted PIndices = Indices
-
 deriving via
   (DerivePConstantViaData Indices PIndices)
   instance
@@ -82,6 +80,12 @@ data PWithdrawRedeemer (s :: S)
 instance DerivePlutusType PWithdrawRedeemer where type DPTStrat _ = PlutusTypeData
 deriving anyclass instance
   PTryFrom PData (PAsData PWithdrawRedeemer)
+instance PUnsafeLiftDecl PWithdrawRedeemer where
+  type PLifted PWithdrawRedeemer = WithdrawRedeemer
+deriving via
+  (DerivePConstantViaData WithdrawRedeemer PWithdrawRedeemer)
+  instance
+    PConstantDecl WithdrawRedeemer
 
 data PMyInputAgg (s :: S) = PMyInputAgg (Term s (PBuiltinList PTxInInfo)) (Term s PInteger)
   deriving stock (Generic)

src/Plutarch/SingularUTxOIndexer.hs

@@ -12,7 +12,11 @@ import Plutarch.Api.V2 (
   PValidator,
  )
 import Plutarch.Builtin (pasInt)
-import Plutarch.DataRepr (PDataFields)
+import Plutarch.DataRepr (
+  DerivePConstantViaData (DerivePConstantViaData),
+  PDataFields,
+ )
+import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
 import Plutarch.Prelude
 import Plutarch.Unsafe (punsafeCoerce)
 import PlutusTx
@@ -38,6 +42,12 @@ newtype PSpendRedeemer (s :: S)
 
 instance DerivePlutusType PSpendRedeemer where type DPTStrat _ = PlutusTypeData
 instance PTryFrom PData PSpendRedeemer
+instance PUnsafeLiftDecl PSpendRedeemer where
+  type PLifted PSpendRedeemer = SpendRedeemer
+deriving via
+  (DerivePConstantViaData SpendRedeemer PSpendRedeemer)
+  instance
+    PConstantDecl SpendRedeemer
 
 spend :: Term s (PTxOut :--> PTxOut :--> PBool) -> Term s PValidator
 spend f =

src/Plutarch/SingularUTxOIndexerOneToMany.hs

@@ -14,7 +14,11 @@ import Plutarch.Api.V2 (
   PValidator,
  )
 import Plutarch.Builtin (pasInt)
-import Plutarch.DataRepr (PDataFields)
+import Plutarch.DataRepr (
+  DerivePConstantViaData (DerivePConstantViaData),
+  PDataFields,
+ )
+import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
 import Plutarch.Prelude
 import Plutarch.Unsafe (punsafeCoerce)
 import PlutusTx
@@ -40,6 +44,12 @@ newtype PSpendRedeemer (s :: S)
 
 instance DerivePlutusType PSpendRedeemer where type DPTStrat _ = PlutusTypeData
 instance PTryFrom PData PSpendRedeemer
+instance PUnsafeLiftDecl PSpendRedeemer where
+  type PLifted PSpendRedeemer = SpendRedeemer
+deriving via
+  (DerivePConstantViaData SpendRedeemer PSpendRedeemer)
+  instance
+    PConstantDecl SpendRedeemer
 
 data PMyAggregator (s :: S) = PMyAggregator (Term s PInteger) (Term s (PBuiltinList PTxOut)) (Term s PInteger)
   deriving stock (Generic)

test/Spec.hs

@@ -13,13 +13,20 @@ main :: IO ()
 main = do
   defaultMain $
     testGroup
-      "Unit Test Group"
+      "Tests"
       [ Spec.MerkelizedValidatorSpec.spendUnitTest
       , Spec.MerkelizedValidatorSpec.withdrawUnitTest
+      , Spec.MerkelizedValidatorSpec.propertyTest
       , Spec.StakeValidatorSpec.unitTest
+      , Spec.StakeValidatorSpec.propertyTest
       , Spec.TxLevelMinterSpec.unitTest
+      , Spec.TxLevelMinterSpec.propertyTest
       , Spec.SingularUTxOIndexerSpec.unitTest
+      , Spec.SingularUTxOIndexerSpec.propertyTest
       , Spec.SingularUTxOIndexerOneToManySpec.unitTest
+      , Spec.SingularUTxOIndexerOneToManySpec.propertyTest
       , Spec.MultiUTxOIndexerSpec.unitTest
+      , Spec.MultiUTxOIndexerSpec.propertyTest
       , Spec.MultiUTxOIndexerOneToManySpec.unitTest
+      , Spec.MultiUTxOIndexerOneToManySpec.propertyTest
       ]

test/Spec/MerkelizedValidatorSpec.hs

@@ -1,44 +1,55 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 {- |
 Module      : Spec.MerkelizedValidatorSpec
 Description : Test suite for the Merkelized Validator functions in a Plutarch smart contract environment.
 -}
 module Spec.MerkelizedValidatorSpec (
+  propertyTest,
   psumOfSquares,
   spendUnitTest,
   withdrawUnitTest,
   withdraw,
 ) where
 
 import Plutarch.Api.V2 (
+  PScriptContext,
   PStakeValidator,
   PStakingCredential (..),
   PValidator,
  )
-import Plutarch.Builtin (pasInt, pdataImpl)
+import Plutarch.Builtin (pasInt, pdataImpl, pforgetData)
 import Plutarch.Context (
   buildRewarding',
+  buildSpending',
   extraRedeemer,
   withdrawal,
  )
 import Plutarch.MerkelizedValidator qualified as MerkelizedValidator
 import Plutarch.Num ((#*), (#+))
 import Plutarch.Prelude
-import Plutarch.Test.Precompiled (Expectation (Failure, Success), testEvalCase, tryFromPTerm)
 import Plutarch.Utils (pheadSingleton)
 import PlutusLedgerApi.V2 (
+  BuiltinByteString,
   Credential (..),
   ScriptContext,
   ScriptPurpose (..),
   StakingCredential (..),
  )
 import PlutusTx qualified
 import PlutusTx.Builtins (mkI)
-import Test.Tasty (TestTree)
 import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
   pletC,
   pletFieldsC,
  )
 
+import Plutarch.Test.Precompiled (Expectation (Failure, Success), testEvalCase, tryFromPTerm)
+import Plutarch.Test.QuickCheck (fromPPartial)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.QuickCheck (Property, chooseInteger, forAll, listOf, testProperty)
+
+import Spec.Utils
+
 -- | Calculates the sum of squares of integers provided as a list of 'PData'.
 psumOfSquares :: (PIsListLike list PData, PIsListLike list PInteger) => Term s (PBuiltinList PData :--> list PData)
 psumOfSquares =
@@ -68,8 +79,7 @@ rewardingCred :: StakingCredential
 rewardingCred = StakingHash (ScriptCredential "b055a795895b15d9af25acb752ac89c78524acfa387acb626c7e1bc8")
 
 stakeCred :: Term s PStakingCredential
-stakeCred =
-  pconstant rewardingCred
+stakeCred = pconstant rewardingCred
 
 withdrawRedeemer :: MerkelizedValidator.WithdrawRedeemer
 withdrawRedeemer =
@@ -86,18 +96,24 @@ badWithdrawRedeemer =
     }
 
 spendCtx :: ScriptContext
-spendCtx =
-  buildRewarding' $
+spendCtx = spendCtxWithCred rewardingCred withdrawRedeemer
+
+spendCtxWithCred :: StakingCredential -> MerkelizedValidator.WithdrawRedeemer -> ScriptContext
+spendCtxWithCred s redeemer =
+  buildSpending' $
     mconcat
-      [ withdrawal rewardingCred 1
-      , extraRedeemer (Rewarding rewardingCred) withdrawRedeemer
+      [ withdrawal s 1
+      , extraRedeemer (Rewarding s) redeemer
       ]
 
 withdrawCtx :: ScriptContext
-withdrawCtx =
+withdrawCtx = withdrawCtxWithCred rewardingCred
+
+withdrawCtxWithCred :: StakingCredential -> ScriptContext
+withdrawCtxWithCred s =
   buildRewarding' $
     mconcat
-      [ withdrawal rewardingCred 1
+      [ withdrawal s 0
       ]
 
 -- | Tests the 'spend' function for both successful and failed validation scenarios.
@@ -133,3 +149,56 @@ withdrawUnitTest = tryFromPTerm "Merkelized Validator Withdraw Unit Test" withdr
     [ PlutusTx.toData badWithdrawRedeemer
     , PlutusTx.toData withdrawCtx
     ]
+
+prop_withdrawValidator :: Property
+prop_withdrawValidator = forAll withdrawInput check
+  where
+    withdrawInput = do
+      xs <- listOf (chooseInteger (-1_000_000_000, 1_000_000_000))
+      bs <- genByteString 56
+      return (xs, bs)
+    check (xs, bs) =
+      let inputState :: ClosedTerm (PBuiltinList PData)
+          inputState = pmap # (plam $ pforgetData . pdata) # pconstant xs
+          outputState = psumOfSquares # inputState
+          redeemer :: ClosedTerm MerkelizedValidator.PWithdrawRedeemer
+          redeemer =
+            pcon $
+              MerkelizedValidator.PWithdrawRedeemer $
+                pdcons @"inputState"
+                  # pdata inputState
+                  #$ pdcons @"outputState"
+                  # pdata outputState
+                  # pdnil
+          cred = mkStakingHashFromByteString bs
+          context :: ClosedTerm PScriptContext
+          context = pconstant (withdrawCtxWithCred cred)
+       in fromPPartial $ withdraw # pforgetData (pdata redeemer) # context
+
+prop_spendValidator :: Property
+prop_spendValidator = forAll spendInput check
+  where
+    spendInput = do
+      x <- chooseInteger (-4, 4)
+      y <- chooseInteger (-4, 4)
+      bs <- genByteString 56
+      return (x, y, bs)
+    check (x :: Integer, y :: Integer, bs :: BuiltinByteString) =
+      let cred = mkStakingHashFromByteString bs
+          redeemer =
+            MerkelizedValidator.WithdrawRedeemer
+              { inputState = [PlutusTx.toBuiltinData x, PlutusTx.toBuiltinData y]
+              , outputState = [PlutusTx.toBuiltinData (x * x + y * y)]
+              }
+          context :: ClosedTerm PScriptContext
+          context = pconstant (spendCtxWithCred cred redeemer)
+          asData = pforgetData . pdata . pconstant
+       in fromPPartial $ spend (pconstant cred) # asData x # asData y # context
+
+propertyTest :: TestTree
+propertyTest =
+  testGroup
+    "Property tests for MerkelizedValidator"
+    [ testProperty "withdraw" prop_withdrawValidator
+    , testProperty "spend" prop_spendValidator
+    ]