test: Add property tests

Anastasia-Labs · Aug 4, 2024 · 6a2585a · 6a2585a
1 parent 0475ab1
commit 6a2585a
Show file tree

Hide file tree

Showing 15 changed files with 527 additions and 141 deletions.
diff --git a/Makefile b/Makefile
@@ -4,11 +4,12 @@ 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 "  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:
@@ -25,3 +26,8 @@ test:
 .PHONY: clean
 clean:
 	cabal clean
+
+.PHONY: format
+format:
+	fourmolu -i src
+	fourmolu -i test
diff --git a/src/Plutarch/MultiUTxOIndexer.hs b/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
 

diff --git a/src/Plutarch/MultiUTxOIndexerOneToMany.hs b/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)

diff --git a/src/Plutarch/SingularUTxOIndexer.hs b/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 =

diff --git a/src/Plutarch/SingularUTxOIndexerOneToMany.hs b/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)

diff --git a/src/Plutarch/Utils.hs b/src/Plutarch/Utils.hs
@@ -44,7 +44,7 @@ deriving via (DerivePConstantViaData WrapperRedeemer PWrapperRedeemer) instance
 ptryOwnInput :: (PIsListLike list PTxInInfo) => Term s (list PTxInInfo :--> PTxOutRef :--> PTxOut)
 ptryOwnInput =
   plam $ \inputs ownRef ->
-    precList (\self x xs -> pletFields @'["outRef", "resolved"] x $ \txInFields -> pif (ptrace "." (ownRef #== txInFields.outRef)) txInFields.resolved (self # xs)) (const perror) # inputs
+    precList (\self x xs -> pletFields @'["outRef", "resolved"] x $ \txInFields -> pif (ownRef #== txInFields.outRef) txInFields.resolved (self # xs)) (const perror) # inputs
 
 pheadSingleton :: (PListLike list, PElemConstraint list a) => Term s (list a :--> a)
 pheadSingleton = phoistAcyclic $

diff --git a/test/Spec.hs b/test/Spec.hs
@@ -16,12 +16,17 @@ main = do
       "Tests"
       [ Spec.MerkelizedValidatorSpec.spendUnitTest
       , Spec.MerkelizedValidatorSpec.withdrawUnitTest
-      , Spec.MerkelizedValidatorSpec.propertyTests
+      , 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.propertyTests
+      , Spec.MultiUTxOIndexerSpec.propertyTest
       , Spec.MultiUTxOIndexerOneToManySpec.unitTest
+      , Spec.MultiUTxOIndexerOneToManySpec.propertyTest
       ]
diff --git a/test/Spec/MerkelizedValidatorSpec.hs b/test/Spec/MerkelizedValidatorSpec.hs
@@ -1,11 +1,11 @@
-{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 {- |
 Module      : Spec.MerkelizedValidatorSpec
 Description : Test suite for the Merkelized Validator functions in a Plutarch smart contract environment.
 -}
 module Spec.MerkelizedValidatorSpec (
-  propertyTests,
+  propertyTest,
   psumOfSquares,
   spendUnitTest,
   withdrawUnitTest,
@@ -33,9 +33,9 @@ import PlutusLedgerApi.V2 (
   BuiltinByteString,
   Credential (..),
   ScriptContext,
+  ScriptHash (..),
   ScriptPurpose (..),
   StakingCredential (..),
-  ScriptHash (..),
  )
 import PlutusTx qualified
 import PlutusTx.Builtins (mkI)
@@ -47,7 +47,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
 import Plutarch.Test.Precompiled (Expectation (Failure, Success), testEvalCase, tryFromPTerm)
 import Plutarch.Test.QuickCheck (fromPPartial)
 import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.QuickCheck (forAll, Property, testProperty, chooseInteger, listOf)
+import Test.Tasty.QuickCheck (Property, chooseInteger, forAll, listOf, testProperty)
 
 import Spec.Utils
 
@@ -153,45 +153,53 @@ withdrawUnitTest = tryFromPTerm "Merkelized Validator Withdraw Unit Test" withdr
 
 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 in
-    let outputState = psumOfSquares # inputState                         in
-    let redeemer :: ClosedTerm MerkelizedValidator.PWithdrawRedeemer
-        redeemer = pcon $ MerkelizedValidator.PWithdrawRedeemer
-                         $ pdcons @"inputState"   # pdata inputState
-                        #$ pdcons @"outputState"  # pdata outputState
-                         # pdnil                                         in
-    let cred = StakingHash (ScriptCredential (ScriptHash bs))            in
-    let context :: ClosedTerm PScriptContext
-        context = pconstant (withdrawCtxWithCred cred)                   in
-    fromPPartial $ withdraw # pforgetData (pdata redeemer) # context
+  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 = StakingHash (ScriptCredential (ScriptHash 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 = StakingHash (ScriptCredential (ScriptHash bs)) in
-    let redeemer = MerkelizedValidator.WithdrawRedeemer
-          { inputState = [ PlutusTx.toBuiltinData x, PlutusTx.toBuiltinData y ]
-          , outputState = [ PlutusTx.toBuiltinData (x * x + y * y) ]
-          }                                                   in
-    let context :: ClosedTerm PScriptContext
-        context = pconstant (spendCtxWithCred cred redeemer)  in
-    let asData = pforgetData . pdata . pconstant              in
-    fromPPartial $ spend (pconstant cred) # asData x # asData y # context
-
-propertyTests :: TestTree
-propertyTests = testGroup "Property tests for MerkelizedValidator" [ testProperty "withdraw" prop_withdrawValidator
-                                                                   , testProperty "spend"    prop_spendValidator
-                                                                   ]
+  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 = StakingHash (ScriptCredential (ScriptHash 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
+    ]