rename/docstrings

This commit is contained in:
Seungheon Oh 2022-05-25 11:45:03 -05:00
parent 7ee7d661ef
commit 7a599ffa35
10 changed files with 67 additions and 13 deletions

View file

@ -32,7 +32,7 @@ import Plutus.V1.Ledger.Api (
import Plutus.V1.Ledger.Interval qualified as Interval import Plutus.V1.Ledger.Interval qualified as Interval
import Plutus.V1.Ledger.Value qualified as Value import Plutus.V1.Ledger.Value qualified as Value
import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.AssocMap qualified as AssocMap
import Spec.Spec ( import Spec.Specification (
SpecificationTree, SpecificationTree,
group, group,
scriptFails, scriptFails,

View file

@ -15,7 +15,7 @@ import Sample.Effect.GovernorMutation (
validNewGovernorDatum, validNewGovernorDatum,
) )
import Sample.Shared qualified as Shared import Sample.Shared qualified as Shared
import Spec.Spec ( import Spec.Specification (
SpecificationTree, SpecificationTree,
effectFailsWith, effectFailsWith,
effectSucceedsWith, effectSucceedsWith,

View file

@ -25,7 +25,7 @@ import Sample.Effect.TreasuryWithdrawal (
treasuries, treasuries,
users, users,
) )
import Spec.Spec ( import Spec.Specification (
SpecificationTree, SpecificationTree,
effectFailsWith, effectFailsWith,
effectSucceedsWith, effectSucceedsWith,

View file

@ -19,7 +19,7 @@ import Agora.Proposal (ProposalId (..))
import Data.Default.Class (Default (def)) import Data.Default.Class (Default (def))
import Sample.Governor (createProposal, mintGATs, mintGST, mutateState) import Sample.Governor (createProposal, mintGATs, mintGST, mutateState)
import Sample.Shared qualified as Shared import Sample.Shared qualified as Shared
import Spec.Spec ( import Spec.Specification (
SpecificationTree, SpecificationTree,
group, group,
policySucceedsWith, policySucceedsWith,

View file

@ -45,7 +45,7 @@ import PlutusTx.AssocMap qualified as AssocMap
import Sample.Proposal qualified as Proposal import Sample.Proposal qualified as Proposal
import Sample.Shared (signer, signer2) import Sample.Shared (signer, signer2)
import Sample.Shared qualified as Shared import Sample.Shared qualified as Shared
import Spec.Spec ( import Spec.Specification (
SpecificationTree, SpecificationTree,
group, group,
policySucceedsWith, policySucceedsWith,

View file

@ -1,11 +1,39 @@
module Spec.Spec ( {- |
Module : Spec.Specification
Maintainer : seungheon.ooh@gmail.com
Description: Helpers to build Specification for testing and bench-marking
Constructors for building a specification for Plutarch scripts:
- 'policySucceedsWith': checks that a minting policy succeeds.
- 'policyFailsWith': checks that a minting policy fails.
- 'validatorSucceedsWith': checks that validator succeeds.
- 'validatorFailsWith': checks that validator fails.
- 'effectSucceedsWith': checks that effect succeeds.
- 'effectFailsWith': checks that effect fails.
- 'scriptSucceeds': checks that an arbitrary script does not
`perror`.
- 'scriptFails': checks that an arbitrary script `perror`s out.
-}
module Spec.Specification (
-- * Structures
Specification (..), Specification (..),
SpecificationExpectation (..), SpecificationExpectation (..),
SpecificationTree (..), SpecificationTree (..),
-- * Spec helpers
group, group,
toTestTree,
getSpecification, getSpecification,
getSpecificationTree, getSpecificationTree,
-- * Spec builders
scriptSucceeds, scriptSucceeds,
scriptFails, scriptFails,
policySucceedsWith, policySucceedsWith,
@ -14,6 +42,9 @@ module Spec.Spec (
validatorFailsWith, validatorFailsWith,
effectSucceedsWith, effectSucceedsWith,
effectFailsWith, effectFailsWith,
-- * Converters
toTestTree,
) where ) where
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
@ -26,12 +57,20 @@ import PlutusTx.IsData qualified as PlutusTx (ToData)
import Test.Tasty (TestTree, testGroup) import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertFailure, testCase) import Test.Tasty.HUnit (assertFailure, testCase)
{-| Expectations upon execution of script
@Success@ indicates a successful execution.
@Failure@ inidcates a faulty execution.
@FailureWith@ indicates a faulty execution but with expected reason for failure.
-}
data SpecificationExpectation data SpecificationExpectation
= Success = Success
| Failure | Failure
| FailureWith String | FailureWith String
deriving stock (Show) deriving stock (Show)
{-| Unit of specification. @Specification@ holds name, expectation, and
script to be tested or executed later on.
-}
data Specification = Specification data Specification = Specification
{ sName :: String { sName :: String
, sExpectation :: SpecificationExpectation , sExpectation :: SpecificationExpectation
@ -39,20 +78,25 @@ data Specification = Specification
} }
deriving stock (Show) deriving stock (Show)
-- | Tree-structure to group alike specifications--modeled after @TestTree@ from tasty.
data SpecificationTree data SpecificationTree
= Terminal Specification = Terminal Specification
| Group String [SpecificationTree] | Group String [SpecificationTree]
deriving stock (Show) deriving stock (Show)
-- | Checks if given name exists in @SpecificationTree@ as either
-- group name or specification name.
exists :: String -> SpecificationTree -> Bool exists :: String -> SpecificationTree -> Bool
exists s (Terminal (Specification name _ _)) = s == name exists s (Terminal (Specification name _ _)) = s == name
exists s (Group name st) = or (exists s <$> st) || s == name exists s (Group name st) = or (exists s <$> st) || s == name
-- | Groups alike @SpecificationTree@s into a bigger tree.
group :: String -> [SpecificationTree] -> SpecificationTree group :: String -> [SpecificationTree] -> SpecificationTree
group name st group name st
| or $ exists name <$> st = error $ "Name already exists: " <> name | or $ exists name <$> st = error $ "Name already exists: " <> name
| otherwise = Group name st | otherwise = Group name st
-- | Query specific @Specification@ from a tree.
getSpecification :: String -> SpecificationTree -> Maybe Specification getSpecification :: String -> SpecificationTree -> Maybe Specification
getSpecification name (Terminal spec@(Specification sn _ _)) getSpecification name (Terminal spec@(Specification sn _ _))
| name == sn = Just spec | name == sn = Just spec
@ -63,6 +107,7 @@ getSpecification name (Group _ st)
where where
specs = catMaybes $ getSpecification name <$> st specs = catMaybes $ getSpecification name <$> st
-- | Query specific @SpecificationTree@ from a tree.
getSpecificationTree :: String -> SpecificationTree -> Maybe SpecificationTree getSpecificationTree :: String -> SpecificationTree -> Maybe SpecificationTree
getSpecificationTree name specTree@(Group gn st) getSpecificationTree name specTree@(Group gn st)
| gn == name = Just specTree | gn == name = Just specTree
@ -72,6 +117,7 @@ getSpecificationTree name specTree@(Group gn st)
trees = catMaybes $ getSpecificationTree name <$> st trees = catMaybes $ getSpecificationTree name <$> st
getSpecificationTree _ _ = Nothing getSpecificationTree _ _ = Nothing
-- | Convert @SpecificationTree@ into @TestTree@ to be used as a unit test.
toTestTree :: SpecificationTree -> TestTree toTestTree :: SpecificationTree -> TestTree
toTestTree (Group name st) = testGroup name $ toTestTree <$> st toTestTree (Group name st) = testGroup name $ toTestTree <$> st
toTestTree (Terminal (Specification name expectation script)) = toTestTree (Terminal (Specification name expectation script)) =
@ -103,12 +149,15 @@ toTestTree (Terminal (Specification name expectation script)) =
<> ts <> ts
_ -> pure () _ -> pure ()
-- | Check that an arbitrary script doesn't error when evaluated, given a name.
scriptSucceeds :: String -> Script -> SpecificationTree scriptSucceeds :: String -> Script -> SpecificationTree
scriptSucceeds name script = Terminal $ Specification name Success script scriptSucceeds name script = Terminal $ Specification name Success script
-- | Check that an arbitrary script **does** error when evaluated, given a name.
scriptFails :: String -> Script -> SpecificationTree scriptFails :: String -> Script -> SpecificationTree
scriptFails name script = Terminal $ Specification name Failure script scriptFails name script = Terminal $ Specification name Failure script
-- | Check that a policy script succeeds, given a name and arguments.
policySucceedsWith :: policySucceedsWith ::
( PLift redeemer ( PLift redeemer
, PlutusTx.ToData (PLifted redeemer) , PlutusTx.ToData (PLifted redeemer)
@ -125,7 +174,8 @@ policySucceedsWith tag policy redeemer scriptContext =
# pforgetData (pconstantData redeemer) # pforgetData (pconstantData redeemer)
# pconstant scriptContext # pconstant scriptContext
) )
-- | Check that a policy script fails, given a name and arguments.
policyFailsWith :: policyFailsWith ::
( PLift redeemer ( PLift redeemer
, PlutusTx.ToData (PLifted redeemer) , PlutusTx.ToData (PLifted redeemer)
@ -142,7 +192,8 @@ policyFailsWith tag policy redeemer scriptContext =
# pforgetData (pconstantData redeemer) # pforgetData (pconstantData redeemer)
# pconstant scriptContext # pconstant scriptContext
) )
-- | Check that a validator script succeeds, given a name and arguments.
validatorSucceedsWith :: validatorSucceedsWith ::
( PLift datum ( PLift datum
, PlutusTx.ToData (PLifted datum) , PlutusTx.ToData (PLifted datum)
@ -164,6 +215,7 @@ validatorSucceedsWith tag validator datum redeemer scriptContext =
# pconstant scriptContext # pconstant scriptContext
) )
-- | Check that a validator script fails, given a name and arguments.
validatorFailsWith :: validatorFailsWith ::
( PLift datum ( PLift datum
, PlutusTx.ToData (PLifted datum) , PlutusTx.ToData (PLifted datum)
@ -185,6 +237,7 @@ validatorFailsWith tag validator datum redeemer scriptContext =
# pconstant scriptContext # pconstant scriptContext
) )
-- | Check that an effect succeeds, given a name and argument.
effectSucceedsWith :: effectSucceedsWith ::
( PLift datum ( PLift datum
, PlutusTx.ToData (PLifted datum) , PlutusTx.ToData (PLifted datum)
@ -196,6 +249,7 @@ effectSucceedsWith ::
SpecificationTree SpecificationTree
effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum () effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum ()
-- | Check that an effect fails, given a name and argument.
effectFailsWith :: effectFailsWith ::
( PLift datum ( PLift datum
, PlutusTx.ToData (PLifted datum) , PlutusTx.ToData (PLifted datum)

View file

@ -22,7 +22,7 @@ import Agora.Stake.Scripts (stakePolicy, stakeValidator)
import Sample.Stake (DepositWithdrawExample (DepositWithdrawExample, delta, startAmount), signer) import Sample.Stake (DepositWithdrawExample (DepositWithdrawExample, delta, startAmount), signer)
import Sample.Stake qualified as Stake import Sample.Stake qualified as Stake
import Spec.Spec ( import Spec.Specification (
SpecificationTree, SpecificationTree,
group, group,
policyFailsWith, policyFailsWith,

View file

@ -48,7 +48,7 @@ import Sample.Treasury (
validCtx, validCtx,
walletIn, walletIn,
) )
import Spec.Spec ( import Spec.Specification (
SpecificationTree, SpecificationTree,
group, group,
validatorFailsWith, validatorFailsWith,

View file

@ -17,7 +17,7 @@ import Spec.Stake qualified as Stake
import Spec.Treasury qualified as Treasury import Spec.Treasury qualified as Treasury
import Spec.Utils qualified as Utils import Spec.Utils qualified as Utils
import Spec.Spec (group, toTestTree) import Spec.Specification (group, toTestTree)
-- | The Agora test suite. -- | The Agora test suite.
main :: IO () main :: IO ()

View file

@ -182,13 +182,13 @@ library agora-sample
library agora-spec library agora-spec
import: lang, deps, test-deps import: lang, deps, test-deps
exposed-modules: exposed-modules:
Spec.Specification
Spec.AuthorityToken Spec.AuthorityToken
Spec.Effect.GovernorMutation Spec.Effect.GovernorMutation
Spec.Effect.TreasuryWithdrawal Spec.Effect.TreasuryWithdrawal
Spec.Governor Spec.Governor
Spec.Model.MultiSig Spec.Model.MultiSig
Spec.Proposal Spec.Proposal
Spec.Spec
Spec.Stake Spec.Stake
Spec.Treasury Spec.Treasury
Spec.Utils Spec.Utils