Merge pull request #94 from Liqwid-Labs/seungheonoh/genericSpecInterface

Specs for benchmarking

agora-bench/Bench.hs

@@ -1,12 +1,29 @@
-module Bench (Benchmark (..), benchmarkSize) where
+{-# LANGUAGE RecordWildCards #-}
+
+module Bench (Benchmark (..), benchmarkScript, specificationTreeToBenchmarks) where
 
 import Codec.Serialise (serialise)
 import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString.Short qualified as SBS
-import Data.Set (Set)
+import Data.Csv (DefaultOrdered, ToNamedRecord, header, headerOrder, namedRecord, toNamedRecord, (.=))
-import Data.Set qualified as Set
+import Data.List (intercalate)
-import Data.Text (Text)
+import Data.Maybe (fromJust)
-import Plutus.V1.Ledger.Scripts qualified as Plutus
+import Data.Text (Text, pack)
+import GHC.Generics (Generic)
+import Plutus.V1.Ledger.Api (
+  ExBudget (ExBudget),
+  ExCPU (..),
+  ExMemory (..),
+  Script,
+ )
+import Plutus.V1.Ledger.Api qualified as Plutus
+import Prettyprinter (Pretty (pretty), indent, vsep)
+
+import Spec.Specification (
+  Specification (Specification),
+  SpecificationExpectation (Success),
+  SpecificationTree (..),
+ )
 
 --------------------------------------------------------------------------------
 
@@ -14,20 +31,59 @@ import Plutus.V1.Ledger.Scripts qualified as Plutus
 data Benchmark = Benchmark
   { name :: Text
   -- ^ Human readable name describing script.
-  , size :: Int
+  , cpuBudget :: ExCPU
+  -- ^ The on-chain execution cost of a script.
+  , memoryBudget :: ExMemory
+  -- ^ The on-chain memory budget of a script.
+  , scriptSize :: Int
   -- ^ The on-chain size of a script.
   }
-  deriving stock (Show, Eq, Ord)
+  deriving stock (Show, Eq, Ord, Generic)
 
--- | Create a benchmark containing only the size of the script.
+instance Pretty Benchmark where
-benchmarkSize :: Text -> Plutus.Script -> Set Benchmark
+  pretty (Benchmark name (ExCPU (toInteger -> cpu)) (ExMemory (toInteger -> mem)) size) =
-benchmarkSize name script =
+    vsep
-  Set.singleton $
+      [ pretty name
-    Benchmark
+      , indent 4 $
-      { name = name
+          vsep
-      , size = scriptSize script
+            [ "CPU: " <> pretty cpu
-      }
+            , "MEM: " <> pretty mem
+            , "SIZE: " <> pretty size
+            ]
+      ]
 
--- | Compute the size of a script on-chain.
+instance ToNamedRecord Benchmark where
-scriptSize :: Plutus.Script -> Int
+  toNamedRecord (Benchmark {..}) =
-scriptSize = SBS.length . SBS.toShort . LBS.toStrict . serialise
+    namedRecord
+      [ "name" .= name
+      , "cpu" .= cpuBudget
+      , "mem" .= memoryBudget
+      , "size" .= scriptSize
+      ]
+
+instance DefaultOrdered Benchmark where
+  headerOrder _ = header ["name", "cpu", "mem", "size"]
+
+benchmarkScript :: String -> Script -> Benchmark
+benchmarkScript name script = Benchmark (pack name) cpu mem size
+  where
+    (ExBudget cpu mem) = evalScriptCounting . serialiseScriptShort $ script
+    size = SBS.length . SBS.toShort . LBS.toStrict . serialise $ script
+
+    serialiseScriptShort :: Script -> SBS.ShortByteString
+    serialiseScriptShort = SBS.toShort . LBS.toStrict . serialise -- Using `flat` here breaks `evalScriptCounting`
+    evalScriptCounting :: Plutus.SerializedScript -> Plutus.ExBudget
+    evalScriptCounting script =
+      let costModel = fromJust Plutus.defaultCostModelParams
+          (_logout, e) = Plutus.evaluateScriptCounting Plutus.Verbose costModel script []
+       in case e of
+            Left evalError -> error ("Eval Error: " <> show evalError)
+            Right exbudget -> exbudget
+
+specificationTreeToBenchmarks :: SpecificationTree -> [Benchmark]
+specificationTreeToBenchmarks = go []
+  where
+    go names (Terminal ((Specification n ex s))) = case ex of
+      Success -> [benchmarkScript (intercalate "/" (names <> [n])) s]
+      _ -> []
+    go names (Group gn tree) = mconcat $ go (names <> [gn]) <$> tree

agora-bench/Main.hs

@@ -1,42 +1,43 @@
 module Main (main) where
 
-import Agora.AuthorityToken (authorityTokenPolicy)
+import Bench (specificationTreeToBenchmarks)
-import Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalValidator)
+import Data.Csv (encodeDefaultOrderedByName)
-import Agora.Governor (Governor (..))
+import Data.Text.Lazy.Encoding (decodeUtf8)
-import Agora.Governor.Scripts (governorPolicy, governorValidator)
+import Data.Text.Lazy.IO as I (writeFile)
-import Agora.Proposal.Scripts (proposalPolicy, proposalValidator)
+import Prettyprinter (defaultLayoutOptions, layoutPretty, pretty)
-import Agora.Stake.Scripts (stakePolicy, stakeValidator)
+import Prettyprinter.Render.String (renderString)
-import Agora.Treasury (treasuryValidator)
+import Spec.AuthorityToken qualified as AuthorityToken
-import Bench
+import Spec.Effect.GovernorMutation qualified as GovernorMutation
-import Data.Foldable (for_)
+import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal
-import Plutus.V1.Ledger.Api (CurrencySymbol)
+import Spec.Governor qualified as Governor
-import Sample.Shared
+import Spec.Proposal qualified as Proposal
+import Spec.Specification (group)
+import Spec.Stake qualified as Stake
+import Spec.Treasury qualified as Treasury
 import Prelude
 
 --------------------------------------------------------------------------------
 
 main :: IO ()
 main = do
-  let benchmarks =
+  I.writeFile "bench.csv" $
-        mconcat
+    (decodeUtf8 . encodeDefaultOrderedByName) res
-          [ -- GATs
+
-            benchmarkSize "authorityTokenPolicy" $ compile $ authorityTokenPolicy authorityToken
+  mapM_ (putStrLn . renderString . layoutPretty defaultLayoutOptions . pretty) res
-          , -- Governor
+  where
-            benchmarkSize "governorValidator" $ compile $ governorValidator governor
+    res =
-          , benchmarkSize "governorPolicy" $ compile $ governorPolicy governor
+      specificationTreeToBenchmarks $
-          , -- Stake
+        group
-            benchmarkSize "stakeValidator" $ compile $ stakeValidator stake
+          "Agora"
-          , benchmarkSize "stakePolicy" $ compile $ stakePolicy governor.gtClassRef
+          [ group
-          , -- Proposal
+              "Effects"
-            benchmarkSize "proposalValidator" $ compile $ proposalValidator proposal
+              [ group "Treasury Withdrawal Effect" TreasuryWithdrawal.specs
-          , benchmarkSize "proposalPolicy" $ compile $ proposalPolicy govAssetClass
+              , group "Governor Mutation Effect" GovernorMutation.specs
-          , -- Treasury
+              ]
-            benchmarkSize "treasuryValidator" $ compile $ treasuryValidator gatCS
+          , group "Stake" Stake.specs
-          , -- Effect validators
+          , group "Proposal" Proposal.specs
-            benchmarkSize "treasuryWithdrawalValidator" $ compile $ treasuryWithdrawalValidator gatCS
+          , group "AuthorityToken" AuthorityToken.specs
+          , group "Treasury" Treasury.specs
+          , group "AuthorityToken" AuthorityToken.specs
+          , group "Governor" Governor.specs
           ]
-
-  for_ benchmarks print
-
-gatCS :: CurrencySymbol
-gatCS = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" -- arbitrary CS

agora-spec/Spec/AuthorityToken.hs

@@ -7,13 +7,12 @@ Description: Tests for Authority token functions
 
 Tests for Authority token functions
 -}
-module Spec.AuthorityToken (tests) where
+module Spec.AuthorityToken (specs) where
 
 --------------------------------------------------------------------------------
 
 import Agora.AuthorityToken (singleAuthorityTokenBurned)
 import Plutarch
-import Test.Tasty (TestTree, testGroup)
 import Prelude
 
 --------------------------------------------------------------------------------
@@ -33,7 +32,12 @@ import Plutus.V1.Ledger.Api (
 import Plutus.V1.Ledger.Interval qualified as Interval
 import Plutus.V1.Ledger.Value qualified as Value
 import PlutusTx.AssocMap qualified as AssocMap
-import Test.Util (scriptFails, scriptSucceeds)
+import Spec.Specification (
+  SpecificationTree,
+  group,
+  scriptFails,
+  scriptSucceeds,
+ )
 
 currencySymbol :: CurrencySymbol
 currencySymbol = "deadbeef"
@@ -65,10 +69,10 @@ singleAuthorityTokenBurnedTest mint outs =
           perror
    in compile s
 
-tests :: [TestTree]
+specs :: [SpecificationTree]
-tests =
+specs =
   [ -- This is better suited for plutarch-test
-    testGroup
+    group
       "singleAuthorityTokenBurned"
       [ scriptSucceeds
           "Correct simple"

agora-spec/Spec/Effect/GovernorMutation.hs

@@ -1,4 +1,4 @@
-module Spec.Effect.GovernorMutation (tests) where
+module Spec.Effect.GovernorMutation (specs) where
 
 import Agora.Effect.GovernorMutation (mutateGovernorValidator)
 import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
@@ -15,14 +15,20 @@ import Sample.Effect.GovernorMutation (
   validNewGovernorDatum,
  )
 import Sample.Shared qualified as Shared
-import Test.Tasty (TestTree, testGroup)
+import Spec.Specification (
-import Test.Util (effectFailsWith, effectSucceedsWith, validatorFailsWith, validatorSucceedsWith)
+  SpecificationTree,
+  effectFailsWith,
+  effectSucceedsWith,
+  group,
+  validatorFailsWith,
+  validatorSucceedsWith,
+ )
 
-tests :: [TestTree]
+specs :: [SpecificationTree]
-tests =
+specs =
-  [ testGroup
+  [ group
       "validator"
-      [ testGroup
+      [ group
           "valid new governor datum"
           [ validatorSucceedsWith
               "governor validator should pass"
@@ -44,7 +50,7 @@ tests =
               (mkEffectDatum validNewGovernorDatum)
               (ScriptContext (mkEffectTxInfo validNewGovernorDatum) (Spending effectRef))
           ]
-      , testGroup
+      , group
           "invalid new governor datum"
           [ validatorFailsWith
               "governor validator should fail"

agora-spec/Spec/Effect/TreasuryWithdrawal.hs

@@ -3,9 +3,9 @@ Module     : Spec.Effect.TreasuryWithdrawalEffect
 Maintainer : seungheon.ooh@gmail.com
 Description: Sample based testing for Treasury Withdrawal Effect
 
-This module tests the Treasury Withdrawal Effect.
+This module specs the Treasury Withdrawal Effect.
 -}
-module Spec.Effect.TreasuryWithdrawal (tests) where
+module Spec.Effect.TreasuryWithdrawal (specs) where
 
 import Agora.Effect.TreasuryWithdrawal (
   TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
@@ -25,12 +25,16 @@ import Sample.Effect.TreasuryWithdrawal (
   treasuries,
   users,
  )
-import Test.Tasty (TestTree, testGroup)
+import Spec.Specification (
-import Test.Util (effectFailsWith, effectSucceedsWith)
+  SpecificationTree,
+  effectFailsWith,
+  effectSucceedsWith,
+  group,
+ )
 
-tests :: [TestTree]
+specs :: [SpecificationTree]
-tests =
+specs =
-  [ testGroup
+  [ group
       "effect"
       [ effectSucceedsWith
           "Simple"

agora-spec/Spec/Governor.hs

@@ -3,7 +3,7 @@ Module     : Spec.Governor
 Maintainer : connor@mlabs.city
 Description: Tests for Agora governor.
 
-Thie module exports `tests`, a list of `TestTree`s, which ensure
+Thie module exports `specs`, a list of `TestTree`s, which ensure
 that Agora's governor component workds as intended.
 
 Tests should pass when the validator or policy is given one of the
@@ -11,7 +11,7 @@ valid script contexts, which are defined in 'Agora.Sample.Governor'.
 
 TODO: Add negative test cases, see [#76](https://github.com/Liqwid-Labs/agora/issues/76).
 -}
-module Spec.Governor (tests) where
+module Spec.Governor (specs) where
 
 import Agora.Governor (GovernorDatum (..), GovernorRedeemer (..))
 import Agora.Governor.Scripts (governorPolicy, governorValidator)
@@ -19,14 +19,18 @@ import Agora.Proposal (ProposalId (..))
 import Data.Default.Class (Default (def))
 import Sample.Governor (createProposal, mintGATs, mintGST, mutateState)
 import Sample.Shared qualified as Shared
-import Test.Tasty (TestTree, testGroup)
+import Spec.Specification (
-import Test.Util (policySucceedsWith, validatorSucceedsWith)
+  SpecificationTree,
+  group,
+  policySucceedsWith,
+  validatorSucceedsWith,
+ )
 
 --------------------------------------------------------------------------------
 
-tests :: [TestTree]
+specs :: [SpecificationTree]
-tests =
+specs =
-  [ testGroup
+  [ group
       "policy"
       [ policySucceedsWith
           "GST minting"
@@ -34,7 +38,7 @@ tests =
           ()
           mintGST
       ]
-  , testGroup
+  , group
       "validator"
       [ validatorSucceedsWith
           "proposal creation"

agora-spec/Spec/Proposal.hs

@@ -7,7 +7,7 @@ Description: Tests for Proposal policy and validator
 
 Tests for Proposal policy and validator
 -}
-module Spec.Proposal (tests) where
+module Spec.Proposal (specs) where
 
 --------------------------------------------------------------------------------
 
@@ -45,15 +45,19 @@ import PlutusTx.AssocMap qualified as AssocMap
 import Sample.Proposal qualified as Proposal
 import Sample.Shared (signer, signer2)
 import Sample.Shared qualified as Shared
-import Test.Tasty (TestTree, testGroup)
+import Spec.Specification (
-import Test.Util (policySucceedsWith, validatorSucceedsWith)
+  SpecificationTree,
+  group,
+  policySucceedsWith,
+  validatorSucceedsWith,
+ )
 
 --------------------------------------------------------------------------------
 
--- | Stake tests.
+-- | Stake specs.
-tests :: [TestTree]
+specs :: [SpecificationTree]
-tests =
+specs =
-  [ testGroup
+  [ group
       "policy"
       [ policySucceedsWith
           "proposalCreation"
@@ -61,9 +65,9 @@ tests =
           ()
           Proposal.proposalCreation
       ]
-  , testGroup
+  , group
       "validator"
-      [ testGroup
+      [ group
           "cosignature"
           [ validatorSucceedsWith
               "proposal"
@@ -97,7 +101,7 @@ tests =
               WitnessStake
               (ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.stakeRef))
           ]
-      , testGroup
+      , group
           "voting"
           [ validatorSucceedsWith
               "proposal"

agora-spec/Spec/Specification.hs

@@ -0,0 +1,255 @@
+{- |
+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 (..),
+  SpecificationExpectation (..),
+  SpecificationTree (..),
+
+  -- * Spec helpers
+  group,
+  getSpecification,
+  getSpecificationTree,
+
+  -- * Spec builders
+  scriptSucceeds,
+  scriptFails,
+  policySucceedsWith,
+  policyFailsWith,
+  validatorSucceedsWith,
+  validatorFailsWith,
+  effectSucceedsWith,
+  effectFailsWith,
+
+  -- * Converters
+  toTestTree,
+) where
+
+import Plutarch.Api.V1 (PMintingPolicy, PValidator)
+import Plutarch.Builtin (pforgetData)
+import Plutarch.Evaluate (evalScript)
+import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
+import Plutus.V1.Ledger.Api (Script, ScriptContext)
+import PlutusTx.IsData qualified as PlutusTx (ToData)
+import Test.Tasty (TestTree, testGroup)
+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
+  = Success
+  | Failure
+  | FailureWith String
+  deriving stock (Show)
+
+{- | Unit of specification. @Specification@ holds name, expectation, and
+  script to be tested or executed later on.
+-}
+data Specification = Specification
+  { sName :: String
+  , sExpectation :: SpecificationExpectation
+  , sScript :: Script
+  }
+  deriving stock (Show)
+
+-- | Tree-structure to group alike specifications--modeled after @TestTree@ from tasty.
+data SpecificationTree
+  = Terminal Specification
+  | Group String [SpecificationTree]
+  deriving stock (Show)
+
+{- | Checks if given name exists in @SpecificationTree@ as either
+ group name or specification name.
+-}
+exists :: String -> SpecificationTree -> Bool
+exists s (Terminal (Specification name _ _)) = 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 name st
+  | or $ exists name <$> st = error $ "Name already exists: " <> name
+  | otherwise = Group name st
+
+-- | Query specific @Specification@ from a tree.
+getSpecification :: String -> SpecificationTree -> [Specification]
+getSpecification name (Terminal spec@(Specification sn _ _))
+  | name == sn = [spec]
+  | otherwise = []
+getSpecification name (Group _ st) = mconcat $ getSpecification name <$> st
+
+-- | Query specific @SpecificationTree@ from a tree.
+getSpecificationTree :: String -> SpecificationTree -> [SpecificationTree]
+getSpecificationTree name specTree@(Group gn st)
+  | gn == name = [specTree]
+  | otherwise = mconcat $ getSpecificationTree name <$> st
+getSpecificationTree _ _ = []
+
+-- | Convert @SpecificationTree@ into @TestTree@ to be used as a unit test.
+toTestTree :: SpecificationTree -> TestTree
+toTestTree (Group name st) = testGroup name $ toTestTree <$> st
+toTestTree (Terminal (Specification name expectation script)) =
+  testCase name $ do
+    case expectation of
+      Success -> onSuccess
+      Failure -> onFailure
+      FailureWith s -> onFailureWith s
+  where
+    (res, _budget, traces) = evalScript script
+    ts = " Traces: " <> show traces
+    onSuccess = case res of
+      Left e ->
+        assertFailure $
+          show e <> ts
+      _ -> pure ()
+    onFailure = case res of
+      Right v ->
+        assertFailure $
+          "Expected failure, but succeeded. "
+            <> show v
+            <> ts
+      _ -> pure ()
+    onFailureWith _s = case res of -- TODO: check Trace for this
+      Right v ->
+        assertFailure $
+          "Expected failure, but succeeded. "
+            <> show v
+            <> ts
+      _ -> pure ()
+
+-- | Check that an arbitrary script doesn't error when evaluated, given a name.
+scriptSucceeds :: String -> Script -> SpecificationTree
+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 name script = Terminal $ Specification name Failure script
+
+-- | Check that a policy script succeeds, given a name and arguments.
+policySucceedsWith ::
+  ( PLift redeemer
+  , PlutusTx.ToData (PLifted redeemer)
+  ) =>
+  String ->
+  ClosedTerm PMintingPolicy ->
+  PLifted redeemer ->
+  ScriptContext ->
+  SpecificationTree
+policySucceedsWith tag policy redeemer scriptContext =
+  scriptSucceeds tag $
+    compile
+      ( policy
+          # pforgetData (pconstantData redeemer)
+          # pconstant scriptContext
+      )
+
+-- | Check that a policy script fails, given a name and arguments.
+policyFailsWith ::
+  ( PLift redeemer
+  , PlutusTx.ToData (PLifted redeemer)
+  ) =>
+  String ->
+  ClosedTerm PMintingPolicy ->
+  PLifted redeemer ->
+  ScriptContext ->
+  SpecificationTree
+policyFailsWith tag policy redeemer scriptContext =
+  scriptFails tag $
+    compile
+      ( policy
+          # pforgetData (pconstantData redeemer)
+          # pconstant scriptContext
+      )
+
+-- | Check that a validator script succeeds, given a name and arguments.
+validatorSucceedsWith ::
+  ( PLift datum
+  , PlutusTx.ToData (PLifted datum)
+  , PLift redeemer
+  , PlutusTx.ToData (PLifted redeemer)
+  ) =>
+  String ->
+  ClosedTerm PValidator ->
+  PLifted datum ->
+  PLifted redeemer ->
+  ScriptContext ->
+  SpecificationTree
+validatorSucceedsWith tag validator datum redeemer scriptContext =
+  scriptSucceeds tag $
+    compile
+      ( validator
+          # pforgetData (pconstantData datum)
+          # pforgetData (pconstantData redeemer)
+          # pconstant scriptContext
+      )
+
+-- | Check that a validator script fails, given a name and arguments.
+validatorFailsWith ::
+  ( PLift datum
+  , PlutusTx.ToData (PLifted datum)
+  , PLift redeemer
+  , PlutusTx.ToData (PLifted redeemer)
+  ) =>
+  String ->
+  ClosedTerm PValidator ->
+  PLifted datum ->
+  PLifted redeemer ->
+  ScriptContext ->
+  SpecificationTree
+validatorFailsWith tag validator datum redeemer scriptContext =
+  scriptFails tag $
+    compile
+      ( validator
+          # pforgetData (pconstantData datum)
+          # pforgetData (pconstantData redeemer)
+          # pconstant scriptContext
+      )
+
+-- | Check that an effect succeeds, given a name and argument.
+effectSucceedsWith ::
+  ( PLift datum
+  , PlutusTx.ToData (PLifted datum)
+  ) =>
+  String ->
+  ClosedTerm PValidator ->
+  PLifted datum ->
+  ScriptContext ->
+  SpecificationTree
+effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum ()
+
+-- | Check that an effect fails, given a name and argument.
+effectFailsWith ::
+  ( PLift datum
+  , PlutusTx.ToData (PLifted datum)
+  ) =>
+  String ->
+  ClosedTerm PValidator ->
+  PLifted datum ->
+  ScriptContext ->
+  SpecificationTree
+effectFailsWith tag eff datum = validatorFailsWith tag eff datum ()

agora-spec/Spec/Stake.hs

@@ -7,7 +7,7 @@ Description: Tests for Stake policy and validator
 
 Tests for Stake policy and validator
 -}
-module Spec.Stake (tests) where
+module Spec.Stake (specs) where
 
 --------------------------------------------------------------------------------
 
@@ -15,10 +15,6 @@ import Prelude
 
 --------------------------------------------------------------------------------
 
-import Test.Tasty (TestTree, testGroup)
-
---------------------------------------------------------------------------------
-
 import Agora.Stake (Stake (..), StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw))
 import Agora.Stake.Scripts (stakePolicy, stakeValidator)
 
@@ -26,14 +22,21 @@ import Agora.Stake.Scripts (stakePolicy, stakeValidator)
 
 import Sample.Stake (DepositWithdrawExample (DepositWithdrawExample, delta, startAmount), signer)
 import Sample.Stake qualified as Stake
-import Test.Util (policyFailsWith, policySucceedsWith, toDatum, validatorFailsWith, validatorSucceedsWith)
+import Spec.Specification (
+  SpecificationTree,
+  group,
+  policyFailsWith,
+  policySucceedsWith,
+  validatorFailsWith,
+  validatorSucceedsWith,
+ )
+import Test.Util (toDatum)
 
 --------------------------------------------------------------------------------
 
--- | Stake tests.
+specs :: [SpecificationTree]
-tests :: [TestTree]
+specs =
-tests =
+  [ group
-  [ testGroup
       "policy"
       [ policySucceedsWith
           "stakeCreation"
@@ -51,7 +54,7 @@ tests =
           ()
           Stake.stakeCreationUnsigned
       ]
-  , testGroup
+  , group
       "validator"
       [ validatorSucceedsWith
           "stakeDepositWithdraw deposit"

agora-spec/Spec/Treasury.hs

@@ -5,7 +5,7 @@ Module: Spec.Treasury
 Description: Tests for Agora treasury.
 Maintainer: jack@mlabs.city
 
-This module exports `tests`, a list of `TestTree`s, which ensure
+This module exports `specs`, a list of `TestTree`s, which ensure
 that Agora's treasury component works as desired.
 
 Tests need to fail when:
@@ -19,7 +19,7 @@ Tests need to fail when:
       ii. A script has a GAT, the token name for which does /not/
           match the script's validator hash.
 -}
-module Spec.Treasury (tests) where
+module Spec.Treasury (specs) where
 
 import Agora.Treasury (
   TreasuryRedeemer (SpendTreasuryGAT),
@@ -48,14 +48,18 @@ import Sample.Treasury (
   validCtx,
   walletIn,
  )
-import Test.Tasty (TestTree, testGroup)
+import Spec.Specification (
-import Test.Util (validatorFailsWith, validatorSucceedsWith)
+  SpecificationTree,
+  group,
+  validatorFailsWith,
+  validatorSucceedsWith,
+ )
 
-tests :: [TestTree]
+specs :: [SpecificationTree]
-tests =
+specs =
-  [ testGroup
+  [ group
       "Validator"
-      [ testGroup
+      [ group
           "Positive"
           [ validatorSucceedsWith
               "Allows for effect changes"
@@ -64,9 +68,9 @@ tests =
               SpendTreasuryGAT
               validCtx
           ]
-      , testGroup
+      , group
           "Negative"
-          [ testGroup
+          [ group
               "Fails with ScriptPurpose not Minting"
               [ validatorFailsWith
                   "Spending"

agora-test/README.org

@@ -1,11 +0,0 @@
-#+Title: Agora Test
-This folder is the test suite for Agora governance system.
-
-- =/Spec= contains different tests for different elements of Agora.
-- =/Spec/Model= contain =apropos-tx= model for logical suite
-  generation and tests.
-- =/Spec/Sample= contains primitive hand-made example values.
-- =Util.hs= contains helper functions
-
-Currently, planning to introduce =plutarch-test= for unit tests,
-benchmarks, and golden tests.

agora-test/Spec.hs

@@ -2,6 +2,7 @@ import Prelude
 
 --------------------------------------------------------------------------------
 
+import GHC.IO.Encoding (setLocaleEncoding, utf8)
 import Test.Tasty (defaultMain, testGroup)
 
 --------------------------------------------------------------------------------
@@ -16,39 +17,26 @@ import Spec.Stake qualified as Stake
 import Spec.Treasury qualified as Treasury
 import Spec.Utils qualified as Utils
 
+import Spec.Specification (group, toTestTree)
+
 -- | The Agora test suite.
 main :: IO ()
-main =
+main = do
+  setLocaleEncoding utf8
   defaultMain $
     testGroup
       "test suite"
       [ testGroup
           "Effects"
-          [ testGroup
+          [ toTestTree $ group "Treasury Withdrawal Effect" TreasuryWithdrawal.specs
-              "Treasury Withdrawal Effect"
+          , toTestTree $ group "Governor Mutation Effect" GovernorMutation.specs
-              TreasuryWithdrawal.tests
-          , testGroup
-              "Governor Mutation Effect"
-              GovernorMutation.tests
           ]
-      , testGroup
+      , toTestTree $ group "Stake tests" Stake.specs
-          "Stake tests"
+      , toTestTree $ group "Proposal tests" Proposal.specs
-          Stake.tests
+      , toTestTree $ group "AuthorityToken tests" AuthorityToken.specs
-      , testGroup
+      , toTestTree $ group "Treasury tests" Treasury.specs
-          "Proposal tests"
+      , toTestTree $ group "AuthorityToken tests" AuthorityToken.specs
-          Proposal.tests
+      , toTestTree $ group "Governor tests" Governor.specs
-      , testGroup
-          "AuthorityToken tests"
-          AuthorityToken.tests
-      , testGroup
-          "Treasury tests"
-          Treasury.tests
-      , testGroup
-          "AuthorityToken tests"
-          AuthorityToken.tests
-      , testGroup
-          "Governor tests"
-          Governor.tests
       , testGroup
           "Utility tests"
           Utils.tests

agora-testlib/Test/Util.hs

@@ -2,37 +2,8 @@
 Module     : Test.Util
 Maintainer : emi@haskell.fyi
 Description: Utility functions for testing Plutarch scripts with ScriptContext
-
-Utility functions for testing Plutarch scripts with ScriptContext:
-
-  - '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 Test.Util (
-  -- * Testing utils
-  scriptSucceeds,
-  scriptFails,
-  policySucceedsWith,
-  policyFailsWith,
-  validatorSucceedsWith,
-  validatorFailsWith,
-  effectSucceedsWith,
-  effectFailsWith,
-
   -- * Plutus-land utils
   datumHash,
   toDatum,
@@ -53,19 +24,9 @@ import Data.ByteString.Lazy qualified as ByteString.Lazy
 
 --------------------------------------------------------------------------------
 
-import Test.Tasty (TestTree)
-import Test.Tasty.HUnit (assertFailure, testCase)
-
---------------------------------------------------------------------------------
-
-import Plutarch.Api.V1 (PMintingPolicy, PValidator)
-import Plutarch.Builtin (pforgetData)
 import Plutarch.Crypto (pblake2b_256)
-import Plutarch.Evaluate (evalScript)
-import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
-import Plutus.V1.Ledger.Contexts (ScriptContext)
 import Plutus.V1.Ledger.Interval as PlutusTx
-import Plutus.V1.Ledger.Scripts (Datum (Datum), DatumHash (DatumHash), Script)
+import Plutus.V1.Ledger.Scripts (Datum (Datum), DatumHash (DatumHash))
 import PlutusTx.AssocMap qualified as AssocMap
 import PlutusTx.Builtins qualified as PlutusTx
 import PlutusTx.IsData qualified as PlutusTx
@@ -73,140 +34,6 @@ import PlutusTx.Ord qualified as PlutusTx
 
 --------------------------------------------------------------------------------
 
--- | Check that a policy script succeeds, given a name and arguments.
-policySucceedsWith ::
-  ( PLift redeemer
-  , PlutusTx.ToData (PLifted redeemer)
-  ) =>
-  String ->
-  ClosedTerm PMintingPolicy ->
-  PLifted redeemer ->
-  ScriptContext ->
-  TestTree
-policySucceedsWith tag policy redeemer scriptContext =
-  scriptSucceeds tag $
-    compile
-      ( policy
-          # pforgetData (pconstantData redeemer)
-          # pconstant scriptContext
-      )
-
--- | Check that a policy script fails, given a name and arguments.
-policyFailsWith ::
-  ( PLift redeemer
-  , PlutusTx.ToData (PLifted redeemer)
-  ) =>
-  String ->
-  ClosedTerm PMintingPolicy ->
-  PLifted redeemer ->
-  ScriptContext ->
-  TestTree
-policyFailsWith tag policy redeemer scriptContext =
-  scriptFails tag $
-    compile
-      ( policy
-          # pforgetData (pconstantData redeemer)
-          # pconstant scriptContext
-      )
-
--- | Check that a validator script succeeds, given a name and arguments.
-validatorSucceedsWith ::
-  ( PLift datum
-  , PlutusTx.ToData (PLifted datum)
-  , PLift redeemer
-  , PlutusTx.ToData (PLifted redeemer)
-  ) =>
-  String ->
-  ClosedTerm PValidator ->
-  PLifted datum ->
-  PLifted redeemer ->
-  ScriptContext ->
-  TestTree
-validatorSucceedsWith tag validator datum redeemer scriptContext =
-  scriptSucceeds tag $
-    compile
-      ( validator
-          # pforgetData (pconstantData datum)
-          # pforgetData (pconstantData redeemer)
-          # pconstant scriptContext
-      )
-
--- | Check that a validator script fails, given a name and arguments.
-validatorFailsWith ::
-  ( PLift datum
-  , PlutusTx.ToData (PLifted datum)
-  , PLift redeemer
-  , PlutusTx.ToData (PLifted redeemer)
-  ) =>
-  String ->
-  ClosedTerm PValidator ->
-  PLifted datum ->
-  PLifted redeemer ->
-  ScriptContext ->
-  TestTree
-validatorFailsWith tag validator datum redeemer scriptContext =
-  scriptFails tag $
-    compile
-      ( validator
-          # pforgetData (pconstantData datum)
-          # pforgetData (pconstantData redeemer)
-          # pconstant scriptContext
-      )
-
-{- | Check that a validator script succeeds, given a name and arguments.
-     TODO: Change docstring.
--}
-effectSucceedsWith ::
-  ( PLift datum
-  , PlutusTx.ToData (PLifted datum)
-  ) =>
-  String ->
-  ClosedTerm PValidator ->
-  PLifted datum ->
-  ScriptContext ->
-  TestTree
-effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum ()
-
--- TODO: Change docstring.
-
-{- | Check that a validator script fails, given a name and arguments.
-     TODO: Change docstring.
--}
-effectFailsWith ::
-  ( PLift datum
-  , PlutusTx.ToData (PLifted datum)
-  ) =>
-  String ->
-  ClosedTerm PValidator ->
-  PLifted datum ->
-  ScriptContext ->
-  TestTree
-effectFailsWith tag eff datum = validatorFailsWith tag eff datum ()
-
--- | Check that an arbitrary script doesn't error when evaluated, given a name.
-scriptSucceeds :: String -> Script -> TestTree
-scriptSucceeds name script = testCase name $ do
-  let (res, _budget, traces) = evalScript script
-  case res of
-    Left e -> do
-      assertFailure $
-        show e <> " Traces: " <> show traces
-    Right _v ->
-      pure ()
-
--- | Check that an arbitrary script **does** error when evaluated, given a name.
-scriptFails :: String -> Script -> TestTree
-scriptFails name script = testCase name $ do
-  let (res, _budget, traces) = evalScript script
-  case res of
-    Left _e ->
-      pure ()
-    Right v ->
-      assertFailure $
-        "Expected failure, but succeeded. " <> show v <> " Traces: " <> show traces
-
---------------------------------------------------------------------------------
-
 {- | Create a pair from data for use in 'txInfoData'.
 
    Example:

agora.cabal

@@ -179,26 +179,35 @@ library agora-sample
   hs-source-dirs:  agora-sample
   build-depends:   agora-testlib
 
-test-suite agora-test
+library agora-spec
-  import:         lang, deps, test-deps
+  import:          lang, deps, test-deps
-  type:           exitcode-stdio-1.0
+  exposed-modules:
-  main-is:        Spec.hs
-  hs-source-dirs: agora-test
-  other-modules:
     Spec.AuthorityToken
     Spec.Effect.GovernorMutation
     Spec.Effect.TreasuryWithdrawal
     Spec.Governor
     Spec.Model.MultiSig
     Spec.Proposal
+    Spec.Specification
     Spec.Stake
     Spec.Treasury
     Spec.Utils
 
+  hs-source-dirs:  agora-spec
   build-depends:
     , agora-sample
     , agora-testlib
 
+test-suite agora-test
+  import:         lang, deps, test-deps
+  type:           exitcode-stdio-1.0
+  main-is:        Spec.hs
+  hs-source-dirs: agora-test
+  build-depends:
+    , agora-sample
+    , agora-spec
+    , agora-testlib
+
 benchmark agora-bench
   import:         lang, deps
   hs-source-dirs: agora-bench
@@ -208,6 +217,8 @@ benchmark agora-bench
   build-depends:
     , agora
     , agora-sample
+    , agora-spec
+    , cassava
 
 executable agora-scripts
   import:         lang, deps, exe-opts

bench.csv

@@ -1,4 +1,23 @@
 name,cpu,mem,size
-full_scripts:authorityTokenPolicy,1756707,6000,841
+Agora/Effects/Treasury Withdrawal Effect/effect/Simple,340268715,724428,3050
-full_scripts:stakePolicy,3751498,12700,1610
+Agora/Effects/Treasury Withdrawal Effect/effect/Simple with multiple treasuries ,570029812,1211300,3377
-full_scripts:stakeValidator,3126265,10600,1500
+Agora/Effects/Treasury Withdrawal Effect/effect/Mixed Assets,502351827,1071087,3242
+Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass,103651824,228328,7681
+Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass,126986096,263635,3357
+Agora/Stake/policy/stakeCreation,60250773,128585,2144
+Agora/Stake/validator/stakeDepositWithdraw deposit,275919558,599033,4063
+Agora/Stake/validator/stakeDepositWithdraw withdraw,275919558,599033,4055
+Agora/Proposal/policy/proposalCreation,34571405,70066,1585
+Agora/Proposal/validator/cosignature/proposal,240007066,509127,4892
+Agora/Proposal/validator/cosignature/stake,185913543,402497,4600
+Agora/Proposal/validator/voting/proposal,238383906,489848,4900
+Agora/Proposal/validator/voting/stake,153804848,328239,4653
+Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,25177457,55883,806
+Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,40266637,88241,900
+Agora/Treasury/Validator/Positive/Allows for effect changes,37343572,79744,1841
+Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,25177457,55883,806
+Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,40266637,88241,900
+Agora/Governor/policy/GST minting,57648280,119961,1851
+Agora/Governor/validator/proposal creation,329287002,679689,8196
+Agora/Governor/validator/GATs minting,430385143,929607,8319
+Agora/Governor/validator/mutate governor state,100840784,222602,7738