Implement isGovernorDatumValid tests.

agora-specs/Property/Governor.hs

@@ -7,144 +7,108 @@ Property model and tests for 'Governor' related functions
 -}
 module Property.Governor (props) where
 
--- import Agora.Governor (Governor (gstOutRef), GovernorDatum (..), pisGovernorDatumValid)
--- import Agora.Governor.Scripts (governorPolicy)
--- import Agora.Proposal (
---   ProposalId (ProposalId),
---   ProposalThresholds (ProposalThresholds),
---  )
--- import Agora.Proposal.Time (
---   MaxTimeRangeWidth (MaxTimeRangeWidth),
---   ProposalTimingConfig (ProposalTimingConfig),
---  )
--- import Data.Default.Class (Default (def))
--- import Data.Tagged (Tagged (Tagged))
--- import Data.Universe (Finite (..), Universe (..))
--- import Plutarch.Api.V2 (PScriptContext)
--- import Plutarch.Builtin (pforgetData)
--- import Plutarch.Context (
---   MintingBuilder,
---   buildMinting',
---   input,
---   mint,
---   output,
---   script,
---   withDatum,
---   withMinting,
---   withRef,
---   withValue,
---  )
--- import Plutarch.Extra.AssetClass (assetClassValue)
--- import PlutusLedgerApi.V2 (
---   ScriptContext (scriptContextTxInfo),
---   TxInInfo (txInInfoOutRef),
---   TxInfo (txInfoInputs, txInfoMint, txInfoOutputs),
---   TxOut (txOutValue),
---  )
--- import Property.Generator (genInput, genOutput)
--- import Sample.Shared (
---   governor,
---   governorAssetClass,
---   governorSymbol,
---   governorValidatorHash,
---   gstUTXORef,
---  )
 import Test.Tasty (TestTree)
+import Test.QuickCheck (Property, Gen, Arbitrary (arbitrary), arbitraryBoundedEnum, chooseInteger)
+import Test.Tasty.QuickCheck (testProperty)
+import Data.Universe (Universe)
+import Data.Universe.Class (Finite)
+import Plutarch.Test.QuickCheck (Equality (OnPEq), Partiality (ByComplete), haskEquiv, TestableTerm (TestableTerm), pconstantT)
+import Agora.Governor (pisGovernorDatumValid, GovernorDatum(GovernorDatum), PGovernorDatum)
+import Agora.Proposal (ProposalThresholds(ProposalThresholds), ProposalId (ProposalId))
+import Agora.Proposal.Time (ProposalTimingConfig(ProposalTimingConfig), MaxTimeRangeWidth (MaxTimeRangeWidth))
+import Data.Tagged (Tagged(Tagged))
+import Generics.SOP.NP (NP(Nil, (:*)))
+import Optics (view)
 
--- import Test.Tasty.Plutarch.Property (classifiedPropertyNative)
--- import Test.Tasty.QuickCheck (
---   Gen,
---   Property,
---   choose,
---   chooseInteger,
---   listOf1,
---   testProperty,
---  )
 
--- data GovernorDatumCases
---   = ExecuteLE0
---   | CreateLE0
---   | ToVotingLE0
---   | VoteLE0
---   | CosignLE0
---   | Correct
---   deriving stock (Eq, Show)
+data GovernorDatumCases
+  = ExecuteLE0
+  | CreateLE0
+  | ToVotingLE0
+  | VoteLE0
+  | CosignLE0
+  | Correct
+  deriving stock (Eq, Show, Enum, Bounded)
+  deriving anyclass (Universe, Finite)
 
--- instance Universe GovernorDatumCases where
---   universe =
---     [ ExecuteLE0
---     , CreateLE0
---     , VoteLE0
---     , CosignLE0
---     , Correct
---     ]
+instance Arbitrary GovernorDatumCases where
+  arbitrary = arbitraryBoundedEnum
 
--- instance Finite GovernorDatumCases where
---   universeF = universe
---   cardinality = Tagged 6
+{- | Property that checks `pisGovernorDatumValid` behaves as intended by comparing it
+  to a simple haskell implementation.
+-}
+governorDatumValidProperty :: Property
+governorDatumValidProperty =
+  haskEquiv @'OnPEq @'ByComplete
+    isValidModelImpl
+    (TestableTerm pisGovernorDatumValid)
+    (genDatum :* Nil)
+  where
 
--- {- | Property that checks `governorDatumValid`.
---  `governorDatumValid` determines if given governor datum is valid or not. This property
---  ensures `governorDatumValid` is checking the datum correctly and ruling out improper datum.
--- -}
--- governorDatumValidProperty :: Property
--- governorDatumValidProperty =
---   classifiedPropertyNative gen (const []) expected classifier pisGovernorDatumValid
---   where
---     classifier :: GovernorDatum -> GovernorDatumCases
---     classifier
---       ( (.proposalThresholds) ->
---           ProposalThresholds
---             execute
---             create
---             toVoting
---             vote
---             cosign
---         )
---         | execute < 0 = ExecuteLE0
---         | create < 0 = CreateLE0
---         | toVoting < 0 = ToVotingLE0
---         | vote < 0 = VoteLE0
---         | cosign < 0 = CosignLE0
---         | otherwise = Correct
+    genDatum :: Gen (TestableTerm PGovernorDatum)
+    genDatum = pconstantT <$> (arbitrary >>= genDatumForCase)
+      where
+        genDatumForCase :: GovernorDatumCases -> Gen GovernorDatum
+        genDatumForCase c = do
+          thres <- genProposalThresholds c
 
---     expected :: GovernorDatum -> Maybe Bool
---     expected c = Just $ classifier c == Correct
+          let timing = ProposalTimingConfig 0 0 0 0
+          return $ GovernorDatum thres (ProposalId 0) timing (MaxTimeRangeWidth 1) 3
+          where
+            taggedInteger p = Tagged <$> chooseInteger p
+            genProposalThresholds :: GovernorDatumCases -> Gen ProposalThresholds
+            genProposalThresholds c = do
+              let validGT = taggedInteger (0, 1000000000)
+              execute <- validGT
+              create <- validGT
+              toVoting <- validGT
+              vote <- validGT
+              cosign <- validGT
+              le0 <- taggedInteger (-1000, -1)
 
---     gen :: GovernorDatumCases -> Gen GovernorDatum
---     gen c = do
---       thres <- genProposalThresholds c
+              case c of
+                ExecuteLE0 ->
+                  -- execute < 0
+                  return $ ProposalThresholds le0 create toVoting vote cosign
+                CreateLE0 ->
+                  -- c < 0
+                  return $ ProposalThresholds execute le0 toVoting vote cosign
+                ToVotingLE0 ->
+                  return $ ProposalThresholds execute create le0 vote cosign
+                VoteLE0 ->
+                  -- vote < 0
+                  return $ ProposalThresholds execute create toVoting le0 cosign
+                CosignLE0 ->
+                  return $ ProposalThresholds execute create toVoting vote le0
+                Correct ->
+                  return $ ProposalThresholds execute create toVoting vote cosign
 
---       let timing = ProposalTimingConfig 0 0 0 0
---       return $ GovernorDatum thres (ProposalId 0) timing (MaxTimeRangeWidth 1) 3
---       where
---         taggedInteger p = Tagged <$> chooseInteger p
---         genProposalThresholds :: GovernorDatumCases -> Gen ProposalThresholds
---         genProposalThresholds c = do
---           let validGT = taggedInteger (0, 1000000000)
---           execute <- validGT
---           create <- validGT
---           toVoting <- validGT
---           vote <- validGT
---           cosign <- validGT
---           le0 <- taggedInteger (-1000, -1)
+    -- | This is a model Haskell implementation of `pisGovernorDatumValid`.
+    isValidModelImpl :: GovernorDatum -> Bool
+    isValidModelImpl = correctCase . classifier
+      where
+        correctCase = \case
+          Correct -> True
+          _ -> False
 
---           case c of
---             ExecuteLE0 ->
---               -- execute < 0
---               return $ ProposalThresholds le0 create toVoting vote cosign
---             CreateLE0 ->
---               -- c < 0
---               return $ ProposalThresholds execute le0 toVoting vote cosign
---             ToVotingLE0 ->
---               return $ ProposalThresholds execute create le0 vote cosign
---             VoteLE0 ->
---               -- vote < 0
---               return $ ProposalThresholds execute create toVoting le0 cosign
---             CosignLE0 ->
---               return $ ProposalThresholds execute create toVoting vote le0
---             Correct ->
---               return $ ProposalThresholds execute create toVoting vote cosign
+        classifier :: GovernorDatum -> GovernorDatumCases
+        classifier
+          ( view #proposalThresholds ->
+              ProposalThresholds
+                execute
+                create
+                toVoting
+                vote
+                cosign
+            )
+            | execute < 0 = ExecuteLE0
+            | create < 0 = CreateLE0
+            | toVoting < 0 = ToVotingLE0
+            | vote < 0 = VoteLE0
+            | cosign < 0 = CosignLE0
+            | otherwise = Correct
+
+---
 
 -- data GovernorPolicyCases
 --   = ReferenceUTXONotSpent
@@ -232,11 +196,11 @@ import Test.Tasty (TestTree)
 --         refInputNotExists = gstUTXORef `notElem` (txInInfoOutRef <$> txInfoInputs txinfo)
 --         govOutputNotExists = gst `notElem` (txOutValue <$> txInfoOutputs txinfo)
 
--- props :: [TestTree]
--- props =
---   [ testProperty "governorDatumValid" governorDatumValidProperty
---   , testProperty "governorPolicy" governorMintingProperty
---   ]
-
 props :: [TestTree]
-props = []
+props =
+  [ testProperty "governorDatumValid" governorDatumValidProperty
+  -- , testProperty "governorPolicy" governorMintingProperty
+  ]
+
+-- props :: [TestTree]
+-- props = []

agora.cabal

@@ -143,6 +143,9 @@ common test-deps
 common exe-opts
   ghc-options: -threaded -rtsopts -with-rtsopts=-N -O0
 
+common test-opts
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2
+
 library
   import:          lang, deps, plutarch-prelude
   exposed-modules:
@@ -224,7 +227,7 @@ library agora-specs
   build-depends:   agora-testlib
 
 test-suite agora-test
-  import:         lang, deps, plutarch-prelude, test-deps
+  import:         lang, deps, plutarch-prelude, test-deps, test-opts
   type:           exitcode-stdio-1.0
   main-is:        Spec.hs
   hs-source-dirs: agora-test

agora/Agora/Governor.hs

@@ -56,6 +56,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletFieldsC)
 import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
 import PlutusLedgerApi.V1 (TxOutRef)
 import PlutusTx qualified
+import Optics.TH (makeFieldLabelsNoPrefix)
 
 --------------------------------------------------------------------------------
 
@@ -84,6 +85,10 @@ data GovernorDatum = GovernorDatum
       Generic
     )
 
+-- | @since 0.2.1
+makeFieldLabelsNoPrefix ''GovernorDatum
+
+
 -- | @since 0.1.0
 PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)]
 
@@ -181,6 +186,8 @@ newtype PGovernorDatum (s :: S) = PGovernorDatum
       PDataFields
     , -- | @since 0.1.0
       PEq
+    , -- | @since 0.2.1
+      PShow
     )
 
 -- | @since 0.2.0

agora/Agora/Proposal.hs

@@ -579,6 +579,8 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds
       PIsData
     , -- | @since 0.1.0
       PDataFields
+    , -- | @since 0.2.1
+      PShow
     )
 
 -- | @since 0.2.0

agora/Agora/Proposal/Time.hs

@@ -224,6 +224,8 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
       PIsData
     , -- | @since 0.1.0
       PDataFields
+    , -- | @since 0.2.1
+      PShow
     )
 
 instance DerivePlutusType PProposalTimingConfig where
@@ -260,6 +262,8 @@ newtype PMaxTimeRangeWidth (s :: S)
       PPartialOrd
     , -- | @since 0.1.0
       POrd
+    , -- | @since 0.2.1
+      PShow
     )
 
 instance DerivePlutusType PMaxTimeRangeWidth where