From 5791e51739c09663693956a49ccf3ebae9d4ccb7 Mon Sep 17 00:00:00 2001 From: adamczykm Date: Thu, 10 Nov 2022 15:27:22 +0100 Subject: [PATCH] Implement isGovernorDatumValid tests. --- agora-specs/Property/Governor.hs | 234 +++++++++++++------------------ agora.cabal | 5 +- agora/Agora/Governor.hs | 7 + agora/Agora/Proposal.hs | 2 + agora/Agora/Proposal/Time.hs | 4 + 5 files changed, 116 insertions(+), 136 deletions(-) diff --git a/agora-specs/Property/Governor.hs b/agora-specs/Property/Governor.hs index 46bdc8b..3e29a22 100644 --- a/agora-specs/Property/Governor.hs +++ b/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 = [] diff --git a/agora.cabal b/agora.cabal index 767160d..93107a0 100644 --- a/agora.cabal +++ b/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 diff --git a/agora/Agora/Governor.hs b/agora/Agora/Governor.hs index b977d1d..de5c181 100644 --- a/agora/Agora/Governor.hs +++ b/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 diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index ab289ca..19a86e8 100644 --- a/agora/Agora/Proposal.hs +++ b/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 diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs index 892b10f..1eec301 100644 --- a/agora/Agora/Proposal/Time.hs +++ b/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