rename/docstrings
This commit is contained in:
parent
7ee7d661ef
commit
7a599ffa35
10 changed files with 67 additions and 13 deletions
|
|
@ -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,
|
||||||
|
|
|
||||||
|
|
@ -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,
|
||||||
|
|
|
||||||
|
|
@ -25,7 +25,7 @@ import Sample.Effect.TreasuryWithdrawal (
|
||||||
treasuries,
|
treasuries,
|
||||||
users,
|
users,
|
||||||
)
|
)
|
||||||
import Spec.Spec (
|
import Spec.Specification (
|
||||||
SpecificationTree,
|
SpecificationTree,
|
||||||
effectFailsWith,
|
effectFailsWith,
|
||||||
effectSucceedsWith,
|
effectSucceedsWith,
|
||||||
|
|
|
||||||
|
|
@ -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,
|
||||||
|
|
|
||||||
|
|
@ -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,
|
||||||
|
|
|
||||||
|
|
@ -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)
|
||||||
|
|
@ -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,
|
||||||
|
|
|
||||||
|
|
@ -48,7 +48,7 @@ import Sample.Treasury (
|
||||||
validCtx,
|
validCtx,
|
||||||
walletIn,
|
walletIn,
|
||||||
)
|
)
|
||||||
import Spec.Spec (
|
import Spec.Specification (
|
||||||
SpecificationTree,
|
SpecificationTree,
|
||||||
group,
|
group,
|
||||||
validatorFailsWith,
|
validatorFailsWith,
|
||||||
|
|
|
||||||
|
|
@ -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 ()
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue