ci: add gitleaks workflow (Sulkta canonical)

Release 0.2.0

.forgejo/workflows/gitleaks.yml

@@ -0,0 +1,40 @@
+# .forgejo/workflows/gitleaks.yml
+#
+# Sulkta canonical gitleaks workflow. Drop a copy into every public repo at
+# `.forgejo/workflows/gitleaks.yml` after the Forgejo act_runner is registered
+# (task #295).
+#
+# Pairs with the pre-receive hook installed on every bare repo — that one is
+# the strict enforcement layer (rejects the push); this one provides the
+# per-PR red ✗ that branch-protection rules can require before merge.
+#
+# Layer 1 (this workflow): visible per-PR status, can be a required check.
+# Layer 2 (pre-receive hook): strict enforcement at the server.
+# Layer 3 (johnny5 cron sweep): nightly full-history sweep across all repos.
+
+name: gitleaks
+
+on:
+  push:
+  pull_request:
+
+jobs:
+  scan:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v4
+        with:
+          # Full history — gitleaks needs depth to scan a commit range.
+          fetch-depth: 0
+
+      - name: install gitleaks
+        run: |
+          curl -sSL -o gl.tar.gz \
+            https://github.com/gitleaks/gitleaks/releases/download/v8.21.2/gitleaks_8.21.2_linux_x64.tar.gz
+          tar xzf gl.tar.gz gitleaks
+          chmod +x gitleaks
+          ./gitleaks version
+
+      - name: scan
+        run: |
+          ./gitleaks detect --source . --no-banner --redact --verbose

.github/pull_request_template.md

@@ -1,11 +0,0 @@
-## Describe your changes
-
-## Relevant issues
-
-## Checklist before requesting a review.
-
-- [ ] I have ensured documentation and testing are thorough.
-- [ ] I have updated the changelog.
-- [ ] I have read [CONTRIBUTING.md](../CONTRIBUTING.md)
-- [ ] I have made sure the CI checks run using `nix run .#ci`.
-- [ ] I have followed the code standards to the best of my ability or have documented carefully where and why I haven't.

.gitignore

@@ -25,8 +25,3 @@ TAGS
 # Haddock files and Hoogle databases 
 haddock 
 hoo
-
-.pre-commit-config.yaml
-
-agora-test/goldens/agora.json
-agora-test/goldens/agoraDebug.json

CHANGELOG.md

@@ -4,193 +4,11 @@ This format is based on [Keep A Changelog](https://keepachangelog.com/en/1.0.0).
 
 ## Unreleased (Candidate for 1.0.0)
 
-### Added
-
-- Golden tests for the script exports.
-
-### Modified
-
-- For consistency and performance, the following data types are encoded as flat
-product as opposed to SoP now:
-
-  - `GovernorDatum`
-  - `ProposalThresholds`
-  - `ProposalTimingConfig`
-  - `MutateGovernorDatum`
-  - `TreasuryWithdrawalDatum`
-
-  Included by [#231](https://github.com/Liqwid-Labs/agora/pull/231)
-
-- Fix several vulnerabilities and bugs found by auditors.
-
-  Including:
-  - Stake locks can be removed without retracting votes. This is a bug
-    introduced in the refactoring of `premoveLocks` by #209.
-  - Stake can retract all votes in its cooldown period.
-  - Inconsistent delegate authority checking may fail in some cases, where the
-    delegate votes with own and delegated stakes.
-  
-  Included by [#212](https://github.com/Liqwid-Labs/agora/pull/212)
-
-- Mitigate potential DDoS attack(voting and unlocking repeatedly)
-
-  We fix this issue by posing cooldown time while retracting votes, encoded in  
-  `ProposalTimingConfig`'s `minStakeVotingTime` field. Also to make sure that
-  stake owners can unlock their stakes in s reasonable time, we pose a maximum
-  time range width requirement while voting, encoded in `ProposalTimingConfig`'s `votingTimeRangeMaxWidth` field.
-
-  Included by [#209](https://github.com/Liqwid-Labs/agora/pull/209)
-
-- Fix several vulnerabilities and bugs found by auditors.
-
-  Including:
-  - A bug that allows multiple GATs to be minted into a single UTxO and sent
-    to a malicious script.
-  - A bug that allows delegates to create or cosign proposals with delegated
-    stakes.
-  - Potential DDoS attack: calling `UnlockStake` without any stake.
-  - Potential DDoS attack: calling `UnlockStake` on a `VotingReady` proposal
-    without actually changing the votes.
-  - Ignore staking credential in proposal, stake and governor.
-  - Improve naming and doc strings to avoid confusion.
-
-  Included by [#208](https://github.com/Liqwid-Labs/agora/pull/208)
-
-- Allow delegates to vote and retract vote with their stakes along side with
-  stakes delegated to them in the same transaction.
-
-  Included by [#208](https://github.com/Liqwid-Labs/agora/pull/208)
-
-- Fix several vulnerabilities and bugs found in both proposal and governor scripts.
-
-  Including:
-
-  - Governor accepts fake stake UTxO, meaning that an attacker can DoS by
-    creating Proposals without passing the minimum GT limit.
-  - The proposal policy asserts that GST moves while minting PST, effectively
-    allowing attackers to create fake proposals.
-
-- Fix an exploit that allows arbitrary amount of SSTs to be minted. The attack is
-  very similar to the GAT one. See also the discussion in
-  [#202](https://github.com/Liqwid-Labs/agora/pull/202).
-
-  Included by [#203](https://github.com/Liqwid-Labs/agora/pull/203)
-
-- Fix an exploit that allows burning `m` legitimate GATs from faulty effect
-  validators to mint `n` (`n` < `m`) illegitimate GAT.
-
-  Included by [#203](https://github.com/Liqwid-Labs/agora/pull/203)
-
-- Fix several vulnerabilities and bugs found in both staking and proposal components.
-
-  Including:
-
-  - Proposal thresholds should be inclusively checked.
-  - Attackers can fail any voted-on/locked proposal, or fast track to `Finished`,
-    by constructing a transaction that has a very loose valid time range.
-  - The stake validator can be fooled by stakes that doesn't belong to itself, and
-    consequently allows attack to down vote without voting.
-  - Improve doc string of `authorityTokensValidIn` to avoid confusion.
-  - Rename proposal redeemer `Unlock` to `UnlockStake` to avoid confusion.
-
-  Included by [#200](https://github.com/Liqwid-Labs/agora/pull/200)
-
-- Fix a bug where `lockedBy` and `delegatedTo` fields of stake datums aren't checked
-  during the creation of stakes.
-
-  Included by [#199](https://github.com/Liqwid-Labs/agora/pull/199)
-
-- Fix several vulnerabilities and bugs found in staking components.
-  
-  Including:
-
-  - Stake state token can be taken away
-  - Privilege escalation: Acting on behalf of delegatee role + Unlocking delegated stakes
-  - Delegatee can steal delegated inputs
-  - Stake policy doesn't allow destroying multiple stakes
-
-  Included by [#195](https://github.com/Liqwid-Labs/agora/pull/195)
-
-- Place a lock the stake while cosigning a proposal.
-
-  NOTE: This changes how cosigning works. In particular, the stake has to be
-  spent instead of just presented in the reference inputs. Also, adding multiple
-  cosignatures in one tx is no longer possible.
-
-  Included by [#192](https://github.com/Liqwid-Labs/agora/pull/192)
-
-- Support voting/retracting votes with multiple stakes.
-
-  NOTE: Due to the fact that the order of stake locks is undefined, voting to
-   multiple proposals in a single tx is disallowed.
-  
-  Included by [#186](https://github.com/Liqwid-Labs/agora/pull/186)
-
-- Fix a bug that allows an attacker to send two or more GATs to an effect in the winning effect group.
-
-  Fixed by [#181](https://github.com/Liqwid-Labs/agora/pull/181)
-
-- Workaround `currentProposalTime` always returns `PNothing`, due to the fact
- that upper bound of `txInfoValidRange` is never closed.
-
-  Fixed by [#177](https://github.com/Liqwid-Labs/agora/pull/177)
-
-- Fixed governor validator always fail because of the 0 ADA entry in
- `txInfoF.mint`. (#174)
-
-  Fixed by [#175](https://github.com/Liqwid-Labs/agora/pull/175)
-
-- Standalone stake redeemers. This allows injecting custom validation logic to
-the stake validator easily. The behaviour of the default stake validator remains
- unchanged.
-
-  Included by [#172](https://github.com/Liqwid-Labs/agora/pull/172)
-
-- Witness stakes with reference input. Stake redeemer `WitnessStake` is removed.
-
-  Included by [#168](https://github.com/Liqwid-Labs/agora/pull/168)
-
-- `tracing` flag in `ScriptParams` of `agora-scripts` to enable/disable tracing in exported scripts.
-
-  NOTE: This changes the representation of `ScriptParams`. In order to preserve old behavior, the flag
-  must be set to `True`.
-  
-  Included by [#167](https://github.com/Liqwid-Labs/agora/pull/167).
-
-- `effects` of `Proposaldatum` is now required to be sorted in ascending order. The uniqueness of result tags is also guaranteed.
-
-  `ProposalVotes` should be sorted the same way as a result.
-
-- AuthCheck script is used for tagging GAT TokenName instead of effect script
-  it is deployed at.
-  
-  Included by [#161](https://github.com/Liqwid-Labs/agora/pull/161).
-
-- Use `Credential` instead of `PubKeyHash`
-
-  Included by [#158](https://github.com/Liqwid-Labs/agora/pull/158).
-
-  NOTE: This changes the representation of the following types:
-  
-  - `PStakeDatum`
-  - `PStakeRedeemer`
-  - `PProposalDatum`
-  - `PProposalRedeemer`
-
-- Use plutus v2 types.
-
-  Included by [#156](https://github.com/Liqwid-Labs/agora/pull/156).
-
-- Expected input datum value is pinned instead of out ref for governor mutation
-  effect.
-  
-  Included by [#238](https://github.com/Liqwid-Labs/agora/pull/238).
-
 ## 0.2.0 -- 2022-08-13
 
 ### Added
 
-- Script exporting with `plutarch-script-export`.
+- Script exporting with `plutarch-script-export` 
 
 ### Modified
 
@@ -210,7 +28,7 @@ the stake validator easily. The behaviour of the default stake validator remains
 
   Included by [#146](https://github.com/Liqwid-Labs/agora/pull/146).
 
-- Draft phase and cosigning for Proposals.
+- Draft phase and cosigning for Proposals. 
 
   Included by [#136](https://github.com/Liqwid-Labs/agora/pull/136).
 
@@ -218,7 +36,7 @@ the stake validator easily. The behaviour of the default stake validator remains
 
   Included by [#134](https://github.com/Liqwid-Labs/agora/pull/134).
   
-- Fixed bug that made it impossible to create proposals. Added new stake locking mechanism for creating proposals.
+- Fixed bug that made it impossible to create proposals. Added new stake locking mechanism for creating proposals. 
   
   Included by [#142](https://github.com/Liqwid-Labs/agora/pull/142).
   

CONTRIBUTING.md

@@ -11,7 +11,6 @@ Please follow the [Git policy](https://liqwid.notion.site/Git-Policy-9a7979b2fd5
 This document will make reference to the _Agora core team_. These are the people who work on Agora professionally and will be responsible for maintaining the project in its open source life. They include:
 
 - [Emily Martins](https://github.com/emiflake)
-- [Connor Fang](https://github.com/chfanghr)
 - [Jack Hodgkinson](https://github.com/jhodgdev)
 
 ## Issues
@@ -34,7 +33,7 @@ If you wish to work to resolve the issue, the Agora team would invite you to sub
 
 Only those within the core Agora team may contribute work to the project directly. If you wish to work on the project, you must [fork](https://docs.github.com/en/get-started/quickstart/fork-a-repo) the repository and submit your changes to your fork. Instructions for getting started with the project may be found in the [README](./README.md). Once the work on your fork is completed, you may submit a PR [here](https://github.com/Liqwid-Labs/agora/pulls).
 
-If your PR fixes an issue that isn't a very obvious bug, or has not previously been discussed, please write an issue pertaining to the problem that your PR would solve. Read this document's section on _Issues_ and pay particular heed to the paragraph asking contributors to _look for pre-existing issues_. The prior experiences of existing contributors could save you a significant amount of time and effort. It is possible that a number of issues could be solved by your PR. Please reference any issues that would be ameliorated by your PR - including your own issue, if you have written one - clearly. Please label your PR using GitHub's tagging feature. Please state plainly:
+Before submitting a PR, please write an issue pertaining to the problem that your PR would solve e.g. a bug in the codebase or a missing feature. Read this document's section on _Issues_ and pay particular heed to the paragraph asking contributors to _look for pre-existing issues_. The prior experiences of existing contributors could save you a significant amount of time and effort. It is possible that a number of issues could be solved by your PR. Please reference any issues that would be ameliorated by your PR - including your own issue, if you have written one - clearly. Please label your PR using GitHub's tagging feature. Please state plainly:
 
 - What your PR achieves.
 - How your PR works.
@@ -47,17 +46,23 @@ Contributors should expect that if their work is insufficiently documented (eith
 
 Agora utilises [Plutarch](https://github.com/plutonomicon/plutarch) and your work must be written with Plutarch, when appropriate. Plutarch can prove _complicated_ but the documentation is extensive. We would encourage you to dive deeply into the documentation, whilst stating that Plutarch's [Tricks.md](https://github.com/Plutonomicon/plutarch/blob/master/docs/Tricks.md) could prove particularly helpful.
 
+### Stylistic guidelines
+
+All work must comply with the [MLabs style guide](https://github.com/mlabs-haskell/styleguide/).
+
 ### Continuous integration
 
-For your PR to be merged it must pass the CI checks.
+For your PR to be merged it must pass three automated checks:
 
-These can be run locally by running `nix run .#ci`. If you are making a PR through a fork of the repository, they might not be run in CI. When this is the case, please ensure the CI checks run fine locally before you request a review.
+1. A [`fourmolu`](https://github.com/fourmolu/fourmolu) formatting check.
+2. A [`hlint`](https://github.com/ndmitchell/hlint) linting check.
+3. A Cabal build check.
 
-## Standards
+Our custom `fourmolu` rules may be found in the [base of the repository](./fourmolu.yaml). You can ensure that your work will pass CI by:
 
-Agora follows strict standards to increase consistency, to minimize
-the impact of legacy, to properly use automated tools, and more. The standards document
-can be found [here](https://liqwid.notion.site/Coding-Standards-cd3c430e6e444fa292ecc3c57b7d95eb).
+1. Running `make format` from the included `Makefile`.
+2. Running `make lint` from the included `Makefile` and applying any recommendations.
+3. Ensuring that `cabal build` terminates successfully on your machine in the provided Nix environment.
 
 ## Documentation
 

Makefile

@@ -1,7 +1,7 @@
 # This really ought to be `/usr/bin/env bash`, but nix flakes don't like that.
 SHELL := /bin/sh
 
-.PHONY: hoogle format haddock usage tag format_nix format_haskell format_check	\
+.PHONY: hoogle format haddock usage tag format_nix format_haskell format_check	\ 
 				lint refactor ps_bridge bench bench_check scripts test build ci
 
 SOURCE_FILES := $(shell git ls-tree -r HEAD --full-tree --name-only)
@@ -98,6 +98,4 @@ test: requires_nix_shell
 build: requires_nix_shell
 	cabal build -j$(THREADS)
 
-ci:
-	@ [[ "$$(uname -sm)" == "Linux x86_64" ]] || (echo "NOTE: CI only builds on Linux x86_64. Your system is $$(uname -sm), continuing...")
-	nix build .#checks.$(shell nix eval -f '<nixpkgs>' system).required
+ci: format_check lint build bench_check test haddock

README.md

@@ -6,7 +6,7 @@ Agora is a set of Plutus scripts that compose together to form a governance syst
 
 Goals:
 
--   Agora aims to reduce duplication in Liqwid and XplorerDAO and to serve as a one-size-fits-all governance library for projects on the Cardano blockchain.
+-   Agora aims to reduce duplication in Liqwid and LiqwidX and to serve as a one-size-fits-all governance library for projects on the Cardano blockchain.
 -   Agora aims to be modular and flexible for specific needs but presents an opinionated architecture.
 
 Non-goals:
@@ -34,7 +34,9 @@ cabal run agora-scripts -- --enable-cors-middleware
 
 ## Documentation
 
-Documentation for Agora is hosted on Notion. You can find the specs [here](https://liqwid.notion.site/Agora-Specs-Overview-fd7df78313cf4dc0b1522cb9260b77d1).
+Documentation for Agora is hosted on Notion. You can find the specs [here](https://liqwid.notion.site/e85c09d2c9a542b19aac8dd3d6caa98b?v=d863219cd6a14082a661c4959cabd6e7).
+
+Haddock is deployed on GitHub Pages [here](https://liqwid-labs.github.io/agora/).
 
 ### Using Agora for your protocol
 
@@ -62,12 +64,11 @@ Please read [CONTRIBUTING.md](./CONTRIBUTING.md). Additionally, please follow th
 
 ### v2
 
--   [ ] Flexible scripts using TxT pattern integrated with governance
--   [ ] Different voting mechanisms
+-   [ ] Rewards distribution
+-   [ ] Escrow staking pool solution
 
 ### Available support channels info
 
 You can find help, more information and ongoing discusion about the project here:
 
 - The [Agora & Liqwid Libs Discord](https://discord.gg/yGkjxrYueB) - Most Agora discussion happens here.
-- Specs, issues, and project-management-related information is tracked on [Notion](https://www.notion.so/liqwid)

agora-bench/Bench.hs

@@ -2,16 +2,18 @@
 
 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.Csv (DefaultOrdered, ToNamedRecord, header, headerOrder, namedRecord, toNamedRecord, (.=))
 import Data.List (intercalate)
 import Data.Text (Text, pack)
 import Plutarch.Evaluate (evalScript)
-import Plutarch.Script (Script, serialiseScript)
-import PlutusLedgerApi.V2 (
+import PlutusLedgerApi.V1 (
   ExBudget (ExBudget),
   ExCPU (..),
   ExMemory (..),
+  Script,
  )
 import Prettyprinter (Pretty (pretty), indent, vsep)
 import Test.Specification (
@@ -64,7 +66,7 @@ benchmarkScript name script = Benchmark (pack name) cpu mem size
   where
     (_res, ExBudget cpu mem, _traces) = evalScript script
 
-    size = SBS.length . serialiseScript $ script
+    size = SBS.length . SBS.toShort . LBS.toStrict . serialise $ script
 
 specificationTreeToBenchmarks :: SpecificationTree -> [Benchmark]
 specificationTreeToBenchmarks = go []

agora-bench/Main.hs

@@ -4,7 +4,7 @@ import Bench (specificationTreeToBenchmarks)
 import Data.Csv (EncodeOptions (encUseCrLf), defaultEncodeOptions, encodeDefaultOrderedByNameWith)
 import Data.Text.Lazy.Encoding (decodeUtf8)
 import Data.Text.Lazy.IO as I (putStr, writeFile)
-import Options (Options (output), parseOptions)
+import Options (Options (..), parseOptions)
 import Prettyprinter (defaultLayoutOptions, layoutPretty, pretty)
 import Prettyprinter.Render.Text (renderLazy)
 import Spec.AuthorityToken qualified as AuthorityToken
@@ -16,6 +16,7 @@ import Spec.Stake qualified as Stake
 import Spec.Treasury qualified as Treasury
 import System.IO (hIsTerminalDevice, stdout)
 import Test.Specification (group)
+import Prelude
 
 --------------------------------------------------------------------------------
 

agora-purescript-bridge/AgoraTypes.hs

@@ -11,11 +11,13 @@ import Language.PureScript.Bridge (
 
 --------------------------------------------------------------------------------
 
+import Agora.AuthorityToken qualified as AuthorityToken
 import Agora.Effect.GovernorMutation qualified as GovernorMutation
 import Agora.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawalEffect
 import Agora.Governor qualified as Governor
 import Agora.Proposal qualified as Proposal
 import Agora.Stake qualified as Stake
+import Agora.Treasury qualified as Treasury
 
 --------------------------------------------------------------------------------
 
@@ -37,6 +39,10 @@ agoraTypes =
     mkSumType (Proxy @Stake.ProposalLock)
   , mkSumType (Proxy @Stake.StakeRedeemer)
   , mkSumType (Proxy @Stake.StakeDatum)
+  , -- Treasury
+    mkSumType (Proxy @Treasury.TreasuryRedeemer)
+  , -- AuthorityToken
+    mkSumType (Proxy @AuthorityToken.AuthorityToken)
   , -- Effects
     mkSumType (Proxy @TreasuryWithdrawalEffect.TreasuryWithdrawalDatum)
   , mkSumType (Proxy @GovernorMutation.MutateGovernorDatum)

agora-scripts/Main.hs

@@ -8,43 +8,157 @@
 -}
 module Main (main) where
 
-import Agora.Bootstrap (alwaysSucceedsPolicyRoledScript)
 import Agora.Bootstrap qualified as Bootstrap
-import Agora.Linker (linker)
+import Agora.Governor (Governor (..))
+import Agora.SafeMoney (GTTag)
+import Agora.Scripts qualified as Scripts
+import Agora.Utils (CompiledMintingPolicy (..), CompiledValidator (..))
 import Data.Aeson qualified as Aeson
 import Data.Default (def)
-import Plutarch (Config (Config), TracingMode (DoTracing, NoTracing))
-import Ply (TypedScriptEnvelope)
-import ScriptExport.Export (exportMain)
-import ScriptExport.Types (
-  Builders,
-  insertBuilder,
-  insertScriptExportWithLinker,
-  insertStaticBuilder,
+import Data.Function ((&))
+import Data.Tagged (Tagged)
+import Data.Text (Text)
+import Development.GitRev (gitBranch, gitHash)
+import GHC.Generics qualified as GHC
+import Plutarch (Config (..), TracingMode (DoTracing))
+import PlutusLedgerApi.V1 (
+  MintingPolicy (getMintingPolicy),
+  TxOutRef,
+  Validator (getValidator),
  )
+import PlutusLedgerApi.V1.Value (AssetClass)
+import ScriptExport.API (runServer)
+import ScriptExport.Options (parseOptions)
+import ScriptExport.ScriptInfo (ScriptInfo (..), mkPolicyInfo, mkScriptInfo, mkValidatorInfo)
+import ScriptExport.Types (Builders, insertBuilder)
 
 main :: IO ()
-main = exportMain builders
+main =
+  parseOptions >>= runServer revision builders
+  where
+    -- This encodes the git revision of the server. It's useful for the caller
+    -- to be able to ensure they are compatible with it.
+    revision :: Text
+    revision = $(gitBranch) <> "@" <> $(gitHash)
 
-rawScripts :: Config -> [TypedScriptEnvelope]
-rawScripts conf =
-  either (error . show) id $ Bootstrap.agoraScripts' conf
+{- | Builders for Agora scripts.
 
+     @since 0.2.0
+-}
 builders :: Builders
 builders =
-  mconcat
-    [ insertStaticBuilder "raw" (rawScripts (Config NoTracing))
-    , insertStaticBuilder "rawDebug" (rawScripts (Config DoTracing))
-    , insertScriptExportWithLinker "agora" (Bootstrap.agoraScripts def) linker
-    , insertScriptExportWithLinker
-        "agoraDebug"
-        ( Bootstrap.agoraScripts
-            (Config DoTracing)
-        )
-        linker
-    , -- Note: To be compatible with current off-chain setup, we are not using
-      --  static builder here.
-      insertBuilder
-        "alwaysSucceedsPolicy"
-        (const @_ @Aeson.Value alwaysSucceedsPolicyRoledScript)
-    ]
+  def
+    -- Agora scripts
+    & insertBuilder "governorPolicy" ((.governorPolicyInfo) . agoraScripts)
+    & insertBuilder "governorValidator" ((.governorValidatorInfo) . agoraScripts)
+    & insertBuilder "stakePolicy" ((.stakePolicyInfo) . agoraScripts)
+    & insertBuilder "stakeValidator" ((.stakeValidatorInfo) . agoraScripts)
+    & insertBuilder "proposalPolicy" ((.proposalPolicyInfo) . agoraScripts)
+    & insertBuilder "proposalValidator" ((.proposalValidatorInfo) . agoraScripts)
+    & insertBuilder "treasuryValidator" ((.treasuryValidatorInfo) . agoraScripts)
+    & insertBuilder "authorityTokenPolicy" ((.authorityTokenPolicyInfo) . agoraScripts)
+    -- Trivial scripts. These are useful for testing, but they likely aren't useful
+    -- to you if you are actually interested in deploying to mainnet.
+    & insertBuilder
+      "alwaysSucceedsPolicy"
+      (\() -> mkPolicyInfo $ plam $ \_ _ -> popaque (pconstant ()))
+    & insertBuilder
+      "alwaysSucceedsValidator"
+      (\() -> mkValidatorInfo $ plam $ \_ _ _ -> popaque (pconstant ()))
+    & insertBuilder
+      "neverSucceedsPolicy"
+      (\() -> mkPolicyInfo $ plam $ \_ _ -> perror)
+    & insertBuilder
+      "neverSucceedsValidator"
+      (\() -> mkValidatorInfo $ plam $ \_ _ _ -> perror)
+
+{- | Create scripts from params.
+
+     @since 0.2.0
+-}
+agoraScripts :: ScriptParams -> AgoraScripts
+agoraScripts params =
+  AgoraScripts
+    { governorPolicyInfo = mkPolicyInfo' scripts.compiledGovernorPolicy
+    , governorValidatorInfo = mkValidatorInfo' scripts.compiledGovernorValidator
+    , stakePolicyInfo = mkPolicyInfo' scripts.compiledStakePolicy
+    , stakeValidatorInfo = mkValidatorInfo' scripts.compiledStakeValidator
+    , proposalPolicyInfo = mkPolicyInfo' scripts.compiledProposalPolicy
+    , proposalValidatorInfo = mkValidatorInfo' scripts.compiledProposalValidator
+    , treasuryValidatorInfo = mkValidatorInfo' scripts.compiledTreasuryValidator
+    , authorityTokenPolicyInfo = mkPolicyInfo' scripts.compiledAuthorityTokenPolicy
+    }
+  where
+    governor =
+      Agora.Governor.Governor
+        params.governorInitialSpend
+        params.gtClassRef
+        params.maximumCosigners
+
+    scripts = Bootstrap.agoraScripts plutarchConfig governor
+
+{- | Params required for creating script export.
+
+     @since 0.2.0
+-}
+data ScriptParams where
+  ScriptParams ::
+    { governorInitialSpend :: TxOutRef
+    , gtClassRef :: Tagged GTTag AssetClass
+    , maximumCosigners :: Integer
+    } ->
+    ScriptParams
+  deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
+  deriving stock (Show, Eq, GHC.Generic, Ord)
+
+{- | Scripts that get exported.
+
+     @since 0.2.0
+-}
+data AgoraScripts = AgoraScripts
+  { governorPolicyInfo :: ScriptInfo
+  , governorValidatorInfo :: ScriptInfo
+  , stakePolicyInfo :: ScriptInfo
+  , stakeValidatorInfo :: ScriptInfo
+  , proposalPolicyInfo :: ScriptInfo
+  , proposalValidatorInfo :: ScriptInfo
+  , treasuryValidatorInfo :: ScriptInfo
+  , authorityTokenPolicyInfo :: ScriptInfo
+  }
+  deriving anyclass
+    ( -- | @since 0.2.0
+      Aeson.ToJSON
+    , -- | @since 0.2.0
+      Aeson.FromJSON
+    )
+  deriving stock
+    ( -- | @since 0.2.0
+      Show
+    , -- | @since 0.2.0
+      Eq
+    , -- | @since 0.2.0
+      GHC.Generic
+    )
+
+{- | Default plutarch configuration for compiling scripts.
+
+     TODO: we should have an option to control this.
+
+     @since 0.2.0
+-}
+plutarchConfig :: Config
+plutarchConfig = Config {tracingMode = DoTracing}
+
+{- | Turn a precompiled minting policy to a 'ScriptInfo'.
+
+     @since 0.2.0
+-}
+mkPolicyInfo' :: forall redeemer. CompiledMintingPolicy redeemer -> ScriptInfo
+mkPolicyInfo' = mkScriptInfo . getMintingPolicy . getCompiledMintingPolicy
+
+{- | Turn a precompiled validator to a 'ScriptInfo'.
+
+     @since 0.2.0
+-}
+mkValidatorInfo' :: forall redeemer datum. CompiledValidator datum redeemer -> ScriptInfo
+mkValidatorInfo' = mkScriptInfo . getValidator . getCompiledValidator

agora-scripts/sampleGov.json

@@ -1,15 +0,0 @@
-{
-  "gstOutRef": {
-    "txOutRefId": "f28cd7145c24e66fd5bcd2796837aeb19a48a2656e7833c88c62a2d0450bd00d",
-    "txOutRefIdx": 1
-  },
-  "gtClassRef": {
-    "name": {
-      "unTokenName": "3334363333353331"
-    },
-    "symbol": {
-      "unCurrencySymbol": "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
-    }
-  },
-  "maximumCosigners": 20
-}

agora-specs/Property/Generator.hs

@@ -32,22 +32,22 @@ import Plutarch.Context (
   output,
   withValue,
  )
+import PlutusLedgerApi.V1 (
+  Address (Address),
+  Credential (..),
+  PubKeyHash (PubKeyHash),
+  TxId (..),
+  TxOutRef (..),
+  ValidatorHash (ValidatorHash),
+  Value,
+  toBuiltin,
+ )
 import PlutusLedgerApi.V1.Value (
   AssetClass (AssetClass),
   assetClassValue,
   currencySymbol,
   tokenName,
  )
-import PlutusLedgerApi.V2 (
-  Address (Address),
-  Credential (..),
-  PubKeyHash (PubKeyHash),
-  ScriptHash (ScriptHash),
-  TxId (..),
-  TxOutRef (..),
-  Value,
-  toBuiltin,
- )
 import Test.QuickCheck (
   Arbitrary (arbitrary),
   Gen,
@@ -76,7 +76,7 @@ genUserCredential = PubKeyCredential . PubKeyHash . toBuiltin <$> genHashByteStr
 
 -- | Random script credential.
 genScriptCredential :: Gen Credential
-genScriptCredential = ScriptCredential . ScriptHash . toBuiltin <$> genHashByteString
+genScriptCredential = ScriptCredential . ValidatorHash . toBuiltin <$> genHashByteString
 
 -- | Random credential: combination of user and script credential generators.
 genCredential :: Gen Credential

agora-specs/Property/Governor.hs

@@ -1,7 +1,3 @@
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-
-{-# HLINT ignore "Redundant bracket" #-}
-
 {- |
 Module     : Property.Governor
 Maintainer : seungheon.ooh@gmail.com
@@ -11,299 +7,216 @@ Property model and tests for 'Governor' related functions
 -}
 module Property.Governor (props) where
 
-import Agora.Governor (
-  GovernorDatum (
-    GovernorDatum,
-    createProposalTimeRangeMaxWidth,
-    maximumCreatedProposalsPerStake,
-    nextProposalId,
-    proposalThresholds,
-    proposalTimings
-  ),
-  PGovernorDatum,
-  pisGovernorDatumValid,
- )
+import Agora.Governor (Governor (gstOutRef), GovernorDatum (..), pisGovernorDatumValid)
 import Agora.Governor.Scripts (governorPolicy)
 import Agora.Proposal (
   ProposalId (ProposalId),
-  ProposalThresholds (
-    ProposalThresholds
-  ),
+  ProposalThresholds (ProposalThresholds),
  )
 import Agora.Proposal.Time (
   MaxTimeRangeWidth (MaxTimeRangeWidth),
   ProposalTimingConfig (ProposalTimingConfig),
  )
-import Data.Default (def)
-import Data.Tagged (Tagged (Tagged))
-import Data.Universe (Universe)
-import Data.Universe.Class (Finite)
-import Generics.SOP.NP (NP (Nil, (:*)))
-import Optics (view)
-import Plutarch.Api.V2 (PScriptContext)
+import Data.Default.Class (Default (def))
+import Data.Tagged (Tagged (Tagged), untag)
+import Data.Universe (Finite (..), Universe (..))
+import Plutarch.Api.V1 (PScriptContext)
 import Plutarch.Builtin (pforgetData)
 import Plutarch.Context (
   MintingBuilder,
-  buildMinting',
+  buildMintingUnsafe,
   input,
   mint,
   output,
   script,
   withDatum,
   withMinting,
-  withRef,
+  withOutRef,
   withValue,
  )
-import Plutarch.Evaluate (evalTerm)
-import Plutarch.Extra.AssetClass (assetClassValue)
-import Plutarch.Extra.Compile (mustCompile)
-import Plutarch.Script (Script)
-import Plutarch.Test.QuickCheck (
-  Equality (OnPEq),
-  Partiality (ByComplete),
-  TestableTerm (TestableTerm),
-  haskEquiv,
-  pconstantT,
-  shouldCrash,
-  shouldRun,
+import PlutusLedgerApi.V1 (
+  ScriptContext (scriptContextTxInfo),
+  TxInInfo (txInInfoOutRef),
+  TxInfo (txInfoInputs, txInfoMint, txInfoOutputs),
+  TxOut (txOutValue),
  )
-import PlutusLedgerApi.V2 (ScriptContext)
+import PlutusLedgerApi.V1.Value (assetClassValue)
 import Property.Generator (genInput, genOutput)
 import Sample.Shared (
-  deterministicTracingConfig,
+  govAssetClass,
+  govSymbol,
+  govValidatorHash,
   governor,
-  governorAssetClass,
-  governorScriptHash,
-  governorSymbol,
   gstUTXORef,
  )
-import Test.QuickCheck (
-  Arbitrary (arbitrary),
+import Test.Tasty (TestTree)
+import Test.Tasty.Plutarch.Property (classifiedPropertyNative)
+import Test.Tasty.QuickCheck (
   Gen,
   Property,
-  arbitraryBoundedEnum,
-  checkCoverage,
   choose,
   chooseInteger,
-  cover,
-  forAll,
   listOf1,
+  testProperty,
  )
-import Test.Tasty (TestTree, adjustOption, testGroup)
-import Test.Tasty.QuickCheck (QuickCheckTests, testProperty)
 
 data GovernorDatumCases
   = ExecuteLE0
   | CreateLE0
-  | ToVotingLE0
   | VoteLE0
-  | CosignLE0
   | Correct
-  deriving stock (Eq, Show, Enum, Bounded)
-  deriving anyclass (Universe, Finite)
+  deriving stock (Eq, Show)
 
-instance Arbitrary GovernorDatumCases where
-  arbitrary = arbitraryBoundedEnum
+instance Universe GovernorDatumCases where
+  universe =
+    [ ExecuteLE0
+    , CreateLE0
+    , VoteLE0
+    , Correct
+    ]
 
-{- | Property that checks `pisGovernorDatumValid` behaves as intended by
-     comparing it to a simple haskell implementation.
+instance Finite GovernorDatumCases where
+  universeF = universe
+  cardinality = Tagged 6
+
+{- | 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 =
-  haskEquiv @('OnPEq) @('ByComplete)
-    isValidModelImpl
-    (TestableTerm pisGovernorDatumValid)
-    (genDatum :* Nil)
+  classifiedPropertyNative gen (const []) expected classifier pisGovernorDatumValid
   where
-    genDatum :: Gen (TestableTerm PGovernorDatum)
-    genDatum = pconstantT <$> (arbitrary >>= genDatumForCase)
+    classifier :: GovernorDatum -> GovernorDatumCases
+    classifier (proposalThresholds -> ProposalThresholds e c v)
+      | e < 0 = ExecuteLE0
+      | c < 0 = CreateLE0
+      | v < 0 = VoteLE0
+      | otherwise = Correct
+
+    expected :: GovernorDatum -> Maybe Bool
+    expected c = Just $ classifier c == Correct
+
+    gen :: GovernorDatumCases -> Gen GovernorDatum
+    gen c = do
+      thres <- genProposalThresholds c
+
+      let timing = ProposalTimingConfig 0 0 0 0
+      return $ GovernorDatum thres (ProposalId 0) timing (MaxTimeRangeWidth 1) 3
       where
-        genDatumForCase :: GovernorDatumCases -> Gen GovernorDatum
-        genDatumForCase c = do
-          thres <- genProposalThresholds c
+        taggedInteger p = Tagged <$> chooseInteger p
+        genProposalThresholds :: GovernorDatumCases -> Gen ProposalThresholds
+        genProposalThresholds c = do
+          let validGT = taggedInteger (0, 1000000000)
+          execute <- validGT
+          create <- validGT
+          vote <- validGT
+          le0 <- taggedInteger (-1000, -1)
 
-          let timing = ProposalTimingConfig 0 0 0 0 0 0
-          pure $
-            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)
-
-              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
-
-    -- \| This is a model Haskell implementation of `pisGovernorDatumValid`.
-    isValidModelImpl :: GovernorDatum -> Bool
-    isValidModelImpl = correctCase . classifier
-      where
-        correctCase = \case
-          Correct -> True
-          _ -> False
-
-        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
-
---------------------------------------------------------------------------------
+          case c of
+            ExecuteLE0 ->
+              -- execute < 0
+              return $ ProposalThresholds le0 create vote
+            CreateLE0 ->
+              -- c < 0
+              return $ ProposalThresholds execute le0 vote
+            VoteLE0 ->
+              -- vote < 0
+              return $ ProposalThresholds execute create le0
+            Correct -> do
+              -- c <= vote < execute
+              nv <- taggedInteger (0, untag execute - 1)
+              nc <- taggedInteger (0, untag nv)
+              return $ ProposalThresholds execute nc nv
 
 data GovernorPolicyCases
   = ReferenceUTXONotSpent
   | IncorrectAmountOfTokenMinted
   | GovernorOutputNotFound
+  | GovernorPolicyCorrect
   deriving stock (Eq, Show)
 
-governorMintingPolicyTests :: [TestTree]
-governorMintingPolicyTests =
-  [ mkGovMintingCasePropertyTest
-      "Reference input spend test"
-      ReferenceUTXONotSpent
-      "Spent"
-      "Not spent"
-  , mkGovMintingCasePropertyTest
-      "Amount of token minted test"
-      IncorrectAmountOfTokenMinted
-      "Correct"
-      "Incorrect"
-  , mkGovMintingCasePropertyTest
-      "Governor output presense"
-      GovernorOutputNotFound
-      "Present"
-      "Absent"
-  ]
+instance Universe GovernorPolicyCases where
+  universe =
+    [ ReferenceUTXONotSpent
+    , IncorrectAmountOfTokenMinted
+    , GovernorOutputNotFound
+    , GovernorPolicyCorrect
+    ]
 
-{- | Creates a property by compiling governorPolicy script with given arguments
-   and checking if it runs as expected by a test.
--}
-governorPolicyValid :: ScriptContext -> Bool -> Property
-governorPolicyValid ctx shouldSucceed =
-  let mp = mkPolicyScript ctx in if shouldSucceed then shouldRun mp else shouldCrash mp
+instance Finite GovernorPolicyCases where
+  universeF = universe
+  cardinality = Tagged 4
 
-{-# INLINEABLE mkPolicyScript #-}
-mkPolicyScript :: ScriptContext -> Script
-mkPolicyScript ctx = mustCompile (go # pconstant ctx)
+governorMintingProperty :: Property
+governorMintingProperty =
+  classifiedPropertyNative gen (const []) expected classifier actual
   where
-    go :: forall (s :: S). Term s (PScriptContext :--> POpaque)
-    go = loudEval $
-      plam $ \sc ->
-        governorPolicy
-          # pdata (pconstant (view #gstOutRef governor))
-          # pforgetData (pconstantData ())
-          # sc
+    {- Note:
+    I don't think it's easily possible to randomize orefs. We can't really pass pass `Governor` type to `actual` function.
+    -}
+    gst = assetClassValue govAssetClass 1
+    mintAmount x = mint . mconcat $ replicate x gst
+    outputToGov =
+      output $
+        mconcat
+          [ script govValidatorHash
+          , withValue gst
+          , withDatum govDatum
+          ]
+    referencedInput = input $ withOutRef gstUTXORef
 
--- | Prepares a minting policy test for given policy error case.
-mkGovMintingCasePropertyTest ::
-  String ->
-  GovernorPolicyCases ->
-  String ->
-  String ->
-  TestTree
-mkGovMintingCasePropertyTest name case' positiveCaseName negativeCaseName =
-  testProperty name $
-    forAll (gen case') $
-      \(ctx, valid) ->
-        checkCoverage $
-          cover 48 valid positiveCaseName $
-            cover 48 (not valid) negativeCaseName $
-              governorPolicyValid ctx valid
-  where
-    gen :: GovernorPolicyCases -> Gen (ScriptContext, Bool)
+    govDatum :: GovernorDatum
+    govDatum =
+      GovernorDatum
+        { proposalThresholds = def
+        , nextProposalId = ProposalId 0
+        , proposalTimings = def
+        , createProposalTimeRangeMaxWidth = def
+        , maximumProposalsPerStake = 3
+        }
+
+    gen :: GovernorPolicyCases -> Gen ScriptContext
     gen c = do
       inputs <- fmap mconcat . listOf1 $ genInput @MintingBuilder
       outputs <- fmap mconcat . listOf1 $ genOutput @MintingBuilder
       toks <- choose (2, 100)
 
-      valid <- arbitrary
       let comp =
-            if valid
-              then referencedInput <> outputToGov <> mintAmount 1
-              else case c of
-                ReferenceUTXONotSpent -> outputToGov <> mintAmount 1
-                IncorrectAmountOfTokenMinted ->
-                  referencedInput
-                    <> outputToGov
-                    <> mintAmount toks
-                GovernorOutputNotFound -> referencedInput <> mintAmount 1
+            case c of
+              ReferenceUTXONotSpent -> outputToGov <> mintAmount 1
+              IncorrectAmountOfTokenMinted -> referencedInput <> outputToGov <> mintAmount toks
+              GovernorOutputNotFound -> referencedInput <> mintAmount 1
+              GovernorPolicyCorrect -> referencedInput <> outputToGov <> mintAmount 1
 
-      let ctx =
-            buildMinting' $
-              inputs
-                <> outputs
-                <> comp
-                <> withMinting
-                  governorSymbol
-      pure (ctx, valid)
+      return . buildMintingUnsafe $ inputs <> outputs <> comp <> withMinting govSymbol
+
+    expected :: ScriptContext -> Maybe ()
+    expected sc =
+      case classifier sc of
+        GovernorPolicyCorrect -> Just ()
+        _ -> Nothing
+
+    opaqueToUnit :: Term s (POpaque :--> PUnit)
+    opaqueToUnit = plam $ \_ -> pconstant ()
+
+    actual :: Term s (PScriptContext :--> PUnit)
+    actual = plam $ \sc -> opaqueToUnit #$ governorPolicy governor.gstOutRef # pforgetData (pconstantData ()) # sc
+
+    classifier :: ScriptContext -> GovernorPolicyCases
+    classifier sc
+      | minted /= gst = IncorrectAmountOfTokenMinted
+      | refInputNotExists = ReferenceUTXONotSpent
+      | govOutputNotExists = GovernorOutputNotFound
+      | otherwise = GovernorPolicyCorrect
       where
-        govDatum :: GovernorDatum
-        govDatum =
-          GovernorDatum
-            { proposalThresholds = def
-            , nextProposalId = ProposalId 0
-            , proposalTimings = def
-            , createProposalTimeRangeMaxWidth = def
-            , maximumCreatedProposalsPerStake = 3
-            }
-
-        gst = assetClassValue governorAssetClass 1
-        mintAmount x = mint . mconcat $ replicate x gst
-        referencedInput = input $ withRef gstUTXORef
-        outputToGov =
-          output $
-            mconcat
-              [ script governorScriptHash
-              , withValue gst
-              , withDatum govDatum
-              ]
+        txinfo = scriptContextTxInfo sc
+        minted = txInfoMint txinfo
+        refInputNotExists = gstUTXORef `notElem` (txInInfoOutRef <$> txInfoInputs txinfo)
+        govOutputNotExists = gst `notElem` (txOutValue <$> txInfoOutputs txinfo)
 
 props :: [TestTree]
 props =
-  [ adjustOption go . testProperty "governorDatumValid" $ governorDatumValidProperty
-  , testGroup "governorPolicy" governorMintingPolicyTests
+  [ testProperty "governorDatumValid" governorDatumValidProperty
+  , testProperty "governorPolicy" governorMintingProperty
   ]
-  where
-    go :: QuickCheckTests -> QuickCheckTests
-    go = max 20_000
-
-loudEval ::
-  forall (p :: S -> Type).
-  ClosedTerm p ->
-  ClosedTerm p
-loudEval x =
-  case evalTerm deterministicTracingConfig x of
-    Right (Right t, _, _) -> t
-    Right (Left err, _, trace) -> error $ show err <> show trace
-    Left err -> error $ show err

agora-specs/Property/Utils.hs

@@ -1,37 +0,0 @@
-module Property.Utils (props) where
-
-import Agora.Utils (phashDatum)
-import Generics.SOP (NP (Nil, (:*)))
-import Plutarch.Api.V2 (datumHash)
-import Plutarch.Test.QuickCheck (
-  Equality (OnPEq),
-  Partiality (ByComplete),
-  TestableTerm (TestableTerm),
-  arbitraryPLift,
-  haskEquiv,
- )
-import Plutarch.Test.QuickCheck.Instances ()
-import Test.Tasty (TestTree, adjustOption)
-import Test.Tasty.QuickCheck (
-  Property,
-  QuickCheckTests,
-  resize,
-  testProperty,
- )
-
-propHashDatumCorrect :: Property
-propHashDatumCorrect =
-  haskEquiv
-    @'OnPEq
-    @'ByComplete
-    datumHash
-    (TestableTerm phashDatum)
-    (resize 5 arbitraryPLift :* Nil)
-
-props :: [TestTree]
-props =
-  [ adjustOption go $ testProperty "Correct 'phashDatum'" propHashDatumCorrect
-  ]
-  where
-    go :: QuickCheckTests -> QuickCheckTests
-    go = max 20_000

agora-specs/Sample/AuthorityToken/UnauthorizedMintingExploit.hs

@@ -1,66 +0,0 @@
-module Sample.AuthorityToken.UnauthorizedMintingExploit (
-  Parameters (..),
-  exploit,
-  mkTestCase,
-) where
-
-import Control.Exception (assert)
-import Plutarch.Context (input, mint, normalizeValue, output, script, withValue)
-import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
-import PlutusLedgerApi.V1.Value qualified as Value
-import Sample.Shared (authorityTokenPolicy, authorityTokenSymbol, minAda)
-import Test.Specification (SpecificationTree, testPolicy)
-import Test.Util (CombinableBuilder, mkMinting, validatorHashes)
-
-data Parameters = Parameters
-  { burntGAT :: Int
-  , mintedGAT :: Int
-  }
-
-exploit ::
-  forall b.
-  CombinableBuilder b =>
-  Parameters ->
-  b
-exploit (Parameters burntGAT mintedGAT) =
-  assert (burntGAT > mintedGAT && mintedGAT > 0) $
-    effectInputBuilder <> maliciousGATOutputBuilder
-  where
-    (effectScriptHashes, rest) = splitAt burntGAT validatorHashes
-    maliciousScripts = take mintedGAT rest
-
-    gatValue hash =
-      Value.singleton
-        authorityTokenSymbol
-        (scriptHashToTokenName hash)
-
-    mkGATUTxO hash =
-      mconcat
-        [ script hash
-        , withValue $ normalizeValue $ minAda <> gatValue hash 1
-        ]
-
-    effectInputBuilder =
-      foldMap
-        ( \effectHash ->
-            mconcat
-              [ mint $ gatValue effectHash $ negate 1
-              , input $ mkGATUTxO effectHash
-              ]
-        )
-        effectScriptHashes
-
-    maliciousGATOutputBuilder =
-      foldMap
-        ( \scriptHash ->
-            mconcat
-              [ mint $ gatValue scriptHash 1
-              , output $ mkGATUTxO scriptHash
-              ]
-        )
-        maliciousScripts
-
-mkTestCase :: String -> Parameters -> SpecificationTree
-mkTestCase name ps =
-  testPolicy False name authorityTokenPolicy () $
-    mkMinting exploit ps authorityTokenSymbol

agora-specs/Sample/Effect/GovernorMutation.hs

@@ -2,7 +2,7 @@ module Sample.Effect.GovernorMutation (
   mkEffectTxInfo,
   effectValidator,
   effectValidatorAddress,
-  effectScriptHash,
+  effectValidatorHash,
   atAssetClass,
   govRef,
   effectRef,
@@ -13,83 +13,74 @@ module Sample.Effect.GovernorMutation (
 
 import Agora.Effect.GovernorMutation (
   MutateGovernorDatum (..),
+  mutateGovernorValidator,
  )
-import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
+import Agora.Governor (GovernorDatum (..))
 import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
-import Agora.SafeMoney (AuthorityTokenTag)
+import Agora.Utils (validatorHashToTokenName)
 import Data.Default.Class (Default (def))
-import Data.Map ((!))
 import Data.Tagged (Tagged (..))
-import Plutarch.Api.V2 (scriptHash)
-import Plutarch.Extra.AssetClass (AssetClass (AssetClass), assetClassValue)
-import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
-import Plutarch.Script (Script)
-import PlutusLedgerApi.V1 qualified as Interval (always)
-import PlutusLedgerApi.V1.Address (scriptHashAddress)
-import PlutusLedgerApi.V1.Value qualified as Value (
-  singleton,
- )
-import PlutusLedgerApi.V2 (
+import Plutarch.Api.V1 (mkValidator, validatorHash)
+import PlutusLedgerApi.V1 (
   Address,
   Datum (..),
-  OutputDatum (OutputDatumHash),
-  ScriptHash,
-  ScriptPurpose (Spending),
   ToData (..),
   TxInInfo (..),
   TxInfo (..),
   TxOut (..),
   TxOutRef (TxOutRef),
+  Validator,
+  ValidatorHash (..),
+ )
+import PlutusLedgerApi.V1 qualified as Interval (always)
+import PlutusLedgerApi.V1.Address (scriptHashAddress)
+import PlutusLedgerApi.V1.Value (AssetClass, assetClass)
+import PlutusLedgerApi.V1.Value qualified as Value (
+  assetClassValue,
+  singleton,
  )
-import PlutusTx.AssocMap qualified as AssocMap
 import Sample.Shared (
   agoraScripts,
   authorityTokenSymbol,
-  governorAssetClass,
-  governorValidatorAddress,
+  deterministicTracingConfing,
+  govAssetClass,
+  govValidatorAddress,
   minAda,
-  mkRedeemer,
   signer,
  )
 import Test.Util (datumPair, toDatumHash)
 
 -- | The effect validator instance.
-effectValidator :: Script
-effectValidator = agoraScripts ! "agora:mutateGovernorValidator"
+effectValidator :: Validator
+effectValidator = mkValidator deterministicTracingConfing $ mutateGovernorValidator agoraScripts
 
 -- | The hash of the validator instance.
-effectScriptHash :: ScriptHash
-effectScriptHash = scriptHash effectValidator
+effectValidatorHash :: ValidatorHash
+effectValidatorHash = validatorHash effectValidator
 
 -- | The address of the validator.
 effectValidatorAddress :: Address
-effectValidatorAddress = scriptHashAddress effectScriptHash
+effectValidatorAddress = scriptHashAddress effectValidatorHash
 
 -- | The assetclass of the authority token.
-atAssetClass :: Tagged AuthorityTokenTag AssetClass
-atAssetClass = Tagged $ AssetClass authorityTokenSymbol tokenName
+atAssetClass :: AssetClass
+atAssetClass = assetClass authorityTokenSymbol tokenName
   where
-    tokenName = scriptHashToTokenName effectScriptHash
+    tokenName = validatorHashToTokenName effectValidatorHash
 
 -- | The mock reference of the governor state UTXO.
 govRef :: TxOutRef
-govRef =
-  TxOutRef
-    "d63fe09e6ac6e55dea82291149085d0a9b901df65087b83965188ee92fb25aef"
-    1
+govRef = TxOutRef "1475e1ee22330dfc55430980e5a6b100ec9d9249bb4b462256a79559" 1
 
 -- | The mock reference of the effect UTXO.
 effectRef :: TxOutRef
-effectRef =
-  TxOutRef
-    "3ca6864670aae61a9f3e63064284cec00bd983d77cf4e1ab1e26bef34cafb0a9"
-    1
+effectRef = TxOutRef "a302d327d8e5553d50b9d017475369753f723d7e999ac1b68da8ad52" 1
 
 -- | The input effect datum in 'mkEffectTransaction'.
-mkEffectDatum :: GovernorDatum -> GovernorDatum -> MutateGovernorDatum
-mkEffectDatum oldGovDatum newGovDatum =
+mkEffectDatum :: GovernorDatum -> MutateGovernorDatum
+mkEffectDatum newGovDatum =
   MutateGovernorDatum
-    { oldDatum = oldGovDatum
+    { governorRef = govRef
     , newDatum = newGovDatum
     }
 
@@ -99,11 +90,11 @@ mkEffectDatum oldGovDatum newGovDatum =
 -}
 mkEffectTxInfo :: GovernorDatum -> TxInfo
 mkEffectTxInfo newGovDatum =
-  let gst = assetClassValue governorAssetClass 1
-      at = assetClassValue atAssetClass 1
+  let gst = Value.assetClassValue govAssetClass 1
+      at = Value.assetClassValue atAssetClass 1
 
       -- One authority token is burnt in the process.
-      burnt = assetClassValue atAssetClass (-1)
+      burnt = Value.assetClassValue atAssetClass (-1)
 
       --
 
@@ -114,24 +105,23 @@ mkEffectTxInfo newGovDatum =
           , nextProposalId = ProposalId 0
           , proposalTimings = def
           , createProposalTimeRangeMaxWidth = def
-          , maximumCreatedProposalsPerStake = 3
+          , maximumProposalsPerStake = 3
           }
       governorInputDatum :: Datum
       governorInputDatum = Datum $ toBuiltinData governorInputDatum'
       governorInput :: TxOut
       governorInput =
         TxOut
-          { txOutAddress = governorValidatorAddress
+          { txOutAddress = govValidatorAddress
           , txOutValue = gst
-          , txOutDatum = OutputDatumHash $ toDatumHash governorInputDatum
-          , txOutReferenceScript = Nothing
+          , txOutDatumHash = Just $ toDatumHash governorInputDatum
           }
 
       --
 
       -- The effect should update 'nextProposalId'
       effectInputDatum' :: MutateGovernorDatum
-      effectInputDatum' = mkEffectDatum governorInputDatum' newGovDatum
+      effectInputDatum' = mkEffectDatum newGovDatum
       effectInputDatum :: Datum
       effectInputDatum = Datum $ toBuiltinData effectInputDatum'
       effectInput :: TxOut
@@ -139,8 +129,7 @@ mkEffectTxInfo newGovDatum =
         TxOut
           { txOutAddress = effectValidatorAddress
           , txOutValue = at -- The effect carry an authotity token.
-          , txOutDatum = OutputDatumHash $ toDatumHash effectInputDatum
-          , txOutReferenceScript = Nothing
+          , txOutDatumHash = Just $ toDatumHash effectInputDatum
           }
 
       --
@@ -152,30 +141,23 @@ mkEffectTxInfo newGovDatum =
       governorOutput :: TxOut
       governorOutput =
         TxOut
-          { txOutAddress = governorValidatorAddress
+          { txOutAddress = govValidatorAddress
           , txOutValue = mconcat [gst, minAda]
-          , txOutDatum = OutputDatumHash $ toDatumHash governorOutputDatum
-          , txOutReferenceScript = Nothing
+          , txOutDatumHash = Just $ toDatumHash governorOutputDatum
           }
    in TxInfo
         { txInfoInputs =
             [ TxInInfo effectRef effectInput
             , TxInInfo govRef governorInput
             ]
-        , txInfoReferenceInputs = []
         , txInfoOutputs = [governorOutput]
         , txInfoFee = Value.singleton "" "" 2
         , txInfoMint = burnt
         , txInfoDCert = []
-        , txInfoWdrl = AssocMap.empty
+        , txInfoWdrl = []
         , txInfoValidRange = Interval.always
         , txInfoSignatories = [signer]
-        , txInfoData = AssocMap.fromList $ datumPair <$> [governorInputDatum, governorOutputDatum, effectInputDatum]
-        , txInfoRedeemers =
-            AssocMap.fromList
-              [ (Spending effectRef, mkRedeemer ())
-              , (Spending govRef, mkRedeemer MutateGovernor)
-              ]
+        , txInfoData = datumPair <$> [governorInputDatum, governorOutputDatum, effectInputDatum]
         , txInfoId = "74c75505691e7baa981fa80e50b9b7e88dbe1eda67d4f062d89d203b"
         }
 
@@ -186,7 +168,7 @@ validNewGovernorDatum =
     , nextProposalId = ProposalId 42
     , proposalTimings = def
     , createProposalTimeRangeMaxWidth = def
-    , maximumCreatedProposalsPerStake = 3
+    , maximumProposalsPerStake = 3
     }
 
 invalidNewGovernorDatum :: GovernorDatum
@@ -194,10 +176,10 @@ invalidNewGovernorDatum =
   GovernorDatum
     { proposalThresholds =
         def
-          { toVoting = Tagged (-1)
+          { vote = Tagged (-1)
           }
     , nextProposalId = ProposalId 42
     , proposalTimings = def
     , createProposalTimeRangeMaxWidth = def
-    , maximumCreatedProposalsPerStake = 3
+    , maximumProposalsPerStake = 3
     }

agora-specs/Sample/Effect/TreasuryWithdrawal.hs

@@ -6,209 +6,170 @@ Description: Sample based testing for Treasury Withdrawal Effect
 This module provides samples for Treasury Withdrawal Effect tests.
 -}
 module Sample.Effect.TreasuryWithdrawal (
-  runEffect,
-  Parameters (..),
-  Validity (..),
-  totallyValidParameters,
-  mkTestTree,
+  inputTreasury,
+  inputUser,
+  inputGAT,
+  inputCollateral,
+  outputTreasury,
+  outputUser,
+  buildReceiversOutputFromDatum,
+  currSymbol,
+  users,
+  treasuries,
+  buildScriptContext,
 ) where
 
 import Agora.Effect.TreasuryWithdrawal (
-  TreasuryWithdrawalDatum (..),
+  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
+  treasuryWithdrawalValidator,
  )
-import Control.Composition ((.*))
-import Data.Foldable (Foldable (fold))
-import Data.List (singleton)
-import Data.Map ((!))
-import Data.Map.Ordered (OMap)
-import Data.Map.Ordered qualified as Map
-import Data.Semigroup (mtimesDefault)
-import Plutarch.Api.V2 (scriptHash)
-import Plutarch.Context (credential, input, mint, output, script, withInlineDatum, withRef, withRefTxId, withValue)
-import Plutarch.Script (Script)
-import PlutusLedgerApi.V1.Value qualified as Value (scale, singleton)
-import PlutusLedgerApi.V2 (
+import Data.Default (def)
+import Plutarch.Api.V1 (mkValidator, validatorHash)
+import PlutusLedgerApi.V1 (
+  Address (Address),
   Credential (..),
-  TxId,
+  CurrencySymbol,
+  DatumHash (DatumHash),
+  PubKeyHash,
+  ScriptContext (..),
+  ScriptPurpose (Spending),
+  TokenName (TokenName),
+  TxInInfo (TxInInfo),
+  TxInfo (
+    TxInfo,
+    txInfoDCert,
+    txInfoData,
+    txInfoFee,
+    txInfoId,
+    txInfoInputs,
+    txInfoMint,
+    txInfoOutputs,
+    txInfoSignatories,
+    txInfoValidRange,
+    txInfoWdrl
+  ),
+  TxOut (..),
   TxOutRef (TxOutRef),
+  Validator,
+  ValidatorHash (ValidatorHash),
   Value,
  )
-import PlutusLedgerApi.V3 (ScriptHash)
-import Sample.Shared (agoraScripts, authorityTokenPolicy, authorityTokenSymbol, minAda, signer, signer2, trScriptHash, trValidator)
-import Test.Specification (SpecificationTree, group, testPolicy, testValidator)
-import Test.Util (CombinableBuilder, mkMinting, mkSpending, subtractValue, validatorHashes)
+import PlutusLedgerApi.V1.Interval qualified as Interval (always)
+import PlutusLedgerApi.V1.Value qualified as Value (singleton)
+import Test.Util (scriptCredentials, userCredentials)
 
-data Parameters = Parameters
-  { shouldDeliver ::
-      OMap Credential Value
-  , treasuryInputCount :: Integer
-  , badReceivedValue :: Bool
-  , badReceivers :: Bool
-  , badReceiverOrder :: Bool
-  , badTreasuryPaybackValue :: Bool
-  }
+-- | A sample Currency Symbol.
+currSymbol :: CurrencySymbol
+currSymbol = "9c04a69c7133e26061fe5a15adaf4f79cd51e47ef22a2e3c91a36f04"
 
-data Validity = Validity
-  { forGATPolicy :: Bool
-  , forEffectValidator :: Bool
-  , forTreasury :: Bool
-  }
+-- | A sample 'PubKeyHash'.
+signer :: PubKeyHash
+signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
 
-effectValidator :: Script
-effectValidator = agoraScripts ! "agora:treasuryWithdrawalValidator"
+-- | List of users who the effect will pay to.
+users :: [Credential]
+users = userCredentials
 
-effectHash :: ScriptHash
-effectHash = scriptHash effectValidator
+-- | List of users who the effect will pay to.
+treasuries :: [Credential]
+treasuries = scriptCredentials
 
-mkEffectDatum :: Parameters -> TreasuryWithdrawalDatum
-mkEffectDatum ps =
-  TreasuryWithdrawalDatum
-    { receivers = Map.assocs ps.shouldDeliver
-    , treasuries = [ScriptCredential trScriptHash]
+inputGAT :: TxInInfo
+inputGAT =
+  TxInInfo
+    (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+    TxOut
+      { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+      , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST
+      , txOutDatumHash = Just (DatumHash "")
+      }
+
+-- | Create an input given the index of the treasury and the 'Value' at this input.
+inputTreasury :: Int -> Value -> TxInInfo
+inputTreasury indx val =
+  TxInInfo
+    (TxOutRef "" 1)
+    TxOut
+      { txOutAddress = Address (treasuries !! indx) Nothing
+      , txOutValue = val
+      , txOutDatumHash = Just (DatumHash "")
+      }
+
+-- | Create a input given the index of the user and the 'Value' at this input.
+inputUser :: Int -> Value -> TxInInfo
+inputUser indx val =
+  TxInInfo
+    (TxOutRef "" 1)
+    TxOut
+      { txOutAddress = Address (users !! indx) Nothing
+      , txOutValue = val
+      , txOutDatumHash = Just (DatumHash "")
+      }
+
+-- | Create a input representing the collateral given by a user.
+inputCollateral :: Int -> TxInInfo
+inputCollateral indx =
+  TxInInfo -- Initiator
+    (TxOutRef "" 1)
+    TxOut
+      { txOutAddress = Address (users !! indx) Nothing
+      , txOutValue = Value.singleton "" "" 2000000
+      , txOutDatumHash = Just (DatumHash "")
+      }
+
+-- | Create an output at the nth treasury with the given 'Value'.
+outputTreasury :: Int -> Value -> TxOut
+outputTreasury indx val =
+  TxOut
+    { txOutAddress = Address (treasuries !! indx) Nothing
+    , txOutValue = val
+    , txOutDatumHash = Nothing
     }
 
-effectRef :: TxOutRef
-effectRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 0
-
-treasuryTxId :: TxId
-treasuryTxId = "0ca36f3a357bc69579ab2531aecd1e7d3714d993c7820f40b864be15"
-
-mkEffectInputBuilder :: forall b. CombinableBuilder b => Parameters -> b
-mkEffectInputBuilder ps =
-  let mkGATValue = Value.singleton authorityTokenSymbol ""
-   in mconcat
-        [ mint $ mkGATValue (-1)
-        , input $
-            mconcat
-              [ script effectHash
-              , withRef effectRef
-              , withInlineDatum $ mkEffectDatum ps
-              , withValue $ mkGATValue 1
-              ]
-        ]
-
-mkTreasuryInputBuilder ::
-  forall b.
-  CombinableBuilder b =>
-  Parameters ->
-  b
-mkTreasuryInputBuilder ps =
-  mtimesDefault ps.treasuryInputCount $
-    input $
-      mconcat
-        [ script trScriptHash
-        , withRefTxId treasuryTxId
-        , withInlineDatum ()
-        , withValue $ fold ps.shouldDeliver
-        ]
-
-mkTreasuryPaybackOutputBuilder ::
-  forall b.
-  CombinableBuilder b =>
-  Parameters ->
-  b
-mkTreasuryPaybackOutputBuilder ps =
-  let sentAmount = fold ps.shouldDeliver
-      inputAmount =
-        flip Value.scale sentAmount $
-          if ps.badTreasuryPaybackValue
-            then 1
-            else ps.treasuryInputCount
-      paybackValue = inputAmount `subtractValue` sentAmount
-   in output $
-        mconcat
-          [ script trScriptHash
-          , withValue paybackValue
-          , withInlineDatum ()
-          ]
-
-mkReceiverOutputBuilder ::
-  forall b.
-  CombinableBuilder b =>
-  Parameters ->
-  b
-mkReceiverOutputBuilder ps =
-  let mkOutputValue =
-        (minAda <>)
-          . if ps.badReceivedValue
-            then const $ Value.singleton "" "bruh" 1
-            else id
-      mkFinalOutputs =
-        mconcat
-          . (if ps.badReceiverOrder then reverse else id)
-          . (if ps.badReceivers then drop 1 else id)
-      mkOutput :: _ -> _ -> b
-      mkOutput cred value =
-        output $
-          mconcat
-            [ credential cred
-            , withValue $ mkOutputValue value
-            , withInlineDatum ()
-            ]
-      rawOutputs =
-        foldMap (uncurry $ singleton .* mkOutput) $
-          Map.assocs ps.shouldDeliver
-   in mkFinalOutputs rawOutputs
-
-runEffect :: forall b. CombinableBuilder b => Parameters -> b
-runEffect ps =
-  foldMap
-    ($ ps)
-    [ mkEffectInputBuilder
-    , mkTreasuryInputBuilder
-    , mkReceiverOutputBuilder
-    , mkTreasuryPaybackOutputBuilder
-    ]
-
-totallyValidParameters :: Parameters
-totallyValidParameters =
-  Parameters
-    { shouldDeliver =
-        Map.fromList
-          [ (PubKeyCredential signer, Value.singleton "" "" 42_000_000)
-          , (PubKeyCredential signer2, Value.singleton "" "" 42_000_000)
-          , (ScriptCredential (head validatorHashes), Value.singleton "" "" 42_000_000)
-          ]
-    , treasuryInputCount = 2
-    , badReceivedValue = False
-    , badReceivers = False
-    , badReceiverOrder = False
-    , badTreasuryPaybackValue = False
+-- | Create an output at the nth user with the given 'Value'.
+outputUser :: Int -> Value -> TxOut
+outputUser indx val =
+  TxOut
+    { txOutAddress = Address (users !! indx) Nothing
+    , txOutValue = val
+    , txOutDatumHash = Nothing
     }
 
-mkTestTree ::
-  String ->
-  Parameters ->
-  Validity ->
-  SpecificationTree
-mkTestTree name ps val =
-  group name [effect, treasury, authority]
+-- | Create a list of the outputs that are required as encoded in 'TreasuryWithdrawalDatum'.
+buildReceiversOutputFromDatum :: TreasuryWithdrawalDatum -> [TxOut]
+buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs _) = f <$> xs
   where
-    spend = mkSpending runEffect ps
-    mint = mkMinting runEffect ps
+    f x =
+      TxOut
+        { txOutAddress = Address (fst x) Nothing
+        , txOutValue = snd x
+        , txOutDatumHash = Nothing
+        }
 
-    effect =
-      testValidator
-        val.forEffectValidator
-        "effect"
-        effectValidator
-        (mkEffectDatum ps)
-        ()
-        (spend effectRef)
+-- | Effect validator instance.
+validator :: Validator
+validator = mkValidator def $ treasuryWithdrawalValidator currSymbol
 
-    treasury =
-      testValidator
-        val.forTreasury
-        "treasury"
-        trValidator
-        ()
-        ()
-        (spend $ TxOutRef treasuryTxId 1)
+-- | 'TokenName' that represents the hash of the 'Agora.Stake.Stake' validator.
+validatorHashTN :: TokenName
+validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
 
-    authority =
-      testPolicy
-        val.forGATPolicy
-        "authority"
-        authorityTokenPolicy
-        ()
-        (mint authorityTokenSymbol)
+buildScriptContext :: [TxInInfo] -> [TxOut] -> ScriptContext
+buildScriptContext inputs outputs =
+  ScriptContext
+    { scriptContextTxInfo =
+        TxInfo
+          { txInfoInputs = inputs
+          , txInfoOutputs = outputs
+          , txInfoFee = Value.singleton "" "" 2
+          , txInfoMint = Value.singleton currSymbol validatorHashTN (-1)
+          , txInfoDCert = []
+          , txInfoWdrl = []
+          , txInfoValidRange = Interval.always
+          , txInfoSignatories = [signer]
+          , txInfoData = []
+          , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+          }
+    , scriptContextPurpose =
+        Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+    }

agora-specs/Sample/Governor/Initialize.hs

@@ -21,18 +21,18 @@ module Sample.Governor.Initialize (
 
 import Agora.Bootstrap (agoraScripts)
 import Agora.Governor (Governor (..), GovernorDatum (..))
-import Agora.Linker (linker)
 import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
 import Agora.Proposal.Time (
   MaxTimeRangeWidth (MaxTimeRangeWidth),
   ProposalTimingConfig (ProposalTimingConfig),
  )
+import Agora.Scripts (
+  AgoraScripts (compiledGovernorPolicy),
+  governorSTAssetClass,
+  governorSTSymbol,
+  governorValidatorHash,
+ )
 import Data.Default (Default (..))
-import Data.Map (Map, (!))
-import Data.Text (Text)
-import Optics (view)
-import Plutarch (Script)
-import Plutarch.Api.V2 (scriptHash)
 import Plutarch.Context (
   input,
   mint,
@@ -42,23 +42,20 @@ import Plutarch.Context (
   signedWith,
   txId,
   withDatum,
-  withRef,
+  withOutRef,
   withValue,
  )
+import PlutusLedgerApi.V1 (
+  CurrencySymbol,
+  TxOutRef (TxOutRef),
+  ValidatorHash,
+ )
 import PlutusLedgerApi.V1.Value (AssetClass (..))
 import PlutusLedgerApi.V1.Value qualified as Value
-import PlutusLedgerApi.V2 (
-  CurrencySymbol (CurrencySymbol),
-  ScriptHash,
-  TxOutRef (TxOutRef),
-  getScriptHash,
- )
 import Sample.Shared (
-  deterministicTracingConfig,
   minAda,
  )
 import Sample.Shared qualified as Shared
-import ScriptExport.ScriptInfo (runLinker)
 import Test.Specification (SpecificationTree, testPolicy)
 import Test.Util (CombinableBuilder, mkMinting, pubKeyHashes, sortValue)
 
@@ -68,19 +65,19 @@ data Parameters = Parameters
   -- ^ Whether the 'GovernorDatum.proposalThresholds' field of the output
   --    governor datum is valid or not.
   , datumMaxTimeRangeWidthValid :: Bool
-  -- ^ Whether the 'GovernorDatum.maximumCreatedProposalsPerStake'field of the
+  -- ^ Whether the 'GovernorDatum.maximumProposalsPerStake'field of the
   --    output governor datum is valid or not.
   , datumTimingConfigValid :: Bool
   -- ^ Whether the 'GovernorDatum.proposalTimings'field  of the output
   --    governor datum is valid or not.
   , withGovernorDatum :: Bool
-  -- ^ Whether the output GST UTxO will carry the governor datum.
-  , presentWitness :: Bool
-  -- ^ Whether to spend the UTxO referenced by 'Governor.gstOutRef'.
-  , mintMoreThanOneStateToken :: Bool
-  -- ^ More than one GST will be minted if this is set to true.
-  , mintStateTokenWithName :: Bool
-  -- ^ The token name of the GST won't be empty if this is set to true.
+  , -- Whether the output GST UTxO will carry the governor datum.
+    presentWitness :: Bool
+  , -- Whether to spend the UTxO referenced by 'Governor.gstOutRef'.
+    mintMoreThanOneStateToken :: Bool
+  , -- More than one GST will be minted if this is set to true.
+    mintStateTokenWithName :: Bool
+    -- The token name of the GST won't be empty if this is set to true.
   }
 
 --------------------------------------------------------------------------------
@@ -92,17 +89,17 @@ validGovernorOutputDatum =
     , nextProposalId = ProposalId 0
     , proposalTimings = def
     , createProposalTimeRangeMaxWidth = def
-    , maximumCreatedProposalsPerStake = 3
+    , maximumProposalsPerStake = 3
     }
 
 invalidProposalThresholds :: ProposalThresholds
-invalidProposalThresholds = ProposalThresholds (-1) (-1) (-1) (-1) (-1)
+invalidProposalThresholds = ProposalThresholds (-1) (-1) (-1)
 
 invalidMaxTimeRangeWidth :: MaxTimeRangeWidth
 invalidMaxTimeRangeWidth = MaxTimeRangeWidth 0
 
 invalidProposalTimings :: ProposalTimingConfig
-invalidProposalTimings = ProposalTimingConfig (-1) (-1) (-1) (-1) (-1) (-1)
+invalidProposalTimings = ProposalTimingConfig (-1) (-1) (-1) (-1)
 
 witnessRef :: TxOutRef
 witnessRef = TxOutRef "b0353c22b0bd6c5296a8eef160ba25d90b5dc82a9bb8bdaa6823ffc19515d6ad" 0
@@ -113,31 +110,17 @@ governor =
     { gstOutRef = witnessRef
     }
 
-scripts :: Map Text Script
-scripts =
-  either
-    (error . show)
-    (fmap (view #script) . view #scripts)
-    ( runLinker
-        linker
-        (agoraScripts deterministicTracingConfig)
-        governor
-    )
-
-govPolicy :: Script
-govPolicy = scripts ! "agora:governorPolicy"
-
-govValidator :: Script
-govValidator = scripts ! "agora:governorValidator"
-
-govSymbol :: CurrencySymbol
-govSymbol = CurrencySymbol . getScriptHash $ scriptHash govPolicy
+scripts :: AgoraScripts
+scripts = agoraScripts Shared.deterministicTracingConfing governor
 
 govAssetClass :: AssetClass
-govAssetClass = AssetClass (govSymbol, "")
+govAssetClass = governorSTAssetClass scripts
 
-govScriptHash :: ScriptHash
-govScriptHash = scriptHash govValidator
+govValidatorHash :: ValidatorHash
+govValidatorHash = governorValidatorHash scripts
+
+govSymbol :: CurrencySymbol
+govSymbol = governorSTSymbol scripts
 
 --------------------------------------------------------------------------------
 
@@ -192,7 +175,7 @@ mintGST ps = builder
                 mconcat
                   [ pubKey witnessPubKey
                   , withValue witnessValue
-                  , withRef witnessRef
+                  , withOutRef witnessRef
                   ]
             , output $
                 mconcat
@@ -211,7 +194,7 @@ mintGST ps = builder
               else mempty
        in output $
             mconcat
-              [ script govScriptHash
+              [ script govValidatorHash
               , withValue governorValue
               , datum
               ]
@@ -291,6 +274,6 @@ mkTestCase name ps valid =
   testPolicy
     valid
     name
-    govPolicy
+    scripts.compiledGovernorPolicy
     ()
     (mkMinting mintGST ps govSymbol)

agora-specs/Sample/Governor/Mutate.hs

@@ -16,13 +16,13 @@ module Sample.Governor.Mutate (
   invalidBundles,
 ) where
 
+import Agora.Effect.NoOp (noOpValidator)
 import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
 import Agora.Proposal (ProposalId (ProposalId), ProposalThresholds (..))
+import Agora.Scripts (AgoraScripts (..))
+import Agora.Utils (validatorHashToTokenName)
 import Data.Default (def)
-import Data.Map ((!))
-import Data.Text qualified as T
-import Plutarch (Script)
-import Plutarch.Api.V2 (PMintingPolicy, scriptHash)
+import Plutarch.Api.V1 (PValidator, mkValidator, validatorHash)
 import Plutarch.Context (
   input,
   mint,
@@ -30,34 +30,26 @@ import Plutarch.Context (
   pubKey,
   script,
   withDatum,
-  withRef,
+  withOutRef,
   withValue,
  )
-import Plutarch.Extra.AssetClass (assetClassValue)
-import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
-import PlutusLedgerApi.V1.Value qualified as Value
-import PlutusLedgerApi.V2 (
+import PlutusLedgerApi.V1 (
   Data,
-  ScriptHash,
   TxOutRef (TxOutRef),
+  ValidatorHash,
   Value,
   toData,
  )
+import PlutusLedgerApi.V1.Value qualified as Value
 import Sample.Shared (
   agoraScripts,
   authorityTokenSymbol,
-  governorAssetClass,
-  governorScriptHash,
-  governorValidator,
+  govAssetClass,
+  govValidatorHash,
   minAda,
  )
 import Test.Specification (SpecificationTree, testValidator)
-import Test.Util (
-  CombinableBuilder,
-  mkSpending,
-  pubKeyHashes,
-  sortValue,
- )
+import Test.Util (CombinableBuilder, mkSpending, pubKeyHashes, sortValue, validatorHashes)
 
 --------------------------------------------------------------------------------
 
@@ -104,7 +96,7 @@ governorInputDatum =
     , nextProposalId = ProposalId 0
     , proposalTimings = def
     , createProposalTimeRangeMaxWidth = def
-    , maximumCreatedProposalsPerStake = 3
+    , maximumProposalsPerStake = 3
     }
 
 mkGovernorOutputDatum ::
@@ -114,16 +106,14 @@ mkGovernorOutputDatum DatumValid =
   Just $
     toData $
       governorInputDatum
-        { maximumCreatedProposalsPerStake = 4
+        { maximumProposalsPerStake = 4
         }
 mkGovernorOutputDatum ValueInvalid =
   let invalidProposalThresholds =
         ProposalThresholds
           { execute = -1
           , create = -1
-          , toVoting = -1
           , vote = -1
-          , cosign = -1
           }
    in Just $
         toData $
@@ -145,22 +135,22 @@ governorRedeemer = MutateGovernor
 
 mkGovernorBuilder :: forall b. CombinableBuilder b => GovernorParameters -> b
 mkGovernorBuilder ps =
-  let gst = assetClassValue governorAssetClass 1
+  let gst = Value.assetClassValue govAssetClass 1
       value = sortValue $ gst <> minAda
       gstOutput =
         if ps.stealGST
           then pubKey $ head pubKeyHashes
-          else script governorScriptHash
+          else script govValidatorHash
       withGSTDatum =
         maybe mempty withDatum $
           mkGovernorOutputDatum ps.governorOutputDatumValidity
    in mconcat
         [ input $
             mconcat
-              [ script governorScriptHash
+              [ script govValidatorHash
               , withDatum governorInputDatum
               , withValue value
-              , withRef governorRef
+              , withOutRef governorRef
               ]
         , output $
             mconcat
@@ -172,28 +162,21 @@ mkGovernorBuilder ps =
 
 --------------------------------------------------------------------------------
 
-mockEffectValidator :: Script
-mockEffectValidator = agoraScripts ! "agora:noOpValidator"
+mockEffectValidator :: ClosedTerm PValidator
+mockEffectValidator = noOpValidator authorityTokenSymbol
 
-mockEffectScriptHash :: ScriptHash
-mockEffectScriptHash = scriptHash mockEffectValidator
-
-mockAuthScript :: ClosedTerm PMintingPolicy
-mockAuthScript = plam $ \_ _ -> popaque $ pcon PUnit
-
-mockAuthScriptHash :: ScriptHash
-mockAuthScriptHash =
-  scriptHash . either (error . T.unpack) id $ compile def mockAuthScript
+mockEffectValidatorHash :: ValidatorHash
+mockEffectValidatorHash = validatorHash $ mkValidator def mockEffectValidator
 
 mkGATValue :: GATValidity -> Integer -> Value
 mkGATValue NoGAT _ = mempty
 mkGATValue v q =
-  let authScript = case v of
-        GATValid -> mockAuthScriptHash
-        WrongTag -> ""
+  let gatOwner = case v of
+        GATValid -> mockEffectValidatorHash
+        WrongTag -> head validatorHashes
    in Value.singleton
         authorityTokenSymbol
-        (scriptHashToTokenName authScript)
+        (validatorHashToTokenName gatOwner)
         q
 
 mkMockEffectBuilder :: forall b. CombinableBuilder b => MockEffectParameters -> b
@@ -209,12 +192,12 @@ mkMockEffectBuilder ps =
         [ mint burnt
         , input $
             mconcat
-              [ script mockEffectScriptHash
+              [ script mockEffectValidatorHash
               , withValue inputValue
               ]
         , output $
             mconcat
-              [ script mockEffectScriptHash
+              [ script mockEffectValidatorHash
               , withValue outputValue
               ]
         ]
@@ -236,7 +219,7 @@ mkTestCase name pb (Validity forGov) =
   testValidator
     forGov
     name
-    governorValidator
+    agoraScripts.compiledGovernorValidator
     governorInputDatum
     governorRedeemer
     (mkSpending mutate pb governorRef)

agora-specs/Sample/Proposal/Advance.hs

@@ -24,31 +24,26 @@ module Sample.Proposal.Advance (
   mkValidToNextStateBundle,
   mkValidToNextStateBundles,
   mkValidToFailedStateBundles,
-  mkValidToFinishedInlineGATDatumBundles,
   mkInsufficientVotesBundle,
   mkAmbiguousWinnerBundle,
   mkFromFinishedBundles,
   mkInsufficientCosignsBundle,
   mkToNextStateTooLateBundles,
+  mkInvalidOutputStakeBundles,
   mkMintGATsForWrongEffectsBundle,
   mkNoGATMintedBundle,
   mkGATsWithWrongDatumBundle,
   mkMintGATsWithoutTagBundle,
   mkBadGovernorOutputDatumBundle,
-  mkUnexpectedOutputStakeBundles,
-  mkFastforwardToFinishBundles,
-  mkBadGovernorRedeemerBundle,
 ) where
 
 import Agora.Governor (
   Governor (..),
   GovernorDatum (..),
-  GovernorRedeemer (CreateProposal, MintGATs),
+  GovernorRedeemer (MintGATs),
  )
 import Agora.Proposal (
   ProposalDatum (..),
-  ProposalEffectGroup,
-  ProposalEffectMetadata (ProposalEffectMetadata),
   ProposalId (ProposalId),
   ProposalRedeemer (AdvanceProposal),
   ProposalStatus (..),
@@ -66,63 +61,57 @@ import Agora.Proposal.Time (
     votingTime
   ),
  )
-import Agora.SafeMoney (AuthorityTokenTag, GTTag)
+import Agora.Scripts (AgoraScripts (..))
 import Agora.Stake (
   StakeDatum (..),
+  StakeRedeemer (WitnessStake),
  )
-import Control.Applicative (liftA2)
+import Agora.Utils (validatorHashToTokenName)
 import Control.Monad.State (execState, modify, when)
 import Data.Default (def)
-import Data.List (singleton, sort)
-import Data.Map.Strict qualified as StrictMap
-import Data.Maybe (fromJust)
-import Data.Tagged (Tagged (Tagged), untag)
+import Data.List (sort)
+import Data.Maybe (catMaybes, fromJust)
+import Data.Tagged (Tagged (..), untag)
 import Plutarch.Context (
   input,
   mint,
   output,
-  referenceInput,
   script,
   signedWith,
   timeRange,
   withDatum,
-  withInlineDatum,
-  withRedeemer,
-  withRef,
+  withOutRef,
   withValue,
  )
-import Plutarch.Extra.AssetClass (AssetClass (AssetClass), assetClassValue)
-import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
 import Plutarch.Lift (PLifted, PUnsafeLiftDecl)
-import PlutusLedgerApi.V2 (
-  Credential (PubKeyCredential),
+import PlutusLedgerApi.V1 (
   DatumHash,
   POSIXTime,
   POSIXTimeRange,
   PubKeyHash,
-  ScriptHash,
   TxOutRef (TxOutRef),
+  ValidatorHash,
  )
-import PlutusTx qualified
+import PlutusLedgerApi.V1.Value (AssetClass (..))
+import PlutusLedgerApi.V1.Value qualified as Value
+import PlutusTx.AssocMap qualified as AssocMap
 import Sample.Proposal.Shared (
   governorTxRef,
   proposalTxRef,
   stakeTxRef,
  )
 import Sample.Shared (
-  authorityTokenPolicy,
+  agoraScripts,
   authorityTokenSymbol,
+  govAssetClass,
+  govValidatorHash,
   governor,
-  governorAssetClass,
-  governorScriptHash,
-  governorValidator,
   minAda,
-  proposalAssetClass,
-  proposalScriptHash,
-  proposalValidator,
+  proposalPolicySymbol,
+  proposalValidatorHash,
   signer,
   stakeAssetClass,
-  stakeScriptHash,
+  stakeValidatorHash,
  )
 import Test.Specification (
   SpecificationTree,
@@ -138,9 +127,9 @@ import Test.Util (
   mkMinting,
   mkSpending,
   pubKeyHashes,
-  scriptHashes,
   sortValue,
   toDatum,
+  updateMap,
   validatorHashes,
  )
 
@@ -155,7 +144,7 @@ data ParameterBundle = ParameterBundle
   , governorParameters :: Maybe GovernorParameters
   -- ^ Parameters related to GST moving. If set to 'Nothing', the GST won't
   --   be moved, thus the governor validator won't be run in 'mkTestTree'.
-  , authorityTokenParameters :: [AuthorityTokenParameters]
+  , authorityTokenParameters :: Maybe AuthorityTokenParameters
   -- ^ Parameters related to GAT minting. If set to 'Nothing', no GAT will
   --     be minted, thus the GAT minting policy won't be run in 'mkTestTree'.
   , transactionTimeRange :: POSIXTimeRange
@@ -168,18 +157,9 @@ data ParameterBundle = ParameterBundle
   }
 
 -- | Everything about the generated governor stuff.
-data GovernorParameters = forall
-    (redeemer :: Type)
-    (predeemer :: PType).
-  ( PUnsafeLiftDecl predeemer
-  , PLifted predeemer ~ redeemer
-  , PIsData predeemer
-  , PlutusTx.ToData redeemer
-  ) =>
-  GovernorParameters
+newtype GovernorParameters = GovernorParameters
   { invalidGovernorOutputDatum :: Bool
   -- ^ The output governor datum will be changed.
-  , governorRedeemer :: redeemer
   }
 
 -- | Everything about the generated authority token stuff.
@@ -191,17 +171,13 @@ data AuthorityTokenParameters = forall
   , PIsData pdatum
   ) =>
   AuthorityTokenParameters
-  { mintGATsFor :: ScriptHash
+  { mintGATsFor :: [ValidatorHash]
   -- ^ GATs will be minted and sent to the given group of effects.
   , carryDatum :: Maybe datum
   -- ^ The datum that GAT UTxOs will be carrying.
-  , carryAuthScript :: Maybe ScriptHash
-  -- ^ The authentication script that GAT UTxOs link to through their token name.
   , invalidTokenName :: Bool
   -- ^ If set to true, GATs won't be tagged by their corresponding effect
   --    hashes.
-  , shouldInlineDatum :: Bool
-  -- ^ If set to true, the effect datum will be inlined.
   }
 
 -- | Represent the winning effect group(s).
@@ -217,7 +193,7 @@ data ProposalParameters = ProposalParameters
   -- ^ What status is the proposal advancing from
   , toStatus :: ProposalStatus
   -- ^ What status is the proposal advancing to
-  , effectList :: [ProposalEffectGroup]
+  , effectList :: [AssocMap.Map ValidatorHash DatumHash]
   -- ^ The effect groups of the proposal. A neutral effect group is not
   --    required here.
   , winnerAndVotes :: Maybe (Winner, Integer)
@@ -232,8 +208,9 @@ data ProposalParameters = ProposalParameters
 -- | Everything about the generated stake stuff.
 data StakeParameters = StakeParameters
   { numStake :: NumStake
-  , perStakeGTs :: Tagged GTTag Integer
+  , perStakeGTs :: Integer
   , transactionSignedByOwners :: Bool
+  , invalidStakeOutputDatum :: Bool
   }
 
 -- | Represent the number of stakes or the number of the cosigners.
@@ -242,7 +219,7 @@ type NumStake = Int
 -- | Represent an index.
 type Index = Int
 
-{- | The validity of the generated transaction for variuos componets.
+{- | The validity of the generated transacrion for variuos componets.
      'True' means valid, 'False' means invalid.
 -}
 data Validity = Validity
@@ -257,8 +234,8 @@ data Validity = Validity
 -- * Proposal
 
 -- | Mock cosigners.
-mkCosigners :: NumStake -> [Credential]
-mkCosigners = sort . fmap PubKeyCredential . flip take pubKeyHashes
+mkCosigners :: NumStake -> [PubKeyHash]
+mkCosigners = sort . flip take pubKeyHashes
 
 -- | Allocate the result tag for the effect at the given index.
 outcomeIdxToResultTag :: Index -> ResultTag
@@ -267,20 +244,20 @@ outcomeIdxToResultTag = ResultTag . fromIntegral
 -- | Add a neutral effect group and allocate result tags for the effect groups.
 mkEffects ::
   ProposalParameters ->
-  StrictMap.Map ResultTag ProposalEffectGroup
+  AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash)
 mkEffects ps =
   let resultTags = map ResultTag [0 ..]
-      neutralEffect = StrictMap.empty
+      neutralEffect = AssocMap.empty
       finalEffects = ps.effectList <> [neutralEffect]
-   in StrictMap.fromList $ zip resultTags finalEffects
+   in AssocMap.fromList $ zip resultTags finalEffects
 
 -- | Set the votes of the winning group(s).
 setWinner :: (Winner, Integer) -> ProposalVotes -> ProposalVotes
 setWinner (All, votes) (ProposalVotes m) =
-  ProposalVotes $ StrictMap.mapMaybe (const $ Just votes) m
+  ProposalVotes $ AssocMap.mapMaybe (const $ Just votes) m
 setWinner (EffectAt winnerIdx, votes) (ProposalVotes m) =
   let winnerResultTag = outcomeIdxToResultTag winnerIdx
-   in ProposalVotes $ StrictMap.adjust (const votes) winnerResultTag m
+   in ProposalVotes $ updateMap (const $ Just votes) winnerResultTag m
 
 -- | Mock votes for the proposal, given the parameters.
 mkVotes ::
@@ -293,7 +270,7 @@ mkVotes ps =
 
 -- | The starting time of every generated proposal.
 proposalStartingTime :: POSIXTime
-proposalStartingTime = 100
+proposalStartingTime = 0
 
 -- | Create the input proposal datum given the parameters.
 mkProposalInputDatum :: ProposalParameters -> ProposalDatum
@@ -334,19 +311,19 @@ proposalRef = TxOutRef proposalTxRef 1
 -}
 mkProposalBuilder :: forall b. CombinableBuilder b => ProposalParameters -> b
 mkProposalBuilder ps =
-  let pst = assetClassValue proposalAssetClass 1
+  let pst = Value.singleton proposalPolicySymbol "" 1
       value = sortValue $ minAda <> pst
    in mconcat
         [ input $
             mconcat
-              [ script proposalScriptHash
-              , withRef proposalRef
+              [ script proposalValidatorHash
+              , withOutRef proposalRef
               , withDatum (mkProposalInputDatum ps)
               , withValue value
               ]
         , output $
             mconcat
-              [ script proposalScriptHash
+              [ script proposalValidatorHash
               , withDatum (mkProposalOutputDatum ps)
               , withValue value
               ]
@@ -363,7 +340,7 @@ proposalRedeemer = AdvanceProposal
 -- * Stake
 
 -- Mock owners of the stakes.
-mkStakeOwners :: NumStake -> [Credential]
+mkStakeOwners :: NumStake -> [PubKeyHash]
 mkStakeOwners = mkCosigners
 
 -- | Create the input stake datums given the parameters.
@@ -371,14 +348,32 @@ mkStakeInputDatums :: StakeParameters -> [StakeDatum]
 mkStakeInputDatums ps =
   let template =
         StakeDatum
-          { stakedAmount = ps.perStakeGTs
-          , owner = PubKeyCredential ""
+          { stakedAmount = Tagged ps.perStakeGTs
+          , owner = ""
           , delegatedTo = Nothing
           , lockedBy = []
           }
    in (\owner -> template {owner = owner})
         <$> mkStakeOwners ps.numStake
 
+-- | Create the output stake datums given the parameters.
+mkStakeOutputDatums :: StakeParameters -> [StakeDatum]
+mkStakeOutputDatums ps =
+  let inputDatums = mkStakeInputDatums ps
+      outputStakedAmount =
+        Tagged $
+          if ps.invalidStakeOutputDatum
+            then ps.perStakeGTs * 10
+            else ps.perStakeGTs
+      modify inp = inp {stakedAmount = outputStakedAmount}
+   in modify <$> inputDatums
+
+{- | Get the input stake datum given the index. The range of the index is
+    @[0, 'StakeParameters.numStake - 1']@
+-}
+getStakeInputDatumAt :: StakeParameters -> Index -> StakeDatum
+getStakeInputDatumAt ps = (!!) (mkStakeInputDatums ps)
+
 -- | Create the reference to a particular stake UTXO.
 mkStakeRef :: Index -> TxOutRef
 mkStakeRef = TxOutRef stakeTxRef . (+ 3) . fromIntegral
@@ -391,30 +386,43 @@ mkStakeBuilder ps =
   let perStakeValue =
         sortValue $
           minAda
-            <> assetClassValue stakeAssetClass 1
-            <> assetClassValue
-              governor.gtClassRef
+            <> Value.assetClassValue stakeAssetClass 1
+            <> Value.assetClassValue
+              (untag governor.gtClassRef)
               ps.perStakeGTs
-      perStake idx i =
+      perStake idx i o =
         let withSig =
-              case (i.owner, ps.transactionSignedByOwners) of
-                (PubKeyCredential owner, True) -> signedWith owner
-                _ -> mempty
+              if ps.transactionSignedByOwners
+                then signedWith i.owner
+                else mempty
          in mconcat
               [ withSig
-              , referenceInput $
+              , input $
                   mconcat
-                    [ script stakeScriptHash
-                    , withRef (mkStakeRef idx)
+                    [ script stakeValidatorHash
+                    , withOutRef (mkStakeRef idx)
                     , withValue perStakeValue
-                    , withInlineDatum i
+                    , withDatum i
+                    ]
+              , output $
+                  mconcat
+                    [ script stakeValidatorHash
+                    , withValue perStakeValue
+                    , withDatum o
                     ]
               ]
    in mconcat $
-        zipWith
+        zipWith3
           perStake
           [0 :: Index ..]
           (mkStakeInputDatums ps)
+          (mkStakeOutputDatums ps)
+
+{- | The proposal redeemer used to spend the stake UTXO, which is always
+      'WitnessStake' in this case.
+-}
+stakeRedeemer :: StakeRedeemer
+stakeRedeemer = WitnessStake
 
 --------------------------------------------------------------------------------
 
@@ -428,14 +436,14 @@ governorInputDatum =
     , nextProposalId = ProposalId 42
     , proposalTimings = def
     , createProposalTimeRangeMaxWidth = def
-    , maximumCreatedProposalsPerStake = 3
+    , maximumProposalsPerStake = 3
     }
 
 -- | Create the output governor datum given the parameters.
 mkGovernorOutputDatum :: GovernorParameters -> GovernorDatum
 mkGovernorOutputDatum ps =
   if ps.invalidGovernorOutputDatum
-    then governorInputDatum {maximumCreatedProposalsPerStake = 15}
+    then governorInputDatum {maximumProposalsPerStake = 15}
     else governorInputDatum
 
 -- | Reference to the governor UTXO.
@@ -446,27 +454,32 @@ governorRef = TxOutRef governorTxRef 2
       governor validator.
 -}
 mkGovernorBuilder :: forall b. CombinableBuilder b => GovernorParameters -> b
-mkGovernorBuilder ps@(GovernorParameters _ redeemer) =
-  let gst = assetClassValue governorAssetClass 1
+mkGovernorBuilder ps =
+  let gst = Value.assetClassValue govAssetClass 1
       value = sortValue $ gst <> minAda
    in mconcat
         [ input $
             mconcat
-              [ script governorScriptHash
+              [ script govValidatorHash
               , withValue value
-              , withRef governorRef
+              , withOutRef governorRef
               , withDatum governorInputDatum
-              , withRedeemer redeemer
               ]
         , output $
             mconcat
-              [ script governorScriptHash
+              [ script govValidatorHash
               , withValue value
-              , withRef governorRef
+              , withOutRef governorRef
               , withDatum (mkGovernorOutputDatum ps)
               ]
         ]
 
+{- | The proposal redeemer used to spend the governor UTXO, which is always
+      'MintGATs' in this case.
+-}
+governorRedeemer :: GovernorRedeemer
+governorRedeemer = MintGATs
+
 --------------------------------------------------------------------------------
 
 -- * Authority Token
@@ -479,26 +492,27 @@ mkAuthorityTokenBuilder ::
   CombinableBuilder b =>
   AuthorityTokenParameters ->
   b
-mkAuthorityTokenBuilder ps@AuthorityTokenParameters {carryDatum, shouldInlineDatum} =
-  let tn =
-        case (ps.invalidTokenName, ps.carryAuthScript) of
-          (True, Just _) -> "deadbeef"
-          (True, Nothing) -> "deadbeef"
-          (False, Just as) -> scriptHashToTokenName as
-          (False, Nothing) -> ""
-      ac = Tagged @AuthorityTokenTag $ AssetClass authorityTokenSymbol tn
-      minted = assetClassValue ac 1
-      value = sortValue $ minAda <> minted
-      withDatum' = if shouldInlineDatum then withInlineDatum else withDatum
-   in mconcat
-        [ mint minted
-        , output $
-            mconcat
-              [ script ps.mintGATsFor
-              , maybe mempty withDatum' carryDatum
-              , withValue value
-              ]
-        ]
+mkAuthorityTokenBuilder (AuthorityTokenParameters es mdt invalidTokenName) =
+  foldMap perEffect es
+  where
+    perEffect :: ValidatorHash -> b
+    perEffect vh =
+      let tn =
+            if invalidTokenName
+              then ""
+              else validatorHashToTokenName vh
+          ac = AssetClass (authorityTokenSymbol, tn)
+          minted = Value.assetClassValue ac 1
+          value = sortValue $ minAda <> minted
+       in mconcat
+            [ mint minted
+            , output $
+                mconcat
+                  [ script vh
+                  , maybe mempty withDatum mdt
+                  , withValue value
+                  ]
+            ]
 
 -- | The redeemer used while running the authority token policy.
 authorityTokenRedeemer :: ()
@@ -518,7 +532,7 @@ advance pb =
         [ mkProposalBuilder pb.proposalParameters
         , mkStakeBuilder pb.stakeParameters
         , mkBuilderMaybe mkGovernorBuilder pb.governorParameters
-        , foldMap mkAuthorityTokenBuilder pb.authorityTokenParameters
+        , mkBuilderMaybe mkAuthorityTokenBuilder pb.authorityTokenParameters
         , timeRange pb.transactionTimeRange
         , maybe mempty signedWith pb.extraSignature
         ]
@@ -534,48 +548,52 @@ mkTestTree ::
   Validity ->
   SpecificationTree
 mkTestTree name pb val =
-  group name $ mconcat [proposal, governor, authority]
+  group name $ catMaybes [proposal, stake, governor, authority]
   where
     spend = mkSpending advance pb
+    mint = mkMinting advance pb
 
     proposal =
       let proposalInputDatum = mkProposalInputDatum pb.proposalParameters
-       in singleton $
+       in Just $
             testValidator
               val.forProposalValidator
               "proposal"
-              proposalValidator
+              agoraScripts.compiledProposalValidator
               proposalInputDatum
               proposalRedeemer
               (spend proposalRef)
 
-    governor =
-      maybe
-        []
-        ( singleton
-            . ( \(GovernorParameters _ governorRedeemer) ->
-                  testValidator
-                    (fromJust val.forGovernorValidator)
-                    "governor"
-                    governorValidator
-                    governorInputDatum
-                    governorRedeemer
-                    (spend governorRef)
+    stake =
+      let idx = 0
+       in Just $
+            testValidator
+              val.forStakeValidator
+              "stake"
+              agoraScripts.compiledStakeValidator
+              (getStakeInputDatumAt pb.stakeParameters idx)
+              stakeRedeemer
+              ( spend (mkStakeRef idx)
               )
-        )
-        (pb.governorParameters)
 
-    authority = case pb.authorityTokenParameters of
-      [] -> []
-      _ ->
-        singleton
-          ( testPolicy
-              (fromJust val.forAuthorityTokenPolicy)
-              "authority"
-              authorityTokenPolicy
-              authorityTokenRedeemer
-              (mkMinting advance pb authorityTokenSymbol)
-          )
+    governor =
+      testValidator
+        (fromJust val.forGovernorValidator)
+        "governor"
+        agoraScripts.compiledGovernorValidator
+        governorInputDatum
+        governorRedeemer
+        (spend governorRef)
+        <$ pb.governorParameters
+
+    authority =
+      testPolicy
+        (fromJust val.forAuthorityTokenPolicy)
+        "authority"
+        agoraScripts.compiledAuthorityTokenPolicy
+        authorityTokenRedeemer
+        (mint authorityTokenSymbol)
+        <$ (pb.authorityTokenParameters)
 
 {- | Create a test tree that runs a bunch of parameter bundles. These bundles
       should have the same validity.
@@ -633,8 +651,7 @@ mkInTimeTimeRange advanceFrom =
             + (def :: ProposalTimingConfig).draftTime
             + (def :: ProposalTimingConfig).votingTime
             + (def :: ProposalTimingConfig).lockingTime
-            + (def :: ProposalTimingConfig).executingTime
-            - 1
+            + (def :: ProposalTimingConfig).executingTime - 1
         )
     Finished -> error "Cannot advance 'Finished' proposal"
 
@@ -650,8 +667,7 @@ mkTooLateTimeRange advanceFrom =
         (proposalStartingTime + (def :: ProposalTimingConfig).draftTime + 1)
         ( proposalStartingTime
             + (def :: ProposalTimingConfig).draftTime
-            + (def :: ProposalTimingConfig).votingTime
-            - 1
+            + (def :: ProposalTimingConfig).votingTime - 1
         )
     -- [S + D + V + L + 1, S + D + V + L + E -1]
     VotingReady ->
@@ -697,12 +713,10 @@ getNextState = \case
   Finished -> error "Cannot advance 'Finished' proposal"
 
 -- | Calculate the number of GTs per stake in order to exceed the minimum limit.
-compPerStakeGTsForDraft :: NumStake -> Tagged GTTag Integer
+compPerStakeGTsForDraft :: NumStake -> Integer
 compPerStakeGTsForDraft nCosigners =
-  Tagged $
-    untag (def :: ProposalThresholds).toVoting
-      `div` fromIntegral nCosigners
-      + 1
+  untag (def :: ProposalThresholds).vote
+    `div` fromIntegral nCosigners + 1
 
 dummyDatum :: ()
 dummyDatum = ()
@@ -711,41 +725,29 @@ dummyDatumHash :: DatumHash
 dummyDatumHash = datumHash $ toDatum dummyDatum
 
 -- | Create given number of effect groups. Each group will have 3 effects.
-mkMockEffects :: Bool -> Int -> [ProposalEffectGroup]
-mkMockEffects useAuthScript n = effects
-  where
-    effectsPerGroup = 3
+mkMockEffects :: Int -> [AssocMap.Map ValidatorHash DatumHash]
+mkMockEffects =
+  flip
+    take
+    ( AssocMap.fromList
+        . flip zip (repeat dummyDatumHash)
+        <$> groupsOfN 3 validatorHashes
+    )
 
-    mkAuthScripts True = Just <$> scriptHashes
-    mkAuthScripts False = repeat Nothing
-    authScripts = mkAuthScripts useAuthScript
-
-    datums = repeat dummyDatumHash
-
-    effectMetadata = zipWith ProposalEffectMetadata datums authScripts
-    effectScripts = validatorHashes
-
-    effects =
-      take n $
-        StrictMap.fromList
-          <$> groupsOfN
-            effectsPerGroup
-            (zip effectScripts effectMetadata)
-
-numberOfVotesThatJustMeetsTheMinimumRequirement :: Integer
-numberOfVotesThatJustMeetsTheMinimumRequirement =
-  untag (def @ProposalThresholds).execute
+numberOfVotesThatExceedsTheMinimumRequirement :: Integer
+numberOfVotesThatExceedsTheMinimumRequirement =
+  untag (def @ProposalThresholds).execute + 1
 
 mkWinnerVotes :: Index -> (Winner, Integer)
 mkWinnerVotes idx =
   ( EffectAt idx
-  , numberOfVotesThatJustMeetsTheMinimumRequirement
+  , numberOfVotesThatExceedsTheMinimumRequirement
   )
 
 ambiguousWinnerVotes :: (Winner, Integer)
 ambiguousWinnerVotes =
   ( All
-  , numberOfVotesThatJustMeetsTheMinimumRequirement
+  , numberOfVotesThatExceedsTheMinimumRequirement
   )
 
 --------------------------------------------------------------------------------
@@ -765,18 +767,16 @@ defaultWinnerIdx = 0
 mkValidToNextStateBundle ::
   -- | Number of cosigners.
   Word ->
-  -- | Number of effects.
+  -- | Number of effects
   Word ->
-  -- | Toggle the referenc script in GAT UTXO.
-  Bool ->
   -- | The initial proposal state, should not be 'Finished'.
   ProposalStatus ->
   ParameterBundle
-mkValidToNextStateBundle _ _ _ Finished =
+mkValidToNextStateBundle _ _ Finished =
   error "Cannot advance from Finished"
-mkValidToNextStateBundle nCosigners nEffects authScript from =
+mkValidToNextStateBundle nCosigners nEffects from =
   let next = getNextState from
-      effects = mkMockEffects authScript $ fromIntegral nEffects
+      effects = mkMockEffects $ fromIntegral nEffects
       winner = defaultWinnerIdx
 
       template =
@@ -792,14 +792,15 @@ mkValidToNextStateBundle nCosigners nEffects authScript from =
                 }
           , stakeParameters =
               StakeParameters
-                { numStake = 0
+                { numStake = 1
                 , perStakeGTs =
                     compPerStakeGTsForDraft $
                       fromIntegral nCosigners
                 , transactionSignedByOwners = False
+                , invalidStakeOutputDatum = False
                 }
           , governorParameters = Nothing
-          , authorityTokenParameters = []
+          , authorityTokenParameters = Nothing
           , transactionTimeRange = mkInTimeTimeRange from
           , extraSignature = Just signer
           }
@@ -829,26 +830,18 @@ mkValidToNextStateBundle nCosigners nEffects authScript from =
         when (from == Locked) $
           modify $ \b ->
             let aut =
-                  StrictMap.elems $
-                    StrictMap.mapWithKey
-                      ( \vh (ProposalEffectMetadata _ authScript) ->
-                          AuthorityTokenParameters
-                            { mintGATsFor = vh
-                            , carryDatum = Just dummyDatum
-                            , carryAuthScript = authScript
-                            , invalidTokenName = False
-                            , shouldInlineDatum = False
-                            }
-                      )
-                      (effects !! winner)
+                  AuthorityTokenParameters
+                    { mintGATsFor = AssocMap.keys $ effects !! winner
+                    , carryDatum = Just dummyDatum
+                    , invalidTokenName = False
+                    }
                 gov =
                   GovernorParameters
                     { invalidGovernorOutputDatum = False
-                    , governorRedeemer = MintGATs
                     }
              in b
                   { governorParameters = Just gov
-                  , authorityTokenParameters = aut
+                  , authorityTokenParameters = Just aut
                   }
    in execState modifyTemplate template
 
@@ -859,34 +852,11 @@ mkValidToNextStateBundles ::
   Word ->
   [ParameterBundle]
 mkValidToNextStateBundles nCosigners nEffects =
-  liftA2
-    (mkValidToNextStateBundle nCosigners nEffects)
-    [True, False]
-    [Draft, VotingReady, Locked]
-
-mkValidToFinishedInlineGATDatumBundles ::
-  Word ->
-  Word ->
-  [ParameterBundle]
-mkValidToFinishedInlineGATDatumBundles nCosigners nEffects =
-  let templates =
-        liftA2
-          (mkValidToNextStateBundle nCosigners nEffects)
-          [True, False]
-          [Locked]
-
-      modifyTemplate template =
-        template
-          { authorityTokenParameters =
-              modifyAuthorityParameters
-                <$> template.authorityTokenParameters
-          }
-
-      modifyAuthorityParameters params =
-        params
-          { shouldInlineDatum = True
-          }
-   in modifyTemplate <$> templates
+  mkValidToNextStateBundle nCosigners nEffects
+    <$> [ Draft
+        , VotingReady
+        , Locked
+        ]
 
 mkValidToFailedStateBundles ::
   -- | Number of cosigners
@@ -895,14 +865,15 @@ mkValidToFailedStateBundles ::
   Word ->
   [ParameterBundle]
 mkValidToFailedStateBundles nCosigners nEffects =
-  liftA2
-    mkBundle
-    [True, False]
-    [Draft, VotingReady, Locked]
+  mkBundle
+    <$> [ Draft
+        , VotingReady
+        , Locked
+        ]
   where
-    mkBundle authScript from =
+    mkBundle from =
       let next = Finished
-          effects = mkMockEffects authScript $ fromIntegral nEffects
+          effects = mkMockEffects $ fromIntegral nEffects
        in ParameterBundle
             { proposalParameters =
                 ProposalParameters
@@ -915,14 +886,15 @@ mkValidToFailedStateBundles nCosigners nEffects =
                   }
             , stakeParameters =
                 StakeParameters
-                  { numStake = 0
+                  { numStake = 1
                   , perStakeGTs =
                       compPerStakeGTsForDraft $
                         fromIntegral nCosigners
                   , transactionSignedByOwners = False
+                  , invalidStakeOutputDatum = False
                   }
             , governorParameters = Nothing
-            , authorityTokenParameters = []
+            , authorityTokenParameters = Nothing
             , transactionTimeRange = mkTooLateTimeRange from
             , extraSignature = Just signer
             }
@@ -936,13 +908,14 @@ mkFromFinishedBundles ::
   Word ->
   [ParameterBundle]
 mkFromFinishedBundles nCosigners nEffects =
-  liftA2
-    mkBundle
-    [True, False]
-    [Draft, VotingReady, Locked]
+  mkBundle
+    <$> [ Draft
+        , VotingReady
+        , Locked
+        ]
   where
-    mkBundle authScript from =
-      let template = mkValidToNextStateBundle nCosigners nEffects authScript from
+    mkBundle from =
+      let template = mkValidToNextStateBundle nCosigners nEffects from
        in template
             { proposalParameters =
                 template.proposalParameters
@@ -953,30 +926,28 @@ mkFromFinishedBundles nCosigners nEffects =
 
 mkToNextStateTooLateBundles :: Word -> Word -> [ParameterBundle]
 mkToNextStateTooLateBundles nCosigners nEffects =
-  liftA2
-    mkBundle
-    [True, False]
-    [Draft, VotingReady, Locked]
+  mkBundle
+    <$> [ Draft
+        , VotingReady
+        , Locked
+        ]
   where
-    mkBundle authScript from =
-      let template = mkValidToNextStateBundle nCosigners nEffects authScript from
+    mkBundle from =
+      let template = mkValidToNextStateBundle nCosigners nEffects from
        in template
             { transactionTimeRange = mkTooLateTimeRange from
             }
 
-mkUnexpectedOutputStakeBundles :: Word -> Word -> [ParameterBundle]
-mkUnexpectedOutputStakeBundles nCosigners nEffects =
-  liftA2
-    mkBundle
-    [True, False]
-    [VotingReady, Locked]
+mkInvalidOutputStakeBundles :: Word -> Word -> [ParameterBundle]
+mkInvalidOutputStakeBundles nCosigners nEffects =
+  mkBundle <$> [Draft, VotingReady, Locked]
   where
-    mkBundle authScript from =
-      let template = mkValidToNextStateBundle nCosigners nEffects authScript from
+    mkBundle from =
+      let template = mkValidToNextStateBundle nCosigners nEffects from
        in template
             { stakeParameters =
                 template.stakeParameters
-                  { numStake = 1
+                  { invalidStakeOutputDatum = True
                   }
             }
 
@@ -992,11 +963,9 @@ mkInsufficientCosignsBundle nCosigners nEffects =
     }
   where
     insuffcientPerStakeGTs =
-      Tagged $
-        untag (def :: ProposalThresholds).toVoting
-          `div` fromIntegral nCosigners
-          - 1
-    template = mkValidToNextStateBundle nCosigners nEffects False Draft
+      untag (def :: ProposalThresholds).vote
+        `div` fromIntegral nCosigners - 1
+    template = mkValidToNextStateBundle nCosigners nEffects Draft
 
 -- * From VotingReady
 
@@ -1017,7 +986,7 @@ mkInsufficientVotesBundle ::
   Word ->
   ParameterBundle
 mkInsufficientVotesBundle nCosigners nEffects =
-  mkValidToNextStateBundle nCosigners nEffects False VotingReady
+  mkValidToNextStateBundle nCosigners nEffects VotingReady
     `setWinnerAndVotes` Nothing
 
 mkAmbiguousWinnerBundle ::
@@ -1025,14 +994,14 @@ mkAmbiguousWinnerBundle ::
   Word ->
   ParameterBundle
 mkAmbiguousWinnerBundle nCosigners nEffects =
-  mkValidToNextStateBundle nCosigners nEffects False VotingReady
+  mkValidToNextStateBundle nCosigners nEffects VotingReady
     `setWinnerAndVotes` Just ambiguousWinnerVotes
 
 -- * From Locked
 
 mkValidFromLockedBundle :: Word -> Word -> ParameterBundle
 mkValidFromLockedBundle nCosigners nEffects =
-  mkValidToNextStateBundle nCosigners nEffects False Locked
+  mkValidToNextStateBundle nCosigners nEffects Locked
 
 mkMintGATsForWrongEffectsBundle ::
   Word ->
@@ -1041,11 +1010,17 @@ mkMintGATsForWrongEffectsBundle ::
 mkMintGATsForWrongEffectsBundle nCosigners nEffects =
   template
     { authorityTokenParameters =
-        take 4 $
-          zipWith
-            (\a i -> a {mintGATsFor = validatorHashes !! i})
-            template.authorityTokenParameters
-            [1, 3 ..]
+        ( \aut ->
+            aut
+              { mintGATsFor =
+                  [ validatorHashes !! 1
+                  , validatorHashes !! 3
+                  , validatorHashes !! 5
+                  , validatorHashes !! 7
+                  ]
+              }
+        )
+          <$> template.authorityTokenParameters
     }
   where
     template = mkValidFromLockedBundle nCosigners nEffects
@@ -1056,7 +1031,7 @@ mkNoGATMintedBundle ::
   ParameterBundle
 mkNoGATMintedBundle nCosigners nEffects =
   template
-    { authorityTokenParameters = []
+    { authorityTokenParameters = Nothing
     }
   where
     template = mkValidFromLockedBundle nCosigners nEffects
@@ -1084,20 +1059,16 @@ mkGATsWithWrongDatumBundle ::
   ParameterBundle
 mkGATsWithWrongDatumBundle nCosigners nEffects =
   template
-    { authorityTokenParameters = newAut
+    { authorityTokenParameters = Just newAut
     }
   where
     template = mkValidFromLockedBundle nCosigners nEffects
+    aut = fromJust template.authorityTokenParameters
     newAut =
-      ( \aut ->
-          AuthorityTokenParameters
-            aut.mintGATsFor
-            (Just (1 :: Integer))
-            aut.carryAuthScript
-            False
-            False
-      )
-        <$> template.authorityTokenParameters
+      AuthorityTokenParameters
+        aut.mintGATsFor
+        (Just (1 :: Integer))
+        False
 
 mkBadGovernorOutputDatumBundle ::
   Word ->
@@ -1109,47 +1080,4 @@ mkBadGovernorOutputDatumBundle nCosigners nEffects =
     }
   where
     template = mkValidFromLockedBundle nCosigners nEffects
-    gov = GovernorParameters True MintGATs
-
-mkBadGovernorRedeemerBundle ::
-  Word ->
-  Word ->
-  ParameterBundle
-mkBadGovernorRedeemerBundle nCosigners nEffects =
-  template
-    { governorParameters = Just gov
-    }
-  where
-    template = mkValidFromLockedBundle nCosigners nEffects
-    gov = GovernorParameters False CreateProposal
-
-mkFastforwardToFinishBundles ::
-  Word ->
-  Word ->
-  [ParameterBundle]
-mkFastforwardToFinishBundles nCosigners nEffects = updateTemplate <$> templates
-  where
-    templates = mkValidToFailedStateBundles nCosigners nEffects
-    mkMaliciousTimRange =
-      let lb = proposalStartingTime - 1
-          dub =
-            1
-              + proposalStartingTime
-              + (def :: ProposalTimingConfig).draftTime
-          vub =
-            dub
-              + (def :: ProposalTimingConfig).votingTime
-              + (def :: ProposalTimingConfig).lockingTime
-          lub =
-            vub
-              + (def :: ProposalTimingConfig).executingTime
-          go Draft = (lb, dub)
-          go VotingReady = (lb, vub)
-          go Locked = (lb, lub)
-          go Finished = error "cannot advance from Finished"
-       in uncurry closedBoundedInterval . go
-    updateTemplate template =
-      template
-        { transactionTimeRange =
-            mkMaliciousTimRange template.proposalParameters.fromStatus
-        }
+    gov = GovernorParameters True

agora-specs/Sample/Proposal/Cosign.hs

@@ -6,22 +6,12 @@ Description: Generate sample data for testing the functionalities of cosigning p
 Sample and utilities for testing the functionalities of cosigning proposals.
 -}
 module Sample.Proposal.Cosign (
-  StakedAmount (..),
-  StakeOwner (..),
-  StakeParameters (..),
-  SignedBy (..),
-  TransactionParameters (..),
-  ProposalParameters (..),
-  ParameterBundle (..),
-  Validity (..),
-  cosign,
+  Parameters (..),
+  validCosignNParameters,
+  duplicateCosignersParameters,
+  statusNotDraftCosignNParameters,
+  invalidStakeOutputParameters,
   mkTestTree,
-  totallyValid,
-  insufficientStakedAmount,
-  duplicateCosigners,
-  locksNotUpdated,
-  cosignersNotUpdated,
-  cosignAfterDraft,
 ) where
 
 import Agora.Governor (Governor (..))
@@ -30,7 +20,6 @@ import Agora.Proposal (
   ProposalId (ProposalId),
   ProposalRedeemer (Cosign),
   ProposalStatus (..),
-  ProposalThresholds (..),
   ResultTag (ResultTag),
   emptyVotesFor,
  )
@@ -39,272 +28,194 @@ import Agora.Proposal.Time (
   ProposalTimingConfig (draftTime),
  )
 import Agora.SafeMoney (GTTag)
+import Agora.Scripts (AgoraScripts (..))
 import Agora.Stake (
-  ProposalAction (Cosigned, Created),
-  ProposalLock (ProposalLock),
-  StakeDatum (..),
-  StakeRedeemer (PermitVote),
+  StakeDatum (StakeDatum, owner),
+  StakeRedeemer (WitnessStake),
+  stakedAmount,
  )
 import Data.Coerce (coerce)
 import Data.Default (def)
 import Data.List (sort)
-import Data.Map.Strict qualified as StrictMap
-import Data.Tagged (Tagged)
+import Data.Tagged (Tagged, untag)
 import Plutarch.Context (
   input,
-  normalizeValue,
   output,
   script,
   signedWith,
   timeRange,
   txId,
   withDatum,
-  withInlineDatum,
-  withRedeemer,
-  withRef,
+  withOutRef,
+  withTxId,
   withValue,
  )
-import Plutarch.Extra.AssetClass (assetClassValue)
-import PlutusLedgerApi.V2 (
-  Credential (PubKeyCredential),
-  POSIXTime (POSIXTime),
+import PlutusLedgerApi.V1 (
+  POSIXTimeRange,
   PubKeyHash,
-  TxOutRef (TxOutRef),
+  TxOutRef (..),
+  Value,
  )
+import PlutusLedgerApi.V1.Value qualified as Value
+import PlutusTx.AssocMap qualified as AssocMap
 import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
 import Sample.Shared (
+  agoraScripts,
   governor,
   minAda,
-  proposalAssetClass,
-  proposalScriptHash,
-  proposalValidator,
+  proposalPolicySymbol,
+  proposalValidatorHash,
+  signer,
   stakeAssetClass,
-  stakeScriptHash,
-  stakeValidator,
+  stakeValidatorHash,
  )
 import Test.Specification (
   SpecificationTree,
   group,
   testValidator,
  )
-import Test.Util (
-  CombinableBuilder,
-  closedBoundedInterval,
-  mkSpending,
-  pubKeyHashes,
- )
-
-data StakedAmount = Sufficient | Insufficient
-
-data StakeOwner = Creator | Other
-
-data StakeParameters = StakeParameters
-  { gtAmount :: StakedAmount
-  , stakeOwner :: StakeOwner
-  , dontUpdateLocks :: Bool
-  }
-
-data SignedBy = Owner | Delegatee | Unknown
-
-newtype TransactionParameters = TransactionParameters
-  { signedBy :: SignedBy
-  }
-
-data ProposalParameters = ProposalParameters
-  { proposalStatus :: ProposalStatus
-  , dontUpdateCosigners :: Bool
-  }
+import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, pubKeyHashes, sortValue)
 
 -- | Parameters for cosigning a proposal.
-data ParameterBundle = ParameterBundle
-  { stakeParameters :: StakeParameters
-  , proposalParameters :: ProposalParameters
-  , transactionParameters :: TransactionParameters
+data Parameters = Parameters
+  { newCosigners :: [PubKeyHash]
+  -- ^ New cosigners to be added, and the owners of the generated stakes.
+  , proposalStatus :: ProposalStatus
+  -- ^ Current state of the proposal.
+  , alterOutputStakes :: Bool
+  -- ^ Whether to generate invalid stake outputs.
+  --   In particular, the 'stakedAmount' of all the stake datums will be set to zero.
   }
 
-data Validity = Validity
-  { forProposalValidator :: Bool
-  , forStakeValidator :: Bool
-  }
+-- | Owner of the creator stake, doesn't really matter in this case.
+proposalCreator :: PubKeyHash
+proposalCreator = signer
 
---------------------------------------------------------------------------------
+-- | The amount of GTs every generated stake has, doesn't really matter in this case.
+perStakedGTs :: Tagged GTTag Integer
+perStakedGTs = 5
 
-mkStakeAmount :: StakedAmount -> Tagged GTTag Integer
-mkStakeAmount Sufficient = (def @ProposalThresholds).cosign
-mkStakeAmount Insufficient = mkStakeAmount Sufficient - 1
-
-mkStakeOwner :: StakeOwner -> PubKeyHash
-mkStakeOwner Creator = creator
-mkStakeOwner Other = pubKeyHashes !! 2
-
-mkSigner :: StakeOwner -> SignedBy -> PubKeyHash
-mkSigner so Owner = mkStakeOwner so
-mkSigner _ Delegatee = delegatee
-mkSigner _ Unknown = pubKeyHashes !! 4
-
-creator :: PubKeyHash
-creator = pubKeyHashes !! 1
-
-delegatee :: PubKeyHash
-delegatee = pubKeyHashes !! 3
-
---------------------------------------------------------------------------------
-
-defProposalId :: ProposalId
-defProposalId = ProposalId 0
-
-mkProposalInputDatum :: ParameterBundle -> ProposalDatum
+{- | Create input proposal datum given the parameters.
+   In particular, 'status' is set to 'proposalStstus'.
+-}
+mkProposalInputDatum :: Parameters -> ProposalDatum
 mkProposalInputDatum ps =
   let effects =
-        StrictMap.fromList
-          [ (ResultTag 0, StrictMap.empty)
-          , (ResultTag 1, StrictMap.empty)
+        AssocMap.fromList
+          [ (ResultTag 0, AssocMap.empty)
+          , (ResultTag 1, AssocMap.empty)
           ]
    in ProposalDatum
         { proposalId = ProposalId 0
         , effects = effects
-        , status = ps.proposalParameters.proposalStatus
-        , cosigners = [PubKeyCredential creator]
+        , status = ps.proposalStatus
+        , cosigners = [proposalCreator]
         , thresholds = def
         , votes = emptyVotesFor effects
         , timingConfig = def
         , startingTime = ProposalStartingTime 0
         }
 
-mkProposalOutputDatum :: ParameterBundle -> ProposalDatum
+{- | Create the output proposal datum given the parameters.
+   The 'newCosigners' is added to the exisiting list of cosigners, note the said list should be sorted in
+     ascending order.
+-}
+mkProposalOutputDatum :: Parameters -> ProposalDatum
 mkProposalOutputDatum ps =
   let inputDatum = mkProposalInputDatum ps
-      stakeOwner =
-        PubKeyCredential $
-          mkStakeOwner ps.stakeParameters.stakeOwner
-      newCosigners =
-        if ps.proposalParameters.dontUpdateCosigners
-          then inputDatum.cosigners
-          else sort $ stakeOwner : inputDatum.cosigners
-   in inputDatum {cosigners = newCosigners}
-
-proposalRedeemer :: ProposalRedeemer
-proposalRedeemer = Cosign
-
-proposalRef :: TxOutRef
-proposalRef = TxOutRef proposalTxRef 1
-
---------------------------------------------------------------------------------
-
-mkStakeInputDatum :: ParameterBundle -> StakeDatum
-mkStakeInputDatum ps =
-  let sps = ps.stakeParameters
-      amount = mkStakeAmount sps.gtAmount
-      owner = mkStakeOwner sps.stakeOwner
-      locks = case sps.stakeOwner of
-        Creator -> [ProposalLock defProposalId Created]
-        _ -> []
-   in StakeDatum
-        { stakedAmount = amount
-        , owner = PubKeyCredential owner
-        , delegatedTo = Just $ PubKeyCredential delegatee
-        , lockedBy = locks
+   in inputDatum
+        { cosigners = sort $ inputDatum.cosigners <> ps.newCosigners
         }
 
-mkStakeOuputDatum :: ParameterBundle -> StakeDatum
-mkStakeOuputDatum ps =
-  let sps = ps.stakeParameters
-      inpDatum = mkStakeInputDatum ps
-      locks =
-        if sps.dontUpdateLocks
-          then inpDatum.lockedBy
-          else ProposalLock defProposalId Cosigned : inpDatum.lockedBy
-   in inpDatum {lockedBy = locks}
-
-stakeRedeemer :: StakeRedeemer
-stakeRedeemer = PermitVote
-
-stakeRef :: TxOutRef
-stakeRef = TxOutRef stakeTxRef 0
-
---------------------------------------------------------------------------------
+-- | Create all the input stakes given the parameters.
+mkStakeInputDatums :: Parameters -> [StakeDatum]
+mkStakeInputDatums = fmap (\pk -> StakeDatum perStakedGTs pk Nothing []) . newCosigners
 
 -- | Create a 'TxInfo' that tries to cosign a proposal with new cosigners.
-cosign :: forall b. CombinableBuilder b => ParameterBundle -> b
+cosign :: forall b. CombinableBuilder b => Parameters -> b
 cosign ps = builder
   where
-    pst = assetClassValue proposalAssetClass 1
-    sst = assetClassValue stakeAssetClass 1
+    pst = Value.singleton proposalPolicySymbol "" 1
+    sst = Value.assetClassValue stakeAssetClass 1
 
-    ----------------------------------------------------------------------------
+    ---
 
-    stakeInputDatum = mkStakeInputDatum ps
-    stakeOutputDatum = mkStakeOuputDatum ps
+    stakeInputDatums :: [StakeDatum]
+    stakeInputDatums = mkStakeInputDatums ps
 
+    stakeValue :: Value
     stakeValue =
-      normalizeValue $
+      sortValue $
         minAda
-          <> assetClassValue
-            governor.gtClassRef
-            (mkStakeAmount ps.stakeParameters.gtAmount)
+          <> Value.assetClassValue
+            (untag governor.gtClassRef)
+            (untag perStakedGTs)
           <> sst
 
     stakeBuilder =
-      mconcat
-        [ input $
-            mconcat
-              [ script stakeScriptHash
-              , withValue stakeValue
-              , withInlineDatum stakeInputDatum
-              , withRef stakeRef
-              , withRedeemer stakeRedeemer
-              ]
-        , output $
-            mconcat
-              [ script stakeScriptHash
-              , withValue stakeValue
-              , withInlineDatum stakeOutputDatum
-              ]
-        ]
+      foldMap
+        ( \(stakeDatum, refIdx) ->
+            let stakeOutputDatum =
+                  if ps.alterOutputStakes
+                    then stakeDatum {stakedAmount = 0}
+                    else stakeDatum
+             in mconcat
+                  [ input $
+                      mconcat
+                        [ script stakeValidatorHash
+                        , withValue stakeValue
+                        , withDatum stakeDatum
+                        , withTxId stakeTxRef
+                        , withOutRef (mkStakeRef refIdx)
+                        ]
+                  , output $
+                      mconcat
+                        [ script stakeValidatorHash
+                        , withValue stakeValue
+                        , withDatum stakeOutputDatum
+                        ]
+                  , signedWith stakeDatum.owner
+                  ]
+        )
+        $ zip
+          stakeInputDatums
+          [0 ..]
 
-    ----------------------------------------------------------------------------
+    ---
 
+    proposalInputDatum :: ProposalDatum
     proposalInputDatum = mkProposalInputDatum ps
-    proposalOutputDatum = mkProposalOutputDatum ps
 
-    proposalValue =
-      normalizeValue $
-        pst <> minAda
+    proposalOutputDatum :: ProposalDatum
+    proposalOutputDatum = mkProposalOutputDatum ps
 
     proposalBuilder =
       mconcat
         [ input $
             mconcat
-              [ script proposalScriptHash
-              , withValue proposalValue
+              [ script proposalValidatorHash
+              , withValue pst
               , withDatum proposalInputDatum
-              , withRef proposalRef
-              , withRedeemer proposalRedeemer
+              , withTxId proposalTxRef
+              , withOutRef proposalRef
               ]
         , output $
             mconcat
-              [ script proposalScriptHash
-              , withValue proposalValue
+              [ script proposalValidatorHash
+              , withValue (sortValue (pst <> minAda))
               , withDatum proposalOutputDatum
               ]
         ]
 
-    ----------------------------------------------------------------------------
-
+    validTimeRange :: POSIXTimeRange
     validTimeRange =
       closedBoundedInterval
         (coerce proposalInputDatum.startingTime + 1)
         ( coerce proposalInputDatum.startingTime
-            + proposalInputDatum.timingConfig.draftTime
-            - 1
+            + proposalInputDatum.timingConfig.draftTime - 1
         )
 
-    sig =
-      mkSigner
-        ps.stakeParameters.stakeOwner
-        ps.transactionParameters.signedBy
-
-    ----------------------------------------------------------------------------
+    ---
 
     builder =
       mconcat
@@ -312,107 +223,117 @@ cosign ps = builder
         , timeRange validTimeRange
         , proposalBuilder
         , stakeBuilder
-        , signedWith sig
         ]
 
---------------------------------------------------------------------------------
+-- | Reference index of the proposal UTXO.
+proposalRefIdx :: Integer
+proposalRefIdx = 1
 
+-- | Spend the proposal ST.
+proposalRef :: TxOutRef
+proposalRef = TxOutRef proposalTxRef proposalRefIdx
+
+-- | Consume the given stake.
+mkStakeRef :: Int -> TxOutRef
+mkStakeRef idx =
+  TxOutRef
+    stakeTxRef
+    $ proposalRefIdx + 1 + fromIntegral idx
+
+-- | Create a proposal redeemer which cosigns with the new cosginers.
+mkProposalRedeemer :: Parameters -> ProposalRedeemer
+mkProposalRedeemer (sort . newCosigners -> cs) = Cosign cs
+
+-- | Stake redeemer for cosuming all the stakes generated in the module.
+stakeRedeemer :: StakeRedeemer
+stakeRedeemer = WitnessStake
+
+---
+
+-- | Create a valid parameters that cosign the proposal with a given number of cosigners.
+validCosignNParameters :: Int -> Parameters
+validCosignNParameters n
+  | n > 0 =
+      Parameters
+        { newCosigners = take n pubKeyHashes
+        , proposalStatus = Draft
+        , alterOutputStakes = False
+        }
+  | otherwise = error "Number of cosigners should be positive"
+
+---
+
+{- | Parameters that make 'cosign' yield duplicate cosigners.
+   Invalid for the ptoposal validator, perfectly valid for stake validator.
+-}
+duplicateCosignersParameters :: Parameters
+duplicateCosignersParameters =
+  Parameters
+    { newCosigners = [proposalCreator]
+    , proposalStatus = Draft
+    , alterOutputStakes = False
+    }
+
+---
+
+{- | Generate a list of parameters that sets proposal status to something other than 'Draft'.
+   Invalid for the ptoposal validator, perfectly valid for stake validator.
+-}
+statusNotDraftCosignNParameters :: Int -> [Parameters]
+statusNotDraftCosignNParameters n =
+  map
+    ( \st ->
+        Parameters
+          { newCosigners = take n pubKeyHashes
+          , proposalStatus = st
+          , alterOutputStakes = False
+          }
+    )
+    [VotingReady, Locked, Finished]
+
+---
+
+{- | Parameters thet change the output stake datums.
+   Invalid for both proposal validator and stake validator.
+-}
+invalidStakeOutputParameters :: Parameters
+invalidStakeOutputParameters =
+  (validCosignNParameters 2)
+    { alterOutputStakes = True
+    }
+
+---
+
+-- | Create a test tree given the parameters. Both the proposal validator and stake validator will be run.
 mkTestTree ::
+  -- | The name of the test group.
   String ->
-  ParameterBundle ->
-  Validity ->
+  Parameters ->
+  -- | Are the parameters valid for the proposal validator?
+  Bool ->
   SpecificationTree
-mkTestTree name ps val =
-  group name [proposal, stake]
+mkTestTree name ps isValid = group name [proposal, stake]
   where
     spend = mkSpending cosign ps
 
     proposal =
-      testValidator
-        val.forProposalValidator
-        "proposal"
-        proposalValidator
-        (mkProposalInputDatum ps)
-        proposalRedeemer
-        (spend proposalRef)
+      let proposalInputDatum = mkProposalInputDatum ps
+       in testValidator
+            isValid
+            "proposal"
+            agoraScripts.compiledProposalValidator
+            proposalInputDatum
+            (mkProposalRedeemer ps)
+            (spend proposalRef)
 
     stake =
-      testValidator
-        val.forStakeValidator
-        "stake"
-        stakeValidator
-        (mkStakeInputDatum ps)
-        stakeRedeemer
-        (spend stakeRef)
-
---------------------------------------------------------------------------------
-
-totallyValid :: ParameterBundle
-totallyValid =
-  ParameterBundle
-    { stakeParameters =
-        StakeParameters
-          { gtAmount = Sufficient
-          , stakeOwner = Other
-          , dontUpdateLocks = False
-          }
-    , proposalParameters =
-        ProposalParameters
-          { proposalStatus = Draft
-          , dontUpdateCosigners = False
-          }
-    , transactionParameters =
-        TransactionParameters
-          { signedBy =
-              Owner
-          }
-    }
-
-insufficientStakedAmount :: ParameterBundle
-insufficientStakedAmount =
-  totallyValid
-    { stakeParameters =
-        totallyValid.stakeParameters
-          { gtAmount = Insufficient
-          }
-    }
-
-locksNotUpdated :: ParameterBundle
-locksNotUpdated =
-  totallyValid
-    { stakeParameters =
-        totallyValid.stakeParameters
-          { dontUpdateLocks = True
-          }
-    }
-
-duplicateCosigners :: ParameterBundle
-duplicateCosigners =
-  totallyValid
-    { stakeParameters =
-        totallyValid.stakeParameters
-          { stakeOwner = Creator
-          }
-    }
-
-cosignersNotUpdated :: ParameterBundle
-cosignersNotUpdated =
-  totallyValid
-    { proposalParameters =
-        totallyValid.proposalParameters
-          { dontUpdateCosigners = True
-          }
-    }
-
-cosignAfterDraft :: [ParameterBundle]
-cosignAfterDraft =
-  map
-    ( \s ->
-        totallyValid
-          { proposalParameters =
-              totallyValid.proposalParameters
-                { proposalStatus = s
-                }
-          }
-    )
-    [VotingReady, Locked, Finished]
+      let idx = 0
+          stakeInputDatum = mkStakeInputDatums ps !! idx
+          isValid = not ps.alterOutputStakes
+       in testValidator
+            isValid
+            "stake"
+            agoraScripts.compiledStakeValidator
+            stakeInputDatum
+            stakeRedeemer
+            (spend $ mkStakeRef idx)

agora-specs/Sample/Proposal/Create.hs

@@ -17,99 +17,70 @@ module Sample.Proposal.Create (
   timeRangeNotTightParameters,
   timeRangeNotClosedParameters,
   invalidProposalStatusParameters,
-  fakeSSTParameters,
-  wrongGovernorRedeemer,
-  wrongGovernorRedeemer1,
 ) where
 
 import Agora.Governor (
   Governor (..),
   GovernorDatum (..),
-  GovernorRedeemer (
-    CreateProposal,
-    MintGATs,
-    MutateGovernor
-  ),
+  GovernorRedeemer (CreateProposal),
  )
 import Agora.Proposal (
   ProposalDatum (..),
-  ProposalEffectGroup,
   ProposalId (ProposalId),
   ProposalStatus (..),
   ResultTag (ResultTag),
   emptyVotesFor,
  )
-import Agora.Proposal.Time (
-  MaxTimeRangeWidth (
-    MaxTimeRangeWidth
-  ),
-  ProposalStartingTime (..),
- )
-import Agora.SafeMoney (GTTag)
+import Agora.Proposal.Time (MaxTimeRangeWidth (MaxTimeRangeWidth), ProposalStartingTime (..))
+import Agora.Scripts (AgoraScripts (..))
 import Agora.Stake (
-  ProposalAction (Created, Voted),
-  ProposalLock (ProposalLock),
+  ProposalLock (..),
   StakeDatum (..),
   StakeRedeemer (PermitVote),
  )
 import Data.Coerce (coerce)
 import Data.Default (Default (def))
-import Data.Map.Strict qualified as StrictMap
-import Data.Tagged (Tagged)
+import Data.Tagged (Tagged, untag)
 import Plutarch.Context (
   input,
   mint,
-  normalizeValue,
   output,
   script,
   signedWith,
   timeRange,
   txId,
   withDatum,
-  withRedeemer,
-  withRef,
+  withOutRef,
   withValue,
  )
-import Plutarch.Extra.AssetClass (assetClassValue)
-import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
-import PlutusLedgerApi.V1.Value qualified as Value
-import PlutusLedgerApi.V2 (
-  Credential (PubKeyCredential),
+import PlutusLedgerApi.V1 (
+  DatumHash,
   POSIXTime (POSIXTime),
   POSIXTimeRange,
-  Redeemer (Redeemer),
-  ToData (toBuiltinData),
+  PubKeyHash,
   TxOutRef (TxOutRef),
+  ValidatorHash,
   always,
  )
+import PlutusLedgerApi.V1.Value qualified as Value
+import PlutusTx.AssocMap qualified as AssocMap
 import Sample.Proposal.Shared (stakeTxRef)
 import Sample.Shared (
+  agoraScripts,
+  govAssetClass,
+  govValidatorHash,
   governor,
-  governorAssetClass,
-  governorScriptHash,
-  governorValidator,
   minAda,
-  proposalAssetClass,
-  proposalPolicy,
   proposalPolicySymbol,
-  proposalScriptHash,
   proposalStartingTimeFromTimeRange,
+  proposalValidatorHash,
   signer,
   signer2,
   stakeAssetClass,
-  stakeScriptHash,
-  stakeSymbol,
-  stakeValidator,
+  stakeValidatorHash,
  )
 import Test.Specification (SpecificationTree, group, testPolicy, testValidator)
-import Test.Util (
-  CombinableBuilder,
-  closedBoundedInterval,
-  mkMinting,
-  mkSpending,
-  sortValue,
-  validatorHashes,
- )
+import Test.Util (CombinableBuilder, closedBoundedInterval, mkMinting, mkSpending, sortValue)
 
 -- | Parameters for creating a proposal.
 data Parameters = Parameters
@@ -129,15 +100,11 @@ data Parameters = Parameters
   -- ^ Is 'TxInfo.validTimeRange' closed?
   , proposalStatus :: ProposalStatus
   -- ^ The status of the newly created proposal.
-  , fakeSST :: Bool
-  -- ^ Whether to use SST that doesn't belong to the stake validator.
-  , governorRedeemer :: Redeemer
-  -- ^ The redeemer used to spend the governor.
   }
 
 --------------------------------------------------------------------------------
 
--- | See 'GovernorDatum.maximumCreatedProposalsPerStake'.
+-- | See 'GovernorDatum.maximumProposalsPerStake'.
 maxProposalPerStake :: Integer
 maxProposalPerStake = 3
 
@@ -146,30 +113,29 @@ thisProposalId :: ProposalId
 thisProposalId = ProposalId 25
 
 -- | The arbitrary staked amount. Doesn;t really matter in this case.
-stakedGTs :: Tagged GTTag Integer
+stakedGTs :: Tagged _ Integer
 stakedGTs = 5
 
 -- | The owner of the stake.
-stakeOwner :: Credential
-stakeOwner = PubKeyCredential signer
+stakeOwner :: PubKeyHash
+stakeOwner = signer
 
 {- | The invalid stake owner. If the 'alterOutputStakeOwner' is set to true,
       the output stake owner will be set to this.
 -}
-alteredStakeOwner :: Credential
-alteredStakeOwner = PubKeyCredential signer2
+alteredStakeOwner :: PubKeyHash
+alteredStakeOwner = signer2
 
 -- | Locks the stake that the input stake already has.
 defLocks :: [ProposalLock]
-defLocks = [ProposalLock (ProposalId 0) Created]
+defLocks = [Created (ProposalId 0)]
 
 -- | The effect of the newly created proposal.
-defEffects :: StrictMap.Map ResultTag ProposalEffectGroup
+defEffects :: AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash)
 defEffects =
-  StrictMap.fromList
-    [ (ResultTag 0, StrictMap.empty)
-    , (ResultTag 1, StrictMap.empty)
-    , (ResultTag 3, StrictMap.empty)
+  AssocMap.fromList
+    [ (ResultTag 0, AssocMap.empty)
+    , (ResultTag 1, AssocMap.empty)
     ]
 
 --------------------------------------------------------------------------------
@@ -182,7 +148,7 @@ governorInputDatum =
     , nextProposalId = thisProposalId
     , proposalTimings = def
     , createProposalTimeRangeMaxWidth = def
-    , maximumCreatedProposalsPerStake = maxProposalPerStake
+    , maximumProposalsPerStake = maxProposalPerStake
     }
 
 -- | Create governor output datum given the parameters.
@@ -197,7 +163,7 @@ mkGovernorOutputDatum ps =
         , nextProposalId = nextPid
         , proposalTimings = def
         , createProposalTimeRangeMaxWidth = def
-        , maximumCreatedProposalsPerStake = maxProposalPerStake
+        , maximumProposalsPerStake = maxProposalPerStake
         }
 
 --------------------------------------------------------------------------------
@@ -208,7 +174,7 @@ mkStakeInputDatum ps =
   let locks =
         if ps.createdMoreThanMaximumProposals
           then
-            flip ProposalLock Created . ProposalId
+            Created . ProposalId
               <$> take
                 (fromInteger maxProposalPerStake)
                 [1 ..]
@@ -227,10 +193,10 @@ mkStakeOutputDatum ps =
       newLocks =
         if ps.invalidNewLocks
           then
-            [ ProposalLock thisProposalId $ Voted (ResultTag 0) 100
-            , ProposalLock thisProposalId $ Voted (ResultTag 1) 100
+            [ Voted thisProposalId (ResultTag 0)
+            , Voted thisProposalId (ResultTag 1)
             ]
-          else [ProposalLock thisProposalId Created]
+          else [Created thisProposalId]
       locks = newLocks <> inputDatum.lockedBy
       newOwner = mkOwner ps
    in inputDatum
@@ -245,18 +211,16 @@ mkStakeOutputDatum ps =
 -}
 mkProposalOutputDatum :: Parameters -> ProposalDatum
 mkProposalOutputDatum ps =
-  let effects = defEffects
-      votes = emptyVotesFor defEffects
-   in ProposalDatum
-        { proposalId = thisProposalId
-        , effects = effects
-        , status = ps.proposalStatus
-        , cosigners = [mkOwner ps]
-        , thresholds = def
-        , votes = votes
-        , timingConfig = def
-        , startingTime = mkProposalStartingTime ps
-        }
+  ProposalDatum
+    { proposalId = thisProposalId
+    , effects = defEffects
+    , status = ps.proposalStatus
+    , cosigners = [mkOwner ps]
+    , thresholds = def
+    , votes = emptyVotesFor defEffects
+    , timingConfig = def
+    , startingTime = mkProposalStartingTime ps
+    }
 
 --------------------------------------------------------------------------------
 
@@ -279,7 +243,7 @@ mkProposalStartingTime ps =
     else ProposalStartingTime 0
 
 -- | Who should be the 'owner' of the output stake.
-mkOwner :: Parameters -> Credential
+mkOwner :: Parameters -> PubKeyHash
 mkOwner ps =
   if ps.alterOutputStakeOwner
     then alteredStakeOwner
@@ -301,51 +265,26 @@ governorRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be
 createProposal :: forall b. CombinableBuilder b => Parameters -> b
 createProposal ps = builder
   where
-    pst = assetClassValue proposalAssetClass 1
-    sst = assetClassValue stakeAssetClass 1
-    gst = assetClassValue governorAssetClass 1
-
-    ---
-
-    attacker = head validatorHashes
-
-    fakeStakeBuilder =
-      if ps.fakeSST
-        then
-          mconcat
-            [ input @b $
-                mconcat
-                  [ script attacker
-                  , withValue $
-                      Value.singleton
-                        stakeSymbol
-                        (scriptHashToTokenName attacker)
-                        1
-                  , withDatum $
-                      (mkStakeInputDatum ps)
-                        { stakedAmount = 10000000000
-                        }
-                  ]
-            ]
-        else mempty
+    pst = Value.singleton proposalPolicySymbol "" 1
+    sst = Value.assetClassValue stakeAssetClass 1
+    gst = Value.assetClassValue govAssetClass 1
 
     ---
 
     governorValue = sortValue $ gst <> minAda
     stakeValue =
       sortValue $
-        sst
-          <> assetClassValue governor.gtClassRef stakedGTs
-          <> minAda
+        sortValue $
+          sst
+            <> Value.assetClassValue (untag governor.gtClassRef) (untag stakedGTs)
+            <> minAda
     proposalValue = sortValue $ pst <> minAda
 
     ---
 
     withSig =
       if ps.stakeOwnerSignsTheTransaction
-        then case stakeOwner of
-          PubKeyCredential sig -> signedWith sig
-          _ -> mempty
+        then signedWith stakeOwner
         else mempty
 
     ---
@@ -356,68 +295,43 @@ createProposal ps = builder
         , ---
           withSig
         , ---
-          mint $
-            normalizeValue
-              pst
+          mint pst
         , ---
           timeRange $ mkTimeRange ps
         , input $
             mconcat
-              [ script governorScriptHash
+              [ script govValidatorHash
               , withValue governorValue
               , withDatum governorInputDatum
-              , withRedeemer ps.governorRedeemer
-              , withRef governorRef
+              , withOutRef governorRef
               ]
         , output $
             mconcat
-              [ script governorScriptHash
+              [ script govValidatorHash
               , withValue governorValue
               , withDatum (mkGovernorOutputDatum ps)
               ]
         , ---
-          if ps.fakeSST
-            then
-              mconcat
-                [ input @b $
-                    mconcat
-                      [ script attacker
-                      , withValue $
-                          Value.singleton
-                            stakeSymbol
-                            (scriptHashToTokenName attacker)
-                            1
-                      , withDatum $
-                          (mkStakeInputDatum ps)
-                            { stakedAmount = 10000000000
-                            }
-                      ]
-                ]
-            else
-              mconcat
-                [ input $
-                    mconcat
-                      [ script stakeScriptHash
-                      , withValue stakeValue
-                      , withDatum (mkStakeInputDatum ps)
-                      , withRef stakeRef
-                      ]
-                , output $
-                    mconcat
-                      [ script stakeScriptHash
-                      , withValue stakeValue
-                      , withDatum (mkStakeOutputDatum ps)
-                      ]
-                ]
+          input $
+            mconcat
+              [ script stakeValidatorHash
+              , withValue stakeValue
+              , withDatum (mkStakeInputDatum ps)
+              , withOutRef stakeRef
+              ]
+        , output $
+            mconcat
+              [ script stakeValidatorHash
+              , withValue stakeValue
+              , withDatum (mkStakeOutputDatum ps)
+              ]
         , ---
           output $
             mconcat
-              [ script proposalScriptHash
+              [ script proposalValidatorHash
               , withValue proposalValue
               , withDatum (mkProposalOutputDatum ps)
               ]
-        , ---
-          fakeStakeBuilder
         ]
 
 --------------------------------------------------------------------------------
@@ -426,6 +340,10 @@ createProposal ps = builder
 stakeRedeemer :: StakeRedeemer
 stakeRedeemer = PermitVote
 
+-- | Spend the governor with the 'CreateProposal' redeemer.
+governorRedeemer :: GovernorRedeemer
+governorRedeemer = CreateProposal
+
 -- | Mint the PST with an arbitrary redeemer. Doesn't really matter.
 proposalPolicyRedeemer :: ()
 proposalPolicyRedeemer = ()
@@ -443,8 +361,6 @@ totallyValidParameters =
     , timeRangeTightEnough = True
     , timeRangeClosed = True
     , proposalStatus = Draft
-    , fakeSST = False
-    , governorRedeemer = Redeemer $ toBuiltinData CreateProposal
     }
 
 invalidOutputGovernorDatumParameters :: Parameters
@@ -497,24 +413,6 @@ invalidProposalStatusParameters =
     )
     [VotingReady, Locked, Finished]
 
-fakeSSTParameters :: Parameters
-fakeSSTParameters =
-  totallyValidParameters
-    { fakeSST = True
-    }
-
-wrongGovernorRedeemer :: Parameters
-wrongGovernorRedeemer =
-  totallyValidParameters
-    { governorRedeemer = Redeemer $ toBuiltinData MintGATs
-    }
-
-wrongGovernorRedeemer1 :: Parameters
-wrongGovernorRedeemer1 =
-  totallyValidParameters
-    { governorRedeemer = Redeemer $ toBuiltinData MutateGovernor
-    }
-
 --------------------------------------------------------------------------------
 
 {- | Create a test tree that runs the proposal minting policy, the governor
@@ -537,7 +435,7 @@ mkTestTree
         testPolicy
           validForProposalPolicy
           "proposal"
-          proposalPolicy
+          agoraScripts.compiledProposalPolicy
           proposalPolicyRedeemer
           (mint proposalPolicySymbol)
 
@@ -545,16 +443,16 @@ mkTestTree
         testValidator
           validForGovernorValidator
           "governor"
-          governorValidator
+          agoraScripts.compiledGovernorValidator
           governorInputDatum
-          ps.governorRedeemer
+          governorRedeemer
           (spend governorRef)
 
       stakeTest =
         testValidator
           validForStakeValidator
           "stake"
-          stakeValidator
+          agoraScripts.compiledStakeValidator
           (mkStakeInputDatum ps)
           stakeRedeemer
           (spend stakeRef)

agora-specs/Sample/Proposal/PrivilegeEscalate.hs

@@ -1,254 +0,0 @@
-module Sample.Proposal.PrivilegeEscalate (
-  Operation (..),
-  privilegeEscalate,
-  Validity (..),
-  mkTestTree,
-) where
-
-import Agora.Proposal (
-  ProposalDatum (..),
-  ProposalId (ProposalId),
-  ProposalRedeemer (UnlockStake, Vote),
-  ProposalStatus (VotingReady),
-  ProposalVotes (ProposalVotes),
-  ResultTag (ResultTag),
-  emptyVotesFor,
- )
-import Agora.Proposal.Time (
-  ProposalStartingTime (ProposalStartingTime),
-  ProposalTimingConfig (draftTime, votingTime),
- )
-import Agora.SafeMoney (GTTag)
-import Agora.Stake (
-  ProposalAction (
-    Voted
-  ),
-  ProposalLock (ProposalLock),
-  StakeDatum (..),
-  StakeRedeemer (PermitVote, RetractVotes),
- )
-import Data.Default (Default (def))
-import Data.Map.Strict qualified as StrictMap
-import Data.Tagged (Tagged, untag)
-import Plutarch.Context (
-  input,
-  normalizeValue,
-  output,
-  script,
-  signedWith,
-  timeRange,
-  withDatum,
-  withRedeemer,
-  withRef,
-  withValue,
- )
-import Plutarch.Extra.AssetClass (assetClassValue)
-import PlutusLedgerApi.V1 (Credential (PubKeyCredential))
-import PlutusLedgerApi.V2 (PubKeyHash, TxOutRef (TxOutRef))
-import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
-import Sample.Shared (
-  minAda,
-  proposalAssetClass,
-  proposalScriptHash,
-  proposalValidator,
-  stakeAssetClass,
-  stakeScriptHash,
-  stakeValidator,
- )
-import Test.Specification (SpecificationTree, group, testValidator)
-import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, pubKeyHashes)
-
-data Operation = Voting | RetractingVotes
-
-data Validity = Validity
-  { forStakeValidator :: Bool
-  , forProposalValidator :: Bool
-  }
-
-wrap :: forall x y. Operation -> (x -> x -> y) -> x -> x -> y
-wrap Voting = id
-wrap RetractingVotes = flip
-
-defStakeAmount :: Tagged GTTag Integer
-defStakeAmount = 100000
-
-defResultTag :: ResultTag
-defResultTag = ResultTag 0
-
-defProposalId :: ProposalId
-defProposalId = ProposalId 0
-
-mkProposalInputOutputDatum :: Operation -> (ProposalDatum, ProposalDatum)
-mkProposalInputOutputDatum op =
-  let effects = StrictMap.singleton defResultTag StrictMap.empty
-
-      proposal =
-        ProposalDatum
-          { proposalId = defProposalId
-          , effects = effects
-          , status = VotingReady
-          , cosigners = [] -- doesn't matter
-          , thresholds = def
-          , votes = emptyVotesFor effects
-          , timingConfig = def
-          , startingTime = ProposalStartingTime 0
-          }
-
-      proposalWithVotes =
-        proposal
-          { votes =
-              ProposalVotes $
-                StrictMap.singleton defResultTag (untag defStakeAmount)
-          }
-   in wrap op (,) proposal proposalWithVotes
-
-mkProposalRedeemer :: Operation -> ProposalRedeemer
-mkProposalRedeemer op = wrap op const (Vote defResultTag) UnlockStake
-
-proposalRef :: TxOutRef
-proposalRef = TxOutRef proposalTxRef 1
-
-attacker :: PubKeyHash
-attacker = head pubKeyHashes
-
-mkStakeInputOutputDatums :: Operation -> ([StakeDatum], [StakeDatum])
-mkStakeInputOutputDatums op =
-  let delegatee = pubKeyHashes !! 1
-
-      firstStake =
-        StakeDatum
-          { stakedAmount = defStakeAmount
-          , owner = PubKeyCredential attacker
-          , delegatedTo = Just $ PubKeyCredential delegatee
-          , lockedBy = []
-          }
-
-      otherStakes =
-        (\pkh -> firstStake {owner = PubKeyCredential pkh})
-          <$> drop 2 pubKeyHashes
-
-      allStakes = take 10 $ firstStake : otherStakes
-
-      createdAt = (def :: ProposalTimingConfig).votingTime - 1
-
-      stakeWithLock =
-        ( \stake ->
-            stake
-              { lockedBy =
-                  [ ProposalLock defProposalId $
-                      Voted
-                        defResultTag
-                        createdAt
-                  ]
-              }
-        )
-          <$> allStakes
-   in wrap op (,) allStakes stakeWithLock
-
-mkStakeRedeemer :: Operation -> StakeRedeemer
-mkStakeRedeemer op = wrap op const PermitVote RetractVotes
-
-mkStakeRef :: Integer -> TxOutRef
-mkStakeRef o = TxOutRef stakeTxRef $ 1 + o
-
-privilegeEscalate :: forall b. CombinableBuilder b => Operation -> b
-privilegeEscalate op =
-  let sst = assetClassValue stakeAssetClass 1
-
-      stakeValue = normalizeValue $ minAda <> sst
-
-      (stakeInputDatums, stakeOutputDatums) = mkStakeInputOutputDatums op
-
-      stakeBuilder =
-        mconcat $
-          zipWith3
-            ( \index stakeInput stakeOutput ->
-                mconcat @b
-                  [ input $
-                      mconcat
-                        [ script stakeScriptHash
-                        , withDatum stakeInput
-                        , withValue stakeValue
-                        , withRef $ mkStakeRef index
-                        , withRedeemer $ mkStakeRedeemer op
-                        ]
-                  , output $
-                      mconcat
-                        [ script stakeScriptHash
-                        , withDatum stakeOutput
-                        , withValue stakeValue
-                        ]
-                  ]
-            )
-            [1 ..]
-            stakeInputDatums
-            stakeOutputDatums
-
-      ---
-
-      pst = assetClassValue proposalAssetClass 1
-
-      proposalValue = normalizeValue $ minAda <> pst
-
-      (proposalInput, proposalOutput) = mkProposalInputOutputDatum op
-
-      proposalBuilder =
-        mconcat @b
-          [ input $
-              mconcat
-                [ script proposalScriptHash
-                , withDatum proposalInput
-                , withRedeemer $ mkProposalRedeemer op
-                , withValue proposalValue
-                , withRef proposalRef
-                ]
-          , output $
-              mconcat
-                [ script proposalScriptHash
-                , withDatum proposalOutput
-                , withValue proposalValue
-                ]
-          ]
-
-      ---
-
-      validTimeRange =
-        closedBoundedInterval
-          ((def :: ProposalTimingConfig).draftTime + 1)
-          ((def :: ProposalTimingConfig).votingTime - 1)
-
-      miscBuilder =
-        mconcat @b
-          [ signedWith attacker
-          , timeRange validTimeRange
-          ]
-   in mconcat
-        [ miscBuilder
-        , stakeBuilder
-        , proposalBuilder
-        ]
-
-mkTestTree :: String -> Operation -> Validity -> SpecificationTree
-mkTestTree name op val = group name [proposal, stake]
-  where
-    spend = mkSpending privilegeEscalate op
-
-    proposal =
-      testValidator
-        val.forProposalValidator
-        "proposal"
-        proposalValidator
-        (fst $ mkProposalInputOutputDatum op)
-        (mkProposalRedeemer op)
-        (spend proposalRef)
-
-    stakeInputdDatum = head $ fst $ mkStakeInputOutputDatums op
-
-    stake =
-      testValidator
-        val.forStakeValidator
-        "stake"
-        stakeValidator
-        stakeInputdDatum
-        (mkStakeRedeemer op)
-        (spend $ mkStakeRef 1)

agora-specs/Sample/Proposal/Shared.hs

@@ -7,7 +7,7 @@ Shared constants for proposal samples.
 -}
 module Sample.Proposal.Shared (proposalTxRef, stakeTxRef, governorTxRef) where
 
-import PlutusLedgerApi.V2 (TxId)
+import PlutusLedgerApi.V1 (TxId)
 
 -- | 'TxId' of all the proposal inputs in the samples.
 proposalTxRef :: TxId

agora-specs/Sample/Proposal/Unlock.hs

@@ -1,612 +0,0 @@
-{- |
-Module     : Sample.Proposal.UnlockStake
-Maintainer : connor@mlabs.city
-Description: Generate sample data for testing the functionalities of unlocking stake and retracting votes
-
-Sample and utilities for testing the functionalities of unlocking stake and retracting votes
--}
-module Sample.Proposal.Unlock (
-  ParameterBundle (..),
-  StakeRole (..),
-  TimeRange (..),
-  SignedBy (..),
-  TransactionParameters (..),
-  ProposalParameters (..),
-  SSTOwner (..),
-  StakeParameters (..),
-  Validity (..),
-  unlock,
-  mkTestTree,
-  mkValidVoterRetractVotes,
-  mkValidDelegateeRetractVotes,
-  mkValidVoterCreatorRetractVotes,
-  mkValidCreatorRemoveLock,
-  mkValidVoterRemoveLockAfterVoting,
-  mkRetractVotesWhileNotVoting,
-  mkUnockIrrelevantStakes,
-  mkRemoveCreatorLockBeforeFinished,
-  mkCreatorRetractVotes,
-  mkChangeOutputStakeValue,
-  mkUseFakeStakes,
-  mkDisrespectCooldown,
-) where
-
---------------------------------------------------------------------------------
-
-import Agora.Governor (Governor (..))
-import Agora.Proposal (
-  ProposalDatum (..),
-  ProposalEffectGroup,
-  ProposalId (..),
-  ProposalRedeemer (UnlockStake),
-  ProposalStatus (..),
-  ProposalVotes (..),
-  ResultTag (..),
- )
-import Agora.Proposal.Time (
-  ProposalStartingTime (ProposalStartingTime),
-  ProposalTimingConfig (..),
- )
-import Agora.SafeMoney (GTTag)
-import Agora.Stake (
-  ProposalAction (Created, Voted),
-  ProposalLock (..),
-  StakeDatum (..),
-  StakeRedeemer (RetractVotes),
- )
-import Data.Coerce (coerce)
-import Data.Default.Class (Default (def))
-import Data.Map.Strict qualified as StrictMap
-import Data.Tagged (Tagged, untag)
-import Plutarch.Context (
-  input,
-  normalizeValue,
-  output,
-  script,
-  signedWith,
-  timeRange,
-  txId,
-  withDatum,
-  withRedeemer,
-  withRef,
-  withValue,
- )
-import Plutarch.Extra.AssetClass (assetClassValue)
-import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
-import PlutusLedgerApi.V1.Value qualified as Value
-import PlutusLedgerApi.V2 (
-  Credential (PubKeyCredential),
-  POSIXTime,
-  PubKeyHash,
-  TxOutRef (..),
- )
-import Sample.Proposal.Shared (stakeTxRef)
-import Sample.Shared (
-  governor,
-  minAda,
-  proposalAssetClass,
-  proposalScriptHash,
-  proposalValidator,
-  stakeScriptHash,
-  stakeSymbol,
-  stakeValidator,
- )
-import Test.Specification (SpecificationTree, group, testValidator)
-import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, pubKeyHashes)
-
---------------------------------------------------------------------------------
-
-votesTemplate :: ProposalVotes
-votesTemplate =
-  ProposalVotes $
-    StrictMap.fromList
-      [ (ResultTag 0, 0)
-      , (ResultTag 1, 0)
-      ]
-
--- | Create empty effects for every result tag given the votes.
-emptyEffectFor ::
-  ProposalVotes ->
-  StrictMap.Map ResultTag ProposalEffectGroup
-emptyEffectFor (ProposalVotes vs) =
-  StrictMap.fromList $
-    map (,StrictMap.empty) (StrictMap.keys vs)
-
--- | The default vote option that will be used by functions in this module.
-defVoteFor :: ResultTag
-defVoteFor = ResultTag 0
-
--- | The default number of GTs the stake will have.
-defStakedGTs :: Tagged GTTag Integer
-defStakedGTs = 100000
-
-alteredStakedGTs :: Tagged GTTag Integer
-alteredStakedGTs = 100
-
--- | Default owner of the stakes.
-defOwner :: PubKeyHash
-defOwner = pubKeyHashes !! 1
-
-defDelegatee :: PubKeyHash
-defDelegatee = pubKeyHashes !! 2
-
-defUnknown :: PubKeyHash
-defUnknown = pubKeyHashes !! 3
-
-defProposalId :: ProposalId
-defProposalId = ProposalId 0
-
-defStartingTime :: ProposalStartingTime
-defStartingTime = ProposalStartingTime 0
-
---------------------------------------------------------------------------------
-
-data ParameterBundle = ParameterBundle
-  { proposalParameters :: ProposalParameters
-  , stakeParameters :: StakeParameters
-  , transactionParameters :: TransactionParameters
-  }
-
-data SignedBy = Owner | Delegatee | Unknown
-
-data TimeRange = WhileVoting {offset :: POSIXTime} | AfterVoting
-
-data TransactionParameters = TransactionParameters
-  { signedBy :: SignedBy
-  , timeRange :: TimeRange
-  }
-
-data ProposalParameters = ProposalParameters
-  { proposalStatus :: ProposalStatus
-  , retractVotes :: Bool
-  }
-
--- | How a stake has been used on a particular proposal.
-data StakeRole
-  = -- | The stake was spent to vote for a paraticular option.
-    Voter
-  | -- | The stake was used to create the proposal.
-    Creator
-  | -- | The stake was used to both create and vote for the proposal.
-    Both
-  | -- | The stake has nothing to do with the proposal.
-    Irrelevant
-  deriving stock (Bounded, Enum, Show)
-
-data SSTOwner
-  = StakeValidator
-  | Attacker
-
-data StakeParameters = StakeParameters
-  { numStakes :: Integer
-  , stakeRole :: StakeRole
-  , removeVoterLock :: Bool
-  , removeCreatorLock :: Bool
-  , alterOutputValue :: Bool
-  , sstOwner :: SSTOwner
-  , votingLockCreatedAt :: POSIXTime
-  }
-
-data Validity = Validity
-  { forProposalValidator :: Bool
-  , forStakeValidator :: Bool
-  }
-
---------------------------------------------------------------------------------
-
-mkStakeRef :: Integer -> TxOutRef
-mkStakeRef = TxOutRef stakeTxRef
-
-stakeRedeemer :: StakeRedeemer
-stakeRedeemer = RetractVotes
-
-mkStakeInputDatum :: StakeParameters -> StakeDatum
-mkStakeInputDatum ps =
-  StakeDatum
-    { stakedAmount = defStakedGTs
-    , owner = PubKeyCredential defOwner
-    , delegatedTo = Just $ PubKeyCredential defDelegatee
-    , lockedBy = stakeLocks
-    }
-  where
-    stakeLocks = mkStakeLocks' ps.stakeRole
-
-    mkStakeLocks' Voter =
-      [ ProposalLock defProposalId $
-          Voted defVoteFor ps.votingLockCreatedAt
-      ]
-    mkStakeLocks' Creator = [ProposalLock defProposalId Created]
-    mkStakeLocks' Both = mkStakeLocks' Voter <> mkStakeLocks' Creator
-    mkStakeLocks' Irrelevant =
-      let ProposalId pid = defProposalId
-          ResultTag vid = defVoteFor
-       in [ ProposalLock (ProposalId $ pid + 1) $
-              Voted
-                (ResultTag $ vid + 1)
-                ps.votingLockCreatedAt
-          , ProposalLock (ProposalId $ pid + 1) Created
-          ]
-
---------------------------------------------------------------------------------
-
-proposalRef :: TxOutRef
-proposalRef = TxOutRef stakeTxRef 0
-
-proposalRedeemer :: ProposalRedeemer
-proposalRedeemer = UnlockStake
-
-mkProposalInputDatum ::
-  StakeParameters ->
-  ProposalParameters ->
-  ProposalDatum
-mkProposalInputDatum sps pps =
-  ProposalDatum
-    { proposalId = defProposalId
-    , effects = emptyEffectFor votesTemplate
-    , status = pps.proposalStatus
-    , cosigners = [PubKeyCredential $ head pubKeyHashes]
-    , thresholds = def
-    , votes = updatVotes votesTemplate
-    , timingConfig = def
-    , startingTime = defStartingTime
-    }
-  where
-    updatVotes (ProposalVotes vt) =
-      ProposalVotes $
-        StrictMap.adjust
-          (+ sps.numStakes * untag defStakedGTs)
-          defVoteFor
-          vt
-
---------------------------------------------------------------------------------
-
-unlock :: forall b. CombinableBuilder b => ParameterBundle -> b
-unlock ps = builder
-  where
-    pst = assetClassValue proposalAssetClass 1
-
-    proposalInputDatum =
-      mkProposalInputDatum
-        ps.stakeParameters
-        ps.proposalParameters
-
-    proposalOutputDatum =
-      if ps.proposalParameters.retractVotes
-        then proposalInputDatum {votes = votesTemplate}
-        else proposalInputDatum
-
-    proposalValue = normalizeValue $ pst <> minAda
-
-    proposalBuilder :: b
-    proposalBuilder =
-      mconcat
-        [ input $
-            mconcat
-              [ script proposalScriptHash
-              , withValue proposalValue
-              , withDatum proposalInputDatum
-              , withRef proposalRef
-              , withRedeemer proposalRedeemer
-              ]
-        , output $
-            mconcat
-              [ script proposalScriptHash
-              , withValue proposalValue
-              , withDatum proposalOutputDatum
-              ]
-        ]
-
-    ---
-
-    sstName = case ps.stakeParameters.sstOwner of
-      StakeValidator -> scriptHashToTokenName stakeScriptHash
-      _ -> ""
-
-    sst = Value.singleton stakeSymbol sstName 1
-
-    stakeInputDatum = mkStakeInputDatum ps.stakeParameters
-
-    -- TODO respect timing
-    removeLocks v c =
-      filter $ \(ProposalLock pid action) ->
-        pid == defProposalId
-          && not
-            ( case action of
-                Voted _ _ -> v
-                _ -> c
-            )
-
-    stakeOutputDatum =
-      stakeInputDatum
-        { lockedBy =
-            removeLocks
-              ps.stakeParameters.removeVoterLock
-              ps.stakeParameters.removeCreatorLock
-              stakeInputDatum.lockedBy
-        }
-
-    mkStakeValue gt =
-      normalizeValue $
-        mconcat
-          [ minAda
-          , sst
-          , assetClassValue
-              governor.gtClassRef
-              gt
-          ]
-
-    stakeInputValue = mkStakeValue defStakedGTs
-
-    stakeOutputValue =
-      mkStakeValue $
-        if ps.stakeParameters.alterOutputValue
-          then alteredStakedGTs
-          else defStakedGTs
-
-    stakeBuilder :: b
-    stakeBuilder =
-      foldMap
-        ( \i ->
-            mconcat
-              [ input $
-                  mconcat
-                    [ script stakeScriptHash
-                    , withValue stakeInputValue
-                    , withDatum stakeInputDatum
-                    , withRef $ mkStakeRef i
-                    ]
-              , output $
-                  mconcat
-                    [ script stakeScriptHash
-                    , withValue stakeOutputValue
-                    , withDatum stakeOutputDatum
-                    ]
-              ]
-        )
-        [1 .. ps.stakeParameters.numStakes]
-
-    ---
-
-    ProposalStartingTime s = defStartingTime
-
-    time = case ps.transactionParameters.timeRange of
-      WhileVoting offset ->
-        let lb =
-              ps.stakeParameters.votingLockCreatedAt
-                + offset
-            ub =
-              s
-                + (def :: ProposalTimingConfig).draftTime
-                + (def :: ProposalTimingConfig).votingTime
-         in closedBoundedInterval (lb + 1) (ub - 1)
-      AfterVoting ->
-        let lb =
-              s
-                + (def :: ProposalTimingConfig).draftTime
-                + (def :: ProposalTimingConfig).votingTime
-            ub = lb + (def :: ProposalTimingConfig).lockingTime
-         in closedBoundedInterval (lb + 1) (ub - 1)
-
-    sig = case ps.transactionParameters.signedBy of
-      Unknown -> defUnknown
-      Owner -> defOwner
-      Delegatee -> defDelegatee
-
-    ---
-
-    builder =
-      mconcat
-        [ txId "388bc0b897b3dadcd479da4c88291de4113a50b72ddbed001faf7fc03f11bc52"
-        , proposalBuilder
-        , stakeBuilder
-        , signedWith sig
-        , timeRange time
-        ]
-
---------------------------------------------------------------------------------
-
-{- | Create a test tree that runs both the stake validator and the proposal
-     validator.
--}
-mkTestTree :: String -> ParameterBundle -> Validity -> SpecificationTree
-mkTestTree name ps val = group name [stake, proposal]
-  where
-    spend = mkSpending unlock ps
-
-    stake =
-      testValidator
-        val.forStakeValidator
-        "stake"
-        stakeValidator
-        (mkStakeInputDatum ps.stakeParameters)
-        stakeRedeemer
-        (spend $ mkStakeRef 1)
-
-    proposal =
-      testValidator
-        val.forProposalValidator
-        "proposal"
-        proposalValidator
-        (mkProposalInputDatum ps.stakeParameters ps.proposalParameters)
-        proposalRedeemer
-        (spend proposalRef)
-
---------------------------------------------------------------------------------
-
-mkValidVoterRetractVotes :: Integer -> ParameterBundle
-mkValidVoterRetractVotes i =
-  ParameterBundle
-    { proposalParameters =
-        ProposalParameters
-          { proposalStatus = VotingReady
-          , retractVotes = True
-          }
-    , stakeParameters =
-        StakeParameters
-          { numStakes = i
-          , stakeRole = Voter
-          , removeVoterLock = True
-          , removeCreatorLock = False
-          , alterOutputValue = False
-          , sstOwner = StakeValidator
-          , votingLockCreatedAt =
-              coerce defStartingTime
-                + (def :: ProposalTimingConfig).draftTime
-                + 1
-          }
-    , transactionParameters =
-        TransactionParameters
-          { signedBy = Owner
-          , timeRange =
-              WhileVoting
-                { offset =
-                    coerce
-                      (def :: ProposalTimingConfig).minStakeVotingTime
-                      + 5
-                }
-          }
-    }
-
-mkValidDelegateeRetractVotes :: Integer -> ParameterBundle
-mkValidDelegateeRetractVotes i =
-  let template = mkValidVoterRetractVotes i
-   in template
-        { transactionParameters =
-            template.transactionParameters
-              { signedBy = Delegatee
-              }
-        }
-
-mkValidVoterCreatorRetractVotes :: Integer -> ParameterBundle
-mkValidVoterCreatorRetractVotes i =
-  let template = mkValidVoterRetractVotes i
-   in template
-        { stakeParameters =
-            template.stakeParameters
-              { stakeRole = Both
-              }
-        }
-
-mkValidCreatorRemoveLock :: Integer -> ParameterBundle
-mkValidCreatorRemoveLock i =
-  let template = mkValidVoterRetractVotes i
-   in template
-        { proposalParameters =
-            template.proposalParameters
-              { proposalStatus = Finished
-              , retractVotes = False
-              }
-        , stakeParameters =
-            template.stakeParameters
-              { stakeRole = Creator
-              , removeCreatorLock = True
-              }
-        , transactionParameters =
-            template.transactionParameters
-              { timeRange = AfterVoting
-              }
-        }
-
-mkValidVoterRemoveLockAfterVoting :: Integer -> ParameterBundle
-mkValidVoterRemoveLockAfterVoting i =
-  let template = mkValidVoterRetractVotes i
-   in template
-        { proposalParameters =
-            template.proposalParameters
-              { proposalStatus = Finished
-              , retractVotes = False
-              }
-        , transactionParameters =
-            template.transactionParameters
-              { timeRange = AfterVoting
-              }
-        }
-
-mkRetractVotesWhileNotVoting :: Integer -> [ParameterBundle]
-mkRetractVotesWhileNotVoting i =
-  let template = mkValidVoterRetractVotes i
-   in map
-        ( \s ->
-            template
-              { proposalParameters =
-                  template.proposalParameters
-                    { proposalStatus = s
-                    }
-              }
-        )
-        [Draft, Locked, Finished]
-
-mkUnockIrrelevantStakes :: Integer -> ParameterBundle
-mkUnockIrrelevantStakes i =
-  let template = mkValidVoterRetractVotes i
-   in template
-        { stakeParameters =
-            template.stakeParameters
-              { stakeRole = Irrelevant
-              , removeCreatorLock = True
-              }
-        }
-
-mkRemoveCreatorLockBeforeFinished :: Integer -> [ParameterBundle]
-mkRemoveCreatorLockBeforeFinished i =
-  let template = mkValidCreatorRemoveLock i
-   in map
-        ( \s ->
-            template
-              { proposalParameters =
-                  template.proposalParameters
-                    { proposalStatus = s
-                    }
-              }
-        )
-        [Draft, VotingReady, Locked]
-
-mkCreatorRetractVotes :: Integer -> ParameterBundle
-mkCreatorRetractVotes i =
-  let template = mkValidVoterRetractVotes i
-   in template
-        { proposalParameters =
-            template.proposalParameters
-              { proposalStatus = VotingReady
-              }
-        , stakeParameters =
-            template.stakeParameters
-              { stakeRole = Creator
-              }
-        }
-
-mkChangeOutputStakeValue :: Integer -> ParameterBundle
-mkChangeOutputStakeValue i =
-  let template = mkValidVoterRetractVotes i
-   in template
-        { stakeParameters =
-            template.stakeParameters
-              { alterOutputValue = True
-              }
-        }
-
-mkUseFakeStakes :: Integer -> ParameterBundle
-mkUseFakeStakes i =
-  let template = mkValidVoterCreatorRetractVotes i
-   in template
-        { stakeParameters =
-            template.stakeParameters
-              { sstOwner = Attacker
-              }
-        }
-
-mkDisrespectCooldown :: Integer -> ParameterBundle
-mkDisrespectCooldown i =
-  let template = mkValidVoterCreatorRetractVotes i
-   in template
-        { transactionParameters =
-            template.transactionParameters
-              { timeRange =
-                  WhileVoting
-                    { offset =
-                        coerce
-                          (def :: ProposalTimingConfig).minStakeVotingTime
-                          - 5
-                    }
-              }
-        }

agora-specs/Sample/Proposal/UnlockStake.hs

@@ -0,0 +1,550 @@
+{- |
+Module     : Sample.Proposal.UnlockStake
+Maintainer : connor@mlabs.city
+Description: Generate sample data for testing the functionalities of unlocking stake and retracting votes
+
+Sample and utilities for testing the functionalities of unlocking stake and retracting votes
+-}
+module Sample.Proposal.UnlockStake (
+  StakeRole (..),
+  Parameters (..),
+  unlockStake,
+  mkTestTree,
+  mkVoterRetractVotesWhileVotingParameters,
+  mkVoterCreatorRetractVotesWhileVotingParameters,
+  mkCreatorRemoveCreatorLocksWhenFinishedParameters,
+  mkVoterCreatorRemoveAllLocksWhenFinishedParameters,
+  mkVoterUnlockStakeAfterVotingParameters,
+  mkVoterCreatorRemoveVoteLocksWhenLockedParameters,
+  mkRetractVotesWhileNotVoting,
+  mkUnockIrrelevantStakeParameters,
+  mkRemoveCreatorLockBeforeFinishedParameters,
+  mkRetractVotesWithCreatorStakeParamaters,
+  mkAlterStakeParameters,
+) where
+
+--------------------------------------------------------------------------------
+
+import Agora.Governor (Governor (..))
+import Agora.Proposal (
+  ProposalDatum (..),
+  ProposalId (..),
+  ProposalRedeemer (Unlock),
+  ProposalStatus (..),
+  ProposalVotes (..),
+  ResultTag (..),
+ )
+import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime))
+import Agora.Scripts (AgoraScripts (..))
+import Agora.Stake (ProposalLock (..), StakeDatum (..), StakeRedeemer (RetractVotes))
+import Data.Default.Class (Default (def))
+import Data.Tagged (Tagged (..), untag)
+import Plutarch.Context (
+  input,
+  output,
+  script,
+  signedWith,
+  txId,
+  withDatum,
+  withOutRef,
+  withValue,
+ )
+import PlutusLedgerApi.V1 (
+  DatumHash,
+  PubKeyHash,
+  TxOutRef (..),
+  ValidatorHash,
+ )
+import PlutusLedgerApi.V1.Value qualified as Value
+import PlutusTx.AssocMap qualified as AssocMap
+import Sample.Proposal.Shared (stakeTxRef)
+import Sample.Shared (
+  agoraScripts,
+  governor,
+  minAda,
+  proposalPolicySymbol,
+  proposalValidatorHash,
+  signer,
+  stakeAssetClass,
+  stakeValidatorHash,
+ )
+import Test.Specification (SpecificationTree, group, testValidator)
+import Test.Util (CombinableBuilder, mkSpending, sortValue, updateMap)
+
+--------------------------------------------------------------------------------
+
+-- | The template "shape" that votes of proposals generated by 'mkProposalDatumPair' have.
+votesTemplate :: ProposalVotes
+votesTemplate =
+  ProposalVotes $
+    AssocMap.fromList
+      [ (ResultTag 0, 0)
+      , (ResultTag 1, 0)
+      ]
+
+-- | Create empty effects for every result tag given the votes.
+emptyEffectFor ::
+  ProposalVotes ->
+  AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash)
+emptyEffectFor (ProposalVotes vs) =
+  AssocMap.fromList $
+    map (,AssocMap.empty) (AssocMap.keys vs)
+
+-- | The default vote option that will be used by functions in this module.
+defVoteFor :: ResultTag
+defVoteFor = ResultTag 0
+
+-- | The default number of GTs the stake will have.
+defStakedGTs :: Tagged _ Integer
+defStakedGTs = 100000
+
+{- | If 'Parameters.alterOutputStake' is set to true, the
+     'StakeDatum.stakedAmount' will be set to this.
+-}
+alteredStakedGTs :: Tagged _ Integer
+alteredStakedGTs = 100
+
+-- | Default owner of the stakes.
+defOwner :: PubKeyHash
+defOwner = signer
+
+-- | How a stake has been used on a particular proposal.
+data StakeRole
+  = -- | The stake was spent to vote for a paraticular option.
+    Voter
+  | -- | The stake was used to create the proposal.
+    Creator
+  | -- | The stake was used to both create and vote for the proposal.
+    Both
+  | -- | The stake has nothing to do with the proposal.
+    Irrelevant
+  deriving stock (Bounded, Enum, Show)
+
+-- | Parameters for creating a 'TxOut' that unlocks a stake.
+data Parameters = Parameters
+  { proposalCount :: Integer
+  -- ^ The number of proposals in the 'TxOut'.
+  , stakeRole :: StakeRole
+  -- ^ The role of the stake we're unlocking.
+  , retractVotes :: Bool
+  -- ^ Whether to retract votes or not.
+  , removeVoterLock :: Bool
+  -- ^ Remove the voter locks from the input stake.
+  , removeCreatorLock :: Bool
+  -- ^ Remove the creator locks from the input stake.
+  , proposalStatus :: ProposalStatus
+  -- ^ The state of all the proposals.
+  , alterOutputStake :: Bool
+  }
+
+-- | Iterate over the proposal id of every proposal, given the number of proposals.
+forEachProposalId :: Parameters -> (ProposalId -> a) -> [a]
+forEachProposalId ps = forEachProposalId' ps.proposalCount
+  where
+    forEachProposalId' :: Integer -> (ProposalId -> a) -> [a]
+    forEachProposalId' 0 _ = error "zero proposal"
+    forEachProposalId' n f = f . ProposalId <$> [0 .. n - 1]
+
+-- | Create locks for the input stake given the parameters.
+mkInputStakeLocks :: Parameters -> [ProposalLock]
+mkInputStakeLocks ps = mconcat $ forEachProposalId ps $ mkStakeLocksFor ps.stakeRole
+  where
+    mkStakeLocksFor :: StakeRole -> ProposalId -> [ProposalLock]
+    mkStakeLocksFor sr pid =
+      let voted = [Voted pid defVoteFor]
+          created = [Created pid]
+       in case sr of
+            Voter -> voted
+            Creator -> created
+            Both -> voted <> created
+            _ -> []
+
+-- | Create locks for the output stake by removing locks from the input locks.
+mkOutputStakeLocks :: Parameters -> [ProposalLock]
+mkOutputStakeLocks ps =
+  filter
+    ( \lock -> not $ case lock of
+        Voted _ _ -> ps.removeVoterLock
+        Created _ -> ps.removeCreatorLock
+    )
+    inputLocks
+  where
+    inputLocks = mkInputStakeLocks ps
+
+-- | Create the stake input datum given the parameters.
+mkStakeInputDatum :: Parameters -> StakeDatum
+mkStakeInputDatum ps =
+  StakeDatum
+    { stakedAmount = defStakedGTs
+    , owner = defOwner
+    , delegatedTo = Nothing
+    , lockedBy = mkInputStakeLocks ps
+    }
+
+-- | Create stake output datum given the parameters.
+mkStakeOutputDatum :: Parameters -> StakeDatum
+mkStakeOutputDatum ps =
+  let template = mkStakeInputDatum ps
+      stakedAmount' =
+        if ps.alterOutputStake
+          then alteredStakedGTs
+          else defStakedGTs
+   in template
+        { stakedAmount = stakedAmount'
+        , lockedBy = mkOutputStakeLocks ps
+        }
+
+-- | Generate some input proposals and their corresponding output proposals.
+mkProposals :: Parameters -> [(ProposalDatum, ProposalDatum)]
+mkProposals ps = forEachProposalId ps $ mkProposalDatumPair ps
+
+-- | Create the input proposal datum.
+mkProposalInputDatum :: Parameters -> ProposalId -> ProposalDatum
+mkProposalInputDatum p pid = fst $ mkProposalDatumPair p pid
+
+-- | Create a input proposal and its corresponding output proposal.
+mkProposalDatumPair ::
+  Parameters ->
+  ProposalId ->
+  (ProposalDatum, ProposalDatum)
+mkProposalDatumPair params pid =
+  let inputVotes = mkInputVotes params.stakeRole $ untag defStakedGTs
+
+      input =
+        ProposalDatum
+          { proposalId = pid
+          , effects = emptyEffectFor votesTemplate
+          , status = params.proposalStatus
+          , cosigners = [defOwner]
+          , thresholds = def
+          , votes = inputVotes
+          , timingConfig = def
+          , startingTime = ProposalStartingTime 0
+          }
+
+      output =
+        if params.retractVotes
+          then input {votes = votesTemplate}
+          else input
+   in (input, output)
+  where
+    -- Assemble the votes of the input proposal based on 'votesTemplate'.
+    mkInputVotes ::
+      StakeRole ->
+      -- The staked amount/votes.
+      Integer ->
+      ProposalVotes
+    mkInputVotes Creator _ =
+      ProposalVotes $
+        updateMap (Just . const 1000) defVoteFor $
+          getProposalVotes votesTemplate
+    mkInputVotes Irrelevant _ = votesTemplate
+    mkInputVotes _ vc =
+      ProposalVotes $
+        updateMap (Just . const vc) defVoteFor $
+          getProposalVotes votesTemplate
+
+-- | Create a 'TxInfo' that tries to unlock a stake.
+unlockStake :: forall b. CombinableBuilder b => Parameters -> b
+unlockStake ps =
+  let pst = Value.singleton proposalPolicySymbol "" 1
+      sst = Value.assetClassValue stakeAssetClass 1
+
+      pIODatums = mkProposals ps
+
+      proposals =
+        foldMap
+          ( \((i, o), idx) ->
+              mconcat
+                [ input $
+                    mconcat
+                      [ script proposalValidatorHash
+                      , withValue pst
+                      , withDatum i
+                      , withOutRef (mkProposalRef idx)
+                      ]
+                , output $
+                    mconcat
+                      [ script proposalValidatorHash
+                      , withValue (sortValue $ pst <> minAda)
+                      , withDatum o
+                      ]
+                ]
+          )
+          (zip pIODatums [0 ..])
+
+      stakeValue =
+        sortValue $
+          mconcat
+            [ Value.assetClassValue
+                (untag governor.gtClassRef)
+                (untag defStakedGTs)
+            , sst
+            , minAda
+            ]
+
+      sInDatum = mkStakeInputDatum ps
+      sOutDatum = mkStakeOutputDatum ps
+
+      stakes =
+        mconcat
+          [ input $
+              mconcat
+                [ script stakeValidatorHash
+                , withValue stakeValue
+                , withDatum sInDatum
+                , withOutRef stakeRef
+                ]
+          , output $
+              mconcat
+                [ script stakeValidatorHash
+                , withValue stakeValue
+                , withDatum sOutDatum
+                ]
+          ]
+
+      builder =
+        mconcat
+          [ txId "388bc0b897b3dadcd479da4c88291de4113a50b72ddbed001faf7fc03f11bc52"
+          , proposals
+          , stakes
+          , signedWith defOwner
+          ]
+   in builder
+
+-- | Reference to the stake UTXO.
+stakeRef :: TxOutRef
+stakeRef = TxOutRef stakeTxRef 1
+
+-- | Generate the reference to a proposal UTXOs, given the index of the proposal.
+mkProposalRef :: Int -> TxOutRef
+mkProposalRef offset = TxOutRef stakeTxRef $ 2 + fromIntegral offset
+
+-- | Proposal redeemer used by 'mkTestTree', in this case it's always 'Unlock'.
+proposalRedeemer :: ProposalRedeemer
+proposalRedeemer = Unlock
+
+-- | Stake redeemer used by 'mkTestTree', in this case it's always 'RetractVotes'.
+stakeRedeemer :: StakeRedeemer
+stakeRedeemer = RetractVotes
+
+--------------------------------------------------------------------------------
+
+{- | Legal parameters that retract votes while the proposals is in 'VotingReady'
+      state, and also remove voter locks from the stake, which is
+      used to vote on the proposals.
+-}
+mkVoterRetractVotesWhileVotingParameters :: Integer -> Parameters
+mkVoterRetractVotesWhileVotingParameters nProposals =
+  Parameters
+    { proposalCount = nProposals
+    , stakeRole = Voter
+    , retractVotes = True
+    , removeVoterLock = True
+    , removeCreatorLock = False
+    , proposalStatus = VotingReady
+    , alterOutputStake = False
+    }
+
+{- | Legal parameters that retract votes while the proposals is in 'VotingReady'
+      state, and also remove voter locks from the stake, which is
+      used to both create and vote on the proposals.
+-}
+mkVoterCreatorRetractVotesWhileVotingParameters :: Integer -> Parameters
+mkVoterCreatorRetractVotesWhileVotingParameters nProposals =
+  Parameters
+    { proposalCount = nProposals
+    , stakeRole = Both
+    , retractVotes = True
+    , removeVoterLock = True
+    , removeCreatorLock = False
+    , proposalStatus = VotingReady
+    , alterOutputStake = False
+    }
+
+{- | Legal parameters that remove creator locks from the stake while the
+      proposals is in 'Finished' state. The stake was only used for creating
+      the proposals.
+-}
+mkCreatorRemoveCreatorLocksWhenFinishedParameters :: Integer -> Parameters
+mkCreatorRemoveCreatorLocksWhenFinishedParameters nProposals =
+  Parameters
+    { proposalCount = nProposals
+    , stakeRole = Creator
+    , retractVotes = False
+    , removeVoterLock = False
+    , removeCreatorLock = True
+    , proposalStatus = Finished
+    , alterOutputStake = False
+    }
+
+{- | Legal parameters that remove voter and creator locks from the stake while
+      the proposals is in 'Finished' state. The stake was used for creating
+      and voting on the proposals.
+-}
+mkVoterCreatorRemoveAllLocksWhenFinishedParameters :: Integer -> Parameters
+mkVoterCreatorRemoveAllLocksWhenFinishedParameters nProposals =
+  Parameters
+    { proposalCount = nProposals
+    , stakeRole = Both
+    , retractVotes = False
+    , removeVoterLock = True
+    , removeCreatorLock = True
+    , proposalStatus = Finished
+    , alterOutputStake = False
+    }
+
+{- Legal parameters that remove voter locks from the stake after the voting
+    phrase. The stake was used only for voting on the proposals.
+-}
+mkVoterUnlockStakeAfterVotingParameters :: Integer -> [Parameters]
+mkVoterUnlockStakeAfterVotingParameters nProposals =
+  map
+    ( \st ->
+        Parameters
+          { proposalCount = nProposals
+          , stakeRole = Voter
+          , retractVotes = False
+          , removeVoterLock = True
+          , removeCreatorLock = False
+          , proposalStatus = st
+          , alterOutputStake = False
+          }
+    )
+    [Locked, Finished]
+
+{- Legal parameters that remove voter locks whenproposals are in phrase.
+    The stake was used for crating and voting on the proposals.
+-}
+mkVoterCreatorRemoveVoteLocksWhenLockedParameters :: Integer -> Parameters
+mkVoterCreatorRemoveVoteLocksWhenLockedParameters nProposals =
+  Parameters
+    { proposalCount = nProposals
+    , stakeRole = Both
+    , retractVotes = False
+    , removeVoterLock = True
+    , removeCreatorLock = False
+    , proposalStatus = Locked
+    , alterOutputStake = False
+    }
+
+{- | Illegal parameters that retract votes when the proposals are not in voting
+      phrase.
+-}
+mkRetractVotesWhileNotVoting :: Integer -> [Parameters]
+mkRetractVotesWhileNotVoting nProposals = do
+  role <- enumFrom Voter
+  status <- [Draft, Locked, Finished]
+
+  pure $
+    Parameters
+      { proposalCount = nProposals
+      , stakeRole = role
+      , retractVotes = True
+      , removeVoterLock = True
+      , removeCreatorLock = False
+      , proposalStatus = status
+      , alterOutputStake = False
+      }
+
+{- | Illegal parameter that try to unlock a stake that has nothing to do with
+      the proposals.
+-}
+mkUnockIrrelevantStakeParameters :: Integer -> [Parameters]
+mkUnockIrrelevantStakeParameters nProposals = do
+  status <- [Draft, VotingReady, Locked, Finished]
+  retractVotes <- [True, False]
+
+  pure $
+    Parameters
+      { proposalCount = nProposals
+      , stakeRole = Irrelevant
+      , retractVotes = retractVotes
+      , removeVoterLock = True
+      , removeCreatorLock = True
+      , proposalStatus = status
+      , alterOutputStake = False
+      }
+
+{- | Illegal parameters that remove the creator locks before the proposals are
+      'Finished'.
+-}
+mkRemoveCreatorLockBeforeFinishedParameters :: Integer -> [Parameters]
+mkRemoveCreatorLockBeforeFinishedParameters nProposals = do
+  status <- [Draft, VotingReady, Locked]
+
+  pure $
+    Parameters
+      { proposalCount = nProposals
+      , stakeRole = Creator
+      , retractVotes = False
+      , removeVoterLock = False
+      , removeCreatorLock = True
+      , proposalStatus = status
+      , alterOutputStake = False
+      }
+
+{- | Illegal parameters that try to retract votes with a stake that was only used
+    for creating the proposals.
+-}
+mkRetractVotesWithCreatorStakeParamaters :: Integer -> Parameters
+mkRetractVotesWithCreatorStakeParamaters nProposals =
+  Parameters
+    { proposalCount = nProposals
+    , stakeRole = Creator
+    , retractVotes = True
+    , removeVoterLock = True
+    , removeCreatorLock = True
+    , proposalStatus = VotingReady
+    , alterOutputStake = False
+    }
+
+{- | Illegal parameters that try to change the 'StakeDatum.stakedAmount' field of
+      the output stake datum.
+-}
+mkAlterStakeParameters :: Integer -> [Parameters]
+mkAlterStakeParameters nProposals = do
+  role <- enumFrom Voter
+  status <- [Draft, Locked, Finished]
+
+  pure $
+    Parameters
+      { proposalCount = nProposals
+      , stakeRole = role
+      , retractVotes = True
+      , removeVoterLock = True
+      , removeCreatorLock = False
+      , proposalStatus = status
+      , alterOutputStake = True
+      }
+
+--------------------------------------------------------------------------------
+
+{- | Create a test tree that runs both the stake validator and the proposal
+     validator.
+-}
+mkTestTree :: String -> Parameters -> Bool -> SpecificationTree
+mkTestTree name ps isValid = group name [stake, proposal]
+  where
+    spend = mkSpending unlockStake ps
+
+    stake =
+      testValidator
+        (not ps.alterOutputStake)
+        "stake"
+        agoraScripts.compiledStakeValidator
+        (mkStakeInputDatum ps)
+        stakeRedeemer
+        (spend stakeRef)
+
+    proposal =
+      let idx = 0
+          pid = ProposalId $ fromIntegral idx
+          ref = mkProposalRef idx
+       in testValidator
+            isValid
+            "proposal"
+            agoraScripts.compiledProposalValidator
+            (mkProposalInputDatum ps pid)
+            proposalRedeemer
+            (spend ref)

agora-specs/Sample/Proposal/Vote.hs

@@ -2,32 +2,13 @@
 Module     : Sample.Proposal.Vote
 Maintainer : connor@mlabs.city
 Description: Generate sample data for testing the functionalities of voting on proposals.
+
 Sample and utilities for testing the functionalities of voting on proposals.
 -}
 module Sample.Proposal.Vote (
-  ParameterBundle (..),
-  VoteParameters (..),
-  StakeParameters (..),
-  StakeInputParameters (..),
-  StakeOutputParameters (..),
-  NumProposals (..),
-  ProposalParameters (..),
-  TransactionParameters (..),
-  Validity (..),
-  vote,
+  validVoteParameters,
   mkTestTree,
-  mkValidOwnerVoteBundle,
-  mkValidDelegateeVoteBundle,
-  delegateeVoteWithOwnAndDelegatedStakeBundle,
-  transparentAssets,
-  transactionNotAuthorized,
-  voteForNonexistentOutcome,
-  noProposal,
-  moreThanOneProposals,
-  invalidLocks,
-  destroyStakes,
-  insufficientAmount,
-  insufficientAmount1,
+  validVoteAsDelegateParameters,
 ) where
 
 import Agora.Governor (Governor (..))
@@ -36,7 +17,6 @@ import Agora.Proposal (
   ProposalId (ProposalId),
   ProposalRedeemer (Vote),
   ProposalStatus (VotingReady),
-  ProposalThresholds (vote),
   ProposalVotes (ProposalVotes),
   ResultTag (ResultTag),
  )
@@ -44,550 +24,269 @@ import Agora.Proposal.Time (
   ProposalStartingTime (ProposalStartingTime),
   ProposalTimingConfig (draftTime, votingTime),
  )
-import Agora.SafeMoney (GTTag)
+import Agora.Scripts (AgoraScripts (..))
 import Agora.Stake (
-  ProposalAction (Voted),
-  ProposalLock (ProposalLock),
+  ProposalLock (..),
   StakeDatum (..),
-  StakeRedeemer (Destroy, PermitVote),
+  StakeRedeemer (PermitVote),
  )
 import Data.Default (Default (def))
-import Data.Map.Strict qualified as StrictMap
-import Data.Maybe (catMaybes)
-import Data.Tagged (Tagged, untag)
+import Data.Tagged (Tagged (Tagged), untag)
 import Plutarch.Context (
   input,
-  mint,
-  normalizeValue,
   output,
   script,
   signedWith,
   timeRange,
-  withInlineDatum,
-  withRedeemer,
-  withRef,
+  txId,
+  withDatum,
+  withOutRef,
   withValue,
  )
-import Plutarch.Extra.AssetClass (adaClass, assetClassValue)
-import PlutusLedgerApi.V2 (Credential (PubKeyCredential), Interval, POSIXTime, PubKeyHash)
-import PlutusLedgerApi.V2.Contexts (TxOutRef (TxOutRef))
-import Sample.Proposal.Shared (proposalTxRef)
+import PlutusLedgerApi.V1 (
+  PubKeyHash,
+  TxOutRef (TxOutRef),
+ )
+import PlutusLedgerApi.V1.Value qualified as Value
+import PlutusTx.AssocMap qualified as AssocMap
+import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
 import Sample.Shared (
+  agoraScripts,
   governor,
   minAda,
-  proposalAssetClass,
-  proposalScriptHash,
-  proposalValidator,
+  proposalPolicySymbol,
+  proposalValidatorHash,
+  signer,
   stakeAssetClass,
-  stakeScriptHash,
-  stakeValidator,
+  stakeValidatorHash,
  )
-import Test.Specification (SpecificationTree, group, testValidator)
-import Test.Util (
-  CombinableBuilder,
-  closedBoundedInterval,
-  mkSpending,
-  pubKeyHashes,
+import Test.Specification (
+  SpecificationTree,
+  group,
+  testValidator,
+  validatorSucceedsWith,
  )
+import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, pubKeyHashes, sortValue, updateMap)
 
-data ParameterBundle = ParamerterBundle
-  { voteParameters :: VoteParameters
-  , stakeParameters :: StakeParameters
-  , proposalParameters :: ProposalParameters
-  , transactionParameters :: TransactionParameters
+-- | Reference to the proposal UTXO.
+proposalRef :: TxOutRef
+proposalRef = TxOutRef proposalTxRef 0
+
+-- | Reference to the stake UTXO.
+stakeRef :: TxOutRef
+stakeRef = TxOutRef stakeTxRef 1
+
+-- | Parameters for creating a voting transaction.
+data Parameters = Parameters
+  { voteFor :: ResultTag
+  -- ^ The outcome the transaction is voting for.
+  , voteCount :: Integer
+  -- ^ The count of votes.
+  , voteAsDelegate :: Bool
+  -- ^ Delegate the stake and use it to vote.
   }
 
-newtype VoteParameters = VoteParameters {voteFor :: ResultTag}
-
-data StakeParameters = StakeParameters
-  { numStakes :: Integer
-  , mixInDelegateeAsOwner :: Bool
-  , stakeInputParameters :: StakeInputParameters
-  , stakeOutputParameters :: StakeOutputParameters
-  }
-
-newtype StakeInputParameters = StakeInputParameters
-  { perStakeGTs :: Tagged GTTag Integer
-  }
-
-data StakeOutputParameters = StakeOutputParameters
-  { burnStakes :: Bool
-  , dontAddNewLock :: Bool
-  , changeGTAmount :: Bool
-  , changeAdaAmount :: Bool
-  }
-
-data NumProposals = NoProposal | OneProposal | MoreThanOneProposals
-
-data ProposalParameters = ProposalParameters
-  { wrongAddedVotes :: Bool
-  , numProposals :: NumProposals
-  }
-
-data SignedBy = Owner | Delegatee | Unknown
-
-newtype TransactionParameters = TransactionParameters
-  { signedBy :: SignedBy
-  }
-
-data Validity = Validity
-  { forProposalValidator :: Bool
-  , forStakeValidator :: Bool
-  }
-
---------------------------------------------------------------------------------
-
+-- | The public key hash of the stake owner.
 stakeOwner :: PubKeyHash
-stakeOwner = head pubKeyHashes
+stakeOwner = signer
 
-delegatee :: PubKeyHash
-delegatee = pubKeyHashes !! 1
-
-unknownSig :: PubKeyHash
-unknownSig = pubKeyHashes !! 2
-
-validTimeRangeLowerBound :: POSIXTime
-validTimeRangeLowerBound =
-  0
-    + (def :: ProposalTimingConfig).draftTime
-    + 1
-
-validTimeRangeUpperBound :: POSIXTime
-validTimeRangeUpperBound =
-  validTimeRangeLowerBound
-    + (def :: ProposalTimingConfig).votingTime
-    - 2
-
-validTimeRange :: Interval POSIXTime
-validTimeRange =
-  closedBoundedInterval
-    validTimeRangeLowerBound
-    validTimeRangeUpperBound
-
---------------------------------------------------------------------------------
-
-initialVotes :: StrictMap.Map ResultTag Integer
+-- | The votes of the input proposals.
+initialVotes :: AssocMap.Map ResultTag Integer
 initialVotes =
-  StrictMap.fromList
-    [ (ResultTag 0, 114)
-    , (ResultTag 1, 514)
+  AssocMap.fromList
+    [ (ResultTag 0, 42)
+    , (ResultTag 1, 4242)
     ]
 
+-- | The input proposal datum.
 proposalInputDatum :: ProposalDatum
 proposalInputDatum =
   ProposalDatum
-    { proposalId = ProposalId 22
+    { proposalId = ProposalId 42
     , effects =
-        StrictMap.fromList
-          [ (ResultTag 0, StrictMap.empty)
-          , (ResultTag 1, StrictMap.empty)
+        AssocMap.fromList
+          [ (ResultTag 0, AssocMap.empty)
+          , (ResultTag 1, AssocMap.empty)
           ]
     , status = VotingReady
-    , cosigners = [PubKeyCredential stakeOwner]
+    , cosigners = [stakeOwner]
     , thresholds = def
     , votes = ProposalVotes initialVotes
     , timingConfig = def
     , startingTime = ProposalStartingTime 0
     }
 
-mkProposalRedeemer :: VoteParameters -> ProposalRedeemer
-mkProposalRedeemer v = Vote v.voteFor
+-- | The locks of the input stake.
+existingLocks :: [ProposalLock]
+existingLocks =
+  [ Voted (ProposalId 0) (ResultTag 0)
+  , Voted (ProposalId 1) (ResultTag 2)
+  ]
 
-mkProposalRef :: Integer -> TxOutRef
-mkProposalRef = TxOutRef proposalTxRef
+delegate :: PubKeyHash
+delegate = head pubKeyHashes
 
-numProposals :: NumProposals -> Integer
-numProposals NoProposal = 0
-numProposals OneProposal = 1
-numProposals MoreThanOneProposals = 2
-
---------------------------------------------------------------------------------
-
-mkStakeRedeemer :: StakeOutputParameters -> StakeRedeemer
-mkStakeRedeemer params =
-  if params.burnStakes
-    then Destroy
-    else PermitVote
-
-mkStakeInputDatum :: StakeInputParameters -> StakeDatum
+{- | Set the 'StakeDatum.stakedAmount' according to the number of votes being
+      casted.
+-}
+mkStakeInputDatum :: Parameters -> StakeDatum
 mkStakeInputDatum params =
   StakeDatum
-    { stakedAmount = params.perStakeGTs
-    , owner = PubKeyCredential stakeOwner
-    , delegatedTo = Just (PubKeyCredential delegatee)
-    , lockedBy =
-        [ ProposalLock (ProposalId 0) $ Voted (ResultTag 0) 100
-        , ProposalLock (ProposalId 1) $ Voted (ResultTag 2) 200
-        ]
+    { stakedAmount = Tagged params.voteCount
+    , owner = stakeOwner
+    , delegatedTo =
+        if params.voteAsDelegate
+          then Just delegate
+          else Nothing
+    , lockedBy = existingLocks
     }
 
-mkStakeRef :: Integer -> Integer -> TxOutRef
-mkStakeRef o i = TxOutRef proposalTxRef $ o + i
+-- | Create the proposal redeemer. In this case @'Vote' _@ will always be used.
+mkProposalRedeemer :: Parameters -> ProposalRedeemer
+mkProposalRedeemer = Vote . voteFor
 
---------------------------------------------------------------------------------
+-- | Place new proposal locks on the stake.
+mkNewLock :: Parameters -> ProposalLock
+mkNewLock = Voted proposalInputDatum.proposalId . voteFor
 
-vote :: forall b. CombinableBuilder b => ParameterBundle -> b
+{- | The stake redeemer that is used in 'mkTestTree'. In this case it'll always be
+      'PermitVote'.
+-}
+stakeRedeemer :: StakeRedeemer
+stakeRedeemer = PermitVote
+
+-- | Create a valid transaction that votes on a propsal, given the parameters.
+vote :: forall b. CombinableBuilder b => Parameters -> b
 vote params =
-  let pst = assetClassValue proposalAssetClass 1
-      sst = assetClassValue stakeAssetClass 1
+  let pst = Value.singleton proposalPolicySymbol "" 1
+      sst = Value.assetClassValue stakeAssetClass 1
 
       ---
 
-      stakeInputDatum =
-        mkStakeInputDatum
-          params.stakeParameters.stakeInputParameters
+      stakeInputDatum = mkStakeInputDatum params
 
-      stakeInputValue =
-        normalizeValue $
-          sst
-            <> assetClassValue
-              governor.gtClassRef
-              params.stakeParameters.stakeInputParameters.perStakeGTs
-            <> minAda
+      ---
 
-      newLock =
-        ProposalLock
-          proposalInputDatum.proposalId
-          $ Voted
-            params.voteParameters.voteFor
-            validTimeRangeUpperBound
+      updatedVotes :: AssocMap.Map ResultTag Integer
+      updatedVotes = updateMap (Just . (+ params.voteCount)) params.voteFor initialVotes
 
-      updatedLocks =
-        if params.stakeParameters.stakeOutputParameters.dontAddNewLock
-          then stakeInputDatum.lockedBy
-          else newLock : stakeInputDatum.lockedBy
-
-      stakeOutputDatum = stakeInputDatum {lockedBy = updatedLocks}
-
-      stakeOutputValue =
-        let changeAmount cond = if cond then (* 100) else id
-            gtAmount =
-              changeAmount
-                params.stakeParameters.stakeOutputParameters.changeGTAmount
-                params.stakeParameters.stakeInputParameters.perStakeGTs
-            adaAmount =
-              changeAmount
-                params.stakeParameters.stakeOutputParameters.changeAdaAmount
-                10_000_000
-         in normalizeValue $
-              sst
-                <> assetClassValue
-                  governor.gtClassRef
-                  gtAmount
-                <> minAda
-                <> assetClassValue adaClass adaAmount
-
-      stakeRedeemer =
-        mkStakeRedeemer params.stakeParameters.stakeOutputParameters
-
-      mixOwner i datum =
-        if params.stakeParameters.mixInDelegateeAsOwner
-          && i == 2
-          then
-            datum
-              { owner = PubKeyCredential delegatee
-              , delegatedTo = Nothing
-              }
-          else datum
-
-      stakeBuilder :: b
-      stakeBuilder =
-        foldMap
-          ( \i ->
-              mconcat
-                [ input $
-                    mconcat
-                      [ script stakeScriptHash
-                      , withValue stakeInputValue
-                      , withInlineDatum $ mixOwner i stakeInputDatum
-                      , withRedeemer stakeRedeemer
-                      , withRef $ mkStakeRef numProposals' i
-                      ]
-                , if params.stakeParameters.stakeOutputParameters.burnStakes
-                    then mint $ assetClassValue stakeAssetClass (-1)
-                    else
-                      output $
-                        mconcat
-                          [ script stakeScriptHash
-                          , withValue stakeOutputValue
-                          , withInlineDatum $ mixOwner i stakeOutputDatum
-                          ]
-                ]
-          )
-          [1 .. params.stakeParameters.numStakes]
-
-      --------------------------------------------------------------------------
-
-      numProposals' = numProposals params.proposalParameters.numProposals
-
-      updatedVotes =
-        StrictMap.adjust
-          ( ( if params.proposalParameters.wrongAddedVotes
-                then (* 10)
-                else id
-            )
-              . ( +
-                    untag params.stakeParameters.stakeInputParameters.perStakeGTs
-                      * params.stakeParameters.numStakes
-                )
-          )
-          params.voteParameters.voteFor
-          initialVotes
+      ---
 
+      proposalOutputDatum :: ProposalDatum
       proposalOutputDatum =
         proposalInputDatum
           { votes = ProposalVotes updatedVotes
           }
 
-      proposalRedeemer = mkProposalRedeemer params.voteParameters
+      ---
 
-      proposalValue =
-        normalizeValue $
-          pst
+      -- Off-chain code should do exactly like this: prepend new lock toStatus the list.
+      updatedLocks :: [ProposalLock]
+      updatedLocks = mkNewLock params : existingLocks
+
+      ---
+
+      stakeOutputDatum :: StakeDatum
+      stakeOutputDatum =
+        stakeInputDatum
+          { lockedBy = updatedLocks
+          }
+
+      ---
+
+      validTimeRange =
+        closedBoundedInterval
+          ((def :: ProposalTimingConfig).draftTime + 1)
+          ((def :: ProposalTimingConfig).votingTime - 1)
+
+      ---
+
+      stakeValue =
+        sortValue $
+          sst
+            <> Value.assetClassValue (untag governor.gtClassRef) params.voteCount
             <> minAda
 
-      proposalBuidler :: b
-      proposalBuidler =
-        foldMap
-          ( \i ->
-              mconcat
-                [ input $
-                    mconcat
-                      [ script proposalScriptHash
-                      , withValue proposalValue
-                      , withRedeemer proposalRedeemer
-                      , withInlineDatum proposalInputDatum
-                      , withRef $ mkProposalRef i
-                      ]
-                , output $
-                    mconcat
-                      [ script proposalScriptHash
-                      , withValue proposalValue
-                      , withInlineDatum proposalOutputDatum
-                      ]
-                ]
-          )
-          [1 .. numProposals']
+      signer =
+        if params.voteAsDelegate
+          then delegate
+          else stakeOwner
 
-      --------------------------------------------------------------------------
-
-      sig = case params.transactionParameters.signedBy of
-        Owner -> stakeOwner
-        Delegatee -> delegatee
-        Unknown -> unknownSig
-
-      --------------------------------------------------------------------------
-
-      miscBuilder :: b
-      miscBuilder =
-        mconcat
-          [ signedWith sig
-          , timeRange validTimeRange
-          ]
-
-      --------------------------------------------------------------------------
-
-      builder :: b
       builder =
         mconcat
-          [ stakeBuilder
-          , proposalBuidler
-          , miscBuilder
+          [ txId "827598fb2d69a896bbd9e645bb14c307df907f422b39eecbe4d6329bc30b428c"
+          , signedWith signer
+          , timeRange validTimeRange
+          , input $
+              mconcat
+                [ script proposalValidatorHash
+                , withValue pst
+                , withDatum proposalInputDatum
+                , withOutRef proposalRef
+                ]
+          , input $
+              mconcat
+                [ script stakeValidatorHash
+                , withValue stakeValue
+                , withDatum stakeInputDatum
+                , withOutRef stakeRef
+                ]
+          , output $
+              mconcat
+                [ script proposalValidatorHash
+                , withValue pst
+                , withDatum proposalOutputDatum
+                ]
+          , output $
+              mconcat
+                [ script stakeValidatorHash
+                , withValue stakeValue
+                , withDatum stakeOutputDatum
+                ]
           ]
    in builder
 
---------------------------------------------------------------------------------
+---
 
-mkTestTree :: String -> ParameterBundle -> Validity -> SpecificationTree
-mkTestTree name ps val = group name $ catMaybes [proposal, stake]
+-- | Valida parameters that vote on the proposal.
+validVoteParameters :: Parameters
+validVoteParameters =
+  Parameters
+    { voteFor = ResultTag 0
+    , voteCount = 27
+    , voteAsDelegate = False
+    }
+
+validVoteAsDelegateParameters :: Parameters
+validVoteAsDelegateParameters =
+  validVoteParameters
+    { voteAsDelegate = True
+    }
+
+---
+
+{- | Create a test tree that runs the stake validator and proposal validator to
+      test the voting functionalities.
+-}
+mkTestTree :: String -> Parameters -> Bool -> SpecificationTree
+mkTestTree name ps isValid = group name [proposal, stake]
   where
     spend = mkSpending vote ps
 
-    numProposals' = numProposals ps.proposalParameters.numProposals
-
     proposal =
-      case ps.proposalParameters.numProposals of
-        NoProposal -> Nothing
-        _ ->
-          Just $
-            testValidator
-              val.forProposalValidator
-              "proposal"
-              proposalValidator
-              proposalInputDatum
-              (mkProposalRedeemer ps.voteParameters)
-              (spend $ mkProposalRef 1)
+      testValidator
+        isValid
+        "proposal"
+        agoraScripts.compiledProposalValidator
+        proposalInputDatum
+        (mkProposalRedeemer ps)
+        (spend proposalRef)
 
     stake =
-      case ps.stakeParameters.numStakes of
-        0 -> error "At least one stake"
-        _ ->
-          let stakeRef = mkStakeRef numProposals' 1
-           in Just $
-                testValidator
-                  val.forStakeValidator
-                  "stake"
-                  stakeValidator
-                  (mkStakeInputDatum ps.stakeParameters.stakeInputParameters)
-                  (mkStakeRedeemer ps.stakeParameters.stakeOutputParameters)
-                  (spend stakeRef)
-
---------------------------------------------------------------------------------
-
--- TODO(Connor) Use optics
-
-mkValidOwnerVoteBundle :: Integer -> ParameterBundle
-mkValidOwnerVoteBundle stakes =
-  ParamerterBundle
-    { voteParameters =
-        VoteParameters
-          { voteFor = ResultTag 0
-          }
-    , stakeParameters =
-        StakeParameters
-          { numStakes = stakes
-          , mixInDelegateeAsOwner = False
-          , stakeInputParameters =
-              StakeInputParameters
-                { perStakeGTs = (def :: ProposalThresholds).vote
-                }
-          , stakeOutputParameters =
-              StakeOutputParameters
-                { burnStakes = False
-                , dontAddNewLock = False
-                , changeGTAmount = False
-                , changeAdaAmount = False
-                }
-          }
-    , proposalParameters =
-        ProposalParameters
-          { wrongAddedVotes = False
-          , numProposals = OneProposal
-          }
-    , transactionParameters =
-        TransactionParameters
-          { signedBy = Owner
-          }
-    }
-
-mkValidDelegateeVoteBundle :: Integer -> ParameterBundle
-mkValidDelegateeVoteBundle stakes =
-  let template = mkValidOwnerVoteBundle stakes
-   in template
-        { transactionParameters =
-            template.transactionParameters
-              { signedBy = Delegatee
-              }
-        }
-
-delegateeVoteWithOwnAndDelegatedStakeBundle :: ParameterBundle
-delegateeVoteWithOwnAndDelegatedStakeBundle =
-  let template = mkValidDelegateeVoteBundle 5
-   in template
-        { stakeParameters =
-            template.stakeParameters
-              { mixInDelegateeAsOwner = True
-              }
-        }
-
-ownerVoteWithSignleStake :: ParameterBundle
-ownerVoteWithSignleStake = mkValidOwnerVoteBundle 1
-
-transparentAssets :: ParameterBundle
-transparentAssets =
-  ownerVoteWithSignleStake
-    { stakeParameters =
-        ownerVoteWithSignleStake.stakeParameters
-          { stakeOutputParameters =
-              ownerVoteWithSignleStake.stakeParameters.stakeOutputParameters
-                { changeAdaAmount = True
-                }
-          }
-    }
-
-transactionNotAuthorized :: ParameterBundle
-transactionNotAuthorized =
-  ownerVoteWithSignleStake
-    { transactionParameters =
-        ownerVoteWithSignleStake.transactionParameters
-          { signedBy = Unknown
-          }
-    }
-
-voteForNonexistentOutcome :: ParameterBundle
-voteForNonexistentOutcome =
-  ownerVoteWithSignleStake
-    { voteParameters =
-        ownerVoteWithSignleStake.voteParameters
-          { voteFor = ResultTag 1919810
-          }
-    }
-
-noProposal :: ParameterBundle
-noProposal =
-  ownerVoteWithSignleStake
-    { proposalParameters =
-        ownerVoteWithSignleStake.proposalParameters
-          { numProposals = NoProposal
-          }
-    }
-
-moreThanOneProposals :: ParameterBundle
-moreThanOneProposals =
-  ownerVoteWithSignleStake
-    { proposalParameters =
-        ownerVoteWithSignleStake.proposalParameters
-          { numProposals = MoreThanOneProposals
-          }
-    }
-
-ownerVoteWithMultipleStakes :: ParameterBundle
-ownerVoteWithMultipleStakes = mkValidOwnerVoteBundle 5
-
-invalidLocks :: ParameterBundle
-invalidLocks =
-  ownerVoteWithMultipleStakes
-    { stakeParameters =
-        ownerVoteWithMultipleStakes.stakeParameters
-          { stakeOutputParameters =
-              ownerVoteWithMultipleStakes.stakeParameters.stakeOutputParameters
-                { dontAddNewLock = True
-                }
-          }
-    }
-
-destroyStakes :: ParameterBundle
-destroyStakes =
-  ownerVoteWithMultipleStakes
-    { stakeParameters =
-        ownerVoteWithMultipleStakes.stakeParameters
-          { stakeOutputParameters =
-              ownerVoteWithMultipleStakes.stakeParameters.stakeOutputParameters
-                { burnStakes = True
-                }
-          }
-    }
-
-insufficientAmount :: ParameterBundle
-insufficientAmount =
-  ownerVoteWithSignleStake
-    { stakeParameters =
-        ownerVoteWithSignleStake.stakeParameters
-          { stakeInputParameters =
-              ownerVoteWithSignleStake.stakeParameters.stakeInputParameters
-                { perStakeGTs = 1
-                }
-          }
-    }
-
-insufficientAmount1 :: ParameterBundle
-insufficientAmount1 =
-  ownerVoteWithMultipleStakes
-    { stakeParameters =
-        ownerVoteWithMultipleStakes.stakeParameters
-          { stakeInputParameters =
-              ownerVoteWithMultipleStakes.stakeParameters.stakeInputParameters
-                { perStakeGTs = 1
-                }
-          }
-    }
+      let stakeInputDatum = mkStakeInputDatum ps
+       in validatorSucceedsWith
+            "stake"
+            agoraScripts.compiledStakeValidator
+            stakeInputDatum
+            stakeRedeemer
+            (spend stakeRef)

agora-specs/Sample/Shared.hs

@@ -12,8 +12,8 @@ module Sample.Shared (
   signer,
   signer2,
   minAda,
-  deterministicTracingConfig,
-  mkRedeemer,
+  deterministicTracingConfing,
+  mkEffect,
 
   -- * Agora Scripts
   agoraScripts,
@@ -22,33 +22,27 @@ module Sample.Shared (
 
   -- ** Stake
   stakeAssetClass,
-  stakePolicy,
-  stakeValidator,
-  stakeScriptHash,
+  stakeValidatorHash,
   stakeAddress,
   stakeSymbol,
 
   -- ** Governor
   governor,
-  governorPolicy,
-  governorValidator,
-  governorSymbol,
-  governorAssetClass,
-  governorValidatorAddress,
-  governorScriptHash,
+  govPolicy,
+  govValidator,
+  govSymbol,
+  govAssetClass,
+  govValidatorAddress,
+  govValidatorHash,
   gstUTXORef,
 
   -- ** Proposal
-  proposalPolicy,
   proposalPolicySymbol,
-  proposalValidator,
-  proposalScriptHash,
+  proposalValidatorHash,
   proposalValidatorAddress,
   proposalStartingTimeFromTimeRange,
-  proposalAssetClass,
 
   -- ** Authority
-  authorityTokenPolicy,
   authorityTokenSymbol,
 
   -- ** Treasury
@@ -57,67 +51,65 @@ module Sample.Shared (
   gatCs,
   mockTrEffect,
   mockTrEffectHash,
-  trValidator,
-  trScriptHash,
   trCredential,
   wrongEffHash,
 ) where
 
 import Agora.Bootstrap qualified as Bootstrap
+import Agora.Effect.NoOp (noOpValidator)
 import Agora.Governor (Governor (Governor))
-import Agora.Linker (linker)
 import Agora.Proposal (ProposalThresholds (..))
 import Agora.Proposal.Time (
   MaxTimeRangeWidth (..),
   ProposalStartingTime (ProposalStartingTime),
   ProposalTimingConfig (..),
  )
-import Agora.SafeMoney (GovernorSTTag, ProposalSTTag, StakeSTTag)
-import Data.Default.Class (Default (..))
-import Data.Map (Map, (!))
-import Data.Tagged (Tagged (..))
-import Data.Text (Text)
-import Optics (view)
-import Plutarch (Config (..), Script, TracingMode (DetTracing))
-import Plutarch.Api.V2 (scriptHash)
-import Plutarch.Extra.AssetClass (AssetClass (AssetClass))
-import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
-import PlutusLedgerApi.V1.Address (scriptHashAddress)
-import PlutusLedgerApi.V1.Value (TokenName, Value)
-import PlutusLedgerApi.V1.Value qualified as Value (
-  singleton,
+import Agora.Scripts qualified as Scripts
+import Agora.Treasury (treasuryValidator)
+import Agora.Utils (
+  CompiledEffect (CompiledEffect),
+  CompiledMintingPolicy (getCompiledMintingPolicy),
+  CompiledValidator (getCompiledValidator),
+  validatorHashToTokenName,
  )
-import PlutusLedgerApi.V2 (
+import Data.Default.Class (Default (..))
+import Data.Tagged (Tagged (..))
+import Plutarch (Config (..), TracingMode (DetTracing))
+import Plutarch.Api.V1 (
+  PValidator,
+  mintingPolicySymbol,
+  mkValidator,
+  validatorHash,
+ )
+import PlutusLedgerApi.V1 (
   Address (Address),
   Credential (ScriptCredential),
-  CurrencySymbol (CurrencySymbol),
+  CurrencySymbol,
   Extended (..),
   Interval (..),
   LowerBound (..),
-  OutputDatum (NoOutputDatum),
+  MintingPolicy (..),
   POSIXTimeRange,
   PubKeyHash,
-  Redeemer (..),
-  ScriptHash (getScriptHash),
-  ToData (toBuiltinData),
-  TxOut (
-    TxOut,
-    txOutAddress,
-    txOutDatum,
-    txOutReferenceScript,
-    txOutValue
-  ),
   TxOutRef (TxOutRef),
   UpperBound (..),
+  Value,
+ )
+import PlutusLedgerApi.V1.Address (scriptHashAddress)
+import PlutusLedgerApi.V1.Contexts (TxOut (..))
+import PlutusLedgerApi.V1.Scripts (Validator, ValidatorHash (..))
+import PlutusLedgerApi.V1.Value (AssetClass, TokenName)
+import PlutusLedgerApi.V1.Value qualified as Value (
+  assetClass,
+  singleton,
  )
 import PlutusTx qualified
-import ScriptExport.ScriptInfo (runLinker)
 
 -- Plutarch compiler configauration.
 -- TODO: add the ability to change this value. Maybe wrap everything in a
 --        Reader monad?
-deterministicTracingConfig :: Config
-deterministicTracingConfig = Config DetTracing
+deterministicTracingConfing :: Config
+deterministicTracingConfing = Config DetTracing
 
 governor :: Governor
 governor = Governor oref gt mc
@@ -125,69 +117,49 @@ governor = Governor oref gt mc
     oref = gstUTXORef
     gt =
       Tagged $
-        AssetClass
+        Value.assetClass
           "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
           "LQ"
     mc = 20
 
-agoraScripts :: Map Text Script
-agoraScripts =
-  either
-    (error . show)
-    (fmap (view #script) . view #scripts)
-    ( runLinker
-        linker
-        (Bootstrap.agoraScripts deterministicTracingConfig)
-        governor
-    )
-
-stakePolicy :: Script
-stakePolicy = agoraScripts ! "agora:stakePolicy"
+agoraScripts :: Scripts.AgoraScripts
+agoraScripts = Bootstrap.agoraScripts deterministicTracingConfing governor
 
 stakeSymbol :: CurrencySymbol
-stakeSymbol = CurrencySymbol . getScriptHash $ scriptHash stakePolicy
+stakeSymbol = Scripts.stakeSTSymbol agoraScripts
 
-stakeAssetClass :: Tagged StakeSTTag AssetClass
-stakeAssetClass = Tagged $ AssetClass stakeSymbol (scriptHashToTokenName stakeScriptHash)
+stakeAssetClass :: AssetClass
+stakeAssetClass = Scripts.stakeSTAssetClass agoraScripts
 
-stakeValidator :: Script
-stakeValidator = agoraScripts ! "agora:stakeValidator"
-
-stakeScriptHash :: ScriptHash
-stakeScriptHash = scriptHash stakeValidator
+stakeValidatorHash :: ValidatorHash
+stakeValidatorHash = Scripts.stakeValidatorHash agoraScripts
 
 stakeAddress :: Address
-stakeAddress = Address (ScriptCredential stakeScriptHash) Nothing
+stakeAddress = Address (ScriptCredential stakeValidatorHash) Nothing
 
 gstUTXORef :: TxOutRef
 gstUTXORef = TxOutRef "f28cd7145c24e66fd5bcd2796837aeb19a48a2656e7833c88c62a2d0450bd00d" 0
 
-governorPolicy :: Script
-governorPolicy = agoraScripts ! "agora:governorPolicy"
+govPolicy :: MintingPolicy
+govPolicy = getCompiledMintingPolicy $ agoraScripts.compiledGovernorPolicy
 
-governorValidator :: Script
-governorValidator = agoraScripts ! "agora:governorValidator"
+govValidator :: Validator
+govValidator = getCompiledValidator $ agoraScripts.compiledGovernorValidator
 
-governorSymbol :: CurrencySymbol
-governorSymbol = CurrencySymbol . getScriptHash $ scriptHash governorPolicy
+govSymbol :: CurrencySymbol
+govSymbol = mintingPolicySymbol govPolicy
 
-governorAssetClass :: Tagged GovernorSTTag AssetClass
-governorAssetClass = Tagged $ AssetClass governorSymbol ""
+govAssetClass :: AssetClass
+govAssetClass = Scripts.governorSTAssetClass agoraScripts
 
-governorScriptHash :: ScriptHash
-governorScriptHash = scriptHash governorValidator
+govValidatorHash :: ValidatorHash
+govValidatorHash = Scripts.governorValidatorHash agoraScripts
 
-governorValidatorAddress :: Address
-governorValidatorAddress = scriptHashAddress governorScriptHash
-
-proposalPolicy :: Script
-proposalPolicy = agoraScripts ! "agora:proposalPolicy"
+govValidatorAddress :: Address
+govValidatorAddress = scriptHashAddress govValidatorHash
 
 proposalPolicySymbol :: CurrencySymbol
-proposalPolicySymbol = CurrencySymbol . getScriptHash $ scriptHash proposalPolicy
-
-proposalAssetClass :: Tagged ProposalSTTag AssetClass
-proposalAssetClass = Tagged $ AssetClass proposalPolicySymbol ""
+proposalPolicySymbol = Scripts.proposalSTSymbol agoraScripts
 
 -- | A sample 'PubKeyHash'.
 signer :: PubKeyHash
@@ -197,14 +169,11 @@ signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
 signer2 :: PubKeyHash
 signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192"
 
-proposalValidator :: Script
-proposalValidator = agoraScripts ! "agora:proposalValidator"
-
-proposalScriptHash :: ScriptHash
-proposalScriptHash = scriptHash proposalValidator
+proposalValidatorHash :: ValidatorHash
+proposalValidatorHash = Scripts.proposalValidatoHash agoraScripts
 
 proposalValidatorAddress :: Address
-proposalValidatorAddress = scriptHashAddress proposalScriptHash
+proposalValidatorAddress = scriptHashAddress proposalValidatorHash
 
 {- | Default value of 'Agora.Proposal.ProposalThresholds'.
      For testing purpose only.
@@ -214,16 +183,11 @@ instance Default ProposalThresholds where
     ProposalThresholds
       { execute = Tagged 1000
       , create = Tagged 1
-      , toVoting = Tagged 100
       , vote = Tagged 100
-      , cosign = Tagged 100
       }
 
-authorityTokenPolicy :: Script
-authorityTokenPolicy = agoraScripts ! "agora:authorityTokenPolicy"
-
 authorityTokenSymbol :: CurrencySymbol
-authorityTokenSymbol = CurrencySymbol . getScriptHash $ scriptHash authorityTokenPolicy
+authorityTokenSymbol = Scripts.authorityTokenSymbol agoraScripts
 
 {- | Default value of 'Agora.Governor.GovernorDatum.proposalTimings'.
      For testing purpose only.
@@ -235,8 +199,6 @@ instance Default ProposalTimingConfig where
       , votingTime = 1000
       , lockingTime = 2000
       , executingTime = 3000
-      , minStakeVotingTime = 100
-      , votingTimeRangeMaxWidth = 1000000
       }
 
 {- | Default value of 'Agora.Governor.GovernorDatum.createProposalTimeRangeMaxWidth'.
@@ -254,8 +216,8 @@ proposalStartingTimeFromTimeRange
     ProposalStartingTime $ (l + u) `div` 2
 proposalStartingTimeFromTimeRange _ = error "Given time range should be finite and closed"
 
-mkRedeemer :: forall redeemer. PlutusTx.ToData redeemer => redeemer -> Redeemer
-mkRedeemer = Redeemer . toBuiltinData
+mkEffect :: (PlutusTx.ToData datum) => ClosedTerm PValidator -> CompiledEffect datum
+mkEffect v = CompiledEffect $ mkValidator deterministicTracingConfing v
 
 ------------------------------------------------------------------
 
@@ -264,43 +226,41 @@ treasuryOut =
   TxOut
     { txOutAddress = Address trCredential Nothing
     , txOutValue = minAda
-    , txOutDatum = NoOutputDatum
-    , txOutReferenceScript = Nothing
+    , txOutDatumHash = Nothing
     }
 
 {- | Arbitrary 'CurrencySymbol', representing the 'CurrencySymbol'
      of a valid governance authority token (GAT).
 -}
 gatCs :: CurrencySymbol
-gatCs = authorityTokenSymbol
+gatCs = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
 
-trValidator :: Script
-trValidator = agoraScripts ! "agora:treasuryValidator"
-
-trScriptHash :: ScriptHash
-trScriptHash = scriptHash trValidator
+trValidator :: Validator
+trValidator = mkValidator def (treasuryValidator gatCs)
 
 -- | `ScriptCredential` used for the dummy treasury validator.
 trCredential :: Credential
-trCredential = ScriptCredential trScriptHash
+trCredential = ScriptCredential $ validatorHash trValidator
 
 -- | `TokenName` for GAT generated from address of `mockTrEffect`.
 gatTn :: TokenName
-gatTn = scriptHashToTokenName $ scriptHash mockTrEffect
+gatTn = validatorHashToTokenName $ validatorHash mockTrEffect
 
 -- | Mock treasury effect script, used for testing.
-mockTrEffect :: Script
-mockTrEffect = agoraScripts ! "agora:noOpValidator"
+mockTrEffect :: Validator
+mockTrEffect = mkValidator def $ noOpValidator gatCs
 
 -- | Mock treasury effect validator hash
-mockTrEffectHash :: ScriptHash
-mockTrEffectHash = scriptHash mockTrEffect
+mockTrEffectHash :: ValidatorHash
+mockTrEffectHash = validatorHash mockTrEffect
 
 {- | A SHA-256 hash which (in all certainty) should not match the
      hash of the dummy effect script.
 -}
-wrongEffHash :: ScriptHash
-wrongEffHash = "a21bc4a1d95600f9fa0a00b97ed0fa49a152a72de76253cb706f90b4b40f837b"
+wrongEffHash :: ValidatorHash
+wrongEffHash =
+  ValidatorHash
+    "a21bc4a1d95600f9fa0a00b97ed0fa49a152a72de76253cb706f90b4b40f837b"
 
 ------------------------------------------------------------------
 

agora-specs/Sample/Stake.hs

@@ -11,6 +11,9 @@ module Sample.Stake (
   signer,
 
   -- * Script contexts
+  stakeCreation,
+  stakeCreationWrongDatum,
+  stakeCreationUnsigned,
   stakeDepositWithdraw,
   DepositWithdrawExample (..),
 ) where
@@ -20,35 +23,91 @@ import Agora.SafeMoney (GTTag)
 import Agora.Stake (
   StakeDatum (StakeDatum, stakedAmount),
  )
-import Data.Tagged (Tagged)
+import Data.Tagged (Tagged, untag)
 import Plutarch.Context (
+  MintingBuilder,
   SpendingBuilder,
-  buildSpending',
+  buildMintingUnsafe,
+  buildSpendingUnsafe,
   input,
+  mint,
   output,
   script,
   signedWith,
   txId,
   withDatum,
-  withRef,
+  withMinting,
+  withOutRef,
   withSpendingOutRef,
   withValue,
  )
-import Plutarch.Extra.AssetClass (assetClassValue)
-import PlutusLedgerApi.V1.Contexts (TxOutRef (..))
-import PlutusLedgerApi.V2 (
-  Credential (PubKeyCredential),
+import PlutusLedgerApi.V1 (
+  Datum (Datum),
   ScriptContext (..),
+  ScriptPurpose (Minting),
+  ToData (toBuiltinData),
+  TxInfo (txInfoData, txInfoSignatories),
+ )
+import PlutusLedgerApi.V1.Contexts (TxOutRef (..))
+import PlutusLedgerApi.V1.Value qualified as Value (
+  assetClassValue,
+  singleton,
  )
 import Sample.Shared (
   governor,
   signer,
   stakeAssetClass,
-  stakeScriptHash,
   stakeSymbol,
+  stakeValidatorHash,
  )
 import Test.Util (sortValue)
 
+-- | This script context should be a valid transaction.
+stakeCreation :: ScriptContext
+stakeCreation =
+  let st = Value.assetClassValue stakeAssetClass 1 -- Stake ST
+      datum :: StakeDatum
+      datum = StakeDatum 424242424242 signer Nothing []
+
+      builder :: MintingBuilder
+      builder =
+        mconcat
+          [ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+          , signedWith signer
+          , mint st
+          , output $
+              mconcat
+                [ script stakeValidatorHash
+                , withValue (st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242)
+                , withDatum datum
+                ]
+          , withMinting stakeSymbol
+          ]
+   in buildMintingUnsafe builder
+
+-- | This ScriptContext should fail because the datum has too much GT.
+stakeCreationWrongDatum :: ScriptContext
+stakeCreationWrongDatum =
+  let datum :: Datum
+      datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer Nothing []) -- Too much GT
+   in ScriptContext
+        { scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]}
+        , scriptContextPurpose = Minting stakeSymbol
+        }
+
+-- | This ScriptContext should fail because the datum has too much GT.
+stakeCreationUnsigned :: ScriptContext
+stakeCreationUnsigned =
+  ScriptContext
+    { scriptContextTxInfo =
+        stakeCreation.scriptContextTxInfo
+          { txInfoSignatories = []
+          }
+    , scriptContextPurpose = Minting stakeSymbol
+    }
+
+--------------------------------------------------------------------------------
+
 -- | Config for creating a ScriptContext that deposits or withdraws.
 data DepositWithdrawExample = DepositWithdrawExample
   { startAmount :: Tagged GTTag Integer
@@ -60,9 +119,9 @@ data DepositWithdrawExample = DepositWithdrawExample
 -- | Create a ScriptContext that deposits or withdraws, given the config for it.
 stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
 stakeDepositWithdraw config =
-  let st = assetClassValue stakeAssetClass 1 -- Stake ST
+  let st = Value.assetClassValue stakeAssetClass 1 -- Stake ST
       stakeBefore :: StakeDatum
-      stakeBefore = StakeDatum config.startAmount (PubKeyCredential signer) Nothing []
+      stakeBefore = StakeDatum config.startAmount signer Nothing []
 
       stakeAfter :: StakeDatum
       stakeAfter = stakeBefore {stakedAmount = stakeBefore.stakedAmount + config.delta}
@@ -75,27 +134,28 @@ stakeDepositWithdraw config =
         mconcat
           [ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
           , signedWith signer
+          , mint st
           , input $
               mconcat
-                [ script stakeScriptHash
+                [ script stakeValidatorHash
                 , withValue
                     ( sortValue $
                         st
-                          <> assetClassValue governor.gtClassRef stakeBefore.stakedAmount
+                          <> Value.assetClassValue (untag governor.gtClassRef) (untag stakeBefore.stakedAmount)
                     )
-                , withDatum stakeBefore
-                , withRef stakeRef
+                , withDatum stakeAfter
+                , withOutRef stakeRef
                 ]
           , output $
               mconcat
-                [ script stakeScriptHash
+                [ script stakeValidatorHash
                 , withValue
                     ( sortValue $
                         st
-                          <> assetClassValue governor.gtClassRef stakeAfter.stakedAmount
+                          <> Value.assetClassValue (untag governor.gtClassRef) (untag stakeAfter.stakedAmount)
                     )
                 , withDatum stakeAfter
                 ]
           , withSpendingOutRef stakeRef
           ]
-   in buildSpending' builder
+   in buildSpendingUnsafe builder

agora-specs/Sample/Stake/Create.hs

@@ -1,260 +0,0 @@
-{-# LANGUAGE ExistentialQuantification #-}
-
-module Sample.Stake.Create (
-  StakeDatumWrapper (..),
-  Parameters (..),
-  create,
-  mkTestCase,
-  ownerIsPubKeyTotallyValid,
-  ownerIsScriptTotallyValid,
-  createMoreThanOneStake,
-  spendStake,
-  unexpectedStakedAmount,
-  noStakeDatum,
-  malformedStakeDatum,
-  notAuthorizedByOwner,
-  setDelegatee,
-  alreadyHasLocks,
-) where
-
-import Agora.Governor (Governor (gtClassRef))
-import Agora.Proposal (ProposalId (ProposalId))
-import Agora.SafeMoney (GTTag)
-import Agora.Stake (ProposalAction (Created), ProposalLock (ProposalLock), StakeDatum (..))
-import Data.Semigroup (stimesMonoid)
-import Data.Tagged (Tagged)
-import Plutarch.Context (
-  input,
-  mint,
-  normalizeValue,
-  output,
-  pubKey,
-  script,
-  signedWith,
-  withDatum,
-  withValue,
- )
-import Plutarch.Extra.AssetClass (assetClassValue)
-import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
-import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
-import PlutusLedgerApi.V1.Value qualified as Value
-import PlutusLedgerApi.V2 (
-  Credential (
-    PubKeyCredential,
-    ScriptCredential
-  ),
- )
-import Sample.Shared (
-  governor,
-  signer,
-  signer2,
-  stakePolicy,
-  stakeScriptHash,
-  stakeSymbol,
- )
-import Test.Specification (SpecificationTree, testPolicy)
-import Test.Util (CombinableBuilder, mkMinting, validatorHashes)
-
-data StakeDatumWrapper
-  = forall (b :: Type) (p :: S -> Type).
-    (PUnsafeLiftDecl p, PLifted p ~ b, PIsData p) =>
-    StakeDatumWrapper b
-
-data Parameters = Parameters
-  { numSSTMinted :: Integer
-  , invalidSSTName :: Bool
-  , stakeAtInput :: Bool
-  , numGTsInValue :: Tagged GTTag Integer
-  , stakeDatum :: Maybe StakeDatumWrapper
-  , authorizedBy :: Maybe Credential
-  }
-
-create :: forall b. CombinableBuilder b => Parameters -> b
-create ps@Parameters {stakeDatum} =
-  let perStakeGTs =
-        assetClassValue
-          governor.gtClassRef
-          ps.numGTsInValue
-
-      gtValue =
-        stimesMonoid ps.numSSTMinted perStakeGTs
-
-      gtInputBuilder =
-        mconcat
-          [ input $
-              mconcat
-                [ pubKey signer
-                , withValue $ normalizeValue gtValue
-                ]
-          ]
-
-      ---
-
-      sstName =
-        if ps.invalidSSTName
-          then "114514"
-          else scriptHashToTokenName stakeScriptHash
-
-      sst = Value.singleton stakeSymbol sstName 1
-
-      withStakeDatum =
-        maybe
-          mempty
-          (\(StakeDatumWrapper stakeDatum) -> withDatum stakeDatum)
-          stakeDatum
-
-      stakeBuilder =
-        mconcat
-          [ script stakeScriptHash
-          , withValue $ normalizeValue $ sst <> perStakeGTs
-          , withStakeDatum
-          ]
-
-      stakeInputBuilder =
-        if ps.stakeAtInput
-          then input stakeBuilder
-          else mempty
-
-      stakeOutputBuilder =
-        stimesMonoid ps.numSSTMinted $
-          output stakeBuilder
-
-      ---
-
-      withAuthorization =
-        maybe
-          mempty
-          ( \case
-              PubKeyCredential pkh -> signedWith pkh
-              ScriptCredential val -> input $ script val
-          )
-          ps.authorizedBy
-
-      ---
-
-      mintSSTs = mint $ stimesMonoid ps.numSSTMinted sst
-   in mconcat
-        [ gtInputBuilder
-        , stakeInputBuilder
-        , stakeOutputBuilder
-        , withAuthorization
-        , mintSSTs
-        ]
-
-mkTestCase :: String -> Parameters -> Bool -> SpecificationTree
-mkTestCase name ps val = stake
-  where
-    mint = mkMinting create ps
-
-    stake =
-      testPolicy
-        val
-        name
-        stakePolicy
-        ()
-        (mint stakeSymbol)
-
-mkTotallyValid :: Integer -> Credential -> Parameters
-mkTotallyValid gts owner =
-  Parameters
-    { numSSTMinted = 1
-    , invalidSSTName = False
-    , numGTsInValue = fromInteger gts
-    , stakeAtInput = False
-    , stakeDatum =
-        Just $
-          StakeDatumWrapper $
-            StakeDatum
-              { stakedAmount = fromInteger gts
-              , owner = owner
-              , delegatedTo = Nothing
-              , lockedBy = []
-              }
-    , authorizedBy = Just owner
-    }
-
-ownerIsPubKeyTotallyValid :: Parameters
-ownerIsPubKeyTotallyValid = mkTotallyValid 114514 (PubKeyCredential signer)
-
-ownerIsScriptTotallyValid :: Parameters
-ownerIsScriptTotallyValid =
-  mkTotallyValid
-    114514
-    ( ScriptCredential $
-        head validatorHashes
-    )
-
-createMoreThanOneStake :: Parameters
-createMoreThanOneStake =
-  ownerIsPubKeyTotallyValid
-    { numSSTMinted = 5
-    }
-
-spendStake :: Parameters
-spendStake =
-  ownerIsPubKeyTotallyValid
-    { stakeAtInput = True
-    }
-
-unexpectedStakedAmount :: Parameters
-unexpectedStakedAmount =
-  ownerIsPubKeyTotallyValid
-    { numGTsInValue = 114514
-    , stakeDatum =
-        Just $
-          StakeDatumWrapper $
-            StakeDatum
-              { stakedAmount = 1919810
-              , owner = PubKeyCredential signer
-              , delegatedTo = Nothing
-              , lockedBy = []
-              }
-    }
-
-noStakeDatum :: Parameters
-noStakeDatum =
-  ownerIsPubKeyTotallyValid
-    { stakeDatum = Nothing
-    }
-
-malformedStakeDatum :: Parameters
-malformedStakeDatum =
-  ownerIsPubKeyTotallyValid
-    { stakeDatum = Just $ StakeDatumWrapper (1 :: Integer)
-    }
-
-notAuthorizedByOwner :: Parameters
-notAuthorizedByOwner =
-  ownerIsPubKeyTotallyValid
-    { authorizedBy = Nothing
-    }
-
-setDelegatee :: Parameters
-setDelegatee =
-  ownerIsPubKeyTotallyValid
-    { numGTsInValue = 114514
-    , stakeDatum =
-        Just $
-          StakeDatumWrapper $
-            StakeDatum
-              { stakedAmount = 114514
-              , owner = PubKeyCredential signer
-              , delegatedTo = Just $ PubKeyCredential signer2
-              , lockedBy = []
-              }
-    }
-
-alreadyHasLocks :: Parameters
-alreadyHasLocks =
-  ownerIsPubKeyTotallyValid
-    { numGTsInValue = 114514
-    , stakeDatum =
-        Just $
-          StakeDatumWrapper $
-            StakeDatum
-              { stakedAmount = 114514
-              , owner = PubKeyCredential signer
-              , delegatedTo = Nothing
-              , lockedBy = [ProposalLock (ProposalId 0) Created]
-              }
-    }

agora-specs/Sample/Stake/Destroy.hs

@@ -1,298 +0,0 @@
-module Sample.Stake.Destroy (
-  ParameterBundle (..),
-  StakeInputParameters (..),
-  StakeBurningParameters (..),
-  LeftOverStakeMode (..),
-  AuthorizedBy (..),
-  Validity (..),
-  destroy,
-  mkTestTree,
-  mkTotallyValid,
-  oneStake,
-  multipleStakes,
-  stealSST,
-  stealSST1,
-  stealSST3,
-  lockedStakes,
-  authorizedByDelegatee,
-  notAuthorized,
-) where
-
-import Agora.Proposal (ProposalId (..))
-import Agora.Stake (
-  ProposalAction (Created),
-  ProposalLock (ProposalLock),
-  StakeDatum (..),
-  StakeRedeemer (Destroy),
- )
-import Control.Exception (assert)
-import Data.Maybe (catMaybes, fromJust)
-import Data.Semigroup (stimesMonoid)
-import Plutarch.Context (
-  input,
-  mint,
-  normalizeValue,
-  output,
-  pubKey,
-  script,
-  signedWith,
-  withDatum,
-  withRedeemer,
-  withRef,
-  withValue,
- )
-import Plutarch.Extra.AssetClass (assetClassValue)
-import PlutusLedgerApi.V1 (
-  Credential (PubKeyCredential),
-  TxOutRef (TxOutRef),
- )
-import PlutusLedgerApi.V2 (PubKeyHash)
-import Sample.Proposal.Shared (stakeTxRef)
-import Sample.Shared (
-  minAda,
-  signer2,
-  stakeAssetClass,
-  stakePolicy,
-  stakeScriptHash,
-  stakeSymbol,
-  stakeValidator,
- )
-import Test.Specification (
-  SpecificationTree,
-  group,
-  testPolicy,
-  testValidator,
- )
-import Test.Util (CombinableBuilder, mkMinting, mkSpending, pubKeyHashes)
-
-data ParameterBundle = ParameterBundle
-  { stakeInputParameters :: StakeInputParameters
-  , stakeBurningParameters :: StakeBurningParameters
-  , authorizedBy :: AuthorizedBy
-  }
-
-data StakeInputParameters = StakeInputParameters
-  { numInputs :: Int
-  , notUnlocked :: Bool
-  }
-
-data StakeBurningParameters = StakeBurningParameters
-  { numBurnt :: Int
-  , leftOverStakeMode :: Maybe LeftOverStakeMode
-  }
-
-data LeftOverStakeMode = OutputAsIs | CollectSSTInOneUTxO
-
-data AuthorizedBy = Owner | Delegatee | NotAuthorized
-
-data Validity = Validity
-  { forStakePolicy :: Maybe Bool
-  , forStakeValidator :: Bool
-  }
-
---------------------------------------------------------------------------------
-
-owner :: PubKeyHash
-owner = pubKeyHashes !! 2
-
-delegatee :: PubKeyHash
-delegatee = pubKeyHashes !! 3
-
---------------------------------------------------------------------------------
-
-mkStakeInputDatum :: StakeInputParameters -> StakeDatum
-mkStakeInputDatum ps =
-  StakeDatum
-    { stakedAmount = 114514
-    , owner = PubKeyCredential owner
-    , delegatedTo = Just $ PubKeyCredential delegatee
-    , lockedBy = [ProposalLock (ProposalId 0) Created | ps.notUnlocked]
-    }
-
-mkStakeRef :: Int -> TxOutRef
-mkStakeRef = TxOutRef stakeTxRef . fromIntegral
-
-stakeRedeemer :: StakeRedeemer
-stakeRedeemer = Destroy
-
---------------------------------------------------------------------------------
-
-destroy :: forall b. CombinableBuilder b => ParameterBundle -> b
-destroy ps =
-  let stakeInputDatum = mkStakeInputDatum ps.stakeInputParameters
-
-      sst = assetClassValue stakeAssetClass 1
-
-      stakeUTxOTemplate =
-        mconcat
-          [ script stakeScriptHash
-          , withDatum stakeInputDatum
-          , withValue $ normalizeValue $ sst <> minAda
-          ]
-
-      stakeInputBuilder =
-        foldMap
-          ( \i ->
-              input $
-                mconcat
-                  [ stakeUTxOTemplate
-                  , withRef $ mkStakeRef i
-                  , withRedeemer stakeRedeemer
-                  ]
-          )
-          [1 .. ps.stakeInputParameters.numInputs]
-
-      withSSTsBurnt =
-        mint $
-          normalizeValue $
-            assetClassValue stakeAssetClass $
-              negate $
-                fromIntegral ps.stakeBurningParameters.numBurnt
-
-      ---
-
-      leftOverStakes =
-        ps.stakeInputParameters.numInputs
-          - ps.stakeBurningParameters.numBurnt
-
-      stealSSTs =
-        case fromJust ps.stakeBurningParameters.leftOverStakeMode of
-          OutputAsIs ->
-            foldMap output $
-              replicate
-                leftOverStakes
-                stakeUTxOTemplate
-          CollectSSTInOneUTxO ->
-            output $
-              mconcat
-                [ pubKey signer2
-                , withValue $ stimesMonoid leftOverStakes sst
-                ]
-
-      stakeOutputBuilder =
-        assert (leftOverStakes >= 0) $
-          mconcat
-            [ withSSTsBurnt
-            , if leftOverStakes > 0
-                then stealSSTs
-                else mempty
-            ]
-
-      ---
-
-      sigBuilder = case ps.authorizedBy of
-        Owner -> signedWith owner
-        Delegatee -> signedWith delegatee
-        NotAuthorized -> mempty
-   in mconcat
-        [ stakeInputBuilder
-        , stakeOutputBuilder
-        , sigBuilder
-        ]
-
---------------------------------------------------------------------------------
-
-mkTestTree ::
-  String ->
-  ParameterBundle ->
-  Validity ->
-  SpecificationTree
-mkTestTree name pb val = group name $ catMaybes [validator, policy]
-  where
-    spend = mkSpending destroy pb
-    mint = mkMinting destroy pb
-    validator =
-      Just $
-        testValidator
-          val.forStakeValidator
-          "stake validator"
-          stakeValidator
-          (mkStakeInputDatum pb.stakeInputParameters)
-          stakeRedeemer
-          (spend $ mkStakeRef 1)
-
-    policy = case pb.stakeBurningParameters.numBurnt of
-      0 -> Nothing
-      _ ->
-        Just $
-          testPolicy
-            (fromJust val.forStakePolicy)
-            "stake policy"
-            stakePolicy
-            ()
-            (mint stakeSymbol)
-
---------------------------------------------------------------------------------
-
-mkTotallyValid :: Int -> ParameterBundle
-mkTotallyValid numStakes =
-  ParameterBundle
-    { stakeInputParameters =
-        StakeInputParameters
-          { numInputs = numStakes
-          , notUnlocked = False
-          }
-    , stakeBurningParameters =
-        StakeBurningParameters
-          { numBurnt = numStakes
-          , leftOverStakeMode = Nothing
-          }
-    , authorizedBy = Owner
-    }
-
-oneStake :: ParameterBundle
-oneStake = mkTotallyValid 1
-
-multipleStakes :: ParameterBundle
-multipleStakes = mkTotallyValid 10
-
-stealSST :: ParameterBundle
-stealSST =
-  multipleStakes
-    { stakeBurningParameters =
-        StakeBurningParameters
-          { numBurnt = 1
-          , leftOverStakeMode = Just CollectSSTInOneUTxO
-          }
-    }
-
-stealSST1 :: ParameterBundle
-stealSST1 =
-  multipleStakes
-    { stakeBurningParameters =
-        StakeBurningParameters
-          { numBurnt = 0
-          , leftOverStakeMode = Just CollectSSTInOneUTxO
-          }
-    }
-
-stealSST3 :: ParameterBundle
-stealSST3 =
-  multipleStakes
-    { stakeBurningParameters =
-        StakeBurningParameters
-          { numBurnt = 1
-          , leftOverStakeMode = Just OutputAsIs
-          }
-    }
-
-lockedStakes :: ParameterBundle
-lockedStakes =
-  multipleStakes
-    { stakeInputParameters =
-        multipleStakes.stakeInputParameters
-          { notUnlocked = True
-          }
-    }
-
-authorizedByDelegatee :: ParameterBundle
-authorizedByDelegatee =
-  multipleStakes
-    { authorizedBy = Delegatee
-    }
-
-notAuthorized :: ParameterBundle
-notAuthorized =
-  multipleStakes
-    { authorizedBy = NotAuthorized
-    }

agora-specs/Sample/Stake/SetDelegate.hs

@@ -20,38 +20,39 @@ module Sample.Stake.SetDelegate (
 ) where
 
 import Agora.Governor (Governor (gtClassRef))
+import Agora.Scripts (AgoraScripts (..))
 import Agora.Stake (
   StakeDatum (..),
   StakeRedeemer (ClearDelegate, DelegateTo),
  )
+import Data.Tagged (untag)
 import Plutarch.Context (
   SpendingBuilder,
-  buildSpending',
+  buildSpendingUnsafe,
   input,
   output,
   script,
   signedWith,
   txId,
   withDatum,
-  withRef,
+  withOutRef,
   withSpendingOutRef,
   withValue,
  )
-import Plutarch.Extra.AssetClass (assetClassValue)
-import PlutusLedgerApi.V2 (
-  Credential (PubKeyCredential),
+import PlutusLedgerApi.V1 (
   PubKeyHash,
   ScriptContext,
   TxOutRef (TxOutRef),
  )
+import PlutusLedgerApi.V1.Value qualified as Value
 import Sample.Shared (
+  agoraScripts,
   governor,
   minAda,
   signer,
   signer2,
   stakeAssetClass,
-  stakeScriptHash,
-  stakeValidator,
+  stakeValidatorHash,
  )
 import Test.Specification (SpecificationTree, testValidator)
 import Test.Util (pubKeyHashes, sortValue)
@@ -72,7 +73,7 @@ data Parameters = Parameters
 
 -- | Select the correct stake redeemer based on the existence of the new delegate.
 mkStakeRedeemer :: Parameters -> StakeRedeemer
-mkStakeRedeemer params = maybe ClearDelegate (DelegateTo . PubKeyCredential) params.newDelegate
+mkStakeRedeemer (newDelegate -> d) = maybe ClearDelegate DelegateTo d
 
 -- | The owner of the input stake.
 stakeOwner :: PubKeyHash
@@ -83,14 +84,14 @@ mkStakeInputDatum :: Parameters -> StakeDatum
 mkStakeInputDatum ps =
   StakeDatum
     { stakedAmount = 5
-    , owner = PubKeyCredential stakeOwner
-    , delegatedTo = PubKeyCredential <$> ps.existingDelegate
+    , owner = stakeOwner
+    , delegatedTo = ps.existingDelegate
     , lockedBy = []
     }
 
 -- | Generate a 'ScriptContext' that tries to change the delegate of a stake.
 setDelegate :: Parameters -> ScriptContext
-setDelegate ps = buildSpending' builder
+setDelegate ps = buildSpendingUnsafe builder
   where
     stakeRef :: TxOutRef
     stakeRef = TxOutRef "0ffef57e30cc604342c738e31e0451593837b313e7bfb94b0922b142782f98e6" 1
@@ -104,24 +105,22 @@ setDelegate ps = buildSpending' builder
               else stakeInput.stakedAmount
        in stakeInput
             { stakedAmount = stakedAmount
-            , delegatedTo = PubKeyCredential <$> ps.newDelegate
+            , delegatedTo = ps.newDelegate
             }
 
     signer =
       if ps.signedByOwner
-        then case stakeInput.owner of
-          PubKeyCredential c -> c
-          _ -> signer2
+        then stakeInput.owner
         else signer2
 
-    st = assetClassValue stakeAssetClass 1 -- Stake ST
+    st = Value.assetClassValue stakeAssetClass 1 -- Stake ST
     stakeValue =
       sortValue $
         mconcat
           [ st
-          , assetClassValue
-              governor.gtClassRef
-              stakeInput.stakedAmount
+          , Value.assetClassValue
+              (untag governor.gtClassRef)
+              (untag stakeInput.stakedAmount)
           , minAda
           ]
 
@@ -132,14 +131,14 @@ setDelegate ps = buildSpending' builder
         , signedWith signer
         , input $
             mconcat
-              [ script stakeScriptHash
+              [ script stakeValidatorHash
               , withValue stakeValue
               , withDatum stakeInput
-              , withRef stakeRef
+              , withOutRef stakeRef
               ]
         , output $
             mconcat
-              [ script stakeScriptHash
+              [ script stakeValidatorHash
               , withValue stakeValue
               , withDatum stakeOutput
               ]
@@ -156,7 +155,7 @@ mkTestCase name ps valid =
   testValidator
     valid
     name
-    stakeValidator
+    agoraScripts.compiledStakeValidator
     (mkStakeInputDatum ps)
     (mkStakeRedeemer ps)
     (setDelegate ps)

agora-specs/Sample/Stake/UnauthorizedMintingExploit.hs

@@ -1,74 +0,0 @@
-module Sample.Stake.UnauthorizedMintingExploit (
-  Parameters (..),
-  exploit,
-  mkTestCase,
-) where
-
-import Plutarch.Context (
-  input,
-  mint,
-  normalizeValue,
-  output,
-  script,
-  withValue,
- )
-import Plutarch.Extra.AssetClass (assetClassValue)
-import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
-import PlutusLedgerApi.V1.Value qualified as Value
-import Sample.Shared (
-  minAda,
-  stakeAssetClass,
-  stakePolicy,
-  stakeScriptHash,
-  stakeSymbol,
- )
-import Test.Specification (SpecificationTree, testPolicy)
-import Test.Util (
-  CombinableBuilder,
-  mkMinting,
-  validatorHashes,
- )
-
-newtype Parameters = Parameters
-  { inputSST :: Int
-  }
-
-exploit ::
-  forall b.
-  CombinableBuilder b =>
-  Parameters ->
-  b
-exploit (Parameters inputSST) =
-  mconcat
-    [ input $
-        mconcat
-          [ script attacker
-          , withValue $
-              normalizeValue $
-                minAda <> fakeSSTValue inputSST
-          ]
-    , mint $ fakeSSTValue $ negate inputSST
-    , mint sst
-    , output $
-        mconcat
-          [ script stakeScriptHash
-          , withValue $
-              normalizeValue $
-                minAda <> sst
-          ]
-    ]
-  where
-    attacker = head validatorHashes
-
-    fakeSSTValue =
-      Value.singleton
-        stakeSymbol
-        (scriptHashToTokenName attacker)
-        . fromIntegral
-
-    sst = assetClassValue stakeAssetClass 1
-
-mkTestCase :: String -> Parameters -> SpecificationTree
-mkTestCase name ps =
-  testPolicy False name stakePolicy () $
-    mkMinting exploit ps stakeSymbol

agora-specs/Sample/Treasury.hs

@@ -18,8 +18,8 @@ module Sample.Treasury (
 ) where
 
 import Plutarch.Context (
-  SpendingBuilder,
-  buildSpending',
+  MintingBuilder,
+  buildMintingUnsafe,
   credential,
   input,
   mint,
@@ -27,24 +27,23 @@ import Plutarch.Context (
   script,
   signedWith,
   txId,
-  withRefTxId,
-  withSpendingOutRefId,
+  withMinting,
+  withTxId,
   withValue,
  )
-import PlutusLedgerApi.V1.Address (Address (..))
-import PlutusLedgerApi.V1.Value qualified as Value (singleton)
-import PlutusLedgerApi.V2 (
+import PlutusLedgerApi.V1 (
   Credential (PubKeyCredential),
-  OutputDatum (NoOutputDatum),
   PubKeyHash (PubKeyHash),
-  ScriptHash (ScriptHash),
  )
-import PlutusLedgerApi.V2.Contexts (
+import PlutusLedgerApi.V1.Address (Address (..))
+import PlutusLedgerApi.V1.Contexts (
   ScriptContext (..),
   TxInInfo (..),
   TxOut (..),
   TxOutRef (..),
  )
+import PlutusLedgerApi.V1.Scripts (ValidatorHash (ValidatorHash))
+import PlutusLedgerApi.V1.Value qualified as Value (singleton)
 import Sample.Shared (
   gatCs,
   gatTn,
@@ -55,13 +54,13 @@ import Sample.Shared (
   wrongEffHash,
  )
 
-baseCtxBuilder :: SpendingBuilder
+baseCtxBuilder :: MintingBuilder
 baseCtxBuilder =
   let treasury =
         mconcat
           [ credential trCredential
           , withValue minAda
-          , withRefTxId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
+          , withTxId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
           ]
    in mconcat
         [ txId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
@@ -69,7 +68,7 @@ baseCtxBuilder =
         , mint (Value.singleton gatCs gatTn (-1))
         , input treasury
         , output treasury
-        , withSpendingOutRefId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
+        , withMinting gatCs
         ]
 
 {- | A `ScriptContext` that should be compatible with treasury
@@ -77,7 +76,7 @@ baseCtxBuilder =
 -}
 validCtx :: ScriptContext
 validCtx =
-  let builder :: SpendingBuilder
+  let builder :: MintingBuilder
       builder =
         mconcat
           [ baseCtxBuilder
@@ -85,10 +84,10 @@ validCtx =
               mconcat
                 [ script mockTrEffectHash
                 , withValue (Value.singleton gatCs gatTn 1 <> minAda)
-                , withRefTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
+                , withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
                 ]
           ]
-   in buildSpending' builder
+   in buildMintingUnsafe builder
 
 treasuryRef :: TxOutRef
 treasuryRef =
@@ -101,7 +100,7 @@ treasuryRef =
 -}
 walletIn :: TxInInfo
 walletIn =
-  let (ScriptHash addressBs) = mockTrEffectHash
+  let (ValidatorHash addressBs) = mockTrEffectHash
    in TxInInfo
         { txInInfoOutRef =
             TxOutRef
@@ -109,8 +108,7 @@ walletIn =
               0
         , txInInfoResolved =
             TxOut
-              { txOutDatum = NoOutputDatum
-              , txOutReferenceScript = Nothing
+              { txOutDatumHash = Nothing
               , txOutValue = Value.singleton gatCs gatTn 1
               , txOutAddress =
                   Address
@@ -121,7 +119,7 @@ walletIn =
 
 trCtxGATNameNotAddress :: ScriptContext
 trCtxGATNameNotAddress =
-  let builder :: SpendingBuilder
+  let builder :: MintingBuilder
       builder =
         mconcat
           [ baseCtxBuilder
@@ -129,7 +127,7 @@ trCtxGATNameNotAddress =
               mconcat
                 [ script wrongEffHash
                 , withValue (Value.singleton gatCs gatTn 1 <> minAda)
-                , withRefTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
+                , withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
                 ]
           ]
-   in buildSpending' builder
+   in buildMintingUnsafe builder

agora-specs/Spec/AuthorityToken.hs

@@ -10,18 +10,18 @@ Tests for Authority token functions
 module Spec.AuthorityToken (specs) where
 
 import Agora.AuthorityToken (singleAuthorityTokenBurned)
-import Data.Tagged (Tagged (Tagged))
+import Plutarch (ClosedTerm, POpaque, perror, popaque)
 import Plutarch.Extra.Compile (mustCompile)
-import Plutarch.Script (Script)
 import Plutarch.Unsafe (punsafeCoerce)
 import PlutusLedgerApi.V1 (
   Address (Address),
   Credential (PubKeyCredential, ScriptCredential),
   CurrencySymbol,
-  ScriptHash (ScriptHash),
+  Script,
   TxInInfo (TxInInfo),
   TxOut (TxOut),
   TxOutRef (TxOutRef),
+  ValidatorHash (ValidatorHash),
   Value,
  )
 import PlutusLedgerApi.V1.Value qualified as Value (
@@ -29,13 +29,21 @@ import PlutusLedgerApi.V1.Value qualified as Value (
   singleton,
  )
 import PlutusTx.AssocMap qualified as AssocMap (empty)
-import Sample.AuthorityToken.UnauthorizedMintingExploit qualified as UnauthorizedMintingExploit
 import Test.Specification (
   SpecificationTree,
   group,
   scriptFails,
   scriptSucceeds,
  )
+import Prelude (
+  Maybe (Nothing),
+  PBool,
+  Semigroup ((<>)),
+  fmap,
+  pconstant,
+  pif,
+  ($),
+ )
 
 currencySymbol :: CurrencySymbol
 currencySymbol = "deadbeef"
@@ -46,7 +54,7 @@ mkInputs = fmap (TxInInfo (TxOutRef "" 0))
 singleAuthorityTokenBurnedTest :: Value -> [TxOut] -> Script
 singleAuthorityTokenBurnedTest mint outs =
   let actual :: ClosedTerm PBool
-      actual = singleAuthorityTokenBurned (pconstant $ Tagged currencySymbol) (punsafeCoerce $ pconstant $ mkInputs outs) (pconstant mint)
+      actual = singleAuthorityTokenBurned (pconstant currencySymbol) (punsafeCoerce $ pconstant $ mkInputs outs) (pconstant mint)
       s :: ClosedTerm POpaque
       s =
         pif
@@ -68,7 +76,7 @@ specs =
                   <> Value.singleton "aa" "USDC" 100_000
               )
               [ TxOut
-                  (Address (ScriptCredential (ScriptHash "deadbeef")) Nothing)
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
                   (Value.singleton currencySymbol "deadbeef" 1)
                   Nothing
               ]
@@ -84,7 +92,7 @@ specs =
                   (Value.singleton "aaabcc" "hello-token" 1)
                   Nothing
               , TxOut
-                  (Address (ScriptCredential (ScriptHash "deadbeef")) Nothing)
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
                   (Value.singleton currencySymbol "deadbeef" 1)
                   Nothing
               , TxOut
@@ -93,17 +101,6 @@ specs =
                   Nothing
               ]
           )
-      , scriptSucceeds
-          "Correct even though scripts don't match"
-          ( singleAuthorityTokenBurnedTest
-              ( Value.singleton currencySymbol "i'm not deadbeef!" (-1)
-              )
-              [ TxOut
-                  (Address (ScriptCredential (ScriptHash "deadbeef")) Nothing)
-                  (Value.singleton currencySymbol "i'm not deadbeef!" 1)
-                  Nothing
-              ]
-          )
       , scriptFails
           "Incorrect no burn"
           ( singleAuthorityTokenBurnedTest
@@ -118,6 +115,17 @@ specs =
               )
               []
           )
+      , scriptFails
+          "Incorrect script mismatch"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "i'm not deadbeef!" (-1)
+              )
+              [ TxOut
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "i'm not deadbeef!" 1)
+                  Nothing
+              ]
+          )
       , scriptFails
           "Incorrect spent from PK"
           ( singleAuthorityTokenBurnedTest
@@ -136,21 +144,10 @@ specs =
                   <> Value.singleton "aa" "USDC" 100_000
               )
               [ TxOut
-                  (Address (ScriptCredential (ScriptHash "deadbeef")) Nothing)
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
                   (Value.singleton currencySymbol "deadbeef" 2)
                   Nothing
               ]
           )
       ]
-  , group "unauthorized minting exploit"
-      $ map
-        ( UnauthorizedMintingExploit.mkTestCase "(negative test)"
-            . uncurry UnauthorizedMintingExploit.Parameters
-        )
-      $ let l = [1 .. 10]
-         in [ (burnt, minted)
-            | burnt <- l
-            , minted <- l
-            , minted < burnt
-            ]
   ]

agora-specs/Spec/Effect/GovernorMutation.hs

@@ -1,19 +1,20 @@
 module Spec.Effect.GovernorMutation (specs) where
 
+import Agora.Effect.GovernorMutation (mutateGovernorValidator)
 import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
 import Agora.Proposal (ProposalId (..))
+import Agora.Scripts (AgoraScripts (..))
 import Data.Default.Class (Default (def))
-import PlutusLedgerApi.V2 (ScriptContext (ScriptContext), ScriptPurpose (Spending))
+import PlutusLedgerApi.V1 (ScriptContext (ScriptContext), ScriptPurpose (Spending))
 import Sample.Effect.GovernorMutation (
   effectRef,
-  effectValidator,
   govRef,
   invalidNewGovernorDatum,
   mkEffectDatum,
   mkEffectTxInfo,
   validNewGovernorDatum,
  )
-import Sample.Shared (governorValidator)
+import Sample.Shared (agoraScripts, mkEffect)
 import Test.Specification (
   SpecificationTree,
   effectFailsWith,
@@ -31,42 +32,33 @@ specs =
           "valid new governor datum"
           [ validatorSucceedsWith
               "governor validator should pass"
-              governorValidator
+              agoraScripts.compiledGovernorValidator
               ( GovernorDatum
                   def
-                  nextProposalId
+                  (ProposalId 0)
                   def
                   def
                   3
               )
               MutateGovernor
               ( ScriptContext
-                  (mkEffectTxInfo validNewGovernorDatum')
+                  (mkEffectTxInfo validNewGovernorDatum)
                   (Spending govRef)
               )
           , effectSucceedsWith
               "effect validator should pass"
-              effectValidator
-              ( mkEffectDatum
-                  ( GovernorDatum
-                      def
-                      nextProposalId
-                      def
-                      def
-                      3
-                  )
-                  validNewGovernorDatum
-              )
-              (ScriptContext (mkEffectTxInfo validNewGovernorDatum') (Spending effectRef))
+              (mkEffect $ mutateGovernorValidator agoraScripts)
+              (mkEffectDatum validNewGovernorDatum)
+              (ScriptContext (mkEffectTxInfo validNewGovernorDatum) (Spending effectRef))
           ]
       , group
           "invalid new governor datum"
           [ validatorFailsWith
               "governor validator should fail"
-              governorValidator
+              agoraScripts.compiledGovernorValidator
               ( GovernorDatum
                   def
-                  nextProposalId
+                  (ProposalId 0)
                   def
                   def
                   3
@@ -78,26 +70,9 @@ specs =
               )
           , effectFailsWith
               "effect validator should fail"
-              effectValidator
-              ( mkEffectDatum
-                  ( GovernorDatum
-                      def
-                      nextProposalId
-                      def
-                      def
-                      3
-                  )
-                  validNewGovernorDatum
-              )
+              (mkEffect $ mutateGovernorValidator agoraScripts)
+              (mkEffectDatum validNewGovernorDatum)
               (ScriptContext (mkEffectTxInfo invalidNewGovernorDatum) (Spending effectRef))
           ]
       ]
   ]
-  where
-    validNewGovernorDatum' :: GovernorDatum
-    validNewGovernorDatum' = validNewGovernorDatum {nextProposalId}
-    -- \^ The datum value pinned by the effect, disregarding the proposal ID and
-    --   taking this field from the governor input instead
-
-    nextProposalId :: ProposalId
-    nextProposalId = ProposalId 0

agora-specs/Spec/Effect/TreasuryWithdrawal.hs

@@ -7,44 +7,174 @@ This module specs the Treasury Withdrawal Effect.
 -}
 module Spec.Effect.TreasuryWithdrawal (specs) where
 
-import Sample.Effect.TreasuryWithdrawal (
-  Parameters (..),
-  Validity (..),
-  mkTestTree,
-  totallyValidParameters,
+import Agora.Effect.TreasuryWithdrawal (
+  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
+  treasuryWithdrawalValidator,
  )
+import PlutusLedgerApi.V1.Value qualified as Value
+import Sample.Effect.TreasuryWithdrawal (
+  buildReceiversOutputFromDatum,
+  buildScriptContext,
+  currSymbol,
+  inputCollateral,
+  inputGAT,
+  inputTreasury,
+  inputUser,
+  outputTreasury,
+  outputUser,
+  treasuries,
+  users,
+ )
+import Sample.Shared (mkEffect)
 import Test.Specification (
   SpecificationTree,
+  effectFailsWith,
+  effectSucceedsWith,
+  group,
  )
+import Test.Util (sortValue)
 
 specs :: [SpecificationTree]
 specs =
-  [ mkTestTree
-      "totally valid"
-      totallyValidParameters
-      Validity
-        { forGATPolicy = True
-        , forEffectValidator = True
-        , forTreasury = True
-        }
-  , mkTestTree
-      "bad received value"
-      totallyValidParameters
-        { badReceivedValue = True
-        }
-      Validity
-        { forGATPolicy = True
-        , forEffectValidator = False
-        , forTreasury = True
-        }
-  , mkTestTree
-      "bad receiver order"
-      totallyValidParameters
-        { badReceiverOrder = True
-        }
-      Validity
-        { forGATPolicy = True
-        , forEffectValidator = False
-        , forTreasury = True
-        }
+  [ group
+      "effect"
+      [ effectSucceedsWith
+          "Simple"
+          (mkEffect $ treasuryWithdrawalValidator currSymbol)
+          datum1
+          ( buildScriptContext
+              [ inputGAT
+              , inputCollateral 10
+              , inputTreasury 1 (asset1 10)
+              ]
+              $ outputTreasury 1 (asset1 7) :
+              buildReceiversOutputFromDatum datum1
+          )
+      , effectSucceedsWith
+          "Simple with multiple treasuries "
+          (mkEffect $ treasuryWithdrawalValidator currSymbol)
+          datum1
+          ( buildScriptContext
+              [ inputGAT
+              , inputCollateral 10
+              , inputTreasury 1 (asset1 10)
+              , inputTreasury 2 (asset1 100)
+              , inputTreasury 3 (asset1 500)
+              ]
+              $ [ outputTreasury 1 (asset1 7)
+                , outputTreasury 2 (asset1 100)
+                , outputTreasury 3 (asset1 500)
+                ]
+                ++ buildReceiversOutputFromDatum datum1
+          )
+      , effectSucceedsWith
+          "Mixed Assets"
+          (mkEffect $ treasuryWithdrawalValidator currSymbol)
+          datum2
+          ( buildScriptContext
+              [ inputGAT
+              , inputCollateral 10
+              , inputTreasury 1 (asset1 20)
+              , inputTreasury 2 (asset2 20)
+              ]
+              $ [ outputTreasury 1 (asset1 13)
+                , outputTreasury 2 (asset2 14)
+                ]
+                ++ buildReceiversOutputFromDatum datum2
+          )
+      , effectFailsWith
+          "Pay to uknown 3rd party"
+          (mkEffect $ treasuryWithdrawalValidator currSymbol)
+          datum2
+          ( buildScriptContext
+              [ inputGAT
+              , inputCollateral 10
+              , inputTreasury 1 (asset1 20)
+              , inputTreasury 2 (asset2 20)
+              ]
+              $ [ outputUser 100 (asset1 2)
+                , outputTreasury 1 (asset1 11)
+                , outputTreasury 2 (asset2 14)
+                ]
+                ++ buildReceiversOutputFromDatum datum2
+          )
+      , effectFailsWith
+          "Missing receiver"
+          (mkEffect $ treasuryWithdrawalValidator currSymbol)
+          datum2
+          ( buildScriptContext
+              [ inputGAT
+              , inputCollateral 10
+              , inputTreasury 1 (asset1 20)
+              , inputTreasury 2 (asset2 20)
+              ]
+              $ [ outputTreasury 1 (asset1 13)
+                , outputTreasury 2 (asset2 14)
+                ]
+                ++ drop 1 (buildReceiversOutputFromDatum datum2)
+          )
+      , effectFailsWith
+          "Unauthorized treasury"
+          (mkEffect $ treasuryWithdrawalValidator currSymbol)
+          datum3
+          ( buildScriptContext
+              [ inputGAT
+              , inputCollateral 10
+              , inputTreasury 999 (asset1 20)
+              ]
+              $ outputTreasury 999 (asset1 17) :
+              buildReceiversOutputFromDatum datum3
+          )
+      , effectFailsWith
+          "Prevent transactions besides the withdrawal"
+          (mkEffect $ treasuryWithdrawalValidator currSymbol)
+          datum3
+          ( buildScriptContext
+              [ inputGAT
+              , inputTreasury 1 (asset1 20)
+              , inputTreasury 999 (asset1 20)
+              , inputUser 99 (asset2 100)
+              ]
+              $ [ outputTreasury 1 (asset1 17)
+                , outputUser 100 (asset2 100)
+                ]
+                ++ buildReceiversOutputFromDatum datum3
+          )
+      ]
   ]
+  where
+    asset1 =
+      Value.singleton
+        "0d586e057e76238f8c56c0752507bfa45ae13b04f8497a311d4aaa48"
+        "OrangeBottle"
+    asset2 =
+      Value.singleton
+        "7e6aa764bceeba1f7acf47d20f1a2a85440afa2928f8ae96376f4d85"
+        "19721121"
+    datum1 =
+      TreasuryWithdrawalDatum
+        [ (head users, asset1 1)
+        , (users !! 1, asset1 1)
+        , (users !! 2, asset1 1)
+        ]
+        [ treasuries !! 1
+        , treasuries !! 2
+        , treasuries !! 3
+        ]
+    datum2 =
+      TreasuryWithdrawalDatum
+        [ (head users, sortValue $ asset2 5 <> asset1 4)
+        , (users !! 1, sortValue $ asset2 1 <> asset1 2)
+        , (users !! 2, asset1 1)
+        ]
+        [ head treasuries
+        , treasuries !! 1
+        , treasuries !! 2
+        ]
+    datum3 =
+      TreasuryWithdrawalDatum
+        [ (head users, asset1 1)
+        , (users !! 1, asset1 1)
+        , (users !! 2, asset1 1)
+        ]
+        [treasuries !! 1]

agora-specs/Spec/Proposal.hs

@@ -10,10 +10,8 @@ module Spec.Proposal (specs) where
 import Sample.Proposal.Advance qualified as Advance
 import Sample.Proposal.Cosign qualified as Cosign
 import Sample.Proposal.Create qualified as Create
-import Sample.Proposal.PrivilegeEscalate qualified as PrivilegeEscalate
-import Sample.Proposal.Unlock qualified as Unlock
+import Sample.Proposal.UnlockStake qualified as UnlockStake
 import Sample.Proposal.Vote qualified as Vote
-
 import Test.Specification (
   SpecificationTree,
   group,
@@ -54,8 +52,8 @@ specs =
               "invalid stake locks"
               Create.addInvalidLocksParameters
               True
-              True
               False
+              True
           , Create.mkTestTree
               "has reached maximum proposals limit"
               Create.exceedMaximumProposalsParameters
@@ -85,127 +83,59 @@ specs =
                       True
                 )
                 Create.invalidProposalStatusParameters
-          , Create.mkTestTree
-              "fake SST"
-              Create.fakeSSTParameters
-              True
-              False
-              False
-          , Create.mkTestTree
-              "wrong governor redeemer"
-              Create.wrongGovernorRedeemer
-              False
-              False
-              True
-          , Create.mkTestTree
-              "wrong governor redeemer"
-              Create.wrongGovernorRedeemer1
-              False
-              False
-              True
           ]
       ]
   , group
       "validator"
       [ group
           "cosignature"
-          [ Cosign.mkTestTree
-              "legal"
-              Cosign.totallyValid
-              (Cosign.Validity True True)
-          , group
-              "illegal"
-              [ Cosign.mkTestTree
-                  "insufficient staked amount"
-                  Cosign.insufficientStakedAmount
-                  (Cosign.Validity False True)
-              , Cosign.mkTestTree
-                  "proposal locks not updated"
-                  Cosign.locksNotUpdated
-                  (Cosign.Validity True False)
-              , Cosign.mkTestTree
-                  "duplicate cosigners"
-                  Cosign.duplicateCosigners
-                  (Cosign.Validity False True)
-              , Cosign.mkTestTree
-                  "cosigners not updated"
-                  Cosign.cosignersNotUpdated
-                  (Cosign.Validity False True)
-              , group "cosign after draft" $
-                  map
-                    ( \b ->
-                        Cosign.mkTestTree
-                          "(negative test)"
-                          b
-                          (Cosign.Validity False True)
-                    )
-                    Cosign.cosignAfterDraft
-              ]
-          ]
+          $ let cosignerCases = [1, 5, 10]
+
+                mkLegalGroup nCosigners =
+                  Cosign.mkTestTree
+                    (unwords ["with", show nCosigners, "cosigners"])
+                    (Cosign.validCosignNParameters nCosigners)
+                    True
+                legalGroup =
+                  group "legal" $
+                    map mkLegalGroup cosignerCases
+
+                mkIllegalStatusNotDraftGroup nCosigners =
+                  group (unwords ["with", show nCosigners, "cosigners"]) $
+                    map
+                      ( \ps ->
+                          Cosign.mkTestTree
+                            ("status: " <> show ps.proposalStatus)
+                            ps
+                            False
+                      )
+                      (Cosign.statusNotDraftCosignNParameters nCosigners)
+                illegalStatusNotDraftGroup =
+                  group "proposal status not Draft" $
+                    map mkIllegalStatusNotDraftGroup cosignerCases
+
+                illegalGroup =
+                  group
+                    "illegal"
+                    [ Cosign.mkTestTree
+                        "duplicate cosigners"
+                        Cosign.duplicateCosignersParameters
+                        False
+                    , Cosign.mkTestTree
+                        "altered output stake"
+                        Cosign.invalidStakeOutputParameters
+                        False
+                    , illegalStatusNotDraftGroup
+                    ]
+             in [legalGroup, illegalGroup]
       , group
           "voting"
           [ group
               "legal"
-              [ group "different number of stakes" $
-                  map
-                    ( \s ->
-                        group
-                          (unwords [show s, "stakes"])
-                          [ Vote.mkTestTree
-                              "by owner"
-                              (Vote.mkValidOwnerVoteBundle s)
-                              (Vote.Validity True True)
-                          , Vote.mkTestTree
-                              "by delegatee"
-                              (Vote.mkValidDelegateeVoteBundle s)
-                              (Vote.Validity True True)
-                          ]
-                    )
-                    [1, 3, 5, 7, 9]
-              , Vote.mkTestTree
-                  "transparent non-GT tokens"
-                  Vote.transparentAssets
-                  (Vote.Validity True True)
-              , Vote.mkTestTree
-                  "Delegatee vote with own and delegated stakes in one tx"
-                  Vote.delegateeVoteWithOwnAndDelegatedStakeBundle
-                  (Vote.Validity True True)
-              ]
-          , group
-              "illegal"
-              [ Vote.mkTestTree
-                  "vote for nonexistent outcome"
-                  Vote.voteForNonexistentOutcome
-                  (Vote.Validity False True)
-              , Vote.mkTestTree
-                  "unauthorized tx"
-                  Vote.transactionNotAuthorized
-                  (Vote.Validity True False)
-              , Vote.mkTestTree
-                  "no proposal"
-                  Vote.noProposal
-                  (Vote.Validity False False)
-              , Vote.mkTestTree
-                  "more than one proposals"
-                  Vote.voteForNonexistentOutcome
-                  (Vote.Validity False True)
-              , Vote.mkTestTree
-                  "locks not added"
-                  Vote.invalidLocks
-                  (Vote.Validity True False)
-              , Vote.mkTestTree
-                  "attempt to burn stakes"
-                  Vote.destroyStakes
-                  (Vote.Validity True False)
-              , Vote.mkTestTree
-                  "insufficient staked amount"
-                  Vote.insufficientAmount
-                  (Vote.Validity False True)
-              , Vote.mkTestTree
-                  "insufficient staked amount"
-                  Vote.insufficientAmount1
-                  (Vote.Validity False True)
+              [ Vote.mkTestTree "ordinary" Vote.validVoteParameters True
+              , Vote.mkTestTree "delegate" Vote.validVoteAsDelegateParameters True
               ]
+              -- TODO: add negative test cases
           ]
       , group
           "advancing"
@@ -254,11 +184,6 @@ specs =
                                     mkName
                                     (Advance.mkValidToFailedStateBundles cs es)
                                     allValid
-                                , Advance.mkTestTree'
-                                    "to finished state with inline datum"
-                                    mkName
-                                    (Advance.mkValidToFinishedInlineGATDatumBundles cs es)
-                                    allValid
                                 ]
                       , group
                           "illegal"
@@ -309,6 +234,16 @@ specs =
                                 , forGovernorValidator = Just True
                                 , forAuthorityTokenPolicy = Just True
                                 }
+                          , Advance.mkTestTree'
+                              "altered output stake datum"
+                              (\b -> unwords ["from", show b.proposalParameters.fromStatus])
+                              (Advance.mkInvalidOutputStakeBundles cs es)
+                              Advance.Validity
+                                { forProposalValidator = False
+                                , forStakeValidator = False
+                                , forGovernorValidator = Just True
+                                , forAuthorityTokenPolicy = Just True
+                                }
                           , Advance.mkTestTree
                               "forget to mint GATs"
                               (Advance.mkNoGATMintedBundle cs es)
@@ -334,7 +269,7 @@ specs =
                                 { forProposalValidator = True
                                 , forStakeValidator = True
                                 , forGovernorValidator = Just False
-                                , forAuthorityTokenPolicy = Just True
+                                , forAuthorityTokenPolicy = Just False
                                 }
                           , Advance.mkTestTree
                               "wrong GAT datum"
@@ -354,113 +289,106 @@ specs =
                                 , forGovernorValidator = Just False
                                 , forAuthorityTokenPolicy = Just True
                                 }
-                          , Advance.mkTestTree'
-                              "fastforward to finished"
-                              (\b -> unwords ["from", show b.proposalParameters.fromStatus])
-                              (Advance.mkFastforwardToFinishBundles cs es)
-                              Advance.Validity
-                                { forProposalValidator = False
-                                , forStakeValidator = True
-                                , forGovernorValidator = Just False
-                                , forAuthorityTokenPolicy = Just True
-                                }
-                          , Advance.mkTestTree
-                              "wrong governor redeemer"
-                              (Advance.mkBadGovernorRedeemerBundle cs es)
-                              Advance.Validity
-                                { forProposalValidator = True
-                                , forStakeValidator = True
-                                , forGovernorValidator = Just False
-                                , forAuthorityTokenPolicy = Just False
-                                }
                           ]
                       ]
       , group "unlocking" $
-          let stakeCountCases = [1, 3, 5, 7, 9, 11]
+          let proposalCountCases = [1, 5, 10, 42]
 
-              mkSubgroupName nStakes = unwords ["with", show nStakes, "stakes"]
+              mkSubgroupName nProposals = unwords ["with", show nProposals, "proposals"]
 
-              mkLegalGroup nStakes =
+              mkLegalGroup nProposals =
                 group
-                  (mkSubgroupName nStakes)
-                  [ Unlock.mkTestTree
+                  (mkSubgroupName nProposals)
+                  [ UnlockStake.mkTestTree
                       "voter: retract votes while voting"
-                      (Unlock.mkValidVoterRetractVotes nStakes)
-                      (Unlock.Validity True True)
-                  , Unlock.mkTestTree
-                      "voter: retract votes while voting by delegatee"
-                      (Unlock.mkValidDelegateeRetractVotes nStakes)
-                      (Unlock.Validity True True)
-                  , Unlock.mkTestTree
+                      (UnlockStake.mkVoterRetractVotesWhileVotingParameters nProposals)
+                      True
+                  , UnlockStake.mkTestTree
                       "voter/creator: retract votes while voting"
-                      (Unlock.mkValidVoterCreatorRetractVotes nStakes)
-                      (Unlock.Validity True True)
-                  , Unlock.mkTestTree
-                      "creator: remove creator lock after voting"
-                      (Unlock.mkValidCreatorRemoveLock nStakes)
-                      (Unlock.Validity True True)
-                  , Unlock.mkTestTree
-                      "Voter: remove lock after voting"
-                      (Unlock.mkValidVoterRemoveLockAfterVoting nStakes)
-                      (Unlock.Validity True True)
+                      (UnlockStake.mkVoterCreatorRetractVotesWhileVotingParameters nProposals)
+                      True
+                  , UnlockStake.mkTestTree
+                      "creator: remove creator locks when finished"
+                      (UnlockStake.mkCreatorRemoveCreatorLocksWhenFinishedParameters nProposals)
+                      True
+                  , UnlockStake.mkTestTree
+                      "voter/creator: remove all locks when finished"
+                      (UnlockStake.mkVoterCreatorRemoveAllLocksWhenFinishedParameters nProposals)
+                      True
+                  , group "voter: unlock after voting" $
+                      map
+                        ( \ps ->
+                            let name = show ps.proposalStatus
+                             in UnlockStake.mkTestTree name ps True
+                        )
+                        (UnlockStake.mkVoterUnlockStakeAfterVotingParameters nProposals)
+                  , UnlockStake.mkTestTree
+                      "voter/creator: remove vote locks when locked"
+                      (UnlockStake.mkVoterCreatorRemoveVoteLocksWhenLockedParameters nProposals)
+                      True
                   ]
 
-              mkIllegalGroup nStakes =
+              mkIllegalGroup nProposals =
                 group
-                  (mkSubgroupName nStakes)
+                  (mkSubgroupName nProposals)
                   [ group "retract votes while not voting" $
                       map
-                        ( \c ->
-                            Unlock.mkTestTree
-                              "(negative test)"
-                              c
-                              (Unlock.Validity False True)
+                        ( \ps ->
+                            let name =
+                                  unwords
+                                    [ "role:"
+                                    , show ps.stakeRole
+                                    , ","
+                                    , "status:"
+                                    , show ps.proposalStatus
+                                    ]
+                             in UnlockStake.mkTestTree name ps False
                         )
-                        (Unlock.mkRetractVotesWhileNotVoting nStakes)
+                        (UnlockStake.mkRetractVotesWhileNotVoting nProposals)
+                  , group "unlock an irrelevant stake" $
+                      map
+                        ( \ps ->
+                            let name =
+                                  unwords
+                                    [ "status:"
+                                    , show ps.proposalStatus
+                                    , "retract votes:"
+                                    , show ps.retractVotes
+                                    ]
+                             in UnlockStake.mkTestTree name ps False
+                        )
+                        (UnlockStake.mkUnockIrrelevantStakeParameters nProposals)
                   , group "remove creator too early" $
                       map
-                        ( \c ->
-                            Unlock.mkTestTree
-                              "(negative test)"
-                              c
-                              (Unlock.Validity True False)
+                        ( \ps ->
+                            let name =
+                                  unwords
+                                    ["status:", show ps.proposalStatus]
+                             in UnlockStake.mkTestTree name ps False
                         )
-                        (Unlock.mkRemoveCreatorLockBeforeFinished nStakes)
-                  , Unlock.mkTestTree
-                      "unlock an irrelevant stake"
-                      (Unlock.mkUnockIrrelevantStakes nStakes)
-                      (Unlock.Validity False False)
-                  , Unlock.mkTestTree
+                        (UnlockStake.mkRemoveCreatorLockBeforeFinishedParameters nProposals)
+                  , UnlockStake.mkTestTree
                       "creator: retract votes"
-                      (Unlock.mkCreatorRetractVotes nStakes)
-                      (Unlock.Validity False True)
-                  , Unlock.mkTestTree
-                      "change output stake value"
-                      (Unlock.mkChangeOutputStakeValue nStakes)
-                      (Unlock.Validity True False)
-                  , Unlock.mkTestTree
-                      "use fake stake"
-                      (Unlock.mkUseFakeStakes nStakes)
-                      (Unlock.Validity False False)
-                  , Unlock.mkTestTree
-                      "retract votes in cooldown"
-                      (Unlock.mkDisrespectCooldown nStakes)
-                      (Unlock.Validity True False)
+                      (UnlockStake.mkRetractVotesWithCreatorStakeParamaters nProposals)
+                      False
+                  , group "alter output stake datum" $
+                      map
+                        ( \ps ->
+                            let name =
+                                  unwords
+                                    [ "role:"
+                                    , show ps.stakeRole
+                                    , ","
+                                    , "status:"
+                                    , show ps.proposalStatus
+                                    ]
+                             in UnlockStake.mkTestTree name ps False
+                        )
+                        (UnlockStake.mkAlterStakeParameters nProposals)
                   ]
 
-              legalGroup = group "legal" $ map mkLegalGroup stakeCountCases
-              illegalGroup = group "illegal" $ map mkIllegalGroup stakeCountCases
+              legalGroup = group "legal" $ map mkLegalGroup proposalCountCases
+              illegalGroup = group "illegal" $ map mkIllegalGroup proposalCountCases
            in [legalGroup, illegalGroup]
       ]
-  , group
-      "privilege escalate"
-      [ PrivilegeEscalate.mkTestTree
-          "vote"
-          PrivilegeEscalate.Voting
-          (PrivilegeEscalate.Validity False False)
-      , PrivilegeEscalate.mkTestTree
-          "retract votes"
-          PrivilegeEscalate.RetractingVotes
-          (PrivilegeEscalate.Validity False False)
-      ]
   ]

agora-specs/Spec/Stake.hs

@@ -9,12 +9,14 @@ Tests for Stake policy and validator
 -}
 module Spec.Stake (specs) where
 
+import Agora.Scripts (AgoraScripts (..))
 import Agora.Stake (
   StakeDatum (StakeDatum),
   StakeRedeemer (DepositWithdraw),
  )
-import PlutusLedgerApi.V1 (Credential (PubKeyCredential))
-import Sample.Shared (stakeValidator)
+import Data.Bool (Bool (..))
+import Data.Maybe (Maybe (..))
+import Sample.Shared (agoraScripts)
 import Sample.Stake (
   DepositWithdrawExample (
     DepositWithdrawExample,
@@ -24,133 +26,61 @@ import Sample.Stake (
   signer,
  )
 import Sample.Stake qualified as Stake (
+  stakeCreation,
+  stakeCreationUnsigned,
+  stakeCreationWrongDatum,
   stakeDepositWithdraw,
  )
-import Sample.Stake.Create qualified as Create
-import Sample.Stake.Destroy qualified as Destroy
 import Sample.Stake.SetDelegate qualified as SetDelegate
-import Sample.Stake.UnauthorizedMintingExploit qualified as UnauthorizedMintingExploit
 import Test.Specification (
   SpecificationTree,
   group,
+  policyFailsWith,
+  policySucceedsWith,
   validatorFailsWith,
   validatorSucceedsWith,
  )
+import Prelude (Num (negate), ($))
 
 -- | The SpecificationTree exported by this module.
 specs :: [SpecificationTree]
 specs =
   [ group
       "policy"
-      [ group
-          "create"
-          [ group
-              "valid"
-              [ Create.mkTestCase
-                  "stake owner: pub key"
-                  Create.ownerIsPubKeyTotallyValid
-                  True
-              , Create.mkTestCase
-                  "stake owner: script"
-                  Create.ownerIsScriptTotallyValid
-                  True
-              ]
-          , group
-              "invalid"
-              [ Create.mkTestCase
-                  "mint more than one sst in one tx"
-                  Create.createMoreThanOneStake
-                  False
-              , Create.mkTestCase
-                  "spend stake while minting SST"
-                  Create.spendStake
-                  False
-              , Create.mkTestCase
-                  "wrong staked amount"
-                  Create.unexpectedStakedAmount
-                  False
-              , Create.mkTestCase
-                  "no stake datum"
-                  Create.noStakeDatum
-                  False
-              , Create.mkTestCase
-                  "bad stake datum"
-                  Create.malformedStakeDatum
-                  False
-              , Create.mkTestCase
-                  "not authorized by owner"
-                  Create.notAuthorizedByOwner
-                  False
-              , Create.mkTestCase
-                  "delegatee not empty"
-                  Create.setDelegatee
-                  False
-              , Create.mkTestCase
-                  "have locks"
-                  Create.alreadyHasLocks
-                  False
-              ]
-          ]
+      [ policySucceedsWith
+          "stakeCreation"
+          agoraScripts.compiledStakePolicy
+          ()
+          Stake.stakeCreation
+      , policyFailsWith
+          "stakeCreationWrongDatum"
+          agoraScripts.compiledStakePolicy
+          ()
+          Stake.stakeCreationWrongDatum
+      , policyFailsWith
+          "stakeCreationUnsigned"
+          agoraScripts.compiledStakePolicy
+          ()
+          Stake.stakeCreationUnsigned
       ]
   , group
       "validator"
-      [ group
-          "destroy"
-          [ group
-              "legal"
-              [ Destroy.mkTestTree
-                  "One stake"
-                  Destroy.oneStake
-                  (Destroy.Validity (Just True) True)
-              , Destroy.mkTestTree
-                  "Multiple stake"
-                  Destroy.multipleStakes
-                  (Destroy.Validity (Just True) True)
-              ]
-          , group
-              "illegal"
-              [ Destroy.mkTestTree
-                  "Destroy only one stake to steal SST"
-                  Destroy.stealSST
-                  (Destroy.Validity (Just False) False)
-              , Destroy.mkTestTree
-                  "Destroy nothing to steal SST"
-                  Destroy.stealSST1
-                  (Destroy.Validity Nothing False)
-              , Destroy.mkTestTree
-                  "Steal SST"
-                  Destroy.stealSST3
-                  (Destroy.Validity (Just False) False)
-              , Destroy.mkTestTree
-                  "Destroy locked stakes"
-                  Destroy.lockedStakes
-                  (Destroy.Validity (Just True) False)
-              , Destroy.mkTestTree
-                  "not authorized by owner"
-                  Destroy.notAuthorized
-                  (Destroy.Validity (Just True) False)
-              , Destroy.mkTestTree
-                  "not authorized by owner"
-                  Destroy.authorizedByDelegatee
-                  (Destroy.Validity (Just True) False)
-              ]
-          ]
-      , validatorSucceedsWith
+      [ validatorSucceedsWith
           "stakeDepositWithdraw deposit"
-          stakeValidator
-          (StakeDatum 100_000 (PubKeyCredential signer) Nothing [])
+          agoraScripts.compiledStakeValidator
+          (StakeDatum 100_000 signer Nothing [])
           (DepositWithdraw 100_000)
           (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = 100_000})
       , validatorSucceedsWith
           "stakeDepositWithdraw withdraw"
-          stakeValidator
-          (StakeDatum 100_000 (PubKeyCredential signer) Nothing [])
+          agoraScripts.compiledStakeValidator
+          (StakeDatum 100_000 signer Nothing [])
           (DepositWithdraw $ negate 100_000)
           (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 100_000})
       , validatorFailsWith
           "stakeDepositWithdraw negative GT"
-          stakeValidator
-          (StakeDatum 100_000 (PubKeyCredential signer) Nothing [])
+          agoraScripts.compiledStakeValidator
+          (StakeDatum 100_000 signer Nothing [])
           (DepositWithdraw 1_000_000)
           (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 1_000_000})
       , group
@@ -180,13 +110,5 @@ specs =
               SetDelegate.invalidOutputStakeDatumParameters
               False
           ]
-      , group
-          "unauthorized SST minting exploit"
-          $ map
-            ( UnauthorizedMintingExploit.mkTestCase
-                "(negative test)"
-                . UnauthorizedMintingExploit.Parameters
-            )
-            [1 .. 20]
       ]
   ]

agora-specs/Spec/Treasury.hs

@@ -21,22 +21,28 @@ Tests need to fail when:
 -}
 module Spec.Treasury (specs) where
 
-import Plutarch.Script (Script)
+import Agora.Treasury (
+  TreasuryRedeemer (SpendTreasuryGAT),
+  treasuryValidator,
+ )
+import Agora.Utils (CompiledValidator (CompiledValidator))
+import Plutarch.Api.V1 (mkValidator)
+import PlutusLedgerApi.V1 (DCert (DCertDelegRegKey))
+import PlutusLedgerApi.V1.Contexts (
+  ScriptContext (scriptContextPurpose, scriptContextTxInfo),
+  ScriptPurpose (Certifying, Rewarding, Spending),
+  TxInfo (txInfoInputs, txInfoMint),
+ )
 import PlutusLedgerApi.V1.Credential (
   StakingCredential (StakingHash),
  )
 import PlutusLedgerApi.V1.Value qualified as Value (singleton)
-import PlutusLedgerApi.V2 (DCert (DCertDelegRegKey))
-import PlutusLedgerApi.V2.Contexts (
-  ScriptContext (scriptContextPurpose, scriptContextTxInfo),
-  ScriptPurpose (Certifying, Minting, Rewarding),
-  TxInfo (txInfoInputs, txInfoMint),
- )
-import Sample.Shared (trCredential, trValidator)
+import Sample.Shared (deterministicTracingConfing, trCredential)
 import Sample.Treasury (
   gatCs,
   gatTn,
   trCtxGATNameNotAddress,
+  treasuryRef,
   validCtx,
   walletIn,
  )
@@ -47,8 +53,11 @@ import Test.Specification (
   validatorSucceedsWith,
  )
 
-compiledTreasuryValidator :: Script
-compiledTreasuryValidator = trValidator
+compiledTreasuryValidator :: CompiledValidator () TreasuryRedeemer
+compiledTreasuryValidator =
+  CompiledValidator $
+    mkValidator deterministicTracingConfing $
+      treasuryValidator gatCs
 
 specs :: [SpecificationTree]
 specs =
@@ -60,32 +69,26 @@ specs =
               "Allows for effect changes"
               compiledTreasuryValidator
               ()
-              ()
+              SpendTreasuryGAT
               validCtx
-          , validatorSucceedsWith
-              "Fails when GAT token name is not script address"
-              compiledTreasuryValidator
-              ()
-              ()
-              trCtxGATNameNotAddress
           ]
       , group
           "Negative"
           [ group
-              "Fails with ScriptPurpose not Spending"
+              "Fails with ScriptPurpose not Minting"
               [ validatorFailsWith
-                  "Minting"
+                  "Spending"
                   compiledTreasuryValidator
                   ()
-                  ()
+                  SpendTreasuryGAT
                   validCtx
-                    { scriptContextPurpose = Minting ""
+                    { scriptContextPurpose = Spending treasuryRef
                     }
               , validatorFailsWith
                   "Rewarding"
                   compiledTreasuryValidator
                   ()
-                  ()
+                  SpendTreasuryGAT
                   validCtx
                     { scriptContextPurpose =
                         Rewarding $
@@ -95,7 +98,7 @@ specs =
                   "Certifying"
                   compiledTreasuryValidator
                   ()
-                  ()
+                  SpendTreasuryGAT
                   validCtx
                     { scriptContextPurpose =
                         Certifying $
@@ -107,7 +110,7 @@ specs =
               "Fails when multiple GATs burned"
               compiledTreasuryValidator
               ()
-              ()
+              SpendTreasuryGAT
               validCtx
                 { scriptContextTxInfo =
                     validCtx.scriptContextTxInfo
@@ -118,11 +121,17 @@ specs =
                             (-2)
                       }
                 }
+          , validatorFailsWith
+              "Fails when GAT token name is not script address"
+              compiledTreasuryValidator
+              ()
+              SpendTreasuryGAT
+              trCtxGATNameNotAddress
           , validatorFailsWith
               "Fails with wallet as input"
               compiledTreasuryValidator
               ()
-              ()
+              SpendTreasuryGAT
               ( let txInfo = validCtx.scriptContextTxInfo
                     inputs = txInfo.txInfoInputs
                     newInputs =

agora-specs/Spec/Utils.hs

@@ -7,8 +7,7 @@ Tests for utility functions in 'Agora.Utils'.
 -}
 module Spec.Utils (tests) where
 
-import Property.Utils qualified as Props
-import Test.Tasty (TestTree, testGroup)
+import Test.Tasty (TestTree)
 
 tests :: [TestTree]
-tests = [testGroup "properties" Props.props]
+tests = []

agora-test/Golden.hs

@@ -1,52 +0,0 @@
-module Golden (testGolden) where
-
-import Agora.Bootstrap qualified as Bootstrap
-import Agora.Linker (linker)
-import Data.Text qualified as Text
-import Plutarch (Config (Config), TracingMode (DoTracing, NoTracing))
-import ScriptExport.File qualified as ScriptExport
-import ScriptExport.Options qualified as ScriptExport
-import ScriptExport.Types qualified as ScriptExport
-import System.Directory (createDirectoryIfMissing)
-import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.Golden (goldenVsFile)
-import Test.Tasty.Providers (TestName)
-
-builders :: ScriptExport.Builders
-builders =
-  mconcat
-    [ ScriptExport.insertScriptExportWithLinker "agora" (Bootstrap.agoraScripts (Config NoTracing)) linker
-    , ScriptExport.insertScriptExportWithLinker "agoraDebug" (Bootstrap.agoraScripts (Config DoTracing)) linker
-    ]
-
-testGolden :: TestTree
-testGolden =
-  testGroup
-    "Golden tests for script export"
-    [ goldenTest "agora" "./agora-test/goldens/"
-    , goldenTest "agoraDebug" "./agora-test/goldens/"
-    ]
-
-goldenTest :: TestName -> FilePath -> TestTree
-goldenTest builder outputPath =
-  let mkFilename suffix = outputPath <> builder <> suffix <> ".json"
-      goldenFilename = mkFilename "-golden"
-      sampleFilename = mkFilename ""
-   in goldenVsFile
-        builder
-        goldenFilename
-        sampleFilename
-        $ callExportScript builder outputPath
-
--- Call the script server and generate an unapplied script set.
-callExportScript :: String -> FilePath -> IO ()
-callExportScript builder outputPath = do
-  _ <- createDirectoryIfMissing False outputPath
-  ScriptExport.runFile
-    builders
-    ( ScriptExport.FileOptions
-        { out = outputPath
-        , param = ""
-        , builder = Text.pack builder
-        }
-    )

agora-test/Spec.hs

@@ -1,5 +1,8 @@
+import Prelude
+
+--------------------------------------------------------------------------------
+
 import GHC.IO.Encoding (setLocaleEncoding, utf8)
-import Golden qualified
 import Test.Tasty (defaultMain, testGroup)
 
 --------------------------------------------------------------------------------
@@ -23,8 +26,7 @@ main = do
   defaultMain $
     testGroup
       "test suite"
-      [ Golden.testGolden
-      , testGroup
+      [ testGroup
           "Effects"
           [ toTestTree $ group "Treasury Withdrawal Effect" TreasuryWithdrawal.specs
           , toTestTree $ group "Governor Mutation Effect" GovernorMutation.specs

agora-testlib/Test/Specification.hs

@@ -49,25 +49,21 @@ module Test.Specification (
   toTestTree,
 ) where
 
+import Agora.Utils (CompiledEffect (..), CompiledMintingPolicy (..), CompiledValidator (..))
 import Control.Composition ((.**), (.***))
 import Data.Coerce (coerce)
-import Data.Text qualified as Text
 import Plutarch.Evaluate (evalScript)
-import Plutarch.Script (Script (Script))
-import PlutusCore.Data qualified as PLC
-import PlutusCore.MkPlc qualified as PLC
-import PlutusLedgerApi.V2 (
+import PlutusLedgerApi.V1 (
   Datum (..),
   Redeemer (Redeemer),
+  Script,
   ScriptContext,
   ToData (toBuiltinData),
-  toData,
  )
-import PlutusPrelude (over)
+import PlutusLedgerApi.V1.Scripts (Context (..), applyMintingPolicyScript, applyValidator)
 import PlutusTx.IsData qualified as PlutusTx (ToData)
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit (assertFailure, testCase)
-import UntypedPlutusCore qualified as UPLC
 
 {- | Expectations upon execution of script
  @Success@ indicates a successful execution.
@@ -133,12 +129,8 @@ toTestTree (Terminal (Specification name expectation script)) =
       Failure -> onFailure
       FailureWith s -> onFailureWith s
   where
-    beautifyTraces =
-      Text.unpack
-        . Text.intercalate "\n"
-        . map ("  " <>)
     (res, _budget, traces) = evalScript script
-    ts = " Traces:\n" <> beautifyTraces traces
+    ts = " Traces: " <> show traces
     onSuccess = case res of
       Left e ->
         assertFailure $
@@ -167,6 +159,9 @@ scriptSucceeds name script = Terminal $ Specification name Success script
 scriptFails :: String -> Script -> SpecificationTree
 scriptFails name script = Terminal $ Specification name Failure script
 
+mkContext :: ScriptContext -> Context
+mkContext = Context . toBuiltinData
+
 mkRedeemer ::
   forall redeemer.
   (PlutusTx.ToData redeemer) =>
@@ -183,39 +178,37 @@ mkDatum = Datum . toBuiltinData
 
 applyMintingPolicy' ::
   (PlutusTx.ToData redeemer) =>
-  Script ->
+  CompiledMintingPolicy redeemer ->
   redeemer ->
   ScriptContext ->
   Script
 applyMintingPolicy' policy redeemer scriptContext =
-  applyArguments
-    policy
-    [ toData $ mkRedeemer redeemer
-    , toData scriptContext
-    ]
+  applyMintingPolicyScript
+    (mkContext scriptContext)
+    (getCompiledMintingPolicy policy)
+    (mkRedeemer redeemer)
 
 applyValidator' ::
   ( PlutusTx.ToData datum
   , PlutusTx.ToData redeemer
   ) =>
-  Script ->
+  CompiledValidator datum redeemer ->
   datum ->
   redeemer ->
   ScriptContext ->
   Script
 applyValidator' validator datum redeemer scriptContext =
-  applyArguments
-    validator
-    [ toData $ mkDatum datum
-    , toData $ mkRedeemer redeemer
-    , toData scriptContext
-    ]
+  applyValidator
+    (mkContext scriptContext)
+    (getCompiledValidator validator)
+    (mkDatum datum)
+    (mkRedeemer redeemer)
 
 -- | Check that a policy script succeeds, given a name and arguments.
 policySucceedsWith ::
   (PlutusTx.ToData redeemer) =>
   String ->
-  Script ->
+  CompiledMintingPolicy redeemer ->
   redeemer ->
   ScriptContext ->
   SpecificationTree
@@ -226,7 +219,7 @@ policySucceedsWith tag =
 policyFailsWith ::
   (PlutusTx.ToData redeemer) =>
   String ->
-  Script ->
+  CompiledMintingPolicy redeemer ->
   redeemer ->
   ScriptContext ->
   SpecificationTree
@@ -239,7 +232,7 @@ validatorSucceedsWith ::
   , PlutusTx.ToData redeemer
   ) =>
   String ->
-  Script ->
+  CompiledValidator datum redeemer ->
   datum ->
   redeemer ->
   ScriptContext ->
@@ -253,7 +246,7 @@ validatorFailsWith ::
   , PlutusTx.ToData redeemer
   ) =>
   String ->
-  Script ->
+  CompiledValidator datum redeemer ->
   datum ->
   redeemer ->
   ScriptContext ->
@@ -266,7 +259,7 @@ effectSucceedsWith ::
   ( PlutusTx.ToData datum
   ) =>
   String ->
-  Script ->
+  CompiledEffect datum ->
   datum ->
   ScriptContext ->
   SpecificationTree
@@ -277,7 +270,7 @@ effectFailsWith ::
   ( PlutusTx.ToData datum
   ) =>
   String ->
-  Script ->
+  CompiledEffect datum ->
   datum ->
   ScriptContext ->
   SpecificationTree
@@ -290,7 +283,7 @@ testValidator ::
   -- | Is this test case expected to succeed?
   Bool ->
   String ->
-  Script ->
+  CompiledValidator datum redeemer ->
   datum ->
   redeemer ->
   ScriptContext ->
@@ -307,7 +300,7 @@ testPolicy ::
   -- | Is this test case expected to succeed?
   Bool ->
   String ->
-  Script ->
+  CompiledMintingPolicy redeemer ->
   redeemer ->
   ScriptContext ->
   SpecificationTree
@@ -315,11 +308,3 @@ testPolicy isValid =
   if isValid
     then policySucceedsWith
     else policyFailsWith
-
---------------------------------------------------------------------------------
-
-applyArguments :: Script -> [PLC.Data] -> Script
-applyArguments (Script p) args =
-  let termArgs = fmap (PLC.mkConstant ()) args
-      applied t = PLC.mkIterApp () t termArgs
-   in Script $ over UPLC.progTerm applied p

agora-testlib/Test/Util.hs

@@ -15,7 +15,6 @@ module Test.Util (
   sortValue,
   blake2b_224,
   pubKeyHashes,
-  scriptHashes,
   userCredentials,
   scriptCredentials,
   validatorHashes,
@@ -23,7 +22,6 @@ module Test.Util (
   mkSpending,
   mkMinting,
   CombinableBuilder,
-  subtractValue,
 ) where
 
 --------------------------------------------------------------------------------
@@ -38,32 +36,31 @@ import Data.ByteString.Lazy qualified as ByteString.Lazy
 import Data.List (sortOn)
 import Plutarch.Context (
   Builder,
-  buildMinting',
-  buildSpending',
+  buildMintingUnsafe,
+  buildSpendingUnsafe,
   withMinting,
   withSpendingOutRef,
  )
 import Plutarch.Crypto (pblake2b_256)
-import PlutusLedgerApi.V1.Interval qualified as PlutusTx
-import PlutusLedgerApi.V1.Value (Value (..))
-import PlutusLedgerApi.V1.Value qualified as Value
-import PlutusLedgerApi.V2 (
+import PlutusLedgerApi.V1 (
   Credential (
     PubKeyCredential,
     ScriptCredential
   ),
   CurrencySymbol,
-  Datum (Datum),
-  DatumHash (DatumHash),
   PubKeyHash (..),
   ScriptContext,
-  ScriptHash (ScriptHash),
   TxOutRef,
+  ValidatorHash (ValidatorHash),
  )
+import PlutusLedgerApi.V1.Interval qualified as PlutusTx
+import PlutusLedgerApi.V1.Scripts (Datum (Datum), DatumHash (DatumHash))
+import PlutusLedgerApi.V1.Value (Value (..))
 import PlutusTx.AssocMap qualified as AssocMap
 import PlutusTx.Builtins qualified as PlutusTx
 import PlutusTx.IsData qualified as PlutusTx
 import PlutusTx.Ord qualified as PlutusTx
+import Prelude
 
 --------------------------------------------------------------------------------
 
@@ -158,17 +155,13 @@ userCredentials :: [Credential]
 userCredentials = PubKeyCredential <$> pubKeyHashes
 
 -- | An infinite list of *valid* validator hashes.
-validatorHashes :: [ScriptHash]
-validatorHashes = ScriptHash . PlutusTx.toBuiltin <$> blake2b_224Hashes
+validatorHashes :: [ValidatorHash]
+validatorHashes = ValidatorHash . PlutusTx.toBuiltin <$> blake2b_224Hashes
 
 -- | An infinite list of *valid* script credentials.
 scriptCredentials :: [Credential]
 scriptCredentials = ScriptCredential <$> validatorHashes
 
--- | An infinite list of *valid* script hashes.
-scriptHashes :: [ScriptHash]
-scriptHashes = ScriptHash . PlutusTx.toBuiltin <$> blake2b_224Hashes
-
 --------------------------------------------------------------------------------
 
 -- | Turn the given list in to groups which have the given length.
@@ -197,7 +190,7 @@ mkSpending ::
   TxOutRef ->
   ScriptContext
 mkSpending mkBuilder ps oref =
-  buildSpending' $
+  buildSpendingUnsafe $
     mkBuilder ps <> withSpendingOutRef oref
 
 {- | Given the builder generator and the parameters, create a 'ScriptContext'
@@ -210,12 +203,7 @@ mkMinting ::
   CurrencySymbol ->
   ScriptContext
 mkMinting mkBuilder ps cs =
-  buildMinting' $
+  buildMintingUnsafe $
     mkBuilder ps <> withMinting cs
 
 type CombinableBuilder b = (Monoid b, Builder b)
-
---------------------------------------------------------------------------------
-
-subtractValue :: Value -> Value -> Value
-subtractValue = Value.unionWith (-)

agora.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               agora
-version:            1.0.0
+version:            0.2.0
 extra-source-files: CHANGELOG.md
 author:             Emily Martins <emi@haskell.fyi>
 license:            Apache-2.0
@@ -18,6 +18,10 @@ common lang
     -Wmissing-deriving-strategies -Wno-name-shadowing -Wunused-foralls
     -fprint-explicit-foralls -fprint-explicit-kinds -Wunused-do-bind
 
+  mixins:
+    base hiding (Prelude),
+    pprelude (PPrelude as Prelude)
+
   default-extensions:
     NoStarIsType
     BangPatterns
@@ -77,7 +81,6 @@ common lang
     TypeSynonymInstances
     UndecidableInstances
     ViewPatterns
-    NoFieldSelectors
     OverloadedRecordDot
 
   default-language:   Haskell2010
@@ -86,7 +89,7 @@ common deps
   build-depends:
     , aeson
     , ansi-terminal
-    , base                   >=4.14 && <5
+    , base                    >=4.14 && <5
     , base-compat
     , base16
     , bytestring
@@ -96,18 +99,15 @@ common deps
     , containers
     , data-default
     , data-default-class
-    , filepath
     , generics-sop
     , liqwid-plutarch-extra
-    , liqwid-script-export
-    , optics
     , plutarch
-    , plutarch-extra
+    , plutarch-numeric
+    , plutarch-safe-money
+    , plutarch-script-export
     , plutus-core
     , plutus-ledger-api
     , plutus-tx
-    , ply-core
-    , ply-plutarch
     , pprelude
     , prettyprinter
     , recursion-schemes
@@ -116,17 +116,13 @@ common deps
     , template-haskell
     , text
 
-common plutarch-prelude
   mixins:
-    base hiding (Prelude),
-    pprelude (PPrelude as Prelude)
 
 common test-deps
   build-depends:
     , agora
     , cryptonite
     , data-default-class
-    , directory
     , memory
     , mtl
     , plutarch-context-builder
@@ -134,7 +130,6 @@ common test-deps
     , QuickCheck
     , quickcheck-instances
     , tasty
-    , tasty-golden
     , tasty-hedgehog
     , tasty-hunit
     , tasty-quickcheck
@@ -144,30 +139,25 @@ 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
+  import:          lang, deps
   exposed-modules:
     Agora.Aeson.Orphans
     Agora.AuthorityToken
     Agora.Bootstrap
-    Agora.Credential
     Agora.Effect
     Agora.Effect.GovernorMutation
     Agora.Effect.NoOp
     Agora.Effect.TreasuryWithdrawal
     Agora.Governor
     Agora.Governor.Scripts
-    Agora.Linker
     Agora.Plutarch.Orphans
     Agora.Proposal
     Agora.Proposal.Scripts
     Agora.Proposal.Time
     Agora.SafeMoney
+    Agora.Scripts
     Agora.Stake
-    Agora.Stake.Redeemers
     Agora.Stake.Scripts
     Agora.Treasury
     Agora.Utils
@@ -184,7 +174,7 @@ library pprelude
     , plutarch
 
 library agora-testlib
-  import:          lang, deps, plutarch-prelude, test-deps
+  import:          lang, deps, test-deps
   exposed-modules:
     Test.Specification
     Test.Util
@@ -192,12 +182,10 @@ library agora-testlib
   hs-source-dirs:  agora-testlib
 
 library agora-specs
-  import:          lang, deps, plutarch-prelude, test-deps
+  import:          lang, deps, test-deps
   exposed-modules:
     Property.Generator
     Property.Governor
-    Property.Utils
-    Sample.AuthorityToken.UnauthorizedMintingExploit
     Sample.Effect.GovernorMutation
     Sample.Effect.TreasuryWithdrawal
     Sample.Governor.Initialize
@@ -205,16 +193,12 @@ library agora-specs
     Sample.Proposal.Advance
     Sample.Proposal.Cosign
     Sample.Proposal.Create
-    Sample.Proposal.PrivilegeEscalate
     Sample.Proposal.Shared
-    Sample.Proposal.Unlock
+    Sample.Proposal.UnlockStake
     Sample.Proposal.Vote
     Sample.Shared
     Sample.Stake
-    Sample.Stake.Create
-    Sample.Stake.Destroy
     Sample.Stake.SetDelegate
-    Sample.Stake.UnauthorizedMintingExploit
     Sample.Treasury
     Spec.AuthorityToken
     Spec.Effect.GovernorMutation
@@ -226,23 +210,19 @@ library agora-specs
     Spec.Utils
 
   hs-source-dirs:  agora-specs
-  build-depends:
-    , agora-testlib
-    , ordered-containers
+  build-depends:   agora-testlib
 
 test-suite agora-test
-  import:         lang, deps, plutarch-prelude, test-deps, test-opts
+  import:         lang, deps, test-deps
   type:           exitcode-stdio-1.0
   main-is:        Spec.hs
   hs-source-dirs: agora-test
-  other-modules:  Golden
   build-depends:
-    , agora
     , agora-specs
     , agora-testlib
 
 benchmark agora-bench
-  import:         lang, deps, plutarch-prelude
+  import:         lang, deps
   hs-source-dirs: agora-bench
   main-is:        Main.hs
   other-modules:
@@ -264,14 +244,11 @@ executable agora-scripts
   hs-source-dirs: agora-scripts
   other-modules:
   build-depends:
-    , aeson-pretty
     , agora
     , gitrev
 
-  mixins:         base
-
 executable agora-purescript-bridge
-  import:         lang, deps, plutarch-prelude, exe-opts
+  import:         lang, deps, exe-opts
   main-is:        Bridge.hs
   hs-source-dirs: agora-purescript-bridge
   other-modules:

agora/Agora/Aeson/Orphans.hs

@@ -5,7 +5,7 @@ module Agora.Aeson.Orphans (AsBase16Bytes (..)) where
 --------------------------------------------------------------------------------
 
 import Data.Coerce (Coercible, coerce)
-import Plutarch.Orphans ()
+import Prelude
 
 --------------------------------------------------------------------------------
 
@@ -20,6 +20,7 @@ import Data.Text.Encoding qualified as T
 
 import PlutusLedgerApi.V1 qualified as Plutus
 import PlutusLedgerApi.V1.Bytes qualified as Plutus
+import PlutusLedgerApi.V1.Scripts qualified as Plutus
 import PlutusLedgerApi.V1.Value qualified as Plutus
 
 --------------------------------------------------------------------------------
@@ -37,6 +38,19 @@ deriving via
   instance
     Aeson.FromJSON Plutus.AssetClass
 
+deriving via
+  AsBase16Bytes Plutus.TxId
+  instance
+    Aeson.FromJSON Plutus.TxId
+
+deriving via
+  AsBase16Bytes Plutus.TxId
+  instance
+    Aeson.ToJSON Plutus.TxId
+
+deriving anyclass instance Aeson.FromJSON Plutus.TxOutRef
+deriving anyclass instance Aeson.ToJSON Plutus.TxOutRef
+
 instance (Coercible a Plutus.LedgerBytes) => Aeson.ToJSON (AsBase16Bytes a) where
   toJSON =
     Aeson.String
@@ -66,3 +80,86 @@ instance (Codec.Serialise a) => Aeson.FromJSON (AsBase16Codec a) where
         . Codec.deserialiseOrFail
         . Lazy.fromStrict
         . T.encodeUtf8
+
+--------------------------------------------------------------------------------
+
+deriving via
+  (AsBase16Bytes Plutus.CurrencySymbol)
+  instance
+    (Aeson.ToJSON Plutus.CurrencySymbol)
+deriving via
+  (AsBase16Bytes Plutus.CurrencySymbol)
+  instance
+    (Aeson.FromJSON Plutus.CurrencySymbol)
+
+deriving via
+  (AsBase16Bytes Plutus.TokenName)
+  instance
+    (Aeson.ToJSON Plutus.TokenName)
+deriving via
+  (AsBase16Bytes Plutus.TokenName)
+  instance
+    (Aeson.FromJSON Plutus.TokenName)
+
+deriving via
+  (AsBase16Bytes Plutus.ValidatorHash)
+  instance
+    (Aeson.ToJSON Plutus.ValidatorHash)
+deriving via
+  (AsBase16Bytes Plutus.ValidatorHash)
+  instance
+    (Aeson.FromJSON Plutus.ValidatorHash)
+
+deriving via
+  (AsBase16Bytes Plutus.ScriptHash)
+  instance
+    (Aeson.ToJSON Plutus.ScriptHash)
+deriving via
+  (AsBase16Bytes Plutus.ScriptHash)
+  instance
+    (Aeson.FromJSON Plutus.ScriptHash)
+
+deriving via
+  (AsBase16Bytes Plutus.BuiltinByteString)
+  instance
+    (Aeson.ToJSON Plutus.BuiltinByteString)
+deriving via
+  (AsBase16Bytes Plutus.BuiltinByteString)
+  instance
+    (Aeson.FromJSON Plutus.BuiltinByteString)
+
+deriving via
+  (AsBase16Codec Plutus.Validator)
+  instance
+    (Aeson.ToJSON Plutus.Validator)
+deriving via
+  (AsBase16Codec Plutus.Validator)
+  instance
+    (Aeson.FromJSON Plutus.Validator)
+
+deriving via
+  (AsBase16Codec Plutus.MintingPolicy)
+  instance
+    (Aeson.ToJSON Plutus.MintingPolicy)
+deriving via
+  (AsBase16Codec Plutus.MintingPolicy)
+  instance
+    (Aeson.FromJSON Plutus.MintingPolicy)
+
+deriving via
+  (AsBase16Codec Plutus.Script)
+  instance
+    (Aeson.ToJSON Plutus.Script)
+deriving via
+  (AsBase16Codec Plutus.Script)
+  instance
+    (Aeson.FromJSON Plutus.Script)
+
+deriving via
+  Integer
+  instance
+    (Aeson.ToJSON Plutus.POSIXTime)
+deriving via
+  Integer
+  instance
+    (Aeson.FromJSON Plutus.POSIXTime)

agora/Agora/AuthorityToken.hs

@@ -9,135 +9,35 @@ module Agora.AuthorityToken (
   authorityTokenPolicy,
   authorityTokensValidIn,
   singleAuthorityTokenBurned,
+  AuthorityToken (..),
 ) where
 
-import Agora.Governor (PGovernorRedeemer (PMintGATs), presolveGovernorRedeemer)
-import Agora.SafeMoney (AuthorityTokenTag, GovernorSTTag)
-import Agora.Utils (ptag, ptaggedSymbolValueOf, ptoScottEncodingT, puntag)
 import Plutarch.Api.V1 (
-  PCredential (..),
-  PCurrencySymbol (..),
- )
-import Plutarch.Api.V1.AssocMap (PMap (PMap))
-import Plutarch.Api.V1.Value (PValue (PValue))
-import Plutarch.Api.V2 (
   AmountGuarantees,
   KeyGuarantees,
-  PAddress (PAddress),
+  PAddress (..),
+  PCredential (..),
+  PCurrencySymbol (..),
   PMintingPolicy,
-  PScriptPurpose (PMinting),
+  PScriptContext (..),
+  PScriptPurpose (..),
   PTxInInfo (PTxInInfo),
-  PTxOut (PTxOut),
- )
-import Plutarch.Extra.AssetClass (PAssetClassData)
-import Plutarch.Extra.Bool (passert)
-import Plutarch.Extra.Maybe (passertPJust, pfromJust)
-import Plutarch.Extra.Sum (PSum (PSum))
-import Plutarch.Extra.Tagged (PTagged)
-import Plutarch.Extra.Traversable (pfoldMap)
-import Plutarch.Extra.Value (psymbolValueOf')
-import "liqwid-plutarch-extra" Plutarch.Extra.List (plookupAssoc)
-import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
-  pguardC,
-  pletC,
-  pletFieldsC,
-  pmatchC,
+  PTxInfo (..),
+  PTxOut (..),
  )
+import Plutarch.Api.V1.AssetClass (passetClass, passetClassValueOf)
+import Plutarch.Api.V1.AssocMap (PMap (PMap))
+import Plutarch.Api.V1.ScriptContext (pisTokenSpent)
+import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (psymbolValueOf)
+import "plutarch" Plutarch.Api.V1.Value (PValue (PValue))
+import Plutarch.Builtin (pforgetData)
+import Plutarch.Extra.List (plookup)
+import Plutarch.Extra.TermCont (pguardC, pletFieldsC, pmatchC)
+import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
 
 --------------------------------------------------------------------------------
 
-{- | Check that all GATs are valid in a particular TxOut.
-
-     WARNING: As of version 1.0.0, this has been weakened in order to be
-     compatible with RATs. The token name is no loger checked, meaning that a
-     GAT can escape from its effect script, if the effect script is vulnerable.
-     In order to prevent this, all effect scripts should be implemented carefully,
-     and ideally use the trusted effect base. See also 'Agora.Effect'.
-
-     (before 1.0.0) How this is checked: an AuthorityToken should never leave
-     the Effect it was initially sent to, so we simply check that
-     the script address the token resides in matches the TokenName.
-     Since the TokenName was tagged upon mint with the Effect script
-     it was sent to, this is enough to prove validity.
-     In other words, check that all assets of a particular currency symbol
-     are tagged with a TokenName that matches where they live.
-
-     @since 1.0.0
--}
-authorityTokensValidIn :: forall (s :: S). Term s (PTagged AuthorityTokenTag PCurrencySymbol :--> PTxOut :--> PBool)
-authorityTokensValidIn = phoistAcyclic $
-  plam $ \authorityTokenSym txOut'' -> unTermCont $ do
-    PTxOut txOut' <- pmatchC txOut''
-    txOut <- pletFieldsC @'["address", "value"] $ txOut'
-    PAddress address <- pmatchC txOut.address
-    PValue value' <- pmatchC txOut.value
-    PMap value <- pmatchC value'
-    pure $
-      pmatch (plookupAssoc # pfstBuiltin # psndBuiltin # pdata (puntag authorityTokenSym) # value) $ \case
-        PJust (pfromData -> _tokenMap') ->
-          pmatch (pfield @"credential" # address) $ \case
-            PPubKeyCredential _ ->
-              -- GATs should only be sent to Effect validators
-              ptraceIfFalse "authorityTokensValidIn: GAT incorrectly lives at PubKey" $ pconstant False
-            PScriptCredential _ ->
-              -- NOTE: We no longer can perform a check on `TokenName` content here.
-              -- Instead, the auth check system uses `TokenName`s, but it cannot
-              -- check for GATs incorrectly escaping scripts. The effect scripts
-              -- need to be written very carefully in order to disallow this.
-              pcon PTrue
-        PNothing ->
-          -- No GATs exist at this output!
-          pcon PTrue
-
-{- | Assert that a single authority token has been burned.
-
-     @since 0.2.0
--}
-singleAuthorityTokenBurned ::
-  forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
-  Term s (PTagged AuthorityTokenTag PCurrencySymbol) ->
-  Term s (PBuiltinList PTxInInfo) ->
-  Term s (PValue keys amounts) ->
-  Term s PBool
-singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
-  let gatAmountMinted :: Term _ PInteger
-      gatAmountMinted = ptaggedSymbolValueOf # gatCs # mint
-
-  let inputsWithGAT =
-        pfoldMap
-          # plam
-            ( flip pmatch $ \case
-                PTxInInfo txInInfo -> unTermCont $ do
-                  resolved <- pletC $ pfield @"resolved" # txInInfo
-
-                  pguardC "While counting GATs at inputs: all GATs must be valid"
-                    $ authorityTokensValidIn
-                      # gatCs
-                      #$ pfromData
-                    $ resolved
-
-                  pure . pcon . PSum $
-                    ptaggedSymbolValueOf
-                      # gatCs
-                      #$ pfield @"value"
-                      #$ resolved
-            )
-          # inputs
-
-  pure $
-    foldr1
-      (#&&)
-      [ ptraceIfFalse "singleAuthorityTokenBurned: Must burn exactly 1 GAT" $
-          gatAmountMinted #== -1
-      , ptraceIfFalse "Only one GAT must exist at the inputs" $
-          inputsWithGAT #== 1
-      ]
-
-{- | Policy given 'AuthorityToken' params.
-
-     == Authority Token
-
-     An AuthorityToken represents a proof that a particular token
+{- | An AuthorityToken represents a proof that a particular token
      spent in the same transaction the AuthorityToken was minted.
      In effect, this means that the validator that locked such a token
      must have approved the transaction in which an AuthorityToken is minted.
@@ -146,46 +46,117 @@ singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
 
      @since 0.1.0
 -}
-authorityTokenPolicy :: ClosedTerm (PAsData (PTagged GovernorSTTag PAssetClassData) :--> PMintingPolicy)
-authorityTokenPolicy =
-  plam $ \gstAssetClass _redeemer ctx -> unTermCont $ do
-    ctxF <- pletFieldsC @'["txInfo", "purpose"] ctx
-    txInfoF <-
-      pletFieldsC
-        @'[ "inputs"
-          , "mint"
-          , "outputs"
-          , "redeemers"
-          ]
-        ctxF.txInfo
+newtype AuthorityToken = AuthorityToken
+  { authority :: AssetClass
+  -- ^ Token that must move in order for minting this to be valid.
+  }
+  deriving stock
+    ( -- | @since 0.1.0
+      Generic
+    )
 
-    PMinting ownSymbol' <- pmatchC $ pfromData ctxF.purpose
+--------------------------------------------------------------------------------
 
-    let ownSymbol = pfromData $ pfield @"_0" # ownSymbol'
-
-    PPair mintedATs burntATs <-
-      pmatchC $ pfromJust #$ psymbolValueOf' # ownSymbol # txInfoF.mint
+{- | Check that all GATs are valid in a particular TxOut.
+     How this is checked: an AuthorityToken should never leave
+     the Effect it was initially sent to, so we simply check that
+     the script address the token resides in matches the TokenName.
+     Since the TokenName was tagged upon mint with the Effect script
+     it was sent to, this is enough to prove validity.
+     In other words, check that all assets of a particular currency symbol
+     are tagged with a TokenName that matches where they live.
 
+     @since 0.1.0
+-}
+authorityTokensValidIn :: Term s (PCurrencySymbol :--> PTxOut :--> PBool)
+authorityTokensValidIn = phoistAcyclic $
+  plam $ \authorityTokenSym txOut'' -> unTermCont $ do
+    PTxOut txOut' <- pmatchC txOut''
+    txOut <- pletFieldsC @'["address", "value"] $ txOut'
+    PAddress address <- pmatchC txOut.address
+    PValue value' <- pmatchC txOut.value
+    PMap value <- pmatchC value'
     pure $
-      popaque $
+      pmatch (plookup # pdata authorityTokenSym # value) $ \case
+        PJust (pfromData -> tokenMap') ->
+          pmatch (pfield @"credential" # address) $ \case
+            PPubKeyCredential _ ->
+              -- GATs should only be sent to Effect validators
+              ptraceIfFalse "authorityTokensValidIn: GAT incorrectly lives at PubKey" $ pconstant False
+            PScriptCredential ((pfromData . (pfield @"_0" #)) -> cred) -> unTermCont $ do
+              PMap tokenMap <- pmatchC tokenMap'
+              pure $
+                ptraceIfFalse "authorityTokensValidIn: GAT TokenName doesn't match ScriptHash" $
+                  pall
+                    # plam
+                      ( \pair ->
+                          pforgetData (pfstBuiltin # pair) #== pforgetData (pdata cred)
+                      )
+                    # tokenMap
+        PNothing ->
+          -- No GATs exist at this output!
+          pconstant True
+
+{- | Assert that a single authority token has been burned.
+
+     @since 0.2.0
+-}
+singleAuthorityTokenBurned ::
+  forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
+  Term s PCurrencySymbol ->
+  Term s (PBuiltinList PTxInInfo) ->
+  Term s (PValue keys amounts) ->
+  Term s PBool
+singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
+  let gatAmountMinted :: Term _ PInteger
+      gatAmountMinted = psymbolValueOf # gatCs # mint
+
+  pure $
+    foldr1
+      (#&&)
+      [ ptraceIfFalse "singleAuthorityTokenBurned: Must burn exactly 1 GAT" $ gatAmountMinted #== -1
+      , ptraceIfFalse "singleAuthorityTokenBurned: All GAT tokens must be valid at the inputs" $
+          pall
+            # plam
+              ( \txInInfo' -> unTermCont $ do
+                  PTxInInfo txInInfo <- pmatchC txInInfo'
+                  let txOut' = pfield @"resolved" # txInInfo
+                  pure $ authorityTokensValidIn # gatCs # pfromData txOut'
+              )
+            # inputs
+      ]
+
+{- | Policy given 'AuthorityToken' params.
+
+     @since 0.1.0
+-}
+authorityTokenPolicy :: AuthorityToken -> ClosedTerm PMintingPolicy
+authorityTokenPolicy params =
+  plam $ \_redeemer ctx' ->
+    pmatch ctx' $ \(PScriptContext ctx') -> unTermCont $ do
+      ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
+      PTxInfo txInfo' <- pmatchC $ pfromData ctx.txInfo
+      txInfo <- pletFieldsC @'["inputs", "mint", "outputs"] txInfo'
+      let inputs = txInfo.inputs
+          mintedValue = pfromData txInfo.mint
+          AssetClass (govCs, govTn) = params.authority
+          govAc = passetClass # pconstant govCs # pconstant govTn
+          govTokenSpent = pisTokenSpent # govAc # inputs
+
+      PMinting ownSymbol' <- pmatchC $ pfromData ctx.purpose
+
+      let ownSymbol = pfromData $ pfield @"_0" # ownSymbol'
+          mintedATs = passetClassValueOf # mintedValue # (passetClass # ownSymbol # pconstant "")
+      pure $
         pif
           (0 #< mintedATs)
           ( unTermCont $ do
-              pguardC "No GAT burnt" $ 0 #== burntATs
-              let governorRedeemer =
-                    passertPJust
-                      # "GST should move"
-                      #$ presolveGovernorRedeemer
-                      # (ptoScottEncodingT # pfromData gstAssetClass)
-                      # pfromData txInfoF.inputs
-                      # txInfoF.redeemers
-              pguardC "Governor redeemr correct" $
-                pcon PMintGATs #== governorRedeemer
+              pguardC "Parent token did not move in minting GATs" govTokenSpent
               pguardC "All outputs only emit valid GATs" $
                 pall
                   # plam
-                    (authorityTokensValidIn # ptag ownSymbol #)
-                  # txInfoF.outputs
-              pure $ pconstant ()
+                    (authorityTokensValidIn # ownSymbol #)
+                  # txInfo.outputs
+              pure $ popaque $ pconstant ()
           )
-          (passert "No GAT minted" (0 #== mintedATs) (pconstant ()))
+          (popaque $ pconstant ())

agora/Agora/Bootstrap.hs

@@ -4,91 +4,64 @@
 
      Initialize a governance system
 -}
-module Agora.Bootstrap (agoraScripts, agoraScripts', alwaysSucceedsPolicyRoledScript) where
+module Agora.Bootstrap (agoraScripts) where
 
-import Agora.AuthorityToken (authorityTokenPolicy)
-import Agora.Effect.GovernorMutation (mutateGovernorValidator)
-import Agora.Effect.NoOp (noOpValidator)
-import Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalValidator)
+import Agora.AuthorityToken (AuthorityToken (..), authorityTokenPolicy)
+import Agora.Governor (Governor (..))
 import Agora.Governor.Scripts (governorPolicy, governorValidator)
 import Agora.Proposal.Scripts (proposalPolicy, proposalValidator)
+import Agora.Scripts (AgoraScripts (AgoraScripts))
+import Agora.Scripts qualified as Scripts
 import Agora.Stake.Scripts (stakePolicy, stakeValidator)
 import Agora.Treasury (treasuryValidator)
-import Data.Map (fromList)
-import Data.Text (Text, unpack)
+import Agora.Utils (
+  CompiledMintingPolicy (..),
+  CompiledValidator (..),
+ )
 import Plutarch (Config)
-import Plutarch.Api.V2 (PMintingPolicy)
-import Plutarch.Extra.Compile (mustCompile)
-import Ply (ScriptRole (MintingPolicyRole), TypedScriptEnvelope)
-import Ply.Plutarch.TypedWriter (TypedWriter, mkEnvelope)
-import ScriptExport.ScriptInfo (RawScriptExport (..), RoledScript (..))
+import Plutarch.Api.V1 (
+  mintingPolicySymbol,
+  mkMintingPolicy,
+  mkValidator,
+ )
+import PlutusLedgerApi.V1.Value (AssetClass (..))
 
-{- | Parameterize core scripts, given the 'Agora.Governor.Governor'
-     parameters and plutarch configurations.
+{- | Parameterize and precompiled core scripts, given the
+     'Agora.Governor.Governor' parameters and plutarch configurations.
 
-     @since 1.0.0
+     @since 0.2.0
 -}
-agoraScripts :: Config -> RawScriptExport
-agoraScripts conf =
-  RawScriptExport $
-    fromList
-      [ envelope "agora:governorPolicy" governorPolicy
-      , envelope "agora:governorValidator" governorValidator
-      , envelope "agora:stakePolicy" stakePolicy
-      , envelope "agora:stakeValidator" stakeValidator
-      , envelope "agora:proposalPolicy" proposalPolicy
-      , envelope "agora:proposalValidator" proposalValidator
-      , envelope "agora:treasuryValidator" treasuryValidator
-      , envelope "agora:authorityTokenPolicy" authorityTokenPolicy
-      , envelope "agora:noOpValidator" noOpValidator
-      , envelope "agora:treasuryWithdrawalValidator" treasuryWithdrawalValidator
-      , envelope "agora:mutateGovernorValidator" mutateGovernorValidator
-      ]
+agoraScripts :: Config -> Governor -> AgoraScripts
+agoraScripts conf gov = scripts
   where
-    envelope ::
-      forall (pt :: S -> Type).
-      TypedWriter pt =>
-      Text ->
-      ClosedTerm pt ->
-      (Text, TypedScriptEnvelope)
-    envelope d t = (d, either (error . unpack) id $ mkEnvelope conf d t)
+    mkMintingPolicy' = mkMintingPolicy conf
+    mkValidator' = mkValidator conf
 
-agoraScripts' :: Config -> Either Text [TypedScriptEnvelope]
-agoraScripts' conf =
-  sequenceA
-    [ envelope "Governor Policy" governorPolicy
-    , envelope "Governor Validator" governorValidator
-    , envelope "Stake Policy" stakePolicy
-    , envelope "Stake Validator" stakeValidator
-    , envelope "Proposal Policy" proposalPolicy
-    , envelope "Proposal Validator" proposalValidator
-    , envelope "Treasury Validator" treasuryValidator
-    , envelope "Authority Token Policy" authorityTokenPolicy
-    , envelope "NoOp Validator" noOpValidator
-    , envelope "Treasury Withdrawal Validator" treasuryWithdrawalValidator
-    , envelope "Mutate Governor Validator" mutateGovernorValidator
-    , envelope "Always Succeeds Policy" ((plam $ \_ _ -> popaque $ pcon PUnit) :: Term s PMintingPolicy)
-    ]
-  where
-    envelope ::
-      forall (pt :: S -> Type).
-      TypedWriter pt =>
-      Text ->
-      ClosedTerm pt ->
-      Either Text TypedScriptEnvelope
-    envelope = mkEnvelope conf
+    compiledGovernorPolicy = mkMintingPolicy' $ governorPolicy gov.gstOutRef
+    compiledGovernorValidator = mkValidator' $ governorValidator scripts
+    governorSymbol = mintingPolicySymbol compiledGovernorPolicy
+    governorAssetClass = AssetClass (governorSymbol, "")
 
-{- | A minting policy that always succeeds.
+    authority = AuthorityToken governorAssetClass
+    compiledAuthorityPolicy = mkMintingPolicy' $ authorityTokenPolicy authority
+    authorityTokenSymbol = mintingPolicySymbol compiledAuthorityPolicy
 
-  NOTE(Emily, Jan 3rd 2023): Adding this in here because it's useful for testnet GT.
-    In reality, it shouldn't be used by anyone on mainnet, but removing it is not
-    productive for off-chain testing.
+    compiledProposalPolicy = mkMintingPolicy' $ proposalPolicy governorAssetClass
+    compiledProposalValidator = mkValidator' $ proposalValidator scripts gov.maximumCosigners
 
-  @since 1.0.0
--}
-alwaysSucceedsPolicyRoledScript :: RoledScript
-alwaysSucceedsPolicyRoledScript =
-  RoledScript
-    { script = mustCompile @PMintingPolicy $ plam $ \_ _ -> popaque $ pcon PUnit
-    , role = MintingPolicyRole
-    }
+    compiledStakePolicy = mkMintingPolicy' $ stakePolicy gov.gtClassRef
+    compiledStakeValidator = mkValidator' $ stakeValidator scripts gov.gtClassRef
+
+    compiledTreasuryValidator = mkValidator' $ treasuryValidator authorityTokenSymbol
+
+    scripts =
+      AgoraScripts
+        { Scripts.compiledGovernorPolicy = CompiledMintingPolicy compiledGovernorPolicy
+        , Scripts.compiledGovernorValidator = CompiledValidator compiledGovernorValidator
+        , Scripts.compiledStakePolicy = CompiledMintingPolicy compiledStakePolicy
+        , Scripts.compiledStakeValidator = CompiledValidator compiledStakeValidator
+        , Scripts.compiledProposalPolicy = CompiledMintingPolicy compiledProposalPolicy
+        , Scripts.compiledProposalValidator = CompiledValidator compiledProposalValidator
+        , Scripts.compiledTreasuryValidator = CompiledValidator compiledTreasuryValidator
+        , Scripts.compiledAuthorityTokenPolicy = CompiledMintingPolicy compiledAuthorityPolicy
+        }

agora/Agora/Credential.hs

@@ -1,77 +0,0 @@
-{- |
-Module     : Agora.Stake.Scripts
-Maintainer : emi@haskell.fyi
-Description: Functions for dealing with generalized credentials.
-
-Functions for dealing with generalized credentials.
--}
-module Agora.Credential (
-  pauthorizedBy,
-  authorizationContext,
-) where
-
-import GHC.Records (HasField)
-import Plutarch.Api.V1 (PCredential (PPubKeyCredential, PScriptCredential), PPubKeyHash)
-import Plutarch.Api.V2 (PTxInInfo)
-import Plutarch.Extra.ScriptContext (ptxSignedBy)
-import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pmatchC)
-
-{- | Context required in order to check 'AuthorizationCredential'.
-
-     Construct using 'authorizationContext'.
-
-     @since 1.0.0
--}
-data PAuthorizationContext (s :: S) = PAuthorizationContext
-  { signatories :: Term s (PBuiltinList (PAsData PPubKeyHash))
-  , inputs :: Term s (PBuiltinList PTxInInfo)
-  }
-  deriving stock
-    ( -- | @since 1.0.0
-      Generic
-    )
-  deriving anyclass
-    ( -- | @since 1.0.0
-      PlutusType
-    , -- | @since 1.0.0
-      PEq
-    )
-
--- | @since 1.0.0
-instance DerivePlutusType PAuthorizationContext where
-  type DPTStrat _ = PlutusTypeScott
-
-{- | Build up 'PAuthorizationContext' from fields.
-
-     @since 1.0.0
--}
-authorizationContext ::
-  forall (s :: S) (r :: Type).
-  ( HasField "inputs" r (Term s (PBuiltinList PTxInInfo))
-  , HasField "signatories" r (Term s (PBuiltinList (PAsData PPubKeyHash)))
-  ) =>
-  r ->
-  Term s PAuthorizationContext
-authorizationContext f =
-  pcon (PAuthorizationContext f.signatories f.inputs)
-
-{- | Check for authorization by credential.
-
-     @since 1.0.0
--}
-pauthorizedBy :: forall (s :: S). Term s (PAuthorizationContext :--> PCredential :--> PBool)
-pauthorizedBy = phoistAcyclic $
-  plam $ \ctx credential -> unTermCont $ do
-    ctxF <- pmatchC ctx
-    pure $
-      pmatch credential $ \case
-        PPubKeyCredential ((pfield @"_0" #) -> pk) ->
-          ptxSignedBy # ctxF.signatories # pk
-        PScriptCredential ((pfield @"_0" #) -> _) ->
-          pany
-            # plam
-              ( \input ->
-                  (pfield @"credential" #$ pfield @"address" #$ pfield @"resolved" # input)
-                    #== credential
-              )
-            # ctxF.inputs

agora/Agora/Effect.hs

@@ -8,18 +8,17 @@ Helpers for constructing effects.
 module Agora.Effect (makeEffect) where
 
 import Agora.AuthorityToken (singleAuthorityTokenBurned)
-import Agora.SafeMoney (AuthorityTokenTag)
 import Plutarch.Api.V1 (
   PCurrencySymbol,
- )
-import Plutarch.Api.V2 (
   PScriptPurpose (PSpending),
   PTxInfo,
   PTxOutRef,
   PValidator,
+  PValue,
  )
-import Plutarch.Extra.Tagged (PTagged)
-import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
+import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
+import Plutarch.TryFrom ()
+import PlutusLedgerApi.V1.Value (CurrencySymbol)
 
 {- | Helper "template" for creating effect validator.
 
@@ -27,46 +26,36 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFiel
      an effect is implemented. In such situations, it's okay to not use this
      helper.
 
-     @since 1.0.0
+     @since 0.1.0
 -}
 makeEffect ::
-  forall (datum :: PType) (s :: S).
+  forall (datum :: PType).
   (PTryFrom PData datum, PIsData datum) =>
-  ( Term s (PTagged AuthorityTokenTag PCurrencySymbol) ->
-    Term s datum ->
-    Term s PTxOutRef ->
-    Term s (PAsData PTxInfo) ->
-    Term s POpaque
-  ) ->
-  Term s (PAsData (PTagged AuthorityTokenTag PCurrencySymbol)) ->
-  Term s PValidator
-makeEffect f atSymbol' =
+  CurrencySymbol ->
+  (forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
+  ClosedTerm PValidator
+makeEffect gatCs' f =
   plam $ \datum _redeemer ctx' -> unTermCont $ do
-    atSymbol <- pletC $ pfromData atSymbol'
     ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
 
-    -- Convert input datum, PData, into desierable type
+    -- convert input datum, PData, into desierable type
     -- the way this conversion is performed should be defined
     -- by PTryFrom for each datum in effect script.
-    datum' <- fst <$> ptryFromC datum
+    (datum', _) <- ptryFromC datum
 
-    -- Ensure purpose is Spending. Why? The only way that this
-    -- effect script can actually pass any validation onto other
-    -- scripts is by preventing the spend of the GAT.
-    --
-    -- - In the case of GATs which don't get burned, that will
-    --   allow reuse of the GAT.
-    --
-    -- - In the case of GATs which get _referenced_, this script
-    --   won't be run at all, in which case. The auth check needs
-    --   to be especially written with that in mind.
+    -- ensure purpose is Spending.
     PSpending txOutRef <- pmatchC $ pfromData ctx.purpose
     txOutRef' <- pletC (pfield @"_0" # txOutRef)
 
+    -- fetch minted values to ensure single GAT is burned
     txInfo <- pletFieldsC @'["mint", "inputs"] ctx.txInfo
+    let mint :: Term _ (PValue _ _)
+        mint = txInfo.mint
 
-    pguardC "A single authority token has been burned" $
-      singleAuthorityTokenBurned atSymbol txInfo.inputs txInfo.mint
+    -- fetch script context
+    gatCs <- pletC $ pconstant gatCs'
+
+    pguardC "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo.inputs mint
 
     -- run effect function
-    pure $ f atSymbol datum' txOutRef' ctx.txInfo
+    pure $ f gatCs datum' txOutRef' ctx.txInfo

agora/Agora/Effect/GovernorMutation.hs

@@ -21,43 +21,32 @@ module Agora.Effect.GovernorMutation (
 import Agora.Effect (makeEffect)
 import Agora.Governor (
   GovernorDatum,
-  GovernorRedeemer (MutateGovernor),
-  PGovernorDatum (PGovernorDatum),
-  PGovernorRedeemer,
+  PGovernorDatum,
+  pisGovernorDatumValid,
  )
-import Agora.Proposal (PProposalId)
-import Agora.SafeMoney (AuthorityTokenTag, GovernorSTTag)
-import Agora.Utils (pfindInputWithStateThreadToken, pfindOutputWithStateThreadToken)
-import Generics.SOP qualified as SOP
-import Plutarch.Api.V1 (PCurrencySymbol)
-import Plutarch.Api.V2 (
-  PScriptHash,
-  PScriptPurpose (PSpending),
+import Agora.Plutarch.Orphans ()
+import Agora.Scripts (AgoraScripts, authorityTokenSymbol, governorSTAssetClass)
+import Plutarch.Api.V1 (
+  PTxOutRef,
   PValidator,
+  PValue,
  )
+import Plutarch.Api.V1.ScriptContext (pisScriptAddress, ptryFindDatum)
+import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (pvalueOf)
 import Plutarch.DataRepr (
+  DerivePConstantViaData (..),
   PDataFields,
  )
-import Plutarch.Extra.Field (pletAll, pletAllC)
-import Plutarch.Extra.IsData (
-  DerivePConstantViaDataList (DerivePConstantViaDataList),
-  PlutusTypeDataList,
-  ProductIsData (ProductIsData),
+import Plutarch.Extra.Maybe (
+  passertPDJust,
+  passertPJust,
  )
-import Plutarch.Extra.Maybe (passertPJust, pfromJust)
-import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
-import Plutarch.Extra.ScriptContext (
-  pisScriptAddress,
-  pscriptHashFromAddress,
-  ptryFromOutputDatum,
-  ptryFromRedeemer,
- )
-import Plutarch.Extra.Tagged (PTagged)
+import Plutarch.Extra.TermCont (pguardC, pletFieldsC)
 import Plutarch.Lift (PConstantDecl, PLifted, PUnsafeLiftDecl)
+import PlutusLedgerApi.V1 (TxOutRef)
+import PlutusLedgerApi.V1.Value (AssetClass (..))
 import PlutusTx qualified
 
-import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC)
-
 --------------------------------------------------------------------------------
 
 {- | Haskell-level datum for the governor mutation effect script.
@@ -65,8 +54,8 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFiel
      @since 0.1.0
 -}
 data MutateGovernorDatum = MutateGovernorDatum
-  { oldDatum :: GovernorDatum
-  -- ^ The governor datum value on which this effect is valid
+  { governorRef :: TxOutRef
+  -- ^ Referenced governor state UTXO should be updated by the effect.
   , newDatum :: GovernorDatum
   -- ^ The new settings for the governor.
   }
@@ -76,17 +65,8 @@ data MutateGovernorDatum = MutateGovernorDatum
     , -- | @since 0.1.ç
       Generic
     )
-  deriving anyclass
-    ( -- | @since 1.0.0
-      SOP.Generic
-    )
-  deriving
-    ( -- | @since 1.0.0
-      PlutusTx.ToData
-    , -- | @since 1.0.0
-      PlutusTx.FromData
-    )
-    via (ProductIsData MutateGovernorDatum)
+
+PlutusTx.makeIsDataIndexed ''MutateGovernorDatum [('MutateGovernorDatum, 0)]
 
 --------------------------------------------------------------------------------
 
@@ -99,7 +79,7 @@ newtype PMutateGovernorDatum (s :: S)
       ( Term
           s
           ( PDataRecord
-              '[ "oldDatum" ':= PGovernorDatum
+              '[ "governorRef" ':= PTxOutRef
                , "newDatum" ':= PGovernorDatum
                ]
           )
@@ -120,20 +100,16 @@ newtype PMutateGovernorDatum (s :: S)
     )
 
 instance DerivePlutusType PMutateGovernorDatum where
-  type DPTStrat _ = PlutusTypeDataList
+  type DPTStrat _ = PlutusTypeData
 
 -- | @since 0.1.0
-instance PUnsafeLiftDecl PMutateGovernorDatum where
-  type PLifted PMutateGovernorDatum = MutateGovernorDatum
+instance PUnsafeLiftDecl PMutateGovernorDatum where type PLifted PMutateGovernorDatum = MutateGovernorDatum
 
 -- | @since 0.1.0
-deriving via
-  (DerivePConstantViaDataList MutateGovernorDatum PMutateGovernorDatum)
-  instance
-    (PConstantDecl MutateGovernorDatum)
+deriving via (DerivePConstantViaData MutateGovernorDatum PMutateGovernorDatum) instance (PConstantDecl MutateGovernorDatum)
 
 -- | @since 0.1.0
-deriving anyclass instance PTryFrom PData (PAsData PMutateGovernorDatum)
+deriving anyclass instance PTryFrom PData PMutateGovernorDatum
 
 --------------------------------------------------------------------------------
 
@@ -160,137 +136,83 @@ deriving anyclass instance PTryFrom PData (PAsData PMutateGovernorDatum)
          * It has valid governor state datum.
          * The datum is exactly the same as the 'newDatum'.
 
-     @since 1.0.0
+     @since 0.1.0
 -}
 mutateGovernorValidator ::
-  ClosedTerm
-    ( PAsData PScriptHash
-        :--> PAsData (PTagged GovernorSTTag PCurrencySymbol)
-        :--> PAsData (PTagged AuthorityTokenTag PCurrencySymbol)
-        :--> PValidator
-    )
-mutateGovernorValidator =
-  plam $ \govValidatorHash gstSymbol -> makeEffect @(PAsData PMutateGovernorDatum) $
-    \_gatCs (pfromData -> effectDatum) _ txInfo -> unTermCont $ do
-      effectDatumF <- pletAllC effectDatum
-      txInfoF <- pletFieldsC @'["inputs", "outputs", "datums", "redeemers"] txInfo
+  -- | Lazy precompiled scripts. This is beacuse we need the symbol of GST.
+  AgoraScripts ->
+  ClosedTerm PValidator
+mutateGovernorValidator as = makeEffect (authorityTokenSymbol as) $
+  \_gatCs (datum :: Term _ PMutateGovernorDatum) _ txInfo -> unTermCont $ do
+    datumF <- pletFieldsC @'["newDatum", "governorRef"] datum
+    txInfoF <- pletFieldsC @'["mint", "inputs", "outputs", "datums"] txInfo
 
-      --------------------------------------------------------------------------
+    let mint :: Term _ (PBuiltinList _)
+        mint = pto $ pto $ pto $ pfromData txInfoF.mint
 
-      scriptInputs <-
-        pletC $
-          pfilter
-            # plam
-              ( \inInfo ->
-                  pisScriptAddress
-                    #$ pfield @"address"
-                    #$ pfield @"resolved"
-                    # inInfo
+    pguardC "Nothing should be minted/burnt other than GAT" $
+      plength # mint #== 1
+
+    -- Only two script inputs are alloed: one from the effect, one from the governor.
+    pguardC "Only self and governor script inputs are allowed" $
+      pfoldr
+        # phoistAcyclic
+          ( plam $ \inInfo count ->
+              let address = pfield @"address" #$ pfield @"resolved" # inInfo
+               in pif
+                    (pisScriptAddress # address)
+                    (count + 1)
+                    count
+          )
+        # (0 :: Term _ PInteger)
+        # pfromData txInfoF.inputs
+        #== 2
+
+    -- Find the governor input by looking for GST.
+    let inputWithGST =
+          passertPJust # "Governor input not found" #$ pfind
+            # phoistAcyclic
+              ( plam $ \inInfo ->
+                  let value = pfield @"value" #$ pfield @"resolved" # inInfo
+                   in gstValueOf # value #== 1
               )
             # pfromData txInfoF.inputs
 
-      -- Only two script inputs are alloed: one from the effect script, another from the governor.
-      pguardC "Only self and governor script inputs are allowed" $
-        plength # scriptInputs #== 2
+    govInInfo <- pletFieldsC @'["outRef", "resolved"] $ inputWithGST
 
-      let
-        governorInput =
-          passertPJust
-            # "Governor UTXO should carry GST"
-            # ( pfindInputWithStateThreadToken
-                  # pfromData gstSymbol
-                  # scriptInputs
-              )
+    -- The effect can only modify the governor UTXO referenced in the datum.
+    pguardC "Can only modify the pinned governor" $
+      govInInfo.outRef #== datumF.governorRef
 
-        governorRef = pfield @"outRef" # governorInput
+    -- The transaction can only have one output, which should be sent to the governor.
+    pguardC "Only governor output is allowed" $
+      plength # pfromData txInfoF.outputs #== 1
 
-        governorInputDatum =
-          ptrace "Resolve governor input datum" $
-            pfromData $
-              ptryFromOutputDatum @(PAsData PGovernorDatum)
-                # (pfield @"datum" #$ pfield @"resolved" # governorInput)
-                # txInfoF.datums
+    let govAddress = pfield @"address" #$ govInInfo.resolved
+        govOutput' = phead # pfromData txInfoF.outputs
 
-        inputProposalId = pfield @"nextProposalId" # governorInputDatum
+    govOutput <- pletFieldsC @'["address", "value", "datumHash"] govOutput'
 
-        expectedInputDatum =
-          replaceProposalId # effectDatumF.oldDatum # inputProposalId
+    pguardC "No output to the governor" $
+      govOutput.address #== govAddress
 
-      pguardC "Governor input should be valid" $
-        ( pletAll governorInput $ \inputF ->
-            let
-              isGovernorInput =
-                foldl1
-                  (#&&)
-                  [ ptraceIfFalse "Can only modify the pinned governor datum" $
-                      governorInputDatum #== expectedInputDatum
-                  , ptraceIfFalse "Governor validator run" $
-                      let inputScriptHash =
-                            pfromJust
-                              #$ pscriptHashFromAddress
-                              #$ pfield @"address"
-                              # inputF.resolved
-                       in inputScriptHash #== pfromData govValidatorHash
-                  ]
-             in
-              isGovernorInput
-        )
-
-      let
-        governorRedeemer =
-          pfromData $
-            passertPJust
-              # "Governor redeemer should be resolved"
-              #$ ptryFromRedeemer @(PAsData PGovernorRedeemer)
-              # mkRecordConstr PSpending (#_0 .= governorRef)
-              # txInfoF.redeemers
-
-      pguardC "Spend governor with redeemer MutateGovernor" $
-        governorRedeemer #== pconstant MutateGovernor
-
-      ----------------------------------------------------------------------------
-
-      let
-        governorOutput =
-          passertPJust
-            # "No governor output found"
-            #$ pfindOutputWithStateThreadToken
-            # pfromData gstSymbol
-            # pfromData txInfoF.outputs
+    pguardC "Governor output doesn't carry the GST" $
+      gstValueOf # govOutput.value #== 1
 
+    let governorOutputDatumHash =
+          passertPDJust # "Governor output doesn't have datum" # govOutput.datumHash
         governorOutputDatum =
-          ptrace "Resolve governor outoput datum" $
-            pfromData $
-              ptryFromOutputDatum @(PAsData PGovernorDatum)
-                # (pfield @"datum" # governorOutput)
-                # txInfoF.datums
+          passertPJust @PGovernorDatum # "Governor output datum not found"
+            #$ ptryFindDatum # governorOutputDatumHash # txInfoF.datums
 
-        expectedOutputDatum =
-          replaceProposalId # effectDatumF.newDatum # inputProposalId
+    -- Ensure the output governor datum is what we want.
+    pguardC "Unexpected governor datum" $ datumF.newDatum #== governorOutputDatum
+    pguardC "New governor datum should be valid" $ pisGovernorDatumValid # governorOutputDatum
 
-      pguardC "New governor datum correct" $
-        governorOutputDatum #== expectedOutputDatum
-
-      return $ popaque $ pconstant ()
+    return $ popaque $ pconstant ()
   where
-    replaceProposalId ::
-      ClosedTerm
-        ( PGovernorDatum
-            :--> PAsData PProposalId
-            :--> PGovernorDatum
-        )
-    replaceProposalId = plam $ \datum proposalId ->
-      pletAll datum $ \datumF ->
-        mkRecordConstr
-          PGovernorDatum
-          ( #proposalThresholds
-              .= datumF.proposalThresholds
-              .& #nextProposalId
-              .= proposalId
-              .& #proposalTimings
-              .= datumF.proposalTimings
-              .& #createProposalTimeRangeMaxWidth
-              .= datumF.createProposalTimeRangeMaxWidth
-              .& #maximumCreatedProposalsPerStake
-              .= datumF.maximumCreatedProposalsPerStake
-          )
+    -- Get the amount of GST in the a given value.
+    gstValueOf :: Term s (PValue _ _ :--> PInteger)
+    gstValueOf = phoistAcyclic $ plam $ \v -> pvalueOf # v # pconstant cs # pconstant tn
+      where
+        AssetClass (cs, tn) = governorSTAssetClass as

agora/Agora/Effect/NoOp.hs

@@ -8,10 +8,9 @@ A dumb effect that only burns its GAT.
 module Agora.Effect.NoOp (noOpValidator, PNoOp) where
 
 import Agora.Effect (makeEffect)
-import Agora.SafeMoney (AuthorityTokenTag)
-import Plutarch.Api.V1 (PCurrencySymbol)
-import Plutarch.Api.V2 (PValidator)
-import Plutarch.Extra.Tagged (PTagged)
+import Agora.Plutarch.Orphans ()
+import Plutarch.Api.V1 (PValidator)
+import PlutusLedgerApi.V1.Value (CurrencySymbol)
 
 {- | Dummy datum for NoOp effect.
 
@@ -38,9 +37,8 @@ instance PTryFrom PData (PAsData PNoOp)
 
 {- | Dummy effect which can only burn its GAT.
 
-     @since 1.0.0
+     @since 0.1.0
 -}
-noOpValidator :: ClosedTerm (PAsData (PTagged AuthorityTokenTag PCurrencySymbol) :--> PValidator)
-noOpValidator = plam $
-  makeEffect $
-    \_ (_datum :: Term s (PAsData PNoOp)) _ _ -> popaque (pconstant ())
+noOpValidator :: CurrencySymbol -> ClosedTerm PValidator
+noOpValidator curr = makeEffect curr $
+  \_ (_datum :: Term s (PAsData PNoOp)) _ _ -> popaque (pconstant ())

agora/Agora/Effect/TreasuryWithdrawal.hs

@@ -9,50 +9,32 @@ An Effect that withdraws treasury deposit
 -}
 module Agora.Effect.TreasuryWithdrawal (
   TreasuryWithdrawalDatum (..),
-  PTreasuryWithdrawalDatum (PTreasuryWithdrawalDatum),
+  PTreasuryWithdrawalDatum (..),
   treasuryWithdrawalValidator,
 ) where
 
 import Agora.Effect (makeEffect)
-import Agora.SafeMoney (AuthorityTokenTag)
-import Agora.Utils (pisSubValueOf, psubtractSortedValue, puncurryTuple)
-import Generics.SOP qualified as SOP
-import Plutarch.Api.Internal.Hashing (hashData)
-import Plutarch.Api.V1 (PCredential, PCurrencySymbol, PValue)
-import Plutarch.Api.V1.Address (PCredential (PPubKeyCredential))
-import Plutarch.Api.V1.Value (pforgetPositive)
-import Plutarch.Api.V2 (
+import Agora.Plutarch.Orphans ()
+import Plutarch.Api.V1 (
   AmountGuarantees (Positive),
   KeyGuarantees (Sorted),
+  PCredential (..),
   PTuple,
-  PTxInInfo,
-  PTxOut,
   PValidator,
+  PValue,
+  ptuple,
  )
-import Plutarch.Api.V2.Tx (POutputDatum (..))
+import Plutarch.Api.V1.ScriptContext (pfindTxInByTxOutRef, pisPubKey)
+import "plutarch" Plutarch.Api.V1.Value (pnormalize)
 import Plutarch.DataRepr (
+  DerivePConstantViaData (..),
   PDataFields,
  )
-import Plutarch.Extra.Field (pletAllC)
-import Plutarch.Extra.IsData (
-  DerivePConstantViaDataList (
-    DerivePConstantViaDataList
-  ),
-  ProductIsData (ProductIsData),
- )
-import Plutarch.Extra.ScriptContext (pisPubKey)
-import Plutarch.Extra.Tagged (PTagged)
-import Plutarch.Extra.Traversable (pfoldMap)
-import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
+import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC)
+import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
 import PlutusLedgerApi.V1.Credential (Credential)
-import PlutusLedgerApi.V1.Scripts (DatumHash (DatumHash))
-import PlutusLedgerApi.V1.Value (Value)
+import PlutusLedgerApi.V1.Value (CurrencySymbol, Value)
 import PlutusTx qualified
-import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
-  pguardC,
-  pletC,
-  pletFieldsC,
- )
 
 {- | Datum that encodes behavior of Treasury Withdrawal effect.
 
@@ -74,17 +56,12 @@ data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum
     , -- | @since 0.1.0
       Generic
     )
-  deriving anyclass
-    ( -- | @since 1.0.0
-      SOP.Generic
-    )
-  deriving
-    ( -- | @since 1.0.0
-      PlutusTx.ToData
-    , -- | @since 1.0.0
-      PlutusTx.FromData
-    )
-    via (ProductIsData TreasuryWithdrawalDatum)
+
+-- | @since 0.1.0
+PlutusTx.makeLift ''TreasuryWithdrawalDatum
+
+-- | @since 0.1.0
+PlutusTx.makeIsDataIndexed ''TreasuryWithdrawalDatum [('TreasuryWithdrawalDatum, 0)]
 
 {- | Haskell-level version of 'TreasuryWithdrawalDatum'.
 
@@ -114,7 +91,7 @@ newtype PTreasuryWithdrawalDatum (s :: S)
     )
 
 instance DerivePlutusType PTreasuryWithdrawalDatum where
-  type DPTStrat _ = PlutusTypeNewtype
+  type DPTStrat _ = PlutusTypeData
 
 -- | @since 0.1.0
 instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where
@@ -122,12 +99,12 @@ instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where
 
 -- | @since 0.1.0
 deriving via
-  (DerivePConstantViaDataList TreasuryWithdrawalDatum PTreasuryWithdrawalDatum)
+  (DerivePConstantViaData TreasuryWithdrawalDatum PTreasuryWithdrawalDatum)
   instance
     (PConstantDecl TreasuryWithdrawalDatum)
 
 -- | @since 0.1.0
-instance PTryFrom PData (PAsData PTreasuryWithdrawalDatum)
+instance PTryFrom PData PTreasuryWithdrawalDatum
 
 {- | Withdraws given list of values to specific target addresses.
      It can be evoked by burning GAT. The transaction should have correct
@@ -142,156 +119,77 @@ instance PTryFrom PData (PAsData PTreasuryWithdrawalDatum)
 
        2. Left over assets should be redirected back to Treasury
 
-    The output order should be:
+     It can be more flexiable over...
 
-      1. Receiver outputs. They should be in the same order as the 'receivers' field of the datum.
+     - The number of outputs themselves
 
-      2. Other outputs: treasury outputs, colleteral outputs, etc.
-
-     @since 1.0.0
+     @since 0.1.0
 -}
-treasuryWithdrawalValidator ::
-  forall (s :: S).
-  Term s (PAsData (PTagged AuthorityTokenTag PCurrencySymbol) :--> PValidator)
-treasuryWithdrawalValidator = plam $
-  makeEffect @(PAsData PTreasuryWithdrawalDatum) $
-    \_cs (pfromData -> datum) effectInputRef txInfo -> unTermCont $ do
-      datumF <- pletAllC datum
-      txInfoF <- pletFieldsC @'["outputs", "inputs"] txInfo
-
-      let
-        -- Validate the input and if it's from one of the treasuries,
-        --  return the value.
-        --
-        -- Only effect inputs, treasury inputs and public key inputs are
-        --  allowed.
-        extractTreasuryInputValue ::
-          Term _ (PTxInInfo :--> PValue 'Sorted 'Positive)
-        extractTreasuryInputValue = plam $ \input -> unTermCont $ do
-          inputF <- pletAllC input
-          resolvedF <- pletFieldsC @'["address", "value"] inputF.resolved
-
-          cred <- pletC $ pfield @"credential" # resolvedF.address
-
-          let isEffectInput =
-                ptraceIfTrue "Effect input" $
-                  inputF.outRef #== effectInputRef
-              isTreasuryInput =
-                ptraceIfTrue "Treasury input" $
-                  pelem # pdata cred # datumF.treasuries
-              isPubkeyInput =
-                ptraceIfTrue "Pubkey input" $
-                  pisPubKey # cred
-          pure
-            $ pif
-              (isEffectInput #|| isPubkeyInput)
-              mempty
-            $ pif isTreasuryInput resolvedF.value
-            $ ptraceError "Unknown input"
-
-        treasuryInputAmount =
-          pfoldMap
-            # extractTreasuryInputValue
-            # txInfoF.inputs
-
-        sentAmout =
-          pfoldMap
-            # plam ((puncurryTuple # plam (const id) #) . pfromData)
-            # pfromData datumF.receivers
-
-        treasuryLeftOverAmount =
-          psubtractSortedValue
-            # treasuryInputAmount
-            # sentAmout
-
-        remainingOutputs =
-          ptrace "Check receiver outputs" $
-            checkReceiverOutputs
-              # datumF.receivers
-              # txInfoF.outputs
-
-        extractTreasuryOutputValue ::
-          Term _ (PTxOut :--> PValue 'Sorted 'Positive)
-        extractTreasuryOutputValue = plam $
-          flip (pletFields @'["address", "value", "datum"]) $ \outputF ->
-            let cred = pfield @"credential" # outputF.address
-
-                isTreasuryOutput =
-                  ptraceIfFalse "Should sent to one of the treasuries" $
-                    pelem # pdata cred # datumF.treasuries
-
-                isDatumValid =
-                  ptraceIfFalse "Valid output datum" $
-                    checkOutputDatum # cred # outputF.datum
-             in pif
-                  (isTreasuryOutput #&& isDatumValid)
-                  outputF.value
-                  mempty
-
-        -- Return the value if it'll be sent to one of the treasuries.
-        treasuryOutputAmount =
-          pfoldMap
-            # extractTreasuryOutputValue
-            # remainingOutputs
-
-      pguardC "Unused treasury should stay at treasury validators" $
-        treasuryLeftOverAmount #== pforgetPositive treasuryOutputAmount
-
-      pure . popaque $ pconstant ()
-  where
-    -- Make sure that all the receivers get the correct payment, return the
-    --  remaining outputs.
-    --
-    -- This function is not hoisted cause it's used only once.
-    checkReceiverOutputs ::
-      Term
-        s
-        ( PBuiltinList
-            (PAsData (PTuple PCredential (PValue 'Sorted 'Positive)))
-            :--> PBuiltinList PTxOut
-            :--> PBuiltinList PTxOut
-        )
-    checkReceiverOutputs = pfix #$ plam $ \self receivers outputs ->
-      pelimList
-        ( \r rs ->
-            pelimList
-              ( \o os -> pletFields @'["value", "address", "datum"] o $ \oF ->
-                  let isValidReceiverOutput =
-                        puncurryTuple
-                          # plam
-                            ( \expCred expVal ->
-                                foldl1
-                                  (#&&)
-                                  [ ptraceIfFalse "Valid credential" $
-                                      expCred #== pfield @"credential" # oF.address
-                                  , ptraceIfFalse "Valid value" $
-                                      pisSubValueOf # oF.value # expVal
-                                  , ptraceIfFalse "Valid output datum" $
-                                      checkOutputDatum # expCred # oF.datum
-                                  ]
-                            )
-                          # pfromData r
-                   in pif
-                        isValidReceiverOutput
-                        (self # rs # os)
-                        (ptraceError "Invalid receiver output")
+treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
+treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
+  \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> unTermCont $ do
+    datum <- pletFieldsC @'["receivers", "treasuries"] datum'
+    txInfo <- pletFieldsC @'["outputs", "inputs"] txInfo'
+    PJust ((pfield @"resolved" #) -> txOut) <- pmatchC $ pfindTxInByTxOutRef # txOutRef' # pfromData txInfo.inputs
+    effInput <- pletFieldsC @'["address", "value"] $ txOut
+    outputValues <-
+      pletC $
+        pmap
+          # plam
+            ( \txOut' -> unTermCont $ do
+                txOut <- pletFieldsC @'["address", "value"] $ txOut'
+                let cred = pfield @"credential" # pfromData txOut.address
+                pure . pdata $ ptuple # cred # txOut.value
+            )
+          # pfromData txInfo.outputs
+    inputValues <-
+      pletC $
+        pmap
+          # plam
+            ( \((pfield @"resolved" #) -> txOut') -> unTermCont $ do
+                txOut <- pletFieldsC @'["address", "value"] $ txOut'
+                let cred = pfield @"credential" # pfromData txOut.address
+                pure . pdata $ ptuple # cred # txOut.value
+            )
+          # txInfo.inputs
+    let ofTreasury =
+          pfilter
+            # plam (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
+        sumValues = phoistAcyclic $
+          plam $ \v ->
+            pnormalize
+              #$ pfoldr
+              # plam (\(pfromData . (pfield @"_1" #) -> x) y -> x <> y)
+              # mempty
+              # v
+        treasuryInputValuesSum = sumValues #$ ofTreasury # inputValues
+        treasuryOutputValuesSum = sumValues #$ ofTreasury # outputValues
+        receiverValuesSum = sumValues # datum.receivers
+        -- Constraints
+        outputContentMatchesRecivers =
+          pall # plam (\out -> pelem # out # outputValues)
+            #$ datum.receivers
+        excessShouldBePaidToInputs =
+          treasuryOutputValuesSum <> receiverValuesSum #== treasuryInputValuesSum
+        shouldNotPayToEffect =
+          pnot #$ pany
+            # plam
+              ( \x ->
+                  effInput.address #== pfield @"address" # x
               )
-              (ptraceError "Unable to exhaust receivers")
-              outputs
-        )
-        outputs
-        receivers
+            # pfromData txInfo.outputs
+        inputsAreOnlyTreasuriesOrCollateral =
+          pall
+            # plam
+              ( \((pfield @"_0" #) . pfromData -> cred) ->
+                  cred #== pfield @"credential" # effInput.address
+                    #|| pelem # cred # datum.treasuries
+                    #|| pisPubKey # pfromData cred
+              )
+            # inputValues
 
-    unitDatum = PlutusTx.toData ()
-
-    unitDatumHash = DatumHash $ hashData unitDatum
-
-    checkOutputDatum :: Term s (PCredential :--> POutputDatum :--> PBool)
-    checkOutputDatum = phoistAcyclic $ plam $ \cred datum -> pmatch cred $
-      \case
-        PPubKeyCredential _ -> pcon PTrue
-        _ -> pmatch datum $ \case
-          PNoOutputDatum _ -> pcon PFalse
-          POutputDatum _ -> pcon PTrue
-          POutputDatumHash ((pfield @"datumHash" #) -> hash) ->
-            pconstant unitDatumHash #== hash
+    pguardC "Transaction should not pay to effects" shouldNotPayToEffect
+    pguardC "Transaction output does not match receivers" outputContentMatchesRecivers
+    pguardC "Remainders should be returned to the treasury" excessShouldBePaidToInputs
+    pguardC "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuriesOrCollateral
+    pure . popaque $ pconstant ()

agora/Agora/Governor.hs

@@ -21,13 +21,11 @@ module Agora.Governor (
   pgetNextProposalId,
   getNextProposalId,
   pisGovernorDatumValid,
-  presolveGovernorRedeemer,
 ) where
 
-import Agora.Aeson.Orphans ()
 import Agora.Proposal (
-  PProposalId (PProposalId),
-  PProposalThresholds,
+  PProposalId (..),
+  PProposalThresholds (..),
   ProposalId (ProposalId),
   ProposalThresholds,
   pisProposalThresholdsValid,
@@ -40,37 +38,22 @@ import Agora.Proposal.Time (
   pisMaxTimeRangeWidthValid,
   pisProposalTimingConfigValid,
  )
-import Agora.SafeMoney (GTTag, GovernorSTTag)
-import Data.Aeson qualified as Aeson
-import Data.Tagged (Tagged)
-import Generics.SOP qualified as SOP
-import Optics.TH (makeFieldLabelsNoPrefix)
-import Plutarch.Api.V1.Scripts (PRedeemer)
-import Plutarch.Api.V2 (KeyGuarantees (Unsorted), PMap, PScriptPurpose (PSpending), PTxInInfo)
-import Plutarch.DataRepr (PDataFields)
-import Plutarch.Extra.AssetClass (AssetClass, PAssetClass)
-import Plutarch.Extra.Bind (PBind ((#>>=)))
-import Plutarch.Extra.Field (pletAll)
-import Plutarch.Extra.Function (pflip)
-import Plutarch.Extra.Functor (PFunctor (pfmap))
-import Plutarch.Extra.IsData (
-  DerivePConstantViaDataList (DerivePConstantViaDataList),
-  DerivePConstantViaEnum (DerivePConstantEnum),
-  EnumIsData (EnumIsData),
-  PlutusTypeDataList,
-  PlutusTypeEnumData,
-  ProductIsData (ProductIsData),
+import Agora.SafeMoney (GTTag)
+import Data.Tagged (Tagged (..))
+import Plutarch.DataRepr (
+  DerivePConstantViaData (..),
+  PDataFields,
  )
-import Plutarch.Extra.Maybe (pjust, pnothing)
-import Plutarch.Extra.Record (mkRecordConstr, (.=))
-import Plutarch.Extra.ScriptContext (ptryFromRedeemer)
-import Plutarch.Extra.Tagged (PTagged)
-import Plutarch.Extra.Value (passetClassValueOfT)
-import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
+import Plutarch.Extra.IsData (
+  DerivePConstantViaEnum (..),
+  EnumIsData (..),
+  PlutusTypeEnumData,
+ )
+import Plutarch.Extra.TermCont (pletFieldsC)
+import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
 import PlutusLedgerApi.V1 (TxOutRef)
+import PlutusLedgerApi.V1.Value (AssetClass (..))
 import PlutusTx qualified
-import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
-import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletFieldsC)
 
 --------------------------------------------------------------------------------
 
@@ -88,8 +71,9 @@ data GovernorDatum = GovernorDatum
   --   Will get copied over upon the creation of proposals.
   , createProposalTimeRangeMaxWidth :: MaxTimeRangeWidth
   -- ^ The maximum valid duration of a transaction that creats a proposal.
-  , maximumCreatedProposalsPerStake :: Integer
-  -- ^ The maximum number of proposals created by any given stakes.
+  , maximumProposalsPerStake :: Integer
+  -- ^ The maximum number of unfinished proposals that a stake is allowed to be
+  --   associated to.
   }
   deriving stock
     ( -- | @since 0.1.0
@@ -97,17 +81,9 @@ data GovernorDatum = GovernorDatum
     , -- | @since 0.1.0
       Generic
     )
-  deriving anyclass
-    ( -- | @since 1.0.0
-      SOP.Generic
-    )
-  deriving
-    ( -- | @since 1.0.0
-      PlutusTx.ToData
-    , -- | @since 1.0.0
-      PlutusTx.FromData
-    )
-    via (ProductIsData GovernorDatum)
+
+-- | @since 0.1.0
+PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)]
 
 {- | Redeemer for Governor script. The governor has two primary
      responsibilities:
@@ -164,14 +140,6 @@ data Governor = Governor
     , -- | @since 0.2.0
       Show
     )
-  deriving anyclass
-    ( -- | @since 1.0.0
-      Aeson.ToJSON
-    , -- | @since 1.0.0
-      Aeson.FromJSON
-    )
-
-makeFieldLabelsNoPrefix ''Governor
 
 --------------------------------------------------------------------------------
 
@@ -188,7 +156,7 @@ newtype PGovernorDatum (s :: S) = PGovernorDatum
              , "nextProposalId" ':= PProposalId
              , "proposalTimings" ':= PProposalTimingConfig
              , "createProposalTimeRangeMaxWidth" ':= PMaxTimeRangeWidth
-             , "maximumCreatedProposalsPerStake" ':= PInteger
+             , "maximumProposalsPerStake" ':= PInteger
              ]
         )
   }
@@ -205,25 +173,20 @@ newtype PGovernorDatum (s :: S) = PGovernorDatum
       PDataFields
     , -- | @since 0.1.0
       PEq
-    , -- | @since 0.2.1
-      PShow
     )
 
 -- | @since 0.2.0
 instance DerivePlutusType PGovernorDatum where
-  type DPTStrat _ = PlutusTypeDataList
+  type DPTStrat _ = PlutusTypeData
 
 -- | @since 0.1.0
-instance PUnsafeLiftDecl PGovernorDatum where type PLifted _ = GovernorDatum
+instance PUnsafeLiftDecl PGovernorDatum where type PLifted PGovernorDatum = GovernorDatum
 
 -- | @since 0.1.0
-deriving via
-  (DerivePConstantViaDataList GovernorDatum PGovernorDatum)
-  instance
-    (PConstantDecl GovernorDatum)
+deriving via (DerivePConstantViaData GovernorDatum PGovernorDatum) instance (PConstantDecl GovernorDatum)
 
 -- | @since 0.1.0
-deriving anyclass instance PTryFrom PData (PAsData PGovernorDatum)
+deriving anyclass instance PTryFrom PData PGovernorDatum
 
 {- | Plutarch-level version of 'GovernorRedeemer'.
 
@@ -269,7 +232,7 @@ deriving via (DerivePConstantViaEnum GovernorRedeemer PGovernorRedeemer) instanc
 
      @since 0.1.0
 -}
-pgetNextProposalId :: forall (s :: S). Term s (PProposalId :--> PProposalId)
+pgetNextProposalId :: Term s (PProposalId :--> PProposalId)
 pgetNextProposalId = phoistAcyclic $ plam $ \(pto -> pid) -> pcon $ PProposalId $ pid + 1
 
 {- | Get next proposal id.
@@ -285,7 +248,7 @@ getNextProposalId (ProposalId pid) = ProposalId $ pid + 1
 
      @since 0.1.0
 -}
-pisGovernorDatumValid :: forall (s :: S). Term s (PGovernorDatum :--> PBool)
+pisGovernorDatumValid :: Term s (PGovernorDatum :--> PBool)
 pisGovernorDatumValid = phoistAcyclic $
   plam $ \datum -> unTermCont $ do
     datumF <-
@@ -306,53 +269,3 @@ pisGovernorDatumValid = phoistAcyclic $
         , ptraceIfFalse "time range valid" $
             pisMaxTimeRangeWidthValid # datumF.createProposalTimeRangeMaxWidth
         ]
-
-{- | Find the governor input and resolve the corresponding governor redeemer,
-     given the assetclass of GST.
-
-     @since 1.0.0
--}
-presolveGovernorRedeemer ::
-  forall (s :: S).
-  Term
-    s
-    ( PTagged GovernorSTTag PAssetClass
-        :--> PBuiltinList PTxInInfo
-        :--> PMap 'Unsorted PScriptPurpose PRedeemer
-        :--> PMaybe PGovernorRedeemer
-    )
-presolveGovernorRedeemer = phoistAcyclic $
-  plam $ \gstClass inputs redeemers ->
-    let governorInputRef =
-          pfindJust
-            # plam
-              ( flip pletAll $ \inputF ->
-                  let value = pfield @"value" # inputF.resolved
-                      isGovernorInput =
-                        passetClassValueOfT
-                          # gstClass
-                          # value
-                          #== 1
-                   in pif
-                        isGovernorInput
-                        (pjust # inputF.outRef)
-                        pnothing
-              )
-            # inputs
-
-        governorScriptPurpose =
-          pfmap
-            # plam
-              ( \ref ->
-                  mkRecordConstr
-                    PSpending
-                    (#_0 .= ref)
-              )
-            # governorInputRef
-
-        governorRedeemer =
-          governorScriptPurpose
-            #>>= pflip
-            # ptryFromRedeemer @(PAsData PGovernorRedeemer)
-            # redeemers
-     in pfmap # plam pfromData # governorRedeemer

agora/Agora/Governor/Scripts.hs

@@ -21,8 +21,8 @@ import Agora.AuthorityToken (
   singleAuthorityTokenBurned,
  )
 import Agora.Governor (
+  GovernorRedeemer (..),
   PGovernorDatum (PGovernorDatum),
-  PGovernorRedeemer (..),
   pgetNextProposalId,
   pisGovernorDatumValid,
  )
@@ -35,43 +35,52 @@ import Agora.Proposal (
   pneutralOption,
   pwinner,
  )
-import Agora.Proposal.Time (pvalidateProposalStartingTime)
-import Agora.SafeMoney (AuthorityTokenTag, GovernorSTTag, ProposalSTTag, StakeSTTag)
+import Agora.Proposal.Time (createProposalStartingTime)
+import Agora.Scripts (AgoraScripts, authorityTokenSymbol, governorSTSymbol, proposalSTSymbol, proposalValidatoHash, stakeSTSymbol)
 import Agora.Stake (
+  PProposalLock (..),
+  PStakeDatum (..),
   pnumCreatedProposals,
-  presolveStakeInputDatum,
  )
-import Agora.Utils (phashDatum, ptaggedSymbolValueOf, ptoScottEncodingT, puntag)
-import Data.Function (on)
-import Plutarch.Api.V1 (PCurrencySymbol)
-import Plutarch.Api.V1.AssocMap (plookup)
-import Plutarch.Api.V1.AssocMap qualified as AssocMap
-import Plutarch.Api.V2 (PDatum, PMintingPolicy, PScriptHash, PScriptPurpose (PMinting, PSpending), PTxOut, PTxOutRef, PValidator)
-import Plutarch.Api.V2.Tx (POutputDatum (..))
-import Plutarch.Extra.AssetClass (PAssetClassData, passetClass)
-import Plutarch.Extra.Field (pletAll, pletAllC)
-import Plutarch.Extra.Maybe (passertPJust, pfromMaybe, pjust, pmaybeData, pnothing)
-import Plutarch.Extra.Ord (POrdering (..), pcompareBy, pfromOrd, psort)
-import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
-import Plutarch.Extra.ScriptContext (
+import Agora.Utils (
+  mustFindDatum',
+  validatorHashToAddress,
+ )
+import Plutarch.Api.V1 (
+  PAddress,
+  PCurrencySymbol,
+  PDatumHash,
+  PMap,
+  PMintingPolicy,
+  PScriptPurpose (PMinting, PSpending),
+  PTxOut,
+  PValidator,
+  PValidatorHash,
+ )
+import Plutarch.Api.V1.AssetClass (
+  passetClass,
+  passetClassValueOf,
+ )
+import Plutarch.Api.V1.ScriptContext (
+  pfindOutputsToAddress,
   pfindTxInByTxOutRef,
   pisUTXOSpent,
   pscriptHashFromAddress,
-  pscriptHashToTokenName,
-  ptryFromOutputDatum,
+  ptryFindDatum,
   pvalueSpent,
  )
-import Plutarch.Extra.Tagged (PTagged)
-import Plutarch.Extra.Value (passetClassValueOf, psymbolValueOf)
-import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, plistEqualsBy, pmapMaybe)
-import "liqwid-plutarch-extra" Plutarch.Extra.Map (pkeys, ptryLookup)
-import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
-  pguardC,
-  pletC,
-  pletFieldsC,
-  pmatchC,
-  ptryFromC,
+import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (phasOnlyOneTokenOfCurrencySymbol, psymbolValueOf)
+import Plutarch.Extra.Field (pletAllC)
+import Plutarch.Extra.IsData (pmatchEnumFromData)
+import Plutarch.Extra.List (pfirstJust)
+import Plutarch.Extra.Map (
+  plookup,
+  plookup',
  )
+import Plutarch.Extra.Maybe (passertPDJust, passertPJust, pfromJust, pisDJust)
+import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
+import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
+import PlutusLedgerApi.V1 (TxOutRef)
 
 --------------------------------------------------------------------------------
 
@@ -100,63 +109,41 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
   NOTE: It's user's responsibility to make sure the token is sent to the corresponding governor validator.
         We /can't/ really check this in the policy, otherwise we create a cyclic reference issue.
 
-  @since 1.0.0
+  @since 0.1.0
 -}
-governorPolicy :: ClosedTerm (PAsData PTxOutRef :--> PMintingPolicy)
-governorPolicy =
-  plam $ \initialSpend _ ctx -> unTermCont $ do
-    PMinting ((pfield @"_0" #) -> gstSymbol) <-
-      pmatchC (pfromData $ pfield @"purpose" # ctx)
+governorPolicy :: TxOutRef -> ClosedTerm PMintingPolicy
+governorPolicy initialSpend =
+  plam $ \_ ctx' -> unTermCont $ do
+    let oref = pconstant initialSpend
 
-    let txInfo = pfromData $ pfield @"txInfo" # ctx
+    PMinting ((pfield @"_0" #) -> ownSymbol) <- pmatchC (pfromData $ pfield @"purpose" # ctx')
+    let ownAssetClass = passetClass # ownSymbol # pconstant ""
+        txInfo = pfromData $ pfield @"txInfo" # ctx'
 
-    txInfoF <-
-      pletFieldsC
-        @'[ "mint"
-          , "inputs"
-          , "outputs"
-          , "datums"
-          , "validRange"
-          ]
-        txInfo
+    txInfoF <- pletFieldsC @'["mint", "inputs", "outputs", "datums", "validRange"] txInfo
 
     pguardC "Referenced utxo should be spent" $
-      pisUTXOSpent # pfromData initialSpend # txInfoF.inputs
+      pisUTXOSpent # oref # txInfoF.inputs
 
     pguardC "Exactly one token should be minted" $
-      let vMap = pfromData $ pto txInfoF.mint
-          tnMap =
-            passertPJust
-              # "GST symbol entry"
-              #$ plookup
-              # gstSymbol
-              # vMap
-       in tnMap #== AssocMap.psingleton # pconstant "" # 1
+      psymbolValueOf # ownSymbol # txInfoF.mint #== 1
+        #&& passetClassValueOf # txInfoF.mint # ownAssetClass #== 1
 
-    let governorOutputDatum =
-          passertPJust
-            # "Governor output should present"
-            #$ pfindJust
-            # plam
-              ( flip (pletFields @'["value", "datum"]) $ \txOutF ->
-                  let isGovernorUTxO =
-                        psymbolValueOf
-                          # gstSymbol
-                          # txOutF.value
-                          #== 1
+    govOutput <-
+      pletC $
+        passertPJust
+          # "Governor output not found"
+            #$ pfind
+          # plam
+            ( \((pfield @"value" #) -> value) ->
+                psymbolValueOf # ownSymbol # value #== 1
+            )
+          # pfromData txInfoF.outputs
 
-                      governorDatum =
-                        ptrace "Resolve governor datum" $
-                          pfromData $
-                            ptryFromOutputDatum @(PAsData PGovernorDatum)
-                              # txOutF.datum
-                              # txInfoF.datums
-                   in pif isGovernorUTxO (pjust # governorDatum) pnothing
-              )
-            # pfromData txInfoF.outputs
+    let datumHash = pfield @"datumHash" # govOutput
+        datum = mustFindDatum' @PGovernorDatum # datumHash # txInfoF.datums
 
-    pguardC "Governor output datum valid" $
-      pisGovernorDatumValid # governorOutputDatum
+    pguardC "Governor output datum valid" $ pisGovernorDatumValid # datum
 
     pure $ popaque $ pconstant ()
 
@@ -244,360 +231,359 @@ governorPolicy =
      - Exactly one GAT is burnt in the transaction.
      - Said GAT is tagged by the effect.
 
-     == Arguments
-
-     Following arguments should be provided(in this order):
-     1. proposal validator address
-     2. state ST symbol
-     3. governor ST symbol
-     4. proposal ST symbol
-     5. authority token symbol.
-
-     @since 1.0.0
+     @since 0.1.0
 -}
 governorValidator ::
   -- | Lazy precompiled scripts.
-  ClosedTerm
-    ( PAsData PScriptHash
-        :--> PAsData (PTagged StakeSTTag PAssetClassData)
-        :--> PAsData (PTagged GovernorSTTag PCurrencySymbol)
-        :--> PAsData (PTagged ProposalSTTag PCurrencySymbol)
-        :--> PAsData (PTagged AuthorityTokenTag PCurrencySymbol)
-        :--> PValidator
-    )
-governorValidator =
-  plam $ \proposalScriptHash sstClass gstSymbol pstSymbol' atSymbol' datum redeemer ctx -> unTermCont $ do
-    atSymbol <- pletC $ pfromData atSymbol'
-    pstSymbol <- pletC $ pfromData pstSymbol'
-    ctxF <- pletAllC ctx
-    txInfo <- pletC $ pfromData ctxF.txInfo
-    txInfoF <-
-      pletFieldsC
-        @'[ "mint"
-          , "inputs"
-          , "outputs"
-          , "datums"
-          , "signatories"
-          , "validRange"
-          ]
-        txInfo
+  AgoraScripts ->
+  ClosedTerm PValidator
+governorValidator as =
+  plam $ \datum' redeemer' ctx' -> unTermCont $ do
+    ctxF <- pletAllC ctx'
 
-    ----------------------------------------------------------------------------
+    txInfo' <- pletC $ pfromData $ ctxF.txInfo
+    txInfoF <- pletFieldsC @'["mint", "inputs", "outputs", "datums", "signatories", "validRange"] txInfo'
 
-    governorInputDatum <- pfromData . fst <$> ptryFromC @(PAsData PGovernorDatum) datum
-    governorInputDatumF <- pletAllC governorInputDatum
+    PSpending (pfromData . (pfield @"_0" #) -> ownInputRef) <- pmatchC $ pfromData ctxF.purpose
 
-    PSpending ((pfield @"_0" #) -> governorInputRef) <-
-      pmatchC $ pfromData ctxF.purpose
-
-    let governorInput =
-          pfield @"resolved"
-            #$ passertPJust
-            # "Malformed script context: own input not found"
-            #$ pfindTxInByTxOutRef
-            # governorInputRef
-            # txInfoF.inputs
-
-    governorInputF <- pletFieldsC @'["address", "value"] governorInput
-
-    ----------------------------------------------------------------------------
-
-    governorOutputDatum <-
+    ((pfield @"resolved" #) -> ownInput) <-
       pletC $
-        passertPJust
-          # "Own output should present"
-          #$ pfindJust
-          # plam
-            ( flip pletAll $ \outputF ->
-                let isGovernorUTxO =
-                      foldl1
-                        (#&&)
-                        [ ptraceIfFalse "Own by governor validator" $
-                            ((#==) `on` (pscriptHashFromAddress #))
-                              outputF.address
-                              governorInputF.address
-                        , ptraceIfFalse "Has governor ST" $
-                            ptaggedSymbolValueOf # pfromData gstSymbol # outputF.value #== 1
-                        ]
+        passertPJust # "Own input not found"
+          #$ pfindTxInByTxOutRef # ownInputRef # txInfoF.inputs
+    ownInputF <- pletFieldsC @'["address", "value"] ownInput
+    let ownAddress = pfromData $ ownInputF.address
 
-                    datum =
-                      ptrace "Resolve governor datum" $
-                        pfromData $
-                          ptryFromOutputDatum @(PAsData PGovernorDatum)
-                            # outputF.datum
-                            # txInfoF.datums
-                 in pif
-                      isGovernorUTxO
-                      (pjust # datum)
-                      pnothing
-            )
-          # pfromData txInfoF.outputs
+    (oldGovernorDatum :: Term _ PGovernorDatum, _) <- ptryFromC datum'
+    oldGovernorDatumF <- pletAllC oldGovernorDatum
 
-    ----------------------------------------------------------------------------
+    -- Check that GST will be returned to the governor.
+    let ownInputGSTAmount = psymbolValueOf # pgstSymbol # ownInputF.value
+    pguardC "Own input should have exactly one state token" $
+      ownInputGSTAmount #== 1
 
-    pstClass <- pletC $ passetClass # pto pstSymbol # pconstant ""
+    ownOutputs <- pletC $ pfindOutputsToAddress # txInfoF.outputs # ownAddress
+    pguardC "Exactly one utxo should be sent to the governor" $
+      plength # ownOutputs #== 1
 
-    getProposalDatum :: Term _ (PTxOut :--> PMaybe PProposalDatum) <-
+    ownOutput <- pletFieldsC @'["value", "datumHash"] $ phead # ownOutputs
+    let ownOuputGSTAmount = psymbolValueOf # pgstSymbol # ownOutput.value
+    pguardC "State token should stay at governor's address" $
+      ownOuputGSTAmount #== 1
+
+    -- Check that own output have datum of type 'GovernorDatum'.
+    let outputGovernorStateDatumHash =
+          passertPDJust # "Governor output doesn't have datum" # ownOutput.datumHash
+    newGovernorDatum <-
       pletC $
-        plam $
-          flip (pletFields @'["value", "datum", "address"]) $ \txOutF ->
-            let isProposalUTxO =
-                  passetClassValueOf
-                    # pstClass
-                    # txOutF.value
-                    #== 1
-                    #&& (pfromMaybe # pconstant "" #$ pscriptHashFromAddress # pfromData txOutF.address)
-                    #== pfromData proposalScriptHash
+        passertPJust # "Ouput governor state datum not found"
+          #$ ptryFindDatum # outputGovernorStateDatumHash # txInfoF.datums
 
-                proposalDatum =
-                  ptrace "Resolve proposal output datum" $
-                    pfromData $
-                      ptryFromOutputDatum
-                        # txOutF.datum
-                        # txInfoF.datums
-             in pif isProposalUTxO (pjust # proposalDatum) pnothing
-
-    ----------------------------------------------------------------------------
-
-    governorRedeemer <- pfromData . fst <$> ptryFromC redeemer
+    pguardC "New datum is valid" $ pisGovernorDatumValid # newGovernorDatum
 
     pure $
-      pmatch governorRedeemer $ \case
-        PCreateProposal -> unTermCont $ do
+      pmatchEnumFromData redeemer' $ \case
+        Just CreateProposal -> unTermCont $ do
           -- Check that the transaction advances proposal id.
 
-          let expectedNextProposalId =
-                pgetNextProposalId
-                  # governorInputDatumF.nextProposalId
+          let expectedNextProposalId = pgetNextProposalId # oldGovernorDatumF.nextProposalId
               expectedNewDatum =
                 mkRecordConstr
                   PGovernorDatum
-                  ( #proposalThresholds
-                      .= governorInputDatumF.proposalThresholds
-                      .& #nextProposalId
-                      .= pdata expectedNextProposalId
-                      .& #proposalTimings
-                      .= governorInputDatumF.proposalTimings
+                  ( #proposalThresholds .= oldGovernorDatumF.proposalThresholds
+                      .& #nextProposalId .= pdata expectedNextProposalId
+                      .& #proposalTimings .= oldGovernorDatumF.proposalTimings
                       .& #createProposalTimeRangeMaxWidth
-                      .= governorInputDatumF.createProposalTimeRangeMaxWidth
-                      .& #maximumCreatedProposalsPerStake
-                      .= governorInputDatumF.maximumCreatedProposalsPerStake
+                        .= oldGovernorDatumF.createProposalTimeRangeMaxWidth
+                      .& #maximumProposalsPerStake
+                        .= oldGovernorDatumF.maximumProposalsPerStake
                   )
-
-          pguardC "Only next proposal id gets advanced" $
-            governorOutputDatum #== expectedNewDatum
+          pguardC "Unexpected governor state datum" $
+            newGovernorDatum #== expectedNewDatum
 
           -- Check that exactly one proposal token is being minted.
 
           pguardC "Exactly one proposal token must be minted" $
-            passetClassValueOf # pstClass # txInfoF.mint #== 1
+            phasOnlyOneTokenOfCurrencySymbol # ppstSymbol # txInfoF.mint
 
           -- Check that a stake is spent to create the propsal,
           --   and the value it contains meets the requirement.
 
-          let stakeInputDatum =
-                passertPJust
-                  # "Stake input should present"
-                  #$ pfindJust
-                  # ( presolveStakeInputDatum
-                        # (ptoScottEncodingT # pfromData sstClass)
-                        # txInfoF.datums
-                    )
-                  # pfromData txInfoF.inputs
+          stakeInputs <-
+            pletC $
+              pfilter
+                # phoistAcyclic
+                  ( plam $
+                      \((pfield @"value" #) . (pfield @"resolved" #) -> value) ->
+                        psymbolValueOf # psstSymbol # value #== 1
+                  )
+                # pfromData txInfoF.inputs
 
-          stakeInputDatumF <- pletAllC stakeInputDatum
+          pguardC "Can process only one stake" $
+            plength # stakeInputs #== 1
 
-          pguardC "Proposals created by the stake must not exceed the limit" $
-            pnumCreatedProposals
-              # stakeInputDatumF.lockedBy
-              #< governorInputDatumF.maximumCreatedProposalsPerStake
+          stakeInput <- pletC $ phead # stakeInputs
 
-          let gtThreshold =
-                pfromData $
-                  pfield @"create"
-                    # governorInputDatumF.proposalThresholds
+          stakeInputF <- pletFieldsC @'["datumHash", "value"] $ pfield @"resolved" # stakeInput
 
-          pguardC "Require minimum amount of GTs" $
-            gtThreshold #<= stakeInputDatumF.stakedAmount
+          pguardC "Stake input doesn't have datum" $
+            pisDJust # stakeInputF.datumHash
+
+          let stakeInputDatum = mustFindDatum' @(PAsData PStakeDatum) # stakeInputF.datumHash # txInfoF.datums
+
+          stakeInputDatumF <- pletAllC $ pto $ pfromData stakeInputDatum
+
+          pguardC "Proposals created by the stake must not exceed the number stored in the governor." $
+            pnumCreatedProposals # stakeInputDatumF.lockedBy
+              #< oldGovernorDatumF.maximumProposalsPerStake
 
           -- Check that the newly minted PST is sent to the proposal validator,
           --   and the datum it carries is legal.
 
-          let proposalOutputDatum =
-                passertPJust
-                  # "Proposal output should present"
-                  #$ pfindJust
-                  # getProposalDatum
-                  # pfromData txInfoF.outputs
+          outputsToProposalValidatorWithStateToken <-
+            pletC $
+              pfilter
+                # phoistAcyclic
+                  ( plam $
+                      \txOut' -> unTermCont $ do
+                        txOut <- pletFieldsC @'["address", "value"] txOut'
 
-          proposalOutputDatumF <- pletAllC proposalOutputDatum
+                        pure $
+                          txOut.address #== pdata pproposalValidatorAddress
+                            #&& psymbolValueOf # ppstSymbol # txOut.value #== 1
+                  )
+                # pfromData txInfoF.outputs
 
-          let expectedCosigners = psingleton @PBuiltinList # stakeInputDatumF.owner
+          pguardC "Exactly one UTXO with proposal state token should be sent to the proposal validator" $
+            plength # outputsToProposalValidatorWithStateToken #== 1
+
+          outputDatumHash <- pletC $ pfield @"datumHash" #$ phead # outputsToProposalValidatorWithStateToken
+
+          proposalOutputDatum' <-
+            pletC $
+              mustFindDatum' @(PAsData PProposalDatum)
+                # outputDatumHash
+                # txInfoF.datums
+
+          proposalOutputDatum <- pletAllC $ pto $ pfromData proposalOutputDatum'
+
+          let expectedStartingTime =
+                pfromJust #$ createProposalStartingTime
+                  # oldGovernorDatumF.createProposalTimeRangeMaxWidth
+                  # txInfoF.validRange
+
+              expectedCosigners = psingleton @PBuiltinList # stakeInputDatumF.owner
 
           pguardC "Proposal datum correct" $
             foldl1
               (#&&)
               [ ptraceIfFalse "has neutral effect" $
-                  phasNeutralEffect # proposalOutputDatumF.effects
+                  phasNeutralEffect # proposalOutputDatum.effects
               , ptraceIfFalse "votes have valid shape" $
-                  pisEffectsVotesCompatible # proposalOutputDatumF.effects # proposalOutputDatumF.votes
+                  pisEffectsVotesCompatible # proposalOutputDatum.effects # proposalOutputDatum.votes
               , ptraceIfFalse "votes are empty" $
-                  pisVotesEmpty # proposalOutputDatumF.votes
+                  pisVotesEmpty # proposalOutputDatum.votes
               , ptraceIfFalse "id correct" $
-                  proposalOutputDatumF.proposalId #== governorInputDatumF.nextProposalId
+                  proposalOutputDatum.proposalId #== oldGovernorDatumF.nextProposalId
               , ptraceIfFalse "status is Draft" $
-                  proposalOutputDatumF.status #== pconstantData Draft
+                  proposalOutputDatum.status #== pconstantData Draft
               , ptraceIfFalse "cosigners correct" $
-                  plistEquals # pfromData proposalOutputDatumF.cosigners # expectedCosigners
-              , ptraceIfFalse "starting time valid" $
-                  pvalidateProposalStartingTime
-                    # governorInputDatumF.createProposalTimeRangeMaxWidth
-                    # txInfoF.validRange
-                    # proposalOutputDatumF.startingTime
+                  plistEquals # pfromData proposalOutputDatum.cosigners # expectedCosigners
+              , ptraceIfFalse "starting time correct" $
+                  proposalOutputDatum.startingTime #== expectedStartingTime
               , ptraceIfFalse "copy over configurations" $
-                  proposalOutputDatumF.thresholds
-                    #== governorInputDatumF.proposalThresholds
-                    #&& proposalOutputDatumF.timingConfig
-                    #== governorInputDatumF.proposalTimings
+                  proposalOutputDatum.thresholds #== oldGovernorDatumF.proposalThresholds
+                    #&& proposalOutputDatum.timingConfig #== oldGovernorDatumF.proposalTimings
               ]
 
+          -- Check the output stake has been proposly updated.
+          let stakeOutputDatumHash =
+                passertPJust # "Output stake should be presented"
+                  #$ pfirstJust
+                    # phoistAcyclic
+                      ( plam
+                          ( \txOut -> unTermCont $ do
+                              txOutF <- pletFieldsC @'["datumHash", "value"] txOut
+
+                              pure $
+                                pif
+                                  (psymbolValueOf # psstSymbol # txOutF.value #== 1)
+                                  ( pcon $
+                                      PJust $
+                                        passertPDJust # "Output stake datum should be presented"
+                                          # txOutF.datumHash
+                                  )
+                                  (pcon PNothing)
+                          )
+                      )
+                    # pfromData txInfoF.outputs
+
+              stakeOutputDatum =
+                passertPJust @(PAsData PStakeDatum) # "Stake output datum presented"
+                  #$ ptryFindDatum # stakeOutputDatumHash # txInfoF.datums
+
+              stakeOutputLocks =
+                pfromData $ pfield @"lockedBy" #$ pto $ pfromData stakeOutputDatum
+
+              -- The stake should be locked by the newly created proposal.
+              newLock =
+                mkRecordConstr
+                  PCreated
+                  ( #created .= oldGovernorDatumF.nextProposalId
+                  )
+
+              -- Append new locks to existing locks
+              expectedProposalLocks =
+                pcons # pdata newLock # stakeInputDatumF.lockedBy
+
+          pguardC "Stake output locks correct" $
+            plistEquals # stakeOutputLocks # expectedProposalLocks
+
           pure $ popaque $ pconstant ()
 
-        ------------------------------------------------------------------------
+        --------------------------------------------------------------------------
 
-        PMintGATs -> unTermCont $ do
-          pguardC "Governor state should not be changed" $ governorOutputDatum #== governorInputDatum
+        Just MintGATs -> unTermCont $ do
+          pguardC "Governor state should not be changed" $ newGovernorDatum #== oldGovernorDatum
 
           -- Filter out proposal inputs and ouputs using PST and the address of proposal validator.
 
           pguardC "The governor can only process one proposal at a time" $
-            (ptaggedSymbolValueOf # pstSymbol #$ pvalueSpent # txInfoF.inputs) #== 1
+            (psymbolValueOf # ppstSymbol #$ pvalueSpent # txInfoF.inputs) #== 1
 
-          let proposalInputDatum =
-                passertPJust
-                  # "Proposal input not found"
-                  #$ pfindJust
-                  # plam ((getProposalDatum #) . (pfield @"resolved" #))
-                  # pfromData txInfoF.inputs
+          proposalInputF <-
+            pletFieldsC @'["datumHash"] $
+              pfield @"resolved"
+                #$ passertPJust
+                # "Proposal input not found"
+                  #$ pfind
+                # plam
+                  ( \((pfield @"resolved" #) -> txOut) -> unTermCont $ do
+                      txOutF <- pletFieldsC @'["address", "value"] txOut
+
+                      pure $
+                        psymbolValueOf # ppstSymbol # txOutF.value #== 1
+                          #&& txOutF.address #== pdata pproposalValidatorAddress
+                  )
+                # pfromData txInfoF.inputs
+
+          proposalInputDatum <-
+            pletC $
+              mustFindDatum' @(PAsData PProposalDatum)
+                # proposalInputF.datumHash
+                # txInfoF.datums
 
           proposalInputDatumF <-
-            pletFieldsC @'["effects", "status", "thresholds", "votes"]
-              proposalInputDatum
+            pletFieldsC @'["effects", "status", "thresholds", "votes"] $
+              pto $ pfromData proposalInputDatum
 
           -- Check that the proposal state is advanced so that a proposal cannot be executed twice.
 
           pguardC "Proposal must be in locked(executable) state in order to execute effects" $
             proposalInputDatumF.status #== pconstantData Locked
 
+          -- TODO: anything else to check here?
+
           -- Find the highest votes and the corresponding tag.
-          let quorum = pto $ pfromData $ pfield @"execute" # proposalInputDatumF.thresholds
+          let quorum = pto $ pto $ pfromData $ pfield @"execute" # proposalInputDatumF.thresholds
               neutralOption = pneutralOption # proposalInputDatumF.effects
               finalResultTag = pwinner # proposalInputDatumF.votes # quorum # neutralOption
 
           -- The effects of the winner outcome.
-          effectGroup <- pletC $ ptryLookup # finalResultTag #$ proposalInputDatumF.effects
+          effectGroup <- pletC $ plookup' # finalResultTag #$ proposalInputDatumF.effects
 
-          let
-            -- For a given output, check if it contains a single valid GAT.
-            getReceiverScriptHash =
-              plam
-                ( \output -> unTermCont $ do
-                    outputF <- pletFieldsC @'["address", "datum", "value"] output
+          gatCount <- pletC $ plength #$ pto $ pto effectGroup
 
-                    let atAmount =
-                          ptaggedSymbolValueOf
-                            # atSymbol
-                            # outputF.value
+          pguardC "Required amount of GATs should be minted" $
+            psymbolValueOf # patSymbol # txInfoF.mint #== gatCount
 
-                        handleAuthorityUTxO =
-                          do
-                            receiverScriptHash <-
-                              pletC $
-                                passertPJust
-                                  # "GAT receiver should be a script"
-                                  #$ pscriptHashFromAddress
-                                  # outputF.address
-
-                            effect <-
-                              pletAllC $
-                                passertPJust
-                                  # "Receiver should be in the effect group"
-                                  #$ AssocMap.plookup
-                                  # receiverScriptHash
-                                  # effectGroup
-
-                            let tagToken =
-                                  pmaybeData
-                                    # pconstant ""
-                                    # plam (pscriptHashToTokenName . pfromData)
-                                    # effect.scriptHash
-                                gatAssetClass = passetClass # puntag atSymbol # tagToken
-                                valueGATCorrect =
-                                  passetClassValueOf
-                                    # gatAssetClass
-                                    # outputF.value
-                                    #== 1
-
-                            let outputDatumHash = pmatch outputF.datum $ \case
-                                  POutputDatum d -> phashDatum #$ pfield @"outputDatum" @PDatum # d
-                                  POutputDatumHash h -> pfield @"datumHash" # h
-                                  _ -> ptraceError "expcted effect datum, got nothing"
-
-                                hasCorrectDatum =
-                                  effect.datumHash #== outputDatumHash
-
-                            pguardC "Authority output valid" $
-                              foldr1
-                                (#&&)
-                                [ ptraceIfFalse "GAT valid" $ authorityTokensValidIn # atSymbol # output
-                                , ptraceIfFalse "Correct datum" hasCorrectDatum
-                                , ptraceIfFalse "Value correctly encodes Auth Check script" valueGATCorrect
-                                ]
-
-                            pure $ pjust # receiverScriptHash
-
-                    pmatchC
-                      ( pcompareBy
-                          # pfromOrd
-                          # atAmount
-                          # 1
+          -- Ensure that every GAT goes to one of the effects in the winner effect group.
+          outputsWithGAT <-
+            pletC $
+              pfilter
+                # phoistAcyclic
+                  ( plam
+                      ( \((pfield @"value" #) -> value) ->
+                          0 #< psymbolValueOf # patSymbol # value
                       )
-                      >>= \case
-                        -- atAmount == 1
-                        PEQ -> handleAuthorityUTxO
-                        -- atAmount < 1
-                        PLT -> pure pnothing
-                        -- atAmount > 1
-                        PGT -> pure $ ptraceError "More than one GAT in one UTxO"
-                )
-
-            -- The sorted hashes of all the GAT receivers.
-            actualReceivers =
-              psort
-                #$ pmapMaybe @PList
-                # getReceiverScriptHash
+                  )
                 # pfromData txInfoF.outputs
 
-            expectedReceivers = pkeys @PList # effectGroup
+          pguardC "Output GATs is more than minted GATs" $
+            plength # outputsWithGAT #== gatCount
 
-          -- This check ensures that it's impossible to send more than one GATs
-          -- to a validator in the winning effect group.
-          pguardC "Each script in the effect group gets a GAT" $
-            plistEqualsBy
-              # plam (\(pfromData -> x) y -> x #== y)
-              # expectedReceivers
-              # actualReceivers
+          let gatOutputValidator' :: Term s (PMap _ PValidatorHash PDatumHash :--> PTxOut :--> PBool)
+              gatOutputValidator' =
+                phoistAcyclic $
+                  plam
+                    ( \effects output' -> unTermCont $ do
+                        output <- pletFieldsC @'["address", "datumHash"] output'
+
+                        let scriptHash =
+                              passertPJust # "GAT receiver is not a script"
+                                #$ pscriptHashFromAddress # output.address
+                            datumHash =
+                              passertPDJust # "Output to effect should have datum"
+                                #$ output.datumHash
+
+                            expectedDatumHash =
+                              passertPJust # "Receiver is not in the effect list"
+                                #$ plookup # scriptHash # effects
+
+                        pure $
+                          foldr1
+                            (#&&)
+                            [ ptraceIfFalse "GAT must be tagged by the effect hash" $ authorityTokensValidIn # patSymbol # output'
+                            , ptraceIfFalse "Unexpected datum" $ datumHash #== expectedDatumHash
+                            ]
+                    )
+
+              gatOutputValidator = gatOutputValidator' # effectGroup
+
+          pguardC "GATs valid" $
+            pfoldr
+              # plam
+                ( \txOut r ->
+                    let value = pfield @"value" # txOut
+                        atValue = psymbolValueOf # patSymbol # value
+                     in pif (atValue #== 0) r $
+                          pif (atValue #== 1) (r #&& gatOutputValidator # txOut) $ pconstant False
+                )
+              # pconstant True
+              # pfromData txInfoF.outputs
 
           pure $ popaque $ pconstant ()
 
-        ------------------------------------------------------------------------
-
-        PMutateGovernor -> unTermCont $ do
-          pguardC "Governor output datum is valid" $
-            pisGovernorDatumValid # governorOutputDatum
+        --------------------------------------------------------------------------
 
+        Just MutateGovernor -> unTermCont $ do
           -- Check that a GAT is burnt.
           pguardC "One valid GAT burnt" $
-            singleAuthorityTokenBurned atSymbol txInfoF.inputs txInfoF.mint
+            singleAuthorityTokenBurned patSymbol txInfoF.inputs txInfoF.mint
 
           pure $ popaque $ pconstant ()
+
+        --------------------------------------------------------------------------
+        Nothing -> ptraceError "Unknown redeemer"
+  where
+    -- The currency symbol of authority token.
+    patSymbol :: Term s PCurrencySymbol
+    patSymbol = pconstant $ authorityTokenSymbol as
+
+    -- The currency symbol of the proposal state token.
+    ppstSymbol :: Term s PCurrencySymbol
+    ppstSymbol = pconstant $ proposalSTSymbol as
+
+    -- The address of the proposal validator.
+    pproposalValidatorAddress :: Term s PAddress
+    pproposalValidatorAddress =
+      pconstant $
+        validatorHashToAddress $
+          proposalValidatoHash as
+
+    -- The currency symbol of the stake state token.
+    psstSymbol :: Term s PCurrencySymbol
+    psstSymbol = pconstant $ stakeSTSymbol as
+
+    -- The currency symbol of the governor state token.
+    pgstSymbol :: Term s PCurrencySymbol
+    pgstSymbol = pconstant $ governorSTSymbol as

agora/Agora/Linker.hs

@@ -1,193 +0,0 @@
-{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
-
-module Agora.Linker (linker, AgoraScriptInfo (..)) where
-
-import Agora.Governor (Governor (gstOutRef, gtClassRef, maximumCosigners))
-import Agora.SafeMoney (AuthorityTokenTag, GTTag, GovernorSTTag, ProposalSTTag, StakeSTTag)
-import Data.Aeson qualified as Aeson
-import Data.Map (fromList)
-import Data.Tagged (Tagged (Tagged))
-import Plutarch.Api.V2 (scriptHash)
-import Plutarch.Extra.AssetClass (AssetClass (AssetClass))
-import Plutarch.Extra.ScriptContext (scriptHashToTokenName)
-import PlutusLedgerApi.V2 (CurrencySymbol (CurrencySymbol), ScriptHash, TxOutRef, getScriptHash)
-import Ply (
-  AsData (AsData),
-  ScriptRole (MintingPolicyRole, ValidatorRole),
-  (#),
- )
-import ScriptExport.ScriptInfo (
-  Linker,
-  ScriptExport (..),
-  fetchTS,
-  getParam,
-  toRoledScript,
-  toScript,
- )
-import Prelude hiding ((#))
-
-{- | Additional information provided after linking.
-
- @since 1.0.0
--}
-data AgoraScriptInfo = AgoraScriptInfo
-  { governorAssetClass :: Tagged GovernorSTTag AssetClass
-  , authorityTokenSymbol :: Tagged AuthorityTokenTag CurrencySymbol
-  , proposalAssetClass :: Tagged ProposalSTTag AssetClass
-  , stakeAssetClass :: Tagged StakeSTTag AssetClass
-  , governor :: Governor
-  }
-  deriving stock (Generic, Show)
-  deriving anyclass (Aeson.FromJSON, Aeson.ToJSON)
-
-{- | Links parameterized Agora scripts given parameters.
-
- @since 1.0.0
--}
-linker :: Linker Governor (ScriptExport AgoraScriptInfo)
-linker = do
-  govPol <-
-    fetchTS
-      @MintingPolicyRole
-      @'[AsData TxOutRef]
-      "agora:governorPolicy"
-  govVal <-
-    fetchTS
-      @ValidatorRole
-      @'[ AsData ScriptHash
-        , AsData (Tagged StakeSTTag AssetClass)
-        , AsData (Tagged GovernorSTTag CurrencySymbol)
-        , AsData (Tagged ProposalSTTag CurrencySymbol)
-        , AsData (Tagged AuthorityTokenTag CurrencySymbol)
-        ]
-      "agora:governorValidator"
-  stkPol <-
-    fetchTS
-      @MintingPolicyRole
-      @'[AsData (Tagged GTTag AssetClass)]
-      "agora:stakePolicy"
-  stkVal <-
-    fetchTS
-      @ValidatorRole
-      @'[ AsData (Tagged StakeSTTag CurrencySymbol)
-        , AsData (Tagged ProposalSTTag AssetClass)
-        , AsData (Tagged GTTag AssetClass)
-        ]
-      "agora:stakeValidator"
-  prpPol <-
-    fetchTS @MintingPolicyRole
-      @'[AsData (Tagged GovernorSTTag AssetClass)]
-      "agora:proposalPolicy"
-  prpVal <-
-    fetchTS
-      @ValidatorRole
-      @'[ AsData (Tagged StakeSTTag AssetClass)
-        , AsData (Tagged GovernorSTTag CurrencySymbol)
-        , AsData (Tagged ProposalSTTag CurrencySymbol)
-        , AsData Integer
-        ]
-      "agora:proposalValidator"
-  treVal <-
-    fetchTS
-      @ValidatorRole
-      @'[AsData (Tagged AuthorityTokenTag CurrencySymbol)]
-      "agora:treasuryValidator"
-  atkPol <-
-    fetchTS
-      @MintingPolicyRole
-      @'[AsData (Tagged GovernorSTTag AssetClass)]
-      "agora:authorityTokenPolicy"
-  noOpVal <-
-    fetchTS
-      @ValidatorRole
-      @'[AsData (Tagged AuthorityTokenTag CurrencySymbol)]
-      "agora:noOpValidator"
-  treaWithdrawalVal <-
-    fetchTS
-      @ValidatorRole
-      @'[AsData (Tagged AuthorityTokenTag CurrencySymbol)]
-      "agora:treasuryWithdrawalValidator"
-  mutateGovVal <-
-    fetchTS
-      @ValidatorRole
-      @'[ AsData ScriptHash
-        , AsData (Tagged GovernorSTTag CurrencySymbol)
-        , AsData (Tagged AuthorityTokenTag CurrencySymbol)
-        ]
-      "agora:mutateGovernorValidator"
-
-  governor <- getParam
-
-  let govPol' = govPol # AsData governor.gstOutRef
-      govVal' =
-        govVal
-          # AsData propValHash
-          # AsData (Tagged sstAssetClass)
-          # AsData (Tagged gstSymbol)
-          # AsData (Tagged pstSymbol)
-          # AsData (Tagged atSymbol)
-      gstSymbol = CurrencySymbol . getScriptHash . scriptHash $ toScript govPol'
-      gstAssetClass =
-        AssetClass gstSymbol ""
-      govValHash = scriptHash $ toScript govVal'
-
-      atPol' = atkPol # AsData (Tagged gstAssetClass)
-      atSymbol = CurrencySymbol . getScriptHash . scriptHash $ toScript atPol'
-
-      propPol' = prpPol # AsData (Tagged gstAssetClass)
-      propVal' =
-        prpVal
-          # AsData (Tagged sstAssetClass)
-          # AsData (Tagged gstSymbol)
-          # AsData (Tagged pstSymbol)
-          # AsData governor.maximumCosigners
-      propValHash = scriptHash $ toScript propVal'
-      pstSymbol = CurrencySymbol . getScriptHash . scriptHash $ toScript propPol'
-      pstAssetClass = AssetClass pstSymbol ""
-
-      stakPol' = stkPol # AsData governor.gtClassRef
-      stakVal' =
-        stkVal
-          # AsData (Tagged sstSymbol)
-          # AsData (Tagged pstAssetClass)
-          # AsData governor.gtClassRef
-      sstSymbol = CurrencySymbol . getScriptHash . scriptHash $ toScript stakPol'
-      stakValTokenName =
-        scriptHashToTokenName $ scriptHash $ toScript stakVal'
-      sstAssetClass = AssetClass sstSymbol stakValTokenName
-
-      treaVal' = treVal # AsData (Tagged atSymbol)
-
-      noOpVal' = noOpVal # AsData (Tagged atSymbol)
-      treaWithdrawalVal' = treaWithdrawalVal # AsData (Tagged atSymbol)
-      mutateGovVal' =
-        mutateGovVal
-          # AsData govValHash
-          # AsData (Tagged gstSymbol)
-          # AsData (Tagged atSymbol)
-
-  return $
-    ScriptExport
-      { scripts =
-          fromList
-            [ ("agora:governorPolicy", toRoledScript govPol')
-            , ("agora:governorValidator", toRoledScript govVal')
-            , ("agora:stakePolicy", toRoledScript stakPol')
-            , ("agora:stakeValidator", toRoledScript stakVal')
-            , ("agora:proposalPolicy", toRoledScript propPol')
-            , ("agora:proposalValidator", toRoledScript propVal')
-            , ("agora:treasuryValidator", toRoledScript treaVal')
-            , ("agora:authorityTokenPolicy", toRoledScript atPol')
-            , ("agora:noOpValidator", toRoledScript noOpVal')
-            , ("agora:treasuryWithdrawalValidator", toRoledScript treaWithdrawalVal')
-            , ("agora:mutateGovernorValidator", toRoledScript mutateGovVal')
-            ]
-      , information =
-          AgoraScriptInfo
-            { governorAssetClass = Tagged gstAssetClass
-            , authorityTokenSymbol = Tagged atSymbol
-            , proposalAssetClass = Tagged pstAssetClass
-            , stakeAssetClass = Tagged sstAssetClass
-            , governor = governor
-            }
-      }

agora/Agora/Plutarch/Orphans.hs

@@ -1,86 +1,39 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
+{- FIXME: All of the following instances and
+   types ought to belong in either plutarch or
+   plutarch-extra.
+-}
+
 module Agora.Plutarch.Orphans () where
 
-import Plutarch.Lift (PConstantDecl (..), PUnsafeLiftDecl (PLifted))
+import Plutarch.Api.V1 (PDatumHash (..))
+import Plutarch.Builtin (PIsData (..))
+import Plutarch.Extra.TermCont (ptryFromC)
+import Plutarch.TryFrom (PTryFrom (..))
+import Plutarch.Unsafe (punsafeCoerce)
 
-import Data.Bifunctor (Bifunctor (bimap))
-import Data.Map.Strict qualified as StrictMap
-import Data.Tagged (Tagged (Tagged))
-import Data.Traversable (for)
-import Plutarch.Api.V1 (KeyGuarantees (Sorted), PMap)
-import Plutarch.Extra.Tagged (PTagged)
-import PlutusTx qualified
-import PlutusTx.AssocMap qualified as AssocMap
-import Ply (PlyArg)
-import Ply.Plutarch.Class (PlyArgOf)
+newtype Flip f a b = Flip (f b a) deriving stock (Generic)
 
--- | @since 1.0.0
-instance
-  ( PConstantData k
-  , PConstantData v
-  , Ord k
-  ) =>
-  PConstantDecl (StrictMap.Map k v)
-  where
-  type
-    PConstantRepr (StrictMap.Map k v) =
-      [(PlutusTx.Data, PlutusTx.Data)]
-  type
-    PConstanted (StrictMap.Map k v) =
-      PMap 'Sorted (PConstanted k) (PConstanted v)
-  pconstantToRepr m =
-    bimap
-      PlutusTx.toData
-      PlutusTx.toData
-      <$> StrictMap.toList m
-  pconstantFromRepr m = fmap StrictMap.fromList $
-    for m $ \(x, y) -> do
-      x' <- PlutusTx.fromData x
-      y' <- PlutusTx.fromData y
-      Just (x', y')
+-- | @since 0.1.0
+instance PTryFrom PData (PAsData PDatumHash) where
+  type PTryFromExcess PData (PAsData PDatumHash) = Flip Term PDatumHash
+  ptryFrom' opq = runTermCont $ do
+    (pfromData -> unwrapped, _) <- ptryFromC @(PAsData PByteString) opq
 
--- | @since 1.0.0
-instance
-  ( PLiftData k
-  , PLiftData v
-  , Ord (PLifted k)
-  ) =>
-  PUnsafeLiftDecl (PMap 'Sorted k v)
-  where
-  type PLifted (PMap 'Sorted k v) = StrictMap.Map (PLifted k) (PLifted v)
+    tcont $ \f ->
+      pif
+        -- Blake2b_256 hash: 256 bits/32 bytes.
+        (plengthBS # unwrapped #== 32)
+        (f ())
+        (ptraceError "ptryFrom(PDatumHash): must be 32 bytes long")
 
--- | @since 1.0.0
-instance
-  (PlutusTx.ToData k, PlutusTx.ToData v) =>
-  PlutusTx.ToData (StrictMap.Map k v)
-  where
-  toBuiltinData = PlutusTx.toBuiltinData . toAssocMap
-    where
-      toAssocMap :: StrictMap.Map k v -> AssocMap.Map k v
-      toAssocMap = AssocMap.fromList . StrictMap.toAscList
+    pure (punsafeCoerce opq, pcon $ PDatumHash unwrapped)
 
--- | @since 1.0.0
-instance
-  (PlutusTx.FromData k, PlutusTx.FromData v, Ord k) =>
-  PlutusTx.FromData (StrictMap.Map k v)
-  where
-  fromBuiltinData d = PlutusTx.fromBuiltinData d >>= toStrictMap
-    where
-      toStrictMap :: AssocMap.Map k v -> Maybe (StrictMap.Map k v)
-      toStrictMap m =
-        let l = AssocMap.toList m
-         in if isSorted $ fmap fst l
-              then Just $ StrictMap.fromAscList l
-              else Nothing
+-- | @since 0.2.0
+instance PTryFrom PData (PAsData PUnit)
 
-      isSorted :: forall a. Ord a => [a] -> Bool
-      isSorted [] = True
-      isSorted [_] = True
-      isSorted (x : y : xs) = x < y && isSorted (y : xs)
-
--- | @since 1.0.0
-type instance PlyArgOf (PTagged tag a) = Tagged tag (PlyArgOf a)
-
--- | @since 1.0.0
-deriving newtype instance PlyArg a => PlyArg (Tagged tag a)
+-- | @since 0.2.0
+instance (PIsData a) => PIsData (PAsData a) where
+  pfromDataImpl = punsafeCoerce
+  pdataImpl = pdataImpl . pfromData

agora/Agora/Proposal.hs

@@ -9,8 +9,8 @@ Proposal scripts encoding effects that operate on the system.
 -}
 module Agora.Proposal (
   -- * Haskell-land
-  ProposalEffectMetadata (..),
-  ProposalEffectGroup,
+
+  -- Proposal (..),
   ProposalDatum (..),
   ProposalRedeemer (..),
   ProposalStatus (..),
@@ -21,8 +21,6 @@ module Agora.Proposal (
   emptyVotesFor,
 
   -- * Plutarch-land
-  PProposalEffectMetadata (..),
-  PProposalEffectGroup,
   PProposalDatum (..),
   PProposalRedeemer (..),
   PProposalStatus (..),
@@ -43,53 +41,44 @@ module Agora.Proposal (
 ) where
 
 import Agora.Plutarch.Orphans ()
-import Agora.Proposal.Time (
-  PProposalStartingTime,
-  PProposalTimingConfig,
-  ProposalStartingTime,
-  ProposalTimingConfig,
- )
+import Agora.Proposal.Time (PProposalStartingTime, PProposalTimingConfig, ProposalStartingTime, ProposalTimingConfig)
 import Agora.SafeMoney (GTTag)
-import Data.Map.Strict qualified as StrictMap
 import Data.Tagged (Tagged)
 import Generics.SOP qualified as SOP
-import Plutarch.Api.V1 (PCredential, PMap)
-import Plutarch.Api.V1.AssocMap qualified as PAssocMap
-import Plutarch.Api.V2 (
-  KeyGuarantees (Sorted),
+import Plutarch.Api.V1 (
+  KeyGuarantees (Unsorted),
   PDatumHash,
-  PMaybeData,
-  PScriptHash,
+  PMap,
+  PPubKeyHash,
+  PValidatorHash,
  )
-import Plutarch.DataRepr (
-  DerivePConstantViaData (
-    DerivePConstantViaData
-  ),
-  PDataFields,
- )
-import Plutarch.Extra.Field (pletAll)
+import Plutarch.Api.V1.AssocMap qualified as PAssocMap
+import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields)
+import Plutarch.Extra.Comonad (pextract)
+import Plutarch.Extra.Field (pletAllC)
 import Plutarch.Extra.Function (pbuiltinUncurry)
 import Plutarch.Extra.IsData (
-  DerivePConstantViaDataList (DerivePConstantViaDataList),
-  DerivePConstantViaEnum (DerivePConstantEnum),
-  EnumIsData (EnumIsData),
-  PlutusTypeDataList,
+  DerivePConstantViaDataList (..),
+  DerivePConstantViaEnum (..),
+  EnumIsData (..),
   PlutusTypeEnumData,
   ProductIsData (ProductIsData),
  )
+import Plutarch.Extra.List (pfirstJust)
+import Plutarch.Extra.Map qualified as PM
+import Plutarch.Extra.Map.Unsorted qualified as PUM
 import Plutarch.Extra.Maybe (pfromJust)
-import Plutarch.Extra.Tagged (PTagged)
+import Plutarch.Extra.TermCont (pguardC, pletC, pmatchC)
 import Plutarch.Lift (
-  DerivePConstantViaNewtype (DerivePConstantViaNewtype),
+  DerivePConstantViaNewtype (..),
   PConstantDecl,
-  PUnsafeLiftDecl (type PLifted),
+  PUnsafeLiftDecl (..),
  )
-import Plutarch.Orphans ()
-import PlutusLedgerApi.V2 (Credential, DatumHash, ScriptHash)
+import Plutarch.SafeMoney (PDiscrete (..))
+import Plutarch.Show (PShow (..))
+import PlutusLedgerApi.V1 (DatumHash, PubKeyHash, ValidatorHash)
 import PlutusTx qualified
-import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
-import "liqwid-plutarch-extra" Plutarch.Extra.Map qualified as PM
-import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC)
+import PlutusTx.AssocMap qualified as AssocMap
 
 --------------------------------------------------------------------------------
 -- Haskell-land
@@ -116,6 +105,8 @@ newtype ProposalId = ProposalId {proposalTag :: Integer}
       PlutusTx.ToData
     , -- | @since 0.1.0
       PlutusTx.FromData
+    , -- | @since 0.1.0
+      PlutusTx.UnsafeFromData
     )
 
 {- | Encodes a result. Typically, for a Yes/No proposal, we encode it like this:
@@ -160,7 +151,7 @@ newtype ResultTag = ResultTag {getResultTag :: Integer}
 data ProposalStatus
   = -- | A draft proposal represents a proposal that has yet to be realized.
     --
-    --   In effect, this means one which didn't have enough GT to be a full
+    --   In effect, this means one which didn't have enough LQ to be a full
     --   proposal, and needs cosigners to enable that to happen. This is
     --   similar to a "temperature check", but only useful if multiple people
     --   want to pool governance tokens together. If the proposal doesn't get to
@@ -210,6 +201,8 @@ data ProposalStatus
       PlutusTx.FromData
     , -- | @since 0.1.0
       PlutusTx.ToData
+    , -- | @since 0.1.0
+      PlutusTx.UnsafeFromData
     )
     via (EnumIsData ProposalStatus)
 
@@ -217,7 +210,7 @@ data ProposalStatus
      This data is stored centrally (in the 'Agora.Governor.Governor') and copied over
      to 'Proposal's when they are created.
 
-     @since 1.0.0
+     @since 0.1.0
 -}
 data ProposalThresholds = ProposalThresholds
   { execute :: Tagged GTTag Integer
@@ -227,12 +220,9 @@ data ProposalThresholds = ProposalThresholds
   --
   -- It is recommended this be a high enough amount, in order to prevent DOS from bad
   -- actors.
-  , toVoting :: Tagged GTTag Integer
-  -- ^ How much GT required to to move into 'VotingReady'.
   , vote :: Tagged GTTag Integer
-  -- ^ How much GT required to vote on a outcome.
-  , cosign :: Tagged GTTag Integer
-  -- ^ How much GT required to cosign a proposal.
+  -- ^ How much GT required to allow voting to happen.
+  -- (i.e. to move into 'VotingReady')
   }
   deriving stock
     ( -- | @since 0.1.0
@@ -242,17 +232,8 @@ data ProposalThresholds = ProposalThresholds
     , -- | @since 0.1.0
       Generic
     )
-  deriving anyclass
-    ( -- | @since 1.0.0
-      SOP.Generic
-    )
-  deriving
-    ( -- | @since 1.0.0
-      PlutusTx.ToData
-    , -- | @since 1.0.0
-      PlutusTx.FromData
-    )
-    via (ProductIsData ProposalThresholds)
+
+PlutusTx.makeIsDataIndexed 'ProposalThresholds [('ProposalThresholds, 0)]
 
 {- | Map which encodes the total tally for each result.
      It's important that the "shape" is consistent with the shape of 'effects'.
@@ -268,7 +249,7 @@ data ProposalThresholds = ProposalThresholds
      @since 0.1.0
 -}
 newtype ProposalVotes = ProposalVotes
-  { getProposalVotes :: StrictMap.Map ResultTag Integer
+  { getProposalVotes :: AssocMap.Map ResultTag Integer
   }
   deriving stock
     ( -- | @since 0.1.0
@@ -289,38 +270,8 @@ newtype ProposalVotes = ProposalVotes
 
      @since 0.1.0
 -}
-emptyVotesFor :: forall a. StrictMap.Map ResultTag a -> ProposalVotes
-emptyVotesFor = ProposalVotes . StrictMap.mapWithKey (const . const 0)
-
--- | @since 1.0.0
-data ProposalEffectMetadata = ProposalEffectMetadata
-  { datumHash :: DatumHash
-  -- ^ Hash of datum sent to effect validator with GAT
-  , scriptHash :: Maybe ScriptHash
-  -- ^ A 'ScriptHash' that encodes the authority script.
-  }
-  deriving stock
-    ( -- | @since 1.0.0
-      Generic
-    , -- | @since 1.0.0
-      Show
-    , -- | @since 1.0.0
-      Eq
-    )
-  deriving anyclass
-    ( -- | @since 1.0.0
-      SOP.Generic
-    )
-  deriving
-    ( -- | @since 1.0.0
-      PlutusTx.ToData
-    , -- | @since 1.0.0
-      PlutusTx.FromData
-    )
-    via (ProductIsData ProposalEffectMetadata)
-
--- | @since 1.0.0
-type ProposalEffectGroup = StrictMap.Map ScriptHash ProposalEffectMetadata
+emptyVotesFor :: forall a. AssocMap.Map ResultTag a -> ProposalVotes
+emptyVotesFor = ProposalVotes . AssocMap.mapWithKey (const . const 0)
 
 {- | Haskell-level datum for Proposal scripts.
 
@@ -328,17 +279,15 @@ type ProposalEffectGroup = StrictMap.Map ScriptHash ProposalEffectMetadata
 -}
 data ProposalDatum = ProposalDatum
   { proposalId :: ProposalId
-  -- ^ Identification of the proposal. Note that this map should be sorted in
-  --    ascending order, and its keys should be unique.
-  --
+  -- ^ Identification of the proposal.
   -- TODO: could we encode this more efficiently?
   -- This is shaped this way for future proofing.
   -- See https://github.com/Liqwid-Labs/agora/issues/39
-  , effects :: StrictMap.Map ResultTag ProposalEffectGroup
+  , effects :: AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash)
   -- ^ Effect lookup table. First by result, then by effect hash.
   , status :: ProposalStatus
   -- ^ The status the proposal is in.
-  , cosigners :: [Credential]
+  , cosigners :: [PubKeyHash]
   -- ^ Who created the proposal initially, and who cosigned it later.
   --
   -- This list should be sorted in **ascending** order.
@@ -373,20 +322,22 @@ data ProposalDatum = ProposalDatum
 
 {- | Haskell-level redeemer for Proposal scripts.
 
-     @since 1.0.0
+     @since 0.1.0
 -}
 data ProposalRedeemer
   = -- | Cast one or more votes towards a particular 'ResultTag'.
     Vote ResultTag
-  | -- | Add a credential to the cosignature list.
-    --   Must be authorized by the stake owner.
+  | -- | Add one or more public keys to the cosignature list.
+    --   Must be signed by those cosigning.
     --
     --   This is particularly used in the 'Draft' 'ProposalStatus',
-    --   where matching 'Agora.Stake.Stake's can be witnessed to advance the
-    --   proposal, provided enough GT is shared among them.
-    Cosign
+    --   where matching 'Agora.Stake.Stake's can be called to advance the proposal,
+    --   provided enough GT is shared among them.
+    --
+    --   This list should be sorted in ascending order.
+    Cosign [PubKeyHash]
   | -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'.
-    UnlockStake
+    Unlock
   | -- | Advance the proposal, performing the required checks for whether that is legal.
     --
     --   These are roughly the checks for each possible transition:
@@ -426,7 +377,7 @@ PlutusTx.makeIsDataIndexed
   ''ProposalRedeemer
   [ ('Vote, 0)
   , ('Cosign, 1)
-  , ('UnlockStake, 2)
+  , ('Unlock, 2)
   , ('AdvanceProposal, 3)
   ]
 
@@ -520,8 +471,8 @@ deriving via
 data PProposalStatus (s :: S)
   = -- | @since 0.2.0
     PDraft
-  | -- | @since 1.0.0
-    PVotingReady
+  | -- | @since 0.2.0
+    PVoting
   | -- | @since 0.2.0
     PLocked
   | -- | @since 0.2.0
@@ -558,18 +509,16 @@ deriving via (DerivePConstantViaEnum ProposalStatus PProposalStatus) instance (P
 
 {- | Plutarch-level version of 'ProposalThresholds'.
 
-     @since 1.0.0
+     @since 0.1.0
 -}
 newtype PProposalThresholds (s :: S) = PProposalThresholds
   { getProposalThresholds ::
       Term
         s
         ( PDataRecord
-            '[ "execute" ':= PTagged GTTag PInteger
-             , "create" ':= PTagged GTTag PInteger
-             , "toVoting" ':= PTagged GTTag PInteger
-             , "vote" ':= PTagged GTTag PInteger
-             , "cosign" ':= PTagged GTTag PInteger
+            '[ "execute" ':= PDiscrete GTTag
+             , "create" ':= PDiscrete GTTag
+             , "vote" ':= PDiscrete GTTag
              ]
         )
   }
@@ -584,39 +533,30 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds
       PIsData
     , -- | @since 0.1.0
       PDataFields
-    , -- | @since 0.2.1
-      PShow
     )
 
 -- | @since 0.2.0
 instance DerivePlutusType PProposalThresholds where
-  type DPTStrat _ = PlutusTypeNewtype
+  type DPTStrat _ = PlutusTypeData
 
 -- | @since 0.1.0
-instance PTryFrom PData (PAsData PProposalThresholds)
+instance PTryFrom PData PProposalThresholds
 
 -- | @since 0.1.0
 instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds
 
 -- | @since 0.1.0
 deriving via
-  (DerivePConstantViaDataList ProposalThresholds PProposalThresholds)
+  (DerivePConstantViaData ProposalThresholds PProposalThresholds)
   instance
     (PConstantDecl ProposalThresholds)
 
 {- | Plutarch-level version of 'ProposalVotes'.
 
-     Note: we don't really need this map to be ordered on chain, the purpose of
-     tagging it as sorted is to ensure the uniqueness of the keys. This
-     introduces some performance overhead cause sortness is unnecessarily
-     checked every time we try to recover a `PPropopsalVotes` from `PData`.
-
-     FIXME(Connor): optimize away this.
-
      @since 0.1.0
 -}
 newtype PProposalVotes (s :: S)
-  = PProposalVotes (Term s (PMap 'Sorted PResultTag PInteger))
+  = PProposalVotes (Term s (PMap 'Unsorted PResultTag PInteger))
   deriving stock
     ( -- | @since 0.2.0
       Generic
@@ -626,8 +566,6 @@ newtype PProposalVotes (s :: S)
       PlutusType
     , -- | @since 0.1.0
       PIsData
-    , -- | @since 1.0.0
-      PShow
     )
 
 -- | @since 0.2.0
@@ -642,67 +580,10 @@ instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = Prop
 
 -- | @since 0.1.0
 deriving via
-  (DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap 'Sorted PResultTag PInteger))
+  (DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap 'Unsorted PResultTag PInteger))
   instance
     (PConstantDecl ProposalVotes)
 
-{- | Plutarch-level version of 'ProposalEffectMetadata'.
-
-     @since 1.0.0
--}
-newtype PProposalEffectMetadata (s :: S)
-  = PProposalEffectMetadata
-      ( Term
-          s
-          ( PDataRecord
-              '[ "datumHash" ':= PDatumHash
-               , "scriptHash" ':= PMaybeData (PAsData PScriptHash)
-               ]
-          )
-      )
-  deriving stock
-    ( -- | @since 1.0.0
-      Generic
-    )
-  deriving anyclass
-    ( -- | @since 1.0.0
-      PlutusType
-    , -- | @since 1.0.0
-      PIsData
-    , -- | @since 1.0.0
-      PEq
-    , -- | @since 1.0.0
-      PDataFields
-    )
-
--- | @since 1.0.0
-instance DerivePlutusType PProposalEffectMetadata where
-  type DPTStrat _ = PlutusTypeDataList
-
--- | @since 1.0.0
-instance PUnsafeLiftDecl PProposalEffectMetadata where
-  type PLifted _ = ProposalEffectMetadata
-
--- | @since 1.0.0
-deriving via
-  (DerivePConstantViaDataList ProposalEffectMetadata PProposalEffectMetadata)
-  instance
-    (PConstantDecl ProposalEffectMetadata)
-
--- | @since 1.0.0
-instance PTryFrom PData (PAsData PProposalEffectMetadata)
-
-{- | The effect script hashes and their associated datum hash and authority check script hash
-     belonging to a particular effect group or result.
-
-     @since 1.0.0
--}
-type PProposalEffectGroup =
-  PMap
-    'Sorted
-    PScriptHash
-    PProposalEffectMetadata
-
 {- | Plutarch-level version of 'ProposalDatum'.
 
      @since 0.1.0
@@ -713,9 +594,9 @@ newtype PProposalDatum (s :: S) = PProposalDatum
         s
         ( PDataRecord
             '[ "proposalId" ':= PProposalId
-             , "effects" ':= PMap 'Sorted PResultTag PProposalEffectGroup
+             , "effects" ':= PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
              , "status" ':= PProposalStatus
-             , "cosigners" ':= PBuiltinList (PAsData PCredential)
+             , "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
              , "thresholds" ':= PProposalThresholds
              , "votes" ':= PProposalVotes
              , "timingConfig" ':= PProposalTimingConfig
@@ -734,18 +615,16 @@ newtype PProposalDatum (s :: S) = PProposalDatum
       PIsData
     , -- | @since 0.1.0
       PEq
-    , -- | @since 1.0.0
-      PDataFields
     )
 
--- | @since 1.0.0
+-- | @since 0.2.0
 instance DerivePlutusType PProposalDatum where
-  type DPTStrat _ = PlutusTypeDataList
+  type DPTStrat _ = PlutusTypeNewtype
 
 instance PTryFrom PData (PAsData PProposalDatum)
 
 -- | @since 0.1.0
-instance PUnsafeLiftDecl PProposalDatum where type PLifted _ = ProposalDatum
+instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
 
 -- | @since 0.1.0
 deriving via (DerivePConstantViaDataList ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum)
@@ -756,8 +635,8 @@ deriving via (DerivePConstantViaDataList ProposalDatum PProposalDatum) instance
 -}
 data PProposalRedeemer (s :: S)
   = PVote (Term s (PDataRecord '["resultTag" ':= PResultTag]))
-  | PCosign (Term s (PDataRecord '[]))
-  | PUnlockStake (Term s (PDataRecord '[]))
+  | PCosign (Term s (PDataRecord '["newCosigners" ':= PBuiltinList (PAsData PPubKeyHash)]))
+  | PUnlock (Term s (PDataRecord '[]))
   | PAdvanceProposal (Term s (PDataRecord '[]))
   deriving stock
     ( -- | @since 0.1.0
@@ -800,7 +679,7 @@ phasNeutralEffect ::
   forall (s :: S).
   Term
     s
-    ( PMap 'Sorted PResultTag PProposalEffectGroup
+    ( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
         :--> PBool
     )
 phasNeutralEffect = phoistAcyclic $ PAssocMap.pany # PAssocMap.pnull
@@ -813,15 +692,15 @@ pisEffectsVotesCompatible ::
   forall (s :: S).
   Term
     s
-    ( PMap 'Sorted PResultTag PProposalEffectGroup
+    ( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
         :--> PProposalVotes
         :--> PBool
     )
 pisEffectsVotesCompatible = phoistAcyclic $
-  plam $ \((PM.pkeys @PList #) -> effectKeys) ((PM.pkeys #) . pto -> voteKeys) ->
-    plistEquals # effectKeys # voteKeys
+  plam $ \m (pto -> v :: Term _ (PMap _ _ _)) ->
+    PUM.pkeysEqual # m # v
 
-{- | Returns true if vote counts of /all/ the options are zero.
+{- | Retutns true if vote counts of /all/ the options are zero.
 
    @since 0.2.0
 -}
@@ -842,7 +721,6 @@ pisVotesEmpty = phoistAcyclic $
      @since 0.1.0
 -}
 pwinner ::
-  forall (s :: S).
   Term
     s
     ( PProposalVotes
@@ -863,7 +741,6 @@ pwinner = phoistAcyclic $
      @since 0.1.0
 -}
 pwinner' ::
-  forall (s :: S).
   Term
     s
     ( PProposalVotes
@@ -897,8 +774,8 @@ pwinner' = phoistAcyclic $
             pfoldr # f # 0 # l #== 1
 
         exceedQuorum =
-          ptraceIfFalse "Highest vote count should be at least the minimum threshold" $
-            quorum #<= highestVotes
+          ptraceIfFalse "Highest vote count should exceed the minimum threshold" $
+            quorum #< highestVotes
 
     pure $
       pif
@@ -911,7 +788,6 @@ pwinner' = phoistAcyclic $
      @since 0.1.0
 -}
 phighestVotes ::
-  forall (s :: S).
   Term
     s
     ( PProposalVotes
@@ -934,10 +810,9 @@ phighestVotes = phoistAcyclic $
      @since 0.1.0
 -}
 pneutralOption ::
-  forall (s :: S).
   Term
     s
-    ( PMap 'Sorted PResultTag PProposalEffectGroup
+    ( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
         :--> PResultTag
     )
 pneutralOption = phoistAcyclic $
@@ -952,7 +827,7 @@ pneutralOption = phoistAcyclic $
                 (PAssocMap.pnull # el)
                 (pcon $ PJust rt)
                 (pcon PNothing)
-     in pfromJust #$ pfindJust # f # l
+     in pfromJust #$ pfirstJust # f # l
 
 {- | Return true if the thresholds are valid.
 
@@ -960,30 +835,33 @@ pneutralOption = phoistAcyclic $
 -}
 pisProposalThresholdsValid :: forall (s :: S). Term s (PProposalThresholds :--> PBool)
 pisProposalThresholdsValid = phoistAcyclic $
-  plam $
-    flip pletAll $ \thresholdsF ->
+  plam $ \thresholds -> unTermCont $ do
+    thresholdsF <- pletAllC thresholds
+
+    PDiscrete execute' <- pmatchC thresholdsF.execute
+    PDiscrete draft' <- pmatchC thresholdsF.create
+    PDiscrete vote' <- pmatchC thresholdsF.vote
+
+    execute <- pletC $ pextract # execute'
+    draft <- pletC $ pextract # draft'
+    vote <- pletC $ pextract # vote'
+
+    pure $
       foldr1
         (#&&)
-        [ ptraceIfFalse "Execute threshold is less than or equal to 0" $
-            0 #<= pfromData thresholdsF.execute
-        , ptraceIfFalse "Create threshold is less than or equal to 0" $
-            0 #<= pfromData thresholdsF.create
-        , ptraceIfFalse "toVoting threshold is less than or equal to 0" $
-            0 #<= pfromData thresholdsF.toVoting
-        , ptraceIfFalse "Vote threshold is less than or equal to 0" $
-            0 #<= pfromData thresholdsF.vote
-        , ptraceIfFalse "Cosign threshold is less than or equal to 0" $
-            0 #<= pfromData thresholdsF.cosign
+        [ ptraceIfFalse "Execute threshold is less than or equal to 0" $ 0 #<= execute
+        , ptraceIfFalse "Draft threshold is less than or equal to 0" $ 0 #<= draft
+        , ptraceIfFalse "Vote threshold is less than or equal to 0" $ 0 #<= vote
         ]
 
 {- | Retract votes given the option and the amount of votes.
 
      @since 0.1.0
 -}
-pretractVotes :: forall (s :: S). Term s (PResultTag :--> PInteger :--> PProposalVotes :--> PProposalVotes)
+pretractVotes :: Term s (PResultTag :--> PInteger :--> PProposalVotes :--> PProposalVotes)
 pretractVotes = phoistAcyclic $
   plam $ \rt count votes ->
-    let voteMap :: Term _ (PMap 'Sorted PResultTag PInteger)
+    let voteMap :: Term _ (PMap 'Unsorted PResultTag PInteger)
         voteMap = pto votes
      in pcon $
           PProposalVotes $

agora/Agora/Proposal/Time.hs

@@ -14,59 +14,47 @@ module Agora.Proposal.Time (
   MaxTimeRangeWidth (..),
 
   -- * Plutarch-land
-  PProposalTime,
+  PProposalTime (..),
   PProposalTimingConfig (..),
   PProposalStartingTime (..),
   PMaxTimeRangeWidth (..),
-  PTimingRelation (..),
-  PPeriod (..),
 
   -- * Compute periods given config and starting time.
-  pvalidateProposalStartingTime,
-  pcurrentProposalTime,
+  createProposalStartingTime,
+  currentProposalTime,
+  isDraftPeriod,
+  isVotingPeriod,
+  isLockingPeriod,
+  isExecutionPeriod,
   pisProposalTimingConfigValid,
   pisMaxTimeRangeWidthValid,
-  pgetRelation,
-  pisWithin,
-  psatisfyMaximumWidth,
 ) where
 
-import Data.Functor ((<&>))
-import Generics.SOP qualified as SOP
+import Control.Composition ((.*))
 import Plutarch.Api.V1 (
   PExtended (PFinite),
   PInterval (PInterval),
   PLowerBound (PLowerBound),
   PPOSIXTime,
+  PPOSIXTimeRange,
   PUpperBound (PUpperBound),
  )
-import Plutarch.Api.V2 (PPOSIXTimeRange)
 import Plutarch.DataRepr (
+  DerivePConstantViaData (..),
   PDataFields,
  )
 import Plutarch.Extra.Applicative (PApply (pliftA2))
-import Plutarch.Extra.Bool (passert)
 import Plutarch.Extra.Field (pletAll, pletAllC)
-import Plutarch.Extra.IsData (
-  DerivePConstantViaDataList (DerivePConstantViaDataList),
-  PlutusTypeEnumData,
-  ProductIsData (ProductIsData),
- )
 import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing)
-import Plutarch.Extra.Time (
-  PFullyBoundedTimeRange (PFullyBoundedTimeRange),
-  pisWithinTimeRange,
-  ptimeRangeDuration,
- )
+import Plutarch.Extra.TermCont (pmatchC)
 import Plutarch.Lift (
-  DerivePConstantViaNewtype (DerivePConstantViaNewtype),
+  DerivePConstantViaNewtype (..),
   PConstantDecl,
-  PUnsafeLiftDecl (PLifted),
+  PUnsafeLiftDecl (..),
  )
-import Plutarch.Num (PNum)
 import PlutusLedgerApi.V1 (POSIXTime)
 import PlutusTx qualified
-import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletC, pmatchC)
+import Prelude
 
 --------------------------------------------------------------------------------
 
@@ -90,8 +78,37 @@ newtype ProposalStartingTime = ProposalStartingTime
       PlutusTx.ToData
     , -- | @since 0.1.0
       PlutusTx.FromData
+    , -- | @since 0.1.0
+      PlutusTx.UnsafeFromData
     )
 
+{- | Configuration of proposal timings.
+
+     See: https://liqwid.notion.site/Proposals-589853145a994057aa77f397079f75e4#d25ea378768d4c76b52dd4c1b6bc0fcd
+
+     @since 0.1.0
+-}
+data ProposalTimingConfig = ProposalTimingConfig
+  { draftTime :: POSIXTime
+  -- ^ "D": the length of the draft period.
+  , votingTime :: POSIXTime
+  -- ^ "V": the length of the voting period.
+  , lockingTime :: POSIXTime
+  -- ^ "L": the length of the locking period.
+  , executingTime :: POSIXTime
+  -- ^ "E": the length of the execution period.
+  }
+  deriving stock
+    ( -- | @since 0.1.0
+      Eq
+    , -- | @since 0.1.0
+      Show
+    , -- | @since 0.1.0
+      Generic
+    )
+
+PlutusTx.makeIsDataIndexed 'ProposalTimingConfig [('ProposalTimingConfig, 0)]
+
 -- | Represents the maximum width of a 'PlutusLedgerApi.V1.Time.POSIXTimeRange'.
 newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
   deriving stock
@@ -109,49 +126,9 @@ newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
       PlutusTx.ToData
     , -- | @since 0.1.0
       PlutusTx.FromData
-    , -- | @since 1.0.0
-      Num
-    )
-
-{- | Configuration of proposal timings.
-
-     See: https://liqwid.notion.site/Proposals-589853145a994057aa77f397079f75e4#d25ea378768d4c76b52dd4c1b6bc0fcd
-
-     @since 0.1.0
--}
-data ProposalTimingConfig = ProposalTimingConfig
-  { draftTime :: POSIXTime
-  -- ^ "D": the length of the draft period.
-  , votingTime :: POSIXTime
-  -- ^ "V": the length of the voting period.
-  , lockingTime :: POSIXTime
-  -- ^ "L": the length of the locking period.
-  , executingTime :: POSIXTime
-  -- ^ "E": the length of the execution period.
-  , minStakeVotingTime :: POSIXTime
-  -- ^ Minimum time from creating a voting lock until it can be destroyed.
-  , votingTimeRangeMaxWidth :: MaxTimeRangeWidth
-  -- ^ The maximum width of transaction time range while voting.
-  }
-  deriving stock
-    ( -- | @since 0.1.0
-      Eq
     , -- | @since 0.1.0
-      Show
-    , -- | @since 0.1.0
-      Generic
+      PlutusTx.UnsafeFromData
     )
-  deriving anyclass
-    ( -- | @since 1.0.0
-      SOP.Generic
-    )
-  deriving
-    ( -- | @since 1.0.0
-      PlutusTx.ToData
-    , -- | @since 1.0.0
-      PlutusTx.FromData
-    )
-    via (ProductIsData ProposalTimingConfig)
 
 --------------------------------------------------------------------------------
 
@@ -182,7 +159,23 @@ data ProposalTimingConfig = ProposalTimingConfig
 
      @since 0.1.0
 -}
-type PProposalTime = PFullyBoundedTimeRange
+data PProposalTime (s :: S) = PProposalTime
+  { lowerBound :: Term s PPOSIXTime
+  , upperBound :: Term s PPOSIXTime
+  }
+  deriving stock
+    ( -- | @since 0.1.0
+      Generic
+    )
+  deriving anyclass
+    ( -- | @since 0.1.0
+      PlutusType
+    , -- | @since 0.1.0
+      PEq
+    )
+
+instance DerivePlutusType PProposalTime where
+  type DPTStrat _ = PlutusTypeScott
 
 -- | Plutarch-level version of 'ProposalStartingTime'.
 newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime)
@@ -227,8 +220,6 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
              , "votingTime" ':= PPOSIXTime
              , "lockingTime" ':= PPOSIXTime
              , "executingTime" ':= PPOSIXTime
-             , "minStakeVotingTime" ':= PPOSIXTime
-             , "votingTimeRangeMaxWidth" ':= PMaxTimeRangeWidth
              ]
         )
   }
@@ -243,15 +234,13 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
       PIsData
     , -- | @since 0.1.0
       PDataFields
-    , -- | @since 0.2.1
-      PShow
     )
 
 instance DerivePlutusType PProposalTimingConfig where
-  type DPTStrat _ = PlutusTypeNewtype
+  type DPTStrat _ = PlutusTypeData
 
 -- | @since 0.1.0
-instance PTryFrom PData (PAsData PProposalTimingConfig)
+instance PTryFrom PData PProposalTimingConfig
 
 -- | @since 0.1.0
 instance PUnsafeLiftDecl PProposalTimingConfig where
@@ -259,7 +248,7 @@ instance PUnsafeLiftDecl PProposalTimingConfig where
 
 -- | @since 0.1.0
 deriving via
-  (DerivePConstantViaDataList ProposalTimingConfig PProposalTimingConfig)
+  (DerivePConstantViaData ProposalTimingConfig PProposalTimingConfig)
   instance
     (PConstantDecl ProposalTimingConfig)
 
@@ -281,10 +270,6 @@ newtype PMaxTimeRangeWidth (s :: S)
       PPartialOrd
     , -- | @since 0.1.0
       POrd
-    , -- | @since 0.2.1
-      PShow
-    , -- | @since 1.0.0
-      PNum
     )
 
 instance DerivePlutusType PMaxTimeRangeWidth where
@@ -308,7 +293,7 @@ deriving via
 
      @since 0.2.0
 -}
-pisProposalTimingConfigValid :: forall (s :: S). Term s (PProposalTimingConfig :--> PBool)
+pisProposalTimingConfigValid :: Term s (PProposalTimingConfig :--> PBool)
 pisProposalTimingConfigValid = phoistAcyclic $
   plam $ \conf -> unTermCont $ do
     confF <- pletAllC conf
@@ -328,8 +313,6 @@ pisProposalTimingConfigValid = phoistAcyclic $
           , confF.votingTime
           , confF.lockingTime
           , confF.executingTime
-          , confF.minStakeVotingTime
-          , pto confF.votingTimeRangeMaxWidth
           ]
 
 {- | Return true if the maximum time width is greater than 0.
@@ -343,203 +326,162 @@ pisMaxTimeRangeWidthValid =
       ptraceIfFalse "greater than 0"
         . (pconstant (MaxTimeRangeWidth 0) #<)
 
-{- | Validate starting time of a proposal, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
+{- | Get the starting time of a proposal, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
      For every proposal, this is only meant to run once upon creation. Given time range should be
      tight enough, meaning that the width of the time range should be less than the maximum value.
 
-     @since 1.0.0
+     @since 0.1.0
 -}
-pvalidateProposalStartingTime ::
+createProposalStartingTime ::
   forall (s :: S).
   Term
     s
     ( PMaxTimeRangeWidth
         :--> PPOSIXTimeRange
-        :--> PProposalStartingTime
-        :--> PBool
+        :--> PMaybe PProposalStartingTime
     )
-pvalidateProposalStartingTime = phoistAcyclic $
-  plam $ \maxWidth iv (pto -> st) ->
-    pmaybe
-      # pconstant False
-      # plam
-        ( \ct ->
-            let isTightEnough =
-                  ptraceIfFalse
-                    "createProposalStartingTime: given time range should be tight enough"
-                    $ psatisfyMaximumWidth # maxWidth # ct
-                isInCurrentTimeRange =
-                  ptraceIfFalse
-                    "createProposalStartingTime: starting time should be in current time range"
-                    $ pisWithinTimeRange # st # ct
-             in isTightEnough #&& isInCurrentTimeRange
-        )
-      # (pcurrentProposalTime # iv)
+createProposalStartingTime = phoistAcyclic $
+  plam $ \(pto -> maxDuration) iv ->
+    let ct = currentProposalTime # iv
 
-{- | Get the current proposal time, given the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
+        f :: Term _ (PProposalTime :--> PMaybe PProposalStartingTime)
+        f = plam $
+          flip pmatch $ \(PProposalTime lb ub) ->
+            let duration = ub - lb
+
+                startingTime = pdiv # (lb + ub) # 2
+             in pif
+                  (duration #<= maxDuration)
+                  (pjust #$ pcon $ PProposalStartingTime startingTime)
+                  ( ptrace
+                      "createProposalStartingTime: given time range should be tight enough"
+                      pnothing
+                  )
+     in -- TODO: PMonad when?
+        pmaybe # pnothing # f # ct
+
+{- | Get the current proposal time, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
 
      If it's impossible to get a fully-bounded time, (e.g. either end of the 'PPOSIXTimeRange' is
-     an infinity) then we return nothing.
-
-     Note that we ignore the inclusiveness of the upper bound. Due to the fact
-      that there's no place in the Cardano domain transaction type to store the
-      inclusiveness information, we can never get a time range with closed upper
-      bound. See also the ledger implementation: https://bit.ly/3BDzW5R
+     an infinity) then we error out.
 
      @since 0.1.0
 -}
-pcurrentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PMaybe PProposalTime)
-pcurrentProposalTime = phoistAcyclic $
+currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PMaybe PProposalTime)
+currentProposalTime = phoistAcyclic $
   plam $ \iv -> unTermCont $ do
     PInterval iv' <- pmatchC iv
     ivf <- pletAllC iv'
     PLowerBound lb <- pmatchC ivf.from
     PUpperBound ub <- pmatchC ivf.to
 
-    let lowerBound = pletAll lb $ \f ->
-          pif
-            f._1
-            ( pmatch f._0 $ \case
-                PFinite (pfromData . (pfield @"_0" #) -> d) -> pjust # d
-                _ -> ptrace "currentProposalTime: time range should be bounded" pnothing
-            )
-            (ptrace "currentProposalTime: lower bound of the time range should be inclusive" pnothing)
+    let getBound = phoistAcyclic $
+          plam $
+            flip pletAll $ \f ->
+              pif
+                f._1
+                ( pmatch f._0 $ \case
+                    PFinite (pfromData . (pfield @"_0" #) -> d) -> pjust # d
+                    _ -> ptrace "currentProposalTime: time range should be bounded" pnothing
+                )
+                (ptrace "currentProposalTime: time range should be inclusive" pnothing)
 
-        upperBound = pletAll ub $ \f ->
-          pmatch f._0 $ \case
-            PFinite (pfromData . (pfield @"_0" #) -> d) -> pjust # d
-            _ -> ptrace "currentProposalTime: time range should be bounded" pnothing
-
-        mkTime = phoistAcyclic $
-          plam $ \lb ub ->
-            passert
-              "Upper bound bigger than lower bound"
-              (lb #< ub)
-              (pcon $ PFullyBoundedTimeRange lb ub)
+        lowerBound = getBound # lb
+        upperBound = getBound # ub
 
+        mkTime = phoistAcyclic $ plam $ pcon .* PProposalTime
     pure $ pliftA2 # mkTime # lowerBound # upperBound
 
-{- | Represent relation between current time and a given period.
+{- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
 
-     Note that the "before" relation isn't present due to the fact that
-     it's considered as an error in the proposal script.
-
-     @since 1.0.0
+     @since 0.1.0
 -}
-data PTimingRelation (s :: S)
-  = PWithin
-  | PAfter
-  deriving stock
-    ( -- | @since 1.0.0
-      Generic
-    , -- | @since 1.0.0
-      Enum
-    , -- | @since 1.0.0
-      Bounded
-    )
-  deriving anyclass
-    ( -- | @since 1.0.0
-      PlutusType
+proposalTimeWithin ::
+  Term
+    s
+    ( PPOSIXTime
+        :--> PPOSIXTime
+        :--> PProposalTime
+        :--> PBool
     )
+proposalTimeWithin = phoistAcyclic $
+  plam $ \l h proposalTime' -> unTermCont $ do
+    PProposalTime ut lt <- pmatchC proposalTime'
+    pure $
+      foldr1
+        (#&&)
+        [ l #<= lt
+        , ut #<= h
+        ]
 
--- | @since 1.0.0
-instance DerivePlutusType PTimingRelation where
-  type DPTStrat _ = PlutusTypeEnumData
+{- | True if the 'PProposalTime' is in the draft period.
 
-{- | Return true if a relation is 'PWithin'.
-
-     @since 1.0.0
+     @since 0.1.0
 -}
-pisWithin :: forall (s :: S). Term s (PTimingRelation :--> PBool)
-pisWithin = phoistAcyclic $
-  plam $
-    flip pmatch $ \case
-      PWithin -> pconstant True
-      _ -> pconstant False
-
-{- | Represent a proposal period.
-
-     @since 1.0.0
--}
-data PPeriod (s :: S)
-  = PDraftingPeriod
-  | PVotingPeriod
-  | PLockingPeriod
-  | PExecutingPeriod
-  deriving stock
-    ( -- | @since 1.0.0
-      Generic
-    , -- | @since 1.0.0
-      Enum
-    , -- | @since 1.0.0
-      Bounded
-    )
-  deriving anyclass
-    ( -- | @since 1.0.0
-      PlutusType
-    )
-
--- | @since 1.0.0
-instance DerivePlutusType PPeriod where
-  type DPTStrat _ = PlutusTypeEnumData
-
-{- | Compute the relation between current time range and the given peroid,
-     providing the starting time and timing configuration of a proposal. If the
-     relation cannot be determined, error out.
-
-     @since 1.0.0
--}
-pgetRelation ::
+isDraftPeriod ::
   forall (s :: S).
   Term
     s
     ( PProposalTimingConfig
         :--> PProposalStartingTime
         :--> PProposalTime
-        :--> PPeriod
-        :--> PTimingRelation
+        :--> PBool
     )
-pgetRelation = phoistAcyclic $
-  plam $ \config startingTime currentTime period -> unTermCont $ do
-    configF <- pletAllC config
+isDraftPeriod = phoistAcyclic $
+  plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
+    proposalTimeWithin # s # (s + (pfield @"draftTime" # config))
 
-    PProposalStartingTime s <- pmatchC startingTime
-    PFullyBoundedTimeRange lb ub <- pmatchC currentTime
+{- | True if the 'PProposalTime' is in the voting period.
 
-    dub <- pletC $ s + configF.draftTime
-    vub <- pletC $ dub + configF.votingTime
-    lub <- pletC $ vub + configF.lockingTime
-    eub <- pletC $ lub + configF.executingTime
-
-    (plb, pub) <-
-      pmatchC period
-        <&> ( \case
-                PDraftingPeriod -> (s, dub)
-                PVotingPeriod -> (dub, vub)
-                PLockingPeriod -> (vub, lub)
-                PExecutingPeriod -> (lub, eub)
-            )
-
-    pure $
-      pif (plb #<= lb #&& ub #<= pub) (pcon PWithin) $
-        pif (pub #< lb) (pcon PAfter) $
-          ptraceError "pgetRelation: too early or invalid current time"
-
-{- | Return true if the width of given 'PProposalTime' is shorter than the
-     maximum.
-
-     @since 1.0.0
+     @since 0.1.0
 -}
-psatisfyMaximumWidth ::
+isVotingPeriod ::
   forall (s :: S).
   Term
     s
-    ( PMaxTimeRangeWidth
+    ( PProposalTimingConfig
+        :--> PProposalStartingTime
         :--> PProposalTime
         :--> PBool
     )
-psatisfyMaximumWidth = phoistAcyclic $
-  plam $ \maxWidth time ->
-    let width = ptimeRangeDuration # time
-        max = pto maxWidth
-     in width #<= max
+isVotingPeriod = phoistAcyclic $
+  plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
+    pletFields @'["draftTime", "votingTime"] config $ \f ->
+      proposalTimeWithin # s # (s + f.draftTime + f.votingTime)
+
+{- | True if the 'PProposalTime' is in the locking period.
+
+     @since 0.1.0
+-}
+isLockingPeriod ::
+  forall (s :: S).
+  Term
+    s
+    ( PProposalTimingConfig
+        :--> PProposalStartingTime
+        :--> PProposalTime
+        :--> PBool
+    )
+isLockingPeriod = phoistAcyclic $
+  plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
+    pletFields @'["draftTime", "votingTime", "lockingTime"] config $ \f ->
+      proposalTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime)
+
+{- | True if the 'PProposalTime' is in the execution period.
+
+     @since 0.1.0
+-}
+isExecutionPeriod ::
+  forall (s :: S).
+  Term
+    s
+    ( PProposalTimingConfig
+        :--> PProposalStartingTime
+        :--> PProposalTime
+        :--> PBool
+    )
+isExecutionPeriod = phoistAcyclic $
+  plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
+    pletFields @'["draftTime", "votingTime", "lockingTime", "executingTime"] config $ \f ->
+      proposalTimeWithin # s
+        # (s + f.draftTime + f.votingTime + f.lockingTime + f.executingTime)

agora/Agora/SafeMoney.hs

@@ -11,7 +11,6 @@ module Agora.SafeMoney (
   GovernorSTTag,
   StakeSTTag,
   ProposalSTTag,
-  AuthorityTokenTag,
   adaRef,
 ) where
 
@@ -22,37 +21,31 @@ import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
 
      @since 0.1.0
 -}
-type GTTag = "GTTag"
+data GTTag
 
 {- | ADA.
 
      @since 0.1.0
 -}
-type ADATag = "ADATag"
+data ADATag
 
 {- | Governor ST token.
 
      @since 0.1.0
 -}
-type GovernorSTTag = "GovernorSTTag"
+data GovernorSTTag
 
 {- | Stake ST token.
 
      @since 0.1.0
 -}
-type StakeSTTag = "StakeSTTag"
+data StakeSTTag
 
 {- | Proposal ST token.
 
      @since 0.1.0
 -}
-type ProposalSTTag = "ProposalSTTag"
-
-{- | Authority token.
-
-     @since 1.0.0
--}
-type AuthorityTokenTag = "AuthorityTokenTag"
+data ProposalSTTag
 
 {- | Resolves ada tags.
 

agora/Agora/Scripts.hs

@@ -0,0 +1,138 @@
+{- | Module     : Agora.Scripts
+     Maintainer : connor@mlabs.city
+     Description: Precompiled core scripts and utilities
+
+     Precompiled core scripts and utilities
+-}
+module Agora.Scripts (
+  AgoraScripts (..),
+  governorSTSymbol,
+  governorSTAssetClass,
+  governorValidatorHash,
+  proposalSTSymbol,
+  proposalSTAssetClass,
+  proposalValidatoHash,
+  stakeSTSymbol,
+  stakeSTAssetClass,
+  stakeValidatorHash,
+  authorityTokenSymbol,
+  treasuryValidatorHash,
+) where
+
+import Agora.Governor (GovernorDatum, GovernorRedeemer)
+import Agora.Proposal (ProposalDatum, ProposalRedeemer)
+import Agora.Stake (StakeDatum, StakeRedeemer)
+import Agora.Treasury (TreasuryRedeemer)
+import Agora.Utils (CompiledMintingPolicy (..), CompiledValidator (..), validatorHashToTokenName)
+import Plutarch.Api.V1 (mintingPolicySymbol, validatorHash)
+import PlutusLedgerApi.V1 (CurrencySymbol)
+import PlutusLedgerApi.V1.Scripts (ValidatorHash)
+import PlutusLedgerApi.V1.Value (AssetClass (..))
+
+{- | Precompiled core scripts.
+
+     Including:
+
+    - Governor policy
+    - Governor validator
+    - Proposal policy
+    - Proposal validator
+    - Stake policy
+    - Stake validator
+    - Treasury validator
+    - Authority token policy
+
+     @since 0.2.0
+-}
+data AgoraScripts = AgoraScripts
+  { compiledGovernorPolicy :: CompiledMintingPolicy ()
+  , compiledGovernorValidator :: CompiledValidator GovernorDatum GovernorRedeemer
+  , compiledStakePolicy :: CompiledMintingPolicy ()
+  , compiledStakeValidator :: CompiledValidator StakeDatum StakeRedeemer
+  , compiledProposalPolicy :: CompiledMintingPolicy ()
+  , compiledProposalValidator :: CompiledValidator ProposalDatum ProposalRedeemer
+  , compiledTreasuryValidator :: CompiledValidator () TreasuryRedeemer
+  , compiledAuthorityTokenPolicy :: CompiledMintingPolicy ()
+  }
+
+{- | Get the currency symbol of the governor state token.
+
+     @since 0.2.0
+-}
+governorSTSymbol :: AgoraScripts -> CurrencySymbol
+governorSTSymbol = mintingPolicySymbol . getCompiledMintingPolicy . compiledGovernorPolicy
+
+{- | Get the asset class of the governor state token.
+
+     @since 0.2.0
+-}
+governorSTAssetClass :: AgoraScripts -> AssetClass
+governorSTAssetClass as = AssetClass (governorSTSymbol as, "")
+
+{- | Get the script hash of the governor validator.
+
+     @since 0.2.0
+-}
+governorValidatorHash :: AgoraScripts -> ValidatorHash
+governorValidatorHash = validatorHash . getCompiledValidator . compiledGovernorValidator
+
+{- | Get the currency symbol of the propsoal state token.
+
+     @since 0.2.0
+-}
+proposalSTSymbol :: AgoraScripts -> CurrencySymbol
+proposalSTSymbol as = mintingPolicySymbol $ getCompiledMintingPolicy as.compiledProposalPolicy
+
+{- | Get the asset class of the governor state token.
+
+     @since 0.2.0
+-}
+proposalSTAssetClass :: AgoraScripts -> AssetClass
+proposalSTAssetClass as = AssetClass (proposalSTSymbol as, "")
+
+{- | Get the script hash of the proposal validator.
+
+     @since 0.2.0
+-}
+proposalValidatoHash :: AgoraScripts -> ValidatorHash
+proposalValidatoHash = validatorHash . getCompiledValidator . compiledProposalValidator
+
+{- | Get the script hash of the governor validator.
+
+     @since 0.2.0
+-}
+stakeSTSymbol :: AgoraScripts -> CurrencySymbol
+stakeSTSymbol = mintingPolicySymbol . getCompiledMintingPolicy . compiledStakePolicy
+
+{- | Get the asset class of the stake state token.
+
+     Note that this token is tagged with the hash of the stake validator.
+      See 'Agora.Stake.Script.stakePolicy'.
+
+     @since 0.2.0
+-}
+stakeSTAssetClass :: AgoraScripts -> AssetClass
+stakeSTAssetClass as =
+  let tn = validatorHashToTokenName $ stakeValidatorHash as
+   in AssetClass (stakeSTSymbol as, tn)
+
+{- | Get the script hash of the stake validator.
+
+     @since 0.2.0
+-}
+stakeValidatorHash :: AgoraScripts -> ValidatorHash
+stakeValidatorHash = validatorHash . getCompiledValidator . compiledStakeValidator
+
+{- | Get the currency symbol of the authority token.
+
+     @since 0.2.0
+-}
+authorityTokenSymbol :: AgoraScripts -> CurrencySymbol
+authorityTokenSymbol = mintingPolicySymbol . getCompiledMintingPolicy . compiledAuthorityTokenPolicy
+
+{- | Get the script hash of the treasury validator.
+
+     @since 0.2.0
+-}
+treasuryValidatorHash :: AgoraScripts -> ValidatorHash
+treasuryValidatorHash = validatorHash . getCompiledValidator . compiledTreasuryValidator

agora/Agora/Stake.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE NoFieldSelectors #-}
 
 {- |
 Module     : Agora.Stake
@@ -12,119 +11,53 @@ module Agora.Stake (
   -- * Haskell-land
   StakeDatum (..),
   StakeRedeemer (..),
-  ProposalAction (..),
   ProposalLock (..),
 
   -- * Plutarch-land
   PStakeDatum (..),
   PStakeRedeemer (..),
-  PProposalAction (..),
   PProposalLock (..),
   PStakeRole (..),
 
-  -- * Validation context
-  PSignedBy (..),
-  PSigContext (..),
-  PStakeRedeemerContext (..),
-  PStakeRedeemerHandlerContext (..),
-  PProposalContext (..),
-  PStakeRedeemerHandler,
-  StakeRedeemerImpl (..),
-
   -- * Utility functions
   pstakeLocked,
   pnumCreatedProposals,
   pextractVoteOption,
-  pgetStakeRoles,
+  pgetStakeRole,
   pisVoter,
   pisCreator,
-  pisCosigner,
+  pisPureCreator,
   pisIrrelevant,
-  presolveStakeInputDatum,
 ) where
 
-import Agora.Proposal (
-  PProposalDatum,
-  PProposalId,
-  PProposalRedeemer,
-  PResultTag,
-  ProposalId,
-  ResultTag,
- )
-import Agora.Proposal.Time (PProposalTime)
-import Agora.SafeMoney (GTTag, StakeSTTag)
-import Data.Tagged (Tagged)
+import Agora.Proposal (PProposalId, PResultTag, ProposalId (..), ResultTag (..))
+import Agora.SafeMoney (GTTag)
+import Data.Tagged (Tagged (..))
 import Generics.SOP qualified as SOP
-import Plutarch.Api.V1 (PCredential, PPOSIXTime)
-import Plutarch.Api.V2 (
-  KeyGuarantees (Unsorted),
-  PDatum,
-  PDatumHash,
-  PMap,
+import Plutarch.Api.V1 (
   PMaybeData,
-  PTxInInfo,
-  PTxInfo,
+  PPubKeyHash,
  )
 import Plutarch.DataRepr (
-  DerivePConstantViaData (DerivePConstantViaData),
-  PDataFields,
+  DerivePConstantViaData (..),
  )
-import Plutarch.Extra.Applicative (ppureIf)
-import Plutarch.Extra.AssetClass (PAssetClass)
+import Plutarch.Extra.Field (pletAll)
 import Plutarch.Extra.IsData (
-  DerivePConstantViaDataList (DerivePConstantViaDataList),
+  DerivePConstantViaDataList (..),
   ProductIsData (ProductIsData),
  )
-import Plutarch.Extra.Maybe (passertPJust, pjust, pnothing)
-import Plutarch.Extra.ScriptContext (ptryFromOutputDatum)
-import Plutarch.Extra.Sum (PSum (PSum))
-import Plutarch.Extra.Tagged (PTagged)
+import Plutarch.Extra.List (pnotNull)
+import Plutarch.Extra.Sum (PSum (..))
 import Plutarch.Extra.Traversable (pfoldMap)
-import Plutarch.Extra.Value (passetClassValueOfT)
-import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
-import PlutusLedgerApi.V2 (Credential, POSIXTime)
+import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
+import Plutarch.SafeMoney (PDiscrete)
+import Plutarch.Show (PShow (..))
+import PlutusLedgerApi.V1 (PubKeyHash)
 import PlutusTx qualified
-import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe)
+import Prelude hiding (Num (..))
 
 --------------------------------------------------------------------------------
 
-{- | The action that was performed on a particular proposal.
-
-     @since 1.0.0
--}
-data ProposalAction
-  = -- | The stake was used to create a proposal.
-    --
-    --   This kind of lock is placed upon the creation of a proposal, in order
-    --    to limit creation of proposals per stake.
-    --
-    --   See also: https://github.com/Liqwid-Labs/agora/issues/68
-    Created
-  | -- | The stake was used to vote on a proposal.
-    --
-    --   This kind of lock is placed while voting on a proposal, in order to
-    --    prevent depositing and withdrawing when votes are in place.
-    Voted
-      ResultTag
-      -- ^ The option which was voted on. This allows votes to be retracted.
-      POSIXTime
-      -- ^ The upper bound of the transaction time range when the lock is created.
-  | -- | The stake was used to cosign a proposal.`
-    Cosigned
-  deriving stock
-    ( -- | @since 1.0.0
-      Show
-    , -- | @since 1.0.0
-      Generic
-    )
-
-PlutusTx.makeIsDataIndexed
-  ''ProposalAction
-  [ ('Created, 0)
-  , ('Voted, 1)
-  , ('Cosigned, 2)
-  ]
-
 {- | Locks that are stored in the stake datums for various purposes.
 
      NOTE: Due to retracting votes always being possible,
@@ -150,41 +83,53 @@ PlutusTx.makeIsDataIndexed
      └──────────────┘      └─────────────────┘
      @
 
-     @since 1.0.0
+     @since 0.1.0
 -}
-data ProposalLock = ProposalLock
-  { proposalId :: ProposalId
-  -- ^ The identifier of the proposal.
-  , action :: ProposalAction
-  -- ^ The action that has been performed.
-  }
+data ProposalLock
+  = -- | The stake was used to create a proposal.
+    --
+    --   This kind of lock is placed upon the creation of a proposal, in order
+    --    to limit creation of proposals per stake.
+    --
+    --   See also: https://github.com/Liqwid-Labs/agora/issues/68
+    --
+    --   @since 0.2.0
+    Created
+      ProposalId
+      -- ^ The identifier of the proposal.
+  | -- | The stake was used to vote on a proposal.
+    --
+    --   This kind of lock is placed while voting on a proposal, in order to
+    --    prevent depositing and withdrawing when votes are in place.
+    --
+    --   @since 0.2.0
+    Voted
+      ProposalId
+      -- ^ The identifier of the proposal.
+      ResultTag
+      -- ^ The option which was voted on. This allows votes to be retracted.
   deriving stock
     ( -- | @since 0.1.0
       Show
     , -- | @since 0.1.0
       Generic
     )
-  deriving anyclass
-    ( -- | @since 0.1.0
-      SOP.Generic
-    )
-  deriving
-    ( -- | @since 0.1.0
-      PlutusTx.ToData
-    , -- | @since 0.1.0
-      PlutusTx.FromData
-    )
-    via (ProductIsData ProposalLock)
+
+PlutusTx.makeIsDataIndexed
+  ''ProposalLock
+  [ ('Created, 0)
+  , ('Voted, 1)
+  ]
 
 {- | Haskell-level redeemer for Stake scripts.
 
-     @since 1.0.0
+     @since 0.1.0
 -}
 data StakeRedeemer
   = -- | Deposit or withdraw a discrete amount of the staked governance token.
     --   Stake must be unlocked.
     DepositWithdraw (Tagged GTTag Integer)
-  | -- | Destroy a stake, retrieving its GT, the minimum ADA and any other assets.
+  | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
     --   Stake must be unlocked.
     Destroy
   | -- | Permit a Vote to be added onto a 'Agora.Proposal.Proposal'.
@@ -198,9 +143,12 @@ data StakeRedeemer
     --   always allowed to have votes retracted and won't affect the Proposal datum,
     --   allowing 'Stake's to be unlocked.
     RetractVotes
+  | -- | The owner can consume stake if nothing is changed about it.
+    --   If the proposal token moves, this is equivalent to the owner consuming it.
+    WitnessStake
   | -- | The owner can delegate the stake to another user, allowing the
     --    delegate to vote on prooposals with the stake.
-    DelegateTo Credential
+    DelegateTo PubKeyHash
   | -- | Revoke the existing delegation.
     ClearDelegate
   deriving stock
@@ -216,8 +164,9 @@ PlutusTx.makeIsDataIndexed
   , ('Destroy, 1)
   , ('PermitVote, 2)
   , ('RetractVotes, 3)
-  , ('DelegateTo, 4)
-  , ('ClearDelegate, 5)
+  , ('WitnessStake, 4)
+  , ('DelegateTo, 5)
+  , ('ClearDelegate, 6)
   ]
 
 {- | Haskell-level datum for Stake scripts.
@@ -228,12 +177,12 @@ data StakeDatum = StakeDatum
   { stakedAmount :: Tagged GTTag Integer
   -- ^ Tracks the amount of governance token staked in the datum.
   --   This also acts as the voting weight for 'Agora.Proposal.Proposal's.
-  , owner :: Credential
+  , owner :: PubKeyHash
   -- ^ The hash of the public key this stake belongs to.
   --
   -- TODO Support for MultiSig/Scripts is tracked here:
   --      https://github.com/Liqwid-Labs/agora/issues/45
-  , delegatedTo :: Maybe Credential
+  , delegatedTo :: Maybe PubKeyHash
   -- ^ To whom this stake has been delegated.
   , lockedBy :: [ProposalLock]
   -- ^ The current proposals locking this stake. This field must be empty
@@ -268,9 +217,9 @@ newtype PStakeDatum (s :: S) = PStakeDatum
       Term
         s
         ( PDataRecord
-            '[ "stakedAmount" ':= PTagged GTTag PInteger
-             , "owner" ':= PCredential
-             , "delegatedTo" ':= PMaybeData (PAsData PCredential)
+            '[ "stakedAmount" ':= PDiscrete GTTag
+             , "owner" ':= PPubKeyHash
+             , "delegatedTo" ':= PMaybeData (PAsData PPubKeyHash)
              , "lockedBy" ':= PBuiltinList (PAsData PProposalLock)
              ]
         )
@@ -286,41 +235,37 @@ newtype PStakeDatum (s :: S) = PStakeDatum
       PIsData
     , -- | @since 0.1.0
       PEq
-    , -- | @since 1.0.0
-      PDataFields
-    , -- | @since 1.0.0
-      PShow
     )
 
--- | @since 1.0.0
 instance DerivePlutusType PStakeDatum where
   type DPTStrat _ = PlutusTypeNewtype
 
--- | @since 1.0.0
-instance PUnsafeLiftDecl PStakeDatum where
+-- | @since 0.1.0
+instance Plutarch.Lift.PUnsafeLiftDecl PStakeDatum where
   type PLifted PStakeDatum = StakeDatum
 
 -- | @since 0.1.0
 deriving via
   (DerivePConstantViaDataList StakeDatum PStakeDatum)
   instance
-    (PConstantDecl StakeDatum)
+    (Plutarch.Lift.PConstantDecl StakeDatum)
 
 -- | @since 0.1.0
 instance PTryFrom PData (PAsData PStakeDatum)
 
 {- | Plutarch-level redeemer for Stake scripts.
 
-     @since 1.0.0
+     @since 0.1.0
 -}
 data PStakeRedeemer (s :: S)
   = -- | Deposit or withdraw a discrete amount of the staked governance token.
-    PDepositWithdraw (Term s (PDataRecord '["delta" ':= PTagged GTTag PInteger]))
-  | -- | Destroy a stake, retrieving its GT, the minimum ADA and any other assets.
+    PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag]))
+  | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
     PDestroy (Term s (PDataRecord '[]))
   | PPermitVote (Term s (PDataRecord '[]))
   | PRetractVotes (Term s (PDataRecord '[]))
-  | PDelegateTo (Term s (PDataRecord '["pkh" ':= PCredential]))
+  | PWitnessStake (Term s (PDataRecord '[]))
+  | PDelegateTo (Term s (PDataRecord '["pkh" ':= PPubKeyHash]))
   | PClearDelegate (Term s (PDataRecord '[]))
   deriving stock
     ( -- | @since 0.1.0
@@ -328,12 +273,13 @@ data PStakeRedeemer (s :: S)
     )
   deriving anyclass
     ( -- | @since 0.1.0
+      SOP.Generic
+    , -- | @since 0.1.0
       PlutusType
     , -- | @since 0.1.0
       PIsData
     )
 
--- | @since 0.2.0
 instance DerivePlutusType PStakeRedeemer where
   type DPTStrat _ = PlutusTypeData
 
@@ -341,110 +287,76 @@ instance DerivePlutusType PStakeRedeemer where
 instance PTryFrom PData PStakeRedeemer
 
 -- | @since 0.1.0
-instance PUnsafeLiftDecl PStakeRedeemer where
+instance Plutarch.Lift.PUnsafeLiftDecl PStakeRedeemer where
   type PLifted PStakeRedeemer = StakeRedeemer
 
 -- | @since 0.1.0
 deriving via
   (DerivePConstantViaData StakeRedeemer PStakeRedeemer)
   instance
-    (PConstantDecl StakeRedeemer)
+    (Plutarch.Lift.PConstantDecl StakeRedeemer)
 
-{- | Plutarch-level version of 'ProposalAction'.
+{- | Plutarch-level version of 'ProposalLock'.
 
-    @since 1.0.0
+     @since 0.2.0
 -}
-data PProposalAction (s :: S)
-  = PCreated (Term s (PDataRecord '[]))
+data PProposalLock (s :: S)
+  = PCreated
+      ( Term
+          s
+          ( PDataRecord
+              '["created" ':= PProposalId]
+          )
+      )
   | PVoted
       ( Term
           s
           ( PDataRecord
-              '[ "votedFor" ':= PResultTag
-               , "createdAt" ':= PPOSIXTime
+              '[ "votedOn" ':= PProposalId
+               , "votedFor" ':= PResultTag
                ]
           )
       )
-  | PCosigned (Term s (PDataRecord '[]))
   deriving stock
-    ( -- | @since 1.0.0
+    ( -- | @since 0.1.0
       Generic
     )
   deriving anyclass
-    ( -- | @since 1.0.0
+    ( -- | @since 0.1.0
       PlutusType
-    , -- | @since 1.0.0
+    , -- | @since 0.1.0
       PIsData
-    , -- | @since 1.0.0
+    , -- | @since 0.1.0
       PEq
-    , -- | @since 1.0.0
-      PShow
     )
 
--- | @since 1.0.0
-instance DerivePlutusType PProposalAction where
+instance DerivePlutusType PProposalLock where
   type DPTStrat _ = PlutusTypeData
 
--- | @since 1.0.0
-instance PUnsafeLiftDecl PProposalAction where
-  type PLifted _ = ProposalAction
-
--- | @since 1.0.0
-deriving via
-  (DerivePConstantViaData ProposalAction PProposalAction)
-  instance
-    (PConstantDecl ProposalAction)
-
--- | @since 1.0.0
-instance PTryFrom PData PProposalAction
-
-{- | Plutarch-level version of 'ProposalLock'.
-
-     @since 1.0.0
--}
-newtype PProposalLock (s :: S)
-  = PProposalLock
-      ( Term
-          s
-          ( PDataRecord
-              '[ "proposalId" ':= PProposalId
-               , "action" ':= PProposalAction
-               ]
-          )
-      )
-  deriving stock
-    ( -- | @since 0.1.0
-      Generic
-    )
-  deriving anyclass
-    ( -- | @since 0.1.0
-      PlutusType
-    , -- | @since 0.1.0
-      PIsData
-    , -- | @since 0.1.0
-      PEq
-    , -- | @since 1.0.0
-      PDataFields
-    , -- | @since 0.2.0
-      PShow
-    )
-
--- | @since 0.2.0
-instance DerivePlutusType PProposalLock where
-  type DPTStrat _ = PlutusTypeNewtype
+-- | @since 0.1.0
+instance PTryFrom PData PProposalLock
 
 -- | @since 0.2.0
 instance PTryFrom PData (PAsData PProposalLock)
 
 -- | @since 0.1.0
-instance PUnsafeLiftDecl PProposalLock where
+instance Plutarch.Lift.PUnsafeLiftDecl PProposalLock where
   type PLifted PProposalLock = ProposalLock
 
 -- | @since 0.1.0
 deriving via
-  (DerivePConstantViaDataList ProposalLock PProposalLock)
+  (DerivePConstantViaData ProposalLock PProposalLock)
   instance
-    (PConstantDecl ProposalLock)
+    (Plutarch.Lift.PConstantDecl ProposalLock)
+
+-- | @since 0.2.0
+instance PShow PProposalLock where
+  pshow' :: Bool -> Term s PProposalLock -> Term s PString
+  pshow' True x = "(" <> pshow' False x <> ")"
+  pshow' False lock = pmatch lock $ \case
+    PCreated ((pfield @"created" #) -> pid) -> "PCreated " <> pshow' True pid
+    PVoted x -> pletFields @'["votedOn", "votedFor"] x $ \xF ->
+      "PVoted " <> pshow' True xF.votedOn <> " " <> pshow' True xF.votedFor
 
 --------------------------------------------------------------------------------
 
@@ -455,32 +367,28 @@ deriving via
 pstakeLocked :: forall (s :: S). Term s (PStakeDatum :--> PBool)
 pstakeLocked = phoistAcyclic $
   plam $ \stakeDatum ->
-    pnot #$ pnull #$ pfield @"lockedBy" @(PBuiltinList _) # pto stakeDatum
+    pnotNull #$ pfield @"lockedBy" @(PBuiltinList _) # pto stakeDatum
 
 {- | Get the number of *alive* proposals that were created by the given stake.
 
      @since 0.2.0
 -}
-pnumCreatedProposals ::
-  forall (s :: S).
-  Term s (PBuiltinList (PAsData PProposalLock) :--> PInteger)
+pnumCreatedProposals :: Term s (PBuiltinList (PAsData PProposalLock) :--> PInteger)
 pnumCreatedProposals =
   phoistAcyclic $
     plam $ \l ->
       pto $
         pfoldMap
           # plam
-            ( \lock ->
-                let action = pfromData $ pfield @"action" # lock
-                 in pmatch action $ \case
-                      PCreated _ -> pcon $ PSum 1
-                      _ -> mempty
+            ( \(pfromData -> lock) -> pmatch lock $ \case
+                PCreated _ -> pcon $ PSum 1
+                _ -> mempty
             )
           # l
 
 {- | The role of a stake for a particular proposal. Scott-encoded.
 
-     @since 1.0.0
+     @since 0.2.0
 -}
 data PStakeRole (s :: S)
   = -- | The stake was used to vote on the proposal.
@@ -489,308 +397,122 @@ data PStakeRole (s :: S)
       -- ^ The option which was voted for.
   | -- | The stake was used to create the proposal.
     PCreator
-  | -- | The stake was used to cosign the propsoal.
-    PCosigner
+  | -- | The stake was used to both create and vote on the proposal.
+    PBoth
+      (Term s PResultTag)
+      -- ^ The option which was voted for.
+  | -- | The stake has nothing to do with the given proposal.
+    PIrrelevant
   deriving stock
-    ( -- | @since 1.0.0
+    ( -- | @since 0.2.0
       Generic
     )
   deriving anyclass
-    ( -- | @since 1.0.0
+    ( -- | @since 0.2.0
       PlutusType
+    , -- | @since 0.2.0
+      PEq
     )
 
--- | @since 1.0.0
 instance DerivePlutusType PStakeRole where
   type DPTStrat _ = PlutusTypeScott
 
--- | @since 1.0.0
-type PStakeRoles = PList PStakeRole
+{- | Retutn true if the stake was used to voted on the proposal.
 
---------------------------------------------------------------------------------
-
-{- | Who authorizes the transaction?
-
-     @since 1.0.0
+     @since 0.2.0
 -}
-data PSignedBy (s :: S)
-  = -- | The stake owner authorized the transaction.
-    PSignedByOwner
-  | -- | The delegate authorized the transaction.
-    PSignedByDelegate
-  | -- | Both owner and delegate didn't authorize.
-    PUnknownSig
-  deriving stock
-    ( -- | @since 1.0.0
-      Generic
-    )
-  deriving anyclass
-    ( -- | @since 1.0.0
-      PlutusType
-    )
+pisVoter :: Term s (PStakeRole :--> PBool)
+pisVoter = phoistAcyclic $
+  plam $ \sr -> pmatch sr $ \case
+    PVoter _ -> pconstant True
+    PBoth _ -> pconstant True
+    _ -> pconstant False
 
--- | @since 1.0.0
-instance DerivePlutusType PSignedBy where
-  type DPTStrat _ = PlutusTypeScott
+{- | Retutn true if the stake was used to create the proposal.
 
-{- | The signature context.
-
-     @since 1.0.0
+     @since 0.2.0
 -}
-data PSigContext (s :: S) = PSigContext
-  { owner :: Term s PCredential
-  , delegatee :: Term s (PMaybeData (PAsData PCredential))
-  , signedBy :: Term s PSignedBy
-  }
-  deriving stock
-    ( -- | @since 1.0.0
-      Generic
-    )
-  deriving anyclass
-    ( -- | @since 1.0.0
-      PlutusType
-    )
+pisCreator :: Term s (PStakeRole :--> PBool)
+pisCreator = phoistAcyclic $
+  plam $ \sr -> pmatch sr $ \case
+    PCreator -> pconstant True
+    PBoth _ -> pconstant True
+    _ -> pconstant False
 
--- | @since 1.0.0
-instance DerivePlutusType PSigContext where
-  type DPTStrat _ = PlutusTypeScott
+{- | Retutn true if the stake was used to create the proposal, but not vote on
+     the proposal.
 
-{- | The metadata carried by the stake redeemer. See also 'StakeRedeemer'.
-
-     @since 1.0.0
+     @since 0.2.0
 -}
-data PStakeRedeemerContext (s :: S)
-  = -- | See also 'DepositWithdraw'.
-    PDepositWithdrawDelta (Term s (PTagged GTTag PInteger))
-  | -- | See also 'DelegateTo'.
-    PSetDelegateTo (Term s PCredential)
-  | PNoMetadata
-  deriving stock
-    ( -- | @since 1.0.0
-      Generic
-    )
-  deriving anyclass
-    ( -- | @since 1.0.0
-      PlutusType
-    )
-
--- | @since 1.0.0
-instance DerivePlutusType PStakeRedeemerContext where
-  type DPTStrat _ = PlutusTypeScott
-
-{- | The usage of proposal in the transaction.
-
-     @since 1.0.0
--}
-data PProposalContext (s :: S)
-  = -- | A proposal is spent.
-    PSpendProposal
-      (Term s PProposalDatum)
-      (Term s PProposalRedeemer)
-      (Term s PProposalTime)
-  | -- | A new proposal is created.
-    PNewProposal
-      (Term s PProposalId)
-  | -- | No proposal is spent or created.
-    PNoProposal
-  deriving stock
-    ( -- | @since 1.0.0
-      Generic
-    )
-  deriving anyclass
-    ( -- | @since 1.0.0
-      PlutusType
-    )
-
--- | @since 1.0.0
-instance DerivePlutusType PProposalContext where
-  type DPTStrat _ = PlutusTypeScott
-
-{- | Context required in order for redeemer handlers to peform validation.
-
-     @1.0.0
--}
-data PStakeRedeemerHandlerContext (s :: S) = PStakeRedeemerHandlerContext
-  { stakeInputDatums :: Term s (PList PStakeDatum)
-  , stakeOutputDatums :: Term s (PList PStakeDatum)
-  , redeemerContext :: Term s PStakeRedeemerContext
-  , sigContext :: Term s PSigContext
-  , proposalContext :: Term s PProposalContext
-  , extraTxContext :: Term s PTxInfo
-  }
-  deriving stock
-    ( -- | @since 1.0.0
-      Generic
-    )
-  deriving anyclass
-    ( -- | @since 1.0.0
-      PlutusType
-    )
-
--- | @since 1.0.0
-instance DerivePlutusType PStakeRedeemerHandlerContext where
-  type DPTStrat _ = PlutusTypeScott
-
-{- | The plutarch type signature of the redeemer handlers.
-
-     A redeemer handler is a piece of validation logic that performs a unique
-      set of checks for its corresponding stake redeemer.
-
-     @since 1.0.0
--}
-type PStakeRedeemerHandler = PStakeRedeemerHandlerContext :--> PUnit
-
-{- | A collection of stake redeemer handlers for each stake redeemers.
-
-     @since 1.0.0
--}
-data StakeRedeemerImpl (s :: S) = StakeRedeemerImpl
-  { onDepositWithdraw :: Term s PStakeRedeemerHandler
-  -- ^ Handler for 'DepositWithdraw'.
-  , onDestroy :: Term s PStakeRedeemerHandler
-  -- ^ Handler for 'Destroy'.
-  , onPermitVote :: Term s PStakeRedeemerHandler
-  -- ^ Handler for 'permitVotes'.
-  , onRetractVote :: Term s PStakeRedeemerHandler
-  -- ^ Handler for 'RetractVotes'.
-  , onDelegateTo :: Term s PStakeRedeemerHandler
-  -- ^ Handler for 'DelegateTo'.
-  , onClearDelegate :: Term s PStakeRedeemerHandler
-  -- ^ handler for 'ClearDelegate'.
-  }
-
---------------------------------------------------------------------------------
-
-{- | Return true if the stake was used to voted on the proposal.
-
-     @since 1.0.0
--}
-pisVoter :: forall (s :: S). Term s (PStakeRoles :--> PBool)
-pisVoter =
-  phoistAcyclic $
-    pany
-      #$ plam
-        ( \r -> pmatch r $ \case
-            PVoter _ -> pconstant True
-            _ -> pconstant False
-        )
-
-{- | Return true if the stake was used to create the proposal.
-
-     @since 1.0.0
--}
-pisCreator :: forall (s :: S). Term s (PStakeRoles :--> PBool)
-pisCreator =
-  phoistAcyclic $
-    pany
-      #$ plam
-        ( \r -> pmatch r $ \case
-            PCreator -> pconstant True
-            _ -> pconstant False
-        )
-
-{- | Return true if the stake was used to cosign the proposal.
-
-     @since 1.0.0
--}
-pisCosigner :: forall (s :: S). Term s (PStakeRoles :--> PBool)
-pisCosigner =
-  phoistAcyclic $
-    pany
-      #$ plam
-        ( \r -> pmatch r $ \case
-            PCosigner -> pconstant True
-            _ -> pconstant False
-        )
+pisPureCreator :: Term s (PStakeRole :--> PBool)
+pisPureCreator = phoistAcyclic $
+  plam $ \sr -> pmatch sr $ \case
+    PCreator -> pconstant True
+    _ -> pconstant False
 
 {- | Return true if the stake isn't related to the proposal.
 
-     @since 1.0.0
+     @since 0.2.0
 -}
-pisIrrelevant :: forall (s :: S). Term s (PStakeRoles :--> PBool)
-pisIrrelevant = pnull
+pisIrrelevant :: Term s (PStakeRole :--> PBool)
+pisIrrelevant = phoistAcyclic $
+  plam $ \sr -> pmatch sr $ \case
+    PIrrelevant -> pconstant True
+    _ -> pconstant False
 
 {- | Get the role of a stake for the proposal specified by the poroposal id,
       given the 'StakeDatum.lockedBy' field of the stake.
 
-     @since 1.0.0
+     Note that the list of locks is cosidered valid only if it contains at most
+      two locks from the given proposal: one voter lock and one creator lock.
+
+     @since 0.2.0
 -}
-pgetStakeRoles ::
-  forall (s :: S).
-  Term
-    s
-    ( PProposalId
-        :--> PBuiltinList (PAsData PProposalLock)
-        :--> PStakeRoles
-    )
-pgetStakeRoles = phoistAcyclic $
-  plam $ \pid ->
-    let getStakeRole = flip (pletFields @'["proposalId", "action"]) $
-          \lockF ->
-            ppureIf
-              # (pid #== lockF.proposalId)
-              #$ pmatch lockF.action
-              $ \case
-                PCreated _ -> pcon PCreator
-                PVoted ((pfield @"votedFor" #) -> tag) ->
-                  pcon $ PVoter tag
-                PCosigned _ -> pcon PCosigner
-     in pmapMaybe # plam (getStakeRole . pfromData)
+pgetStakeRole :: Term s (PProposalId :--> PBuiltinList (PAsData PProposalLock) :--> PStakeRole)
+pgetStakeRole = phoistAcyclic $
+  plam $ \pid locks ->
+    pfoldl
+      # plam
+        ( \role (pfromData -> lock) ->
+            let thisRole = pmatch lock $ \case
+                  PCreated ((pfield @"created" #) -> pid') ->
+                    pif
+                      (pid' #== pid)
+                      (pcon PCreator)
+                      (pcon PIrrelevant)
+                  PVoted lock' -> pletAll lock' $ \lockF ->
+                    pif
+                      (lockF.votedOn #== pid)
+                      (pcon $ PVoter lockF.votedFor)
+                      (pcon PIrrelevant)
+             in pcombineStakeRole # thisRole # role
+        )
+      # pcon PIrrelevant
+      # locks
+  where
+    pcombineStakeRole :: Term s (PStakeRole :--> PStakeRole :--> PStakeRole)
+    pcombineStakeRole = phoistAcyclic $
+      plam $ \x y ->
+        let cannotCombine = ptraceError "duplicate roles"
+         in pmatch x $ \case
+              PVoter r -> pmatch y $ \case
+                PCreator -> pcon $ PBoth r
+                PIrrelevant -> x
+                _ -> cannotCombine
+              PCreator -> pmatch y $ \case
+                PVoter r -> pcon $ PBoth r
+                PIrrelevant -> x
+                _ -> cannotCombine
+              PBoth _ -> cannotCombine
+              PIrrelevant -> y
 
 {- | Get the outcome that was voted for.
 
-     @since 1.0.0
+     @since 0.2.0
 -}
-pextractVoteOption :: forall (s :: S). Term s (PStakeRoles :--> PResultTag)
-pextractVoteOption =
-  phoistAcyclic $
-    plam $
-      (passertPJust # "not voter" #)
-        . ( pfindJust
-              # plam
-                ( flip pmatch $ \case
-                    PVoter r -> pjust # r
-                    _ -> pnothing
-                )
-              #
-          )
-
-{- | Resolve stake datum, if the given `PTxInInfo` represents a stake input.
-     Return nothing otherwise.
-
-     The first parameter is the assetclass of SST.
-
-     @since 1.0.0
--}
-presolveStakeInputDatum ::
-  forall (s :: S).
-  Term
-    s
-    ( PTagged StakeSTTag PAssetClass
-        :--> PMap 'Unsorted PDatumHash PDatum
-        :--> PTxInInfo
-        :--> PMaybe PStakeDatum
-    )
-presolveStakeInputDatum = phoistAcyclic $
-  plam $ \sstClass datums ->
-    flip
-      (pletFields @'["value", "datum", "address"])
-      ( \txOutF ->
-          let isStakeUTxO =
-                passetClassValueOfT
-                  # sstClass
-                  # txOutF.value
-                  #== 1
-
-              datum =
-                ptrace "Resolve stake datum" $
-                  pfromData $
-                    ptryFromOutputDatum @(PAsData PStakeDatum)
-                      # txOutF.datum
-                      # datums
-           in pif
-                isStakeUTxO
-                (pjust # datum)
-                pnothing
-      )
-      . (pfield @"resolved" #)
+pextractVoteOption :: Term s (PStakeRole :--> PResultTag)
+pextractVoteOption = phoistAcyclic $
+  plam $ \sr -> pmatch sr $ \case
+    PVoter r -> r
+    PBoth r -> r
+    _ -> ptraceError "not voter"

agora/Agora/Stake/Redeemers.hs

@@ -1,500 +0,0 @@
-{- |
-Module     : Agora.Stake.Redeemers
-Maintainer : connor@mlabs.city
-Description: Default implementation of stake redeemer handlers
-
-Default implementation of stake redeemer handlers.
--}
-module Agora.Stake.Redeemers (
-  ppermitVote,
-  pretractVote,
-  pdelegateTo,
-  pclearDelegate,
-  pdestroy,
-  pdepositWithdraw,
-) where
-
-import Agora.Proposal (
-  PProposalId,
-  PProposalRedeemer (PCosign, PUnlockStake, PVote),
-  ProposalStatus (Finished),
- )
-import Agora.Proposal.Time (PProposalTime)
-import Agora.Stake (
-  PProposalAction (PCosigned, PCreated, PVoted),
-  PProposalContext (
-    PNewProposal,
-    PNoProposal,
-    PSpendProposal
-  ),
-  PProposalLock (PProposalLock),
-  PSigContext (owner, signedBy),
-  PSignedBy (
-    PSignedByDelegate,
-    PSignedByOwner,
-    PUnknownSig
-  ),
-  PStakeDatum (PStakeDatum),
-  PStakeRedeemerContext (
-    PDepositWithdrawDelta,
-    PNoMetadata,
-    PSetDelegateTo
-  ),
-  PStakeRedeemerHandler,
-  PStakeRedeemerHandlerContext (
-    proposalContext,
-    redeemerContext,
-    sigContext,
-    stakeInputDatums,
-    stakeOutputDatums
-  ),
-  pstakeLocked,
- )
-import Plutarch.Api.V1.Address (PCredential)
-import Plutarch.Api.V2 (PMaybeData, PPOSIXTime)
-import Plutarch.Extra.Bool (passert)
-import Plutarch.Extra.Field (pletAll, pletAllC)
-import Plutarch.Extra.Maybe (pdjust, pdnothing, pmaybeData)
-import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
-import Plutarch.Extra.Time (PFullyBoundedTimeRange (PFullyBoundedTimeRange))
-import "liqwid-plutarch-extra" Plutarch.Extra.List (
-  pisSingleton,
-  ptryDeleteFirstBy,
-  ptryFromSingleton,
- )
-import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC)
-
--- | A wrapper which ensures that no proposal is presented in the transaction.
-pwithoutProposal ::
-  forall (s :: S).
-  Term
-    s
-    (PStakeRedeemerHandler :--> PStakeRedeemerHandler)
-pwithoutProposal = phoistAcyclic $
-  plam $ \f ctx -> pmatch ctx $ \ctxF ->
-    pif
-      ( pmatch ctxF.proposalContext $ \case
-          PNoProposal -> pconstant True
-          _ -> pconstant False
-      )
-      (f # ctx)
-      (ptraceError "No proposal is allowed")
-
-{- | Validate stake outputs given a function that converts an input stake datum
-      to an ouput stake datum. / O(n^2) /.
--}
-pbatchUpdateInputs ::
-  forall (s :: S).
-  Term
-    s
-    ( (PStakeDatum :--> PStakeDatum :--> PBool)
-        :--> PStakeRedeemerHandlerContext
-        :--> PBool
-    )
-pbatchUpdateInputs = phoistAcyclic $
-  plam $ \f -> flip pmatch $ \ctxF ->
-    pnull
-      #$ pfoldr
-      # plam (\x -> ptryDeleteFirstBy # (f # x))
-      # ctxF.stakeOutputDatums
-      # ctxF.stakeInputDatums
-
--- | Extract the 'PSigContext.signedBy' field from 'PStakeRedeemerHandlerContext'.
-pgetSignedBy ::
-  forall (s :: S).
-  Term
-    s
-    (PStakeRedeemerHandlerContext :--> PSignedBy)
-pgetSignedBy = phoistAcyclic $
-  plam $ \ctx -> unTermCont $ do
-    ctxF <- pmatchC ctx
-    sctxF <- pmatchC ctxF.sigContext
-    pure sctxF.signedBy
-
--- | Return true if the tx is authorized by either the owner or the delegatee.
-pisSignedBy ::
-  forall (s :: S).
-  Term
-    s
-    (PBool :--> PStakeRedeemerHandlerContext :--> PBool)
-pisSignedBy = phoistAcyclic $
-  plam $ \byDelegate ctx ->
-    pmatch (pgetSignedBy # ctx) $ \case
-      PSignedByOwner -> pconstant True
-      PSignedByDelegate -> byDelegate
-      PUnknownSig -> pconstant False
-
--- | Return true if only the @lockedBy@ field of the stake datum is updated.
-ponlyLocksUpdated ::
-  forall (s :: S).
-  Term
-    s
-    ( ( PBuiltinList (PAsData PProposalLock)
-          :--> PBuiltinList (PAsData PProposalLock)
-      )
-        :--> PStakeRedeemerHandlerContext
-        :--> PBool
-    )
-ponlyLocksUpdated = phoistAcyclic $
-  plam $ \f ->
-    pbatchUpdateInputs #$ plam $ \i o ->
-      pletAll i $ \iF ->
-        let newLocks = f # pfromData iF.lockedBy
-
-            expected =
-              mkRecordConstr
-                PStakeDatum
-                ( #stakedAmount
-                    .= iF.stakedAmount
-                    .& #owner
-                    .= iF.owner
-                    .& #delegatedTo
-                    .= iF.delegatedTo
-                    .& #lockedBy
-                    .= pdata newLocks
-                )
-         in expected #== o
-
--- | Validation logic shared between 'ppermitVote' and 'retractVote'.
-pvoteHelper ::
-  forall (s :: S).
-  Term
-    s
-    ( ( PStakeRedeemerHandlerContext
-          :--> PBuiltinList (PAsData PProposalLock)
-          :--> PBuiltinList (PAsData PProposalLock)
-      )
-        :--> PStakeRedeemerHandler
-    )
-pvoteHelper = phoistAcyclic $
-  plam $ \valProposalCtx ctx ->
-    -- This puts trust into the Proposal. The Proposal must necessarily check
-    -- that this is not abused.
-    passert
-      "Correct outputs"
-      (ponlyLocksUpdated # (valProposalCtx # ctx) # ctx)
-      (pconstant ())
-
--- | Add new lock the the existing list of locked.
-paddNewLock ::
-  forall (s :: S).
-  Term
-    s
-    ( PProposalLock
-        :--> PBuiltinList (PAsData PProposalLock)
-        :--> PBuiltinList (PAsData PProposalLock)
-    )
-paddNewLock = phoistAcyclic $
-  plam $
-    -- Prepend the lock.
-    \newLock -> pcons # pdata newLock
-
-{- | Default implementation of 'Agora.Stake.PermitVote'.
-
-     @since 1.0.0
--}
-ppermitVote :: forall (s :: S). Term s PStakeRedeemerHandler
-ppermitVote = pvoteHelper #$ phoistAcyclic $
-  plam $ \ctx -> unTermCont $ do
-    ctxF <- pmatchC ctx
-
-    withOnlyOneStakeInput <- pletC $
-      plam $ \lock -> unTermCont $ do
-        pguardC "Only one stake input allowed" $
-          pisSingleton # ctxF.stakeInputDatums
-
-        pguardC "Owner signs this transaction" $
-          pisSignedBy # pconstant False # ctx
-
-        pure lock
-
-    pure $
-      paddNewLock #$ pmatch ctxF.proposalContext $ \case
-        PSpendProposal proposal redeemer currentTime -> unTermCont $ do
-          mkLock <- pletC $
-            plam $ \action ->
-              mkRecordConstr
-                PProposalLock
-                ( #proposalId
-                    .= pfield @"proposalId"
-                    # proposal
-                    .& #action
-                    .= pdata action
-                )
-
-          pure $
-            pmatch redeemer $ \case
-              PVote ((pfromData . (pfield @"resultTag" #)) -> voteFor) ->
-                unTermCont $ do
-                  pguardC "Owner or delegatee signs the transaction" $
-                    pisSignedBy # pconstant True # ctx
-
-                  PFullyBoundedTimeRange _ upperBound <- pmatchC currentTime
-
-                  let action =
-                        mkRecordConstr
-                          PVoted
-                          ( #votedFor
-                              .= pdata voteFor
-                              .& #createdAt
-                              .= pdata upperBound
-                          )
-
-                  pure $ mkLock # action
-              PCosign _ ->
-                let action = pcon $ PCosigned pdnil
-                 in withOnlyOneStakeInput #$ mkLock # action
-              _ -> ptraceError "Expected Vote or Cosign"
-        PNewProposal proposalId ->
-          let action = pcon $ PCreated pdnil
-              lock =
-                mkRecordConstr
-                  PProposalLock
-                  ( #proposalId
-                      .= pdata proposalId
-                      .& #action
-                      .= pdata action
-                  )
-           in withOnlyOneStakeInput # lock
-        _ -> ptraceError "Expected a proposal to be spent or created"
-
-data PRemoveLocksMode (s :: S) = PRemoveVoterLockOnly | PRemoveAllLocks
-  deriving stock (Generic)
-  deriving anyclass (PlutusType, PEq)
-
-instance DerivePlutusType PRemoveLocksMode where
-  type DPTStrat _ = PlutusTypeScott
-
-{- | Remove stake locks with the proposal id given the list of existing locks.
-     The first parameter controls whether to remove creator locks or not. If
-     one of the locks performed voting action, the unlock cooldown will be
-     checked.
--}
-premoveLocks ::
-  forall (s :: S).
-  Term
-    s
-    ( PProposalId
-        :--> PPOSIXTime
-        :--> PProposalTime
-        :--> PRemoveLocksMode
-        :--> PBuiltinList (PAsData PProposalLock)
-        :--> PBuiltinList (PAsData PProposalLock)
-    )
-premoveLocks =
-  phoistAcyclic $
-    plam $ \proposalId unlockCooldown currentTime mode -> unTermCont $ do
-      shouldRemoveAllLocks <- pletC $ mode #== pcon PRemoveAllLocks
-
-      PFullyBoundedTimeRange lowerBound _ <- pmatchC currentTime
-
-      let handleVoter
-            ( (pfield @"createdAt" #) ->
-                createdAt
-              ) =
-              let notInCooldown = createdAt + unlockCooldown #<= lowerBound
-               in pif shouldRemoveAllLocks (pconstant True) $
-                    -- Fail the transaction if a voter lock is in cooldown.
-                    passert
-                      "Voter lock shouldn't be in cooldown"
-                      notInCooldown
-                      (pconstant True)
-
-          shouldRemoveLock =
-            flip
-              pletAll
-              ( \lockF ->
-                  foldl1
-                    (#&&)
-                    [ proposalId #== lockF.proposalId
-                    , pmatch lockF.action $ \case
-                        PVoted r -> handleVoter r
-                        _ -> shouldRemoveAllLocks
-                    ]
-              )
-              . pfromData
-
-          -- Return true, given a lock that should be kept.
-          handleLock = plam $ (pnot #) . shouldRemoveLock
-
-      pure $ pfilter # handleLock
-
-{- | Default implementation of 'Agora.Stake.RetractVotes'.
-
-     @since 1.0.0
--}
-pretractVote :: forall (s :: S). Term s PStakeRedeemerHandler
-pretractVote = pvoteHelper #$ phoistAcyclic $
-  plam $ \ctx ->
-    pmatch ctx $ \ctxF ->
-      pmatch ctxF.proposalContext $ \case
-        PSpendProposal proposal redeemer currentTime -> pmatch redeemer $ \case
-          PUnlockStake _ -> unTermCont $ do
-            proposalF <-
-              pletFieldsC
-                @'[ "proposalId"
-                  , "status"
-                  , "timingConfig"
-                  ]
-                proposal
-
-            let unlockCooldown =
-                  pfield @"minStakeVotingTime"
-                    # proposalF.timingConfig
-
-                mode = pmatch (proposalF.status #== pconstant Finished) $ \case
-                  PTrue -> pcon PRemoveAllLocks
-                  _ -> pcon PRemoveVoterLockOnly
-
-            pguardC "Authorized by either opwner or delegatee" $
-              pisSignedBy # pconstant True # ctx
-
-            pure $
-              premoveLocks
-                # proposalF.proposalId
-                # unlockCooldown
-                # currentTime
-                # mode
-          _ -> ptraceError "Expected unlock"
-        _ -> ptraceError "Expected spending proposal"
-
--- | Validation logic shared by 'pdelegateTo' and 'pclearDelegate'.
-pdelegateHelper ::
-  forall (s :: S).
-  Term
-    s
-    ( (PStakeRedeemerContext :--> PMaybeData (PAsData PCredential))
-        :--> PStakeRedeemerHandler
-    )
-pdelegateHelper = phoistAcyclic $
-  plam $ \f -> pwithoutProposal #$ plam $ \ctx -> unTermCont $ do
-    ctxF <- pmatchC ctx
-    sigCtxF <- pmatchC ctxF.sigContext
-
-    pguardC "Owner signs this transaction" $
-      pisSignedBy # pconstant False # ctx
-
-    let newDelegate = f # ctxF.redeemerContext
-
-    pguardC "Cannot delegate to the owner" $
-      pmaybeData
-        # pcon PTrue
-        # plam (\pkh -> pnot #$ sigCtxF.owner #== pfromData pkh)
-        # newDelegate
-
-    pguardC "Correct outputs" $
-      pbatchUpdateInputs
-        # plam
-          ( \i o -> pletAll i $ \iF ->
-              mkRecordConstr
-                PStakeDatum
-                ( #stakedAmount
-                    .= iF.stakedAmount
-                    .& #owner
-                    .= iF.owner
-                    .& #delegatedTo
-                    .= pdata newDelegate
-                    .& #lockedBy
-                    .= iF.lockedBy
-                )
-                #== o
-          )
-        # ctx
-
-    pure $ pconstant ()
-
-{- | Default implementation of 'Agora.Stake.DelegateTo'.
-
-     @since 1.0.0
--}
-pdelegateTo :: forall (s :: S). Term s PStakeRedeemerHandler
-pdelegateTo = pdelegateHelper #$ phoistAcyclic $
-  plam $
-    flip pmatch $ \case
-      PSetDelegateTo c -> pdjust # pdata c
-      _ -> perror
-
-{- | Default implementation of 'Agora.Stake.ClearDelegate'.
-
-     @since 1.0.0
--}
-pclearDelegate :: forall (s :: S). Term s PStakeRedeemerHandler
-pclearDelegate = pdelegateHelper #$ phoistAcyclic $
-  plam $
-    flip pmatch $ \case
-      PNoMetadata -> pdnothing
-      _ -> perror
-
-{- | Default implementation of 'Agora.Stake.Destroy'.
-
-     @since 1.0.0
--}
-pdestroy :: forall (s :: S). Term s PStakeRedeemerHandler
-pdestroy = phoistAcyclic $
-  pwithoutProposal #$ plam $ \ctx -> unTermCont $ do
-    ctxF <- pmatchC ctx
-
-    pguardC "Owner signs this transaction" $
-      pisSignedBy # pconstant False # ctx
-
-    pguardC "All stakes unlocked" $
-      pnot #$ pany # pstakeLocked # ctxF.stakeInputDatums
-
-    pguardC "All stakes burnt" $
-      pnull # ctxF.stakeOutputDatums
-
-    pure $ pconstant ()
-
-{- | Default implementation of 'Agora.Stake.DepositWithdraw'.
-
-     @since 1.0.0
--}
-pdepositWithdraw :: forall (s :: S). Term s PStakeRedeemerHandler
-pdepositWithdraw = phoistAcyclic $
-  pwithoutProposal #$ plam $ \ctx -> unTermCont $ do
-    ctxF <- pmatchC ctx
-
-    pguardC "Owner signs this transaction" $
-      pisSignedBy # pconstant False # ctx
-
-    ----------------------------------------------------------------------------
-
-    stakeInputDatum <-
-      pletC $
-        ptrace "Single stake input" $
-          ptryFromSingleton # ctxF.stakeInputDatums
-    stakeInputDatumF <- pletAllC stakeInputDatum
-
-    let stakeOutputDatum =
-          ptrace "Single stake output" $
-            ptryFromSingleton # ctxF.stakeOutputDatums
-
-    ----------------------------------------------------------------------------
-
-    pguardC "Stake unlocked" $
-      pnot #$ pstakeLocked # stakeInputDatum
-
-    ----------------------------------------------------------------------------
-
-    PDepositWithdrawDelta delta <- pmatchC ctxF.redeemerContext
-
-    newStakedAmount <- pletC $ stakeInputDatumF.stakedAmount + delta
-
-    pguardC "Non-negative staked amount" $ 0 #<= newStakedAmount
-
-    let expectedDatum =
-          mkRecordConstr
-            PStakeDatum
-            ( #stakedAmount
-                .= pdata newStakedAmount
-                .& #owner
-                .= stakeInputDatumF.owner
-                .& #delegatedTo
-                .= stakeInputDatumF.delegatedTo
-                .& #lockedBy
-                .= stakeInputDatumF.lockedBy
-            )
-
-    pguardC "Valid output datum" $ expectedDatum #== stakeOutputDatum
-
-    pure $ pconstant ()

agora/Agora/Treasury.hs

@@ -8,42 +8,123 @@ Description: Treasury scripts.
 Contains the datum, redeemer and validator for a template DAO
 treasury.
 -}
-module Agora.Treasury (
-  treasuryValidator,
-) where
+module Agora.Treasury (module Agora.Treasury) where
 
 import Agora.AuthorityToken (singleAuthorityTokenBurned)
-import Agora.SafeMoney (AuthorityTokenTag)
-import Plutarch.Api.V1.Value (PCurrencySymbol, PValue)
-import Plutarch.Api.V2 (PScriptPurpose (PSpending), PValidator)
-import Plutarch.Extra.Tagged (PTagged)
-import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletFieldsC, pmatchC)
+import Generics.SOP qualified as SOP
+import Plutarch.Api.V1 (PValidator)
+import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting))
+import "plutarch" Plutarch.Api.V1.Value (PValue)
+import Plutarch.Builtin (pforgetData)
+import Plutarch.Extra.IsData (
+  DerivePConstantViaEnum (..),
+  EnumIsData (..),
+  PlutusTypeEnumData,
+ )
+import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC)
+import Plutarch.Lift (PConstantDecl (..), PLifted (..), PUnsafeLiftDecl)
+import Plutarch.TryFrom ()
+import PlutusLedgerApi.V1.Value (CurrencySymbol)
+import PlutusTx qualified
+
+{- | Redeemer for Treasury actions.
+
+     @since 0.1.0
+-}
+data TreasuryRedeemer
+  = -- | Allow transaction to pass by delegating to GAT burn.
+    SpendTreasuryGAT
+  deriving stock
+    ( -- | @since 0.1.0
+      Eq
+    , -- | @since 0.1.0
+      Show
+    , -- | @since 0.1.0
+      Generic
+    , -- | @since 0.2.0
+      Enum
+    , -- | @since 0.2.0
+      Bounded
+    )
+  deriving anyclass
+    ( -- | @since 0.2.0
+      SOP.Generic
+    )
+  deriving
+    ( -- | @since 0.1.0
+      PlutusTx.ToData
+    , -- | @since 0.1.0
+      PlutusTx.FromData
+    )
+    via (EnumIsData TreasuryRedeemer)
+
+--------------------------------------------------------------------------------
+
+{- | Plutarch level type representing valid redeemers of the
+     treasury.
+
+     @since 0.1.0
+-}
+data PTreasuryRedeemer (s :: S)
+  = PSpendTreasuryGAT
+  deriving stock
+    ( -- | @since 0.1.0
+      Generic
+    , -- | @since 0.2.0
+      Bounded
+    , -- | @since 0.2.0
+      Enum
+    )
+  deriving anyclass
+    ( -- | @since 0.1.0
+      PlutusType
+    , -- | @since 0.1.0
+      PIsData
+    )
+
+instance DerivePlutusType PTreasuryRedeemer where
+  type DPTStrat _ = PlutusTypeEnumData
+
+-- | @since 0.1.0
+instance PUnsafeLiftDecl PTreasuryRedeemer where
+  type PLifted PTreasuryRedeemer = TreasuryRedeemer
+
+-- | @since 0.1.0
+deriving via
+  (DerivePConstantViaEnum TreasuryRedeemer PTreasuryRedeemer)
+  instance
+    (PConstantDecl TreasuryRedeemer)
+
+--------------------------------------------------------------------------------
 
 {- | Validator ensuring that transactions consuming the treasury
      do so in a valid manner.
 
-     == Arguments
-
-     Following arguments should be provided(in this order):
-     1. authority token symbol
-
-     @since 1.0.0
+     @since 0.1.0
 -}
 treasuryValidator ::
-  ClosedTerm (PAsData (PTagged AuthorityTokenTag PCurrencySymbol) :--> PValidator)
-treasuryValidator = plam $ \atSymbol _ _ ctx' -> unTermCont $ do
+  -- | Governance Authority Token that can unlock this validator.
+  CurrencySymbol ->
+  ClosedTerm PValidator
+treasuryValidator gatCs' = plam $ \_datum redeemer ctx' -> unTermCont $ do
   -- plet required fields from script context.
   ctx <- pletFieldsC @["txInfo", "purpose"] ctx'
 
-  -- Ensure that script is for spending.
-  PSpending _ <- pmatchC ctx.purpose
+  -- Ensure that script is for burning i.e. minting a negative amount.
+  PMinting _ <- pmatchC ctx.purpose
+
+  -- Ensure redeemer type is valid.
+  pguardC "Redeemer should be SpendTreasuryGAT" $
+    redeemer #== pforgetData (pconstantData SpendTreasuryGAT)
 
   -- Get the minted value from txInfo.
   txInfo <- pletFieldsC @'["mint", "inputs"] ctx.txInfo
   let mint :: Term _ (PValue _ _)
       mint = txInfo.mint
 
+  gatCs <- pletC $ pconstant gatCs'
+
   pguardC "A single authority token has been burned" $
-    singleAuthorityTokenBurned (pfromData atSymbol) txInfo.inputs mint
+    singleAuthorityTokenBurned gatCs txInfo.inputs mint
 
   pure . popaque $ pconstant ()

agora/Agora/Utils.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE QuantifiedConstraints #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
 {- |
 Module     : Agora.Utils
@@ -8,240 +9,124 @@ Description: Plutarch utility functions that should be upstreamed or don't belon
 Plutarch utility functions that should be upstreamed or don't belong anywhere else.
 -}
 module Agora.Utils (
-  scriptHashToAddress,
-  pstringIntercalate,
-  punwords,
-  pisNothing,
-  pisDNothing,
-  ptoScottEncodingT,
-  ptaggedSymbolValueOf,
-  ptag,
-  puntag,
-  phashDatum,
-  puncurryTuple,
-  psubtractSortedValue,
-  pfindInputWithStateThreadToken,
-  pfindOutputWithStateThreadToken,
-  pisSubValueOf,
+  validatorHashToTokenName,
+  mustFindDatum',
+  validatorHashToAddress,
+  pltAsData,
+  withBuiltinPairAsData,
+  CompiledValidator (..),
+  CompiledMintingPolicy (..),
+  CompiledEffect (..),
 ) where
 
-import Plutarch.Api.V1 (AmountGuarantees (Positive), KeyGuarantees (Sorted))
-import Plutarch.Api.V1.AssocMap (punionWith)
-import Plutarch.Api.V1.AssocMap qualified as AssocMap
-import Plutarch.Api.V1.Scripts (PDatumHash (PDatumHash))
-import Plutarch.Api.V2 (
-  AmountGuarantees (NoGuarantees),
-  PCurrencySymbol,
-  PMaybeData (PDNothing),
+import Plutarch.Api.V1 (
+  PDatum,
+  PDatumHash,
+  PMaybeData,
   PTuple,
-  PTxInInfo,
-  PTxOut,
-  PValue,
  )
-import Plutarch.Builtin (pforgetData, pserialiseData)
-import Plutarch.Crypto (pblake2b_256)
-import Plutarch.DataRepr (punDataSum)
-import Plutarch.Extra.AssetClass (PAssetClass, PAssetClassData, ptoScottEncoding)
-import Plutarch.Extra.Field (pletAll)
-import Plutarch.Extra.Functor (PFunctor (pfmap))
-import Plutarch.Extra.Tagged (PTagged)
-import Plutarch.Extra.Value (psymbolValueOf)
-import Plutarch.Num (PNum (pnegate, (#+)))
-import Plutarch.Unsafe (punsafeCoerce, punsafeDowncast)
-import PlutusLedgerApi.V2 (
-  Address (Address),
-  Credential (ScriptCredential),
-  ScriptHash,
+import Plutarch.Builtin (pforgetData)
+import Plutarch.Extra.List (plookupTuple)
+import Plutarch.Extra.Maybe (passertPDJust, passertPJust)
+import Plutarch.Extra.TermCont (ptryFromC)
+import PlutusLedgerApi.V1 (
+  Address (..),
+  Credential (..),
+  MintingPolicy,
+  TokenName (..),
+  Validator,
+  ValidatorHash (..),
  )
 
-{- | Create an 'Address' from a given 'ScriptHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'.
-
-     @since 1.0.0
+{- Functions which should (probably) not be upstreamed
+   All of these functions are quite inefficient.
 -}
-scriptHashToAddress :: ScriptHash -> Address
-scriptHashToAddress vh = Address (ScriptCredential vh) Nothing
 
--- | @since 1.0.0
-pstringIntercalate ::
-  forall (s :: S).
-  Term s PString ->
-  [Term s PString] ->
-  Term s PString
-pstringIntercalate _ [x] = x
-pstringIntercalate i (x : xs) = x <> i <> pstringIntercalate i xs
-pstringIntercalate _ _ = ""
+{- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging
+     tokens for extra safety.
 
--- | @since 1.0.0
-punwords ::
-  forall (s :: S).
-  [Term s PString] ->
-  Term s PString
-punwords = pstringIntercalate " "
+     @since 0.1.0
+-}
+validatorHashToTokenName :: ValidatorHash -> TokenName
+validatorHashToTokenName (ValidatorHash hash) = TokenName hash
 
--- | @since 1.0.0
-pisNothing ::
+{- | Find datum given a maybe datum hash
+
+     @since 0.1.0
+-}
+mustFindDatum' ::
+  forall (datum :: PType).
+  (PIsData datum, PTryFrom PData datum) =>
+  forall s.
+  Term
+    s
+    ( PMaybeData PDatumHash
+        :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum))
+        :--> datum
+    )
+mustFindDatum' = phoistAcyclic $
+  plam $ \mdh datums -> unTermCont $ do
+    let dh = passertPDJust # "Given TxOut dones't have a datum" # mdh
+        dt = passertPJust # "Datum not found in the transaction" #$ plookupTuple # dh # datums
+    (d, _) <- ptryFromC $ pforgetData $ pdata dt
+    pure d
+
+{- | Create an 'Address' from a given 'ValidatorHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'.
+
+     @since 0.1.0
+-}
+validatorHashToAddress :: ValidatorHash -> Address
+validatorHashToAddress vh = Address (ScriptCredential vh) Nothing
+
+{- | Compare two 'PAsData' value, return true if the first one is less than the second one.
+
+ @since 0.2.0
+-}
+pltAsData ::
   forall (a :: PType) (s :: S).
-  Term s (PMaybe a :--> PBool)
-pisNothing = phoistAcyclic $
+  (POrd a, PIsData a) =>
+  Term s (PAsData a :--> PAsData a :--> PBool)
+pltAsData = phoistAcyclic $
   plam $
-    flip pmatch $ \case
-      PNothing -> pconstant True
-      _ -> pconstant False
+    \(pfromData -> l) (pfromData -> r) -> l #< r
 
--- | @since 1.0.0
-pisDNothing ::
-  forall (a :: PType) (s :: S).
-  Term s (PMaybeData a :--> PBool)
-pisDNothing = phoistAcyclic $
-  plam $
-    flip pmatch $ \case
-      PDNothing _ -> pconstant True
-      _ -> pconstant False
+{- | Extract data stored in a 'PBuiltinPair' and call a function to process it.
 
--- | @since 1.0.0
-ptoScottEncodingT ::
-  forall {k :: Type} (unit :: k) (s :: S).
-  Term s (PTagged unit PAssetClassData :--> PTagged unit PAssetClass)
-ptoScottEncodingT = phoistAcyclic $
-  plam $ \d ->
-    punsafeDowncast $ ptoScottEncoding #$ pto d
-
-{- | Get the sum of all values belonging to a particular tagged 'CurrencySymbol'.
-
-     @since 1.0.0
+     @since 0.2.0
 -}
-ptaggedSymbolValueOf ::
-  forall
-    {k :: Type}
-    (unit :: k)
-    (keys :: KeyGuarantees)
-    (amounts :: AmountGuarantees)
-    (s :: S).
-  Term s (PTagged unit PCurrencySymbol :--> (PValue keys amounts :--> PInteger))
-ptaggedSymbolValueOf = phoistAcyclic $ plam $ \tcs -> psymbolValueOf # pto tcs
-
--- | @since 1.0.0
-ptag ::
-  forall {k :: Type} (tag :: k) (a :: PType) (s :: S).
-  Term s a ->
-  Term s (PTagged tag a)
-ptag = punsafeDowncast
-
--- | @since 1.0.0
-puntag ::
-  forall {k :: Type} (tag :: k) (a :: PType) (s :: S).
-  Term s (PTagged tag a) ->
-  Term s a
-puntag = pto
-
-{- | Hash the given datum using the correct algorithm(blake2b_256).
-
-     Note: check the discussion here: https://github.com/input-output-hk/cardano-ledger/issues/2941.
-
-     @since 1.0.0
--}
-phashDatum ::
-  forall (a :: PType) (s :: S).
-  PIsData a =>
-  Term s (a :--> PDatumHash)
-phashDatum =
-  phoistAcyclic $
-    plam $
-      pcon
-        . PDatumHash
-        . (pblake2b_256 #)
-        . (pserialiseData #)
-        . pforgetData
-        . pdata
-
-puncurryTuple ::
-  forall (c :: PType) (a :: PType) (b :: PType) (s :: S).
+withBuiltinPairAsData ::
+  forall (a :: PType) (b :: PType) (c :: PType) (s :: S).
   (PIsData a, PIsData b) =>
-  Term s ((a :--> b :--> c) :--> PTuple a b :--> c)
-puncurryTuple = phoistAcyclic $
-  plam $
-    \f ((punDataSum #) -> r) ->
-      pletAll r $ \rF -> f # rF._0 # rF._1
-
-psubtractSortedValue ::
-  forall (ag :: AmountGuarantees) (s :: S).
+  (Term s a -> Term s b -> Term s c) ->
   Term
     s
-    ( PValue 'Sorted ag
-        :--> PValue 'Sorted ag
-        :--> PValue 'Sorted 'NoGuarantees
-    )
-psubtractSortedValue = phoistAcyclic $ plam $ \a b ->
-  punsafeCoerce $
-    punionWith
-      # (punionWith # plam (#+))
-      # pto a
-      #$ pfmap
-      # (pfmap # pnegate)
-      # pto b
+    (PBuiltinPair (PAsData a) (PAsData b)) ->
+  Term s c
+withBuiltinPairAsData f p =
+  let a = pfromData $ pfstBuiltin # p
+      b = pfromData $ psndBuiltin # p
+   in f a b
 
-{- | Find an input containing exactly one token with the given currency symbol
+{- | Type-safe wrapper for compiled plutus validator.
 
-     @since 1.0.0
+     @since 0.2.0
 -}
-pfindInputWithStateThreadToken ::
-  forall tag.
-  ClosedTerm
-    ( PTagged tag PCurrencySymbol
-        :--> PBuiltinList PTxInInfo
-        :--> PMaybe PTxInInfo
-    )
-pfindInputWithStateThreadToken = plam $ \tokenSymbol inputs ->
-  pfind
-    # ( plam $ \input ->
-          ptaggedSymbolValueOf
-            # tokenSymbol
-            # (pfield @"value" # (pfield @"resolved" # input))
-            #== 1
-      )
-    # inputs
+newtype CompiledValidator (datum :: Type) (redeemer :: Type) = CompiledValidator
+  { getCompiledValidator :: Validator
+  }
 
-{- | Find an output containing exactly one token with the given currency symbol,
+{- | Type-safe wrapper for compiled plutus miting policy.
 
-     @since 1.0.0
+     @since 0.2.0
 -}
-pfindOutputWithStateThreadToken ::
-  forall tag.
-  ClosedTerm
-    ( PTagged tag PCurrencySymbol
-        :--> PBuiltinList PTxOut
-        :--> PMaybe PTxOut
-    )
-pfindOutputWithStateThreadToken = plam $ \tokenSymbol outputs ->
-  pfind
-    # ( plam $ \output ->
-          ( ptaggedSymbolValueOf
-              # tokenSymbol
-              # (pfield @"value" # output)
-              #== 1
-          )
-      )
-    # outputs
+newtype CompiledMintingPolicy (redeemer :: Type) = CompiledMintingPolicy
+  { getCompiledMintingPolicy :: MintingPolicy
+  }
 
-pisNonNegativeValue ::
-  forall (kg :: KeyGuarantees) (am :: AmountGuarantees) (s :: S).
-  Term s (PValue kg am :--> PBool)
-pisNonNegativeValue =
-  phoistAcyclic $
-    plam $
-      (AssocMap.pall # (AssocMap.pall # plam (0 #<=)) #)
-        . pto
+{- | Type-safe wrapper for compiled plutus effect.
 
-pisSubValueOf ::
-  forall (s :: S).
-  Term
-    s
-    ( PValue 'Sorted 'Positive
-        :--> PValue 'Sorted 'Positive
-        :--> PBool
-    )
-pisSubValueOf = phoistAcyclic $ plam $ \vl vr ->
-  pisNonNegativeValue
-    #$ psubtractSortedValue
-    # vl
-    # vr
+     @since 0.2.0
+-}
+newtype CompiledEffect (datum :: Type) = CompiledEffect
+  { getCompiledEffect :: Validator
+  }

docs/README.md

@@ -0,0 +1,21 @@
+# Agora specification and documentation
+
+This folder contains documents explaining the conceptual background and technical implementation of Agora components.
+
+## Technical design
+
+The `tech-design/` subdirectory contains high level descriptions of the architecture of Agora's governance solution.
+
+## Plutarch
+
+Agora makes extensive use of [Plutarch](https://github.com/plutonomicon/plutarch). One unfamiliar with the library will be unable to suitably understand the technical parts of this documentation. The maintainers provide an extensive [guide](https://github.com/Plutonomicon/plutarch/blob/master/docs/GUIDE.md) that will familiarise the developer with the language and thereby this set of documentation.
+
+## Glossary
+
+The following is a list of terms that are used frequently throughout the documentation:
+
+-   **DAO**: decentralised autonomous organisation.
+-   **Proposal**: a set of changes to a Cardano protocol, suggested by a community member. Will be enacted, if passed by the community.
+-   **Governance token (GT)**: the token that confers the right to vote on proposals within the protocol. May affect the user's eligibility for rewards. Examples include Liqwid's LQ.
+-   **Governance authority token (GAT)**: A token that grants the effects of a proposal the authority to alter the system. More information can be read [here](https://liqwid.notion.site/Authority-Tokens-b25d2011c8114e04ac9e73514e6b9421).
+-   **Effect**: A script for implementing changes suggested by a proposal. An effect can make numerous changes and a proposal may have multiple effects.

docs/diagrams/GovernanceAuthorityToken.dot

@@ -0,0 +1,238 @@
+digraph GovernanceAuthorityToken {
+
+  rankdir = LR;
+  // Inputs:
+
+  //////////////////////////////////////////////////////////////////////////////
+  // governance in
+  governance_datum
+    [ shape = record
+    , label =
+        "{{ GovernanceState
+        }}"
+    ];
+
+  governance_addr
+    [ shape = record
+    , label = "{{ Script | Governance }}"
+    , style = "bold"
+    ];
+
+  //////////////////////////////////////////////////////////////////////////////
+  // proposal in
+  proposal_datum
+    [ shape = record
+    , label = "{{ ProposalState }}"
+    ];
+
+  proposal_addr
+    -> proposal_redeemer
+    [style = "dashed", dir="none"];
+
+  proposal_addr
+    [ shape = record
+    , label = "{{ Script | Proposal }}"
+    , style = "bold"
+    ];
+
+  governance_datum
+    -> governance_addr [style = "dashed"];
+
+  governance_redeemer
+    [ shape = record
+    , label = "{{ GovernanceAction | MintAuthorityTokens }}"
+    ];
+
+  governance_addr
+    -> governance_redeemer
+      [style = "dashed", dir="none"];
+
+  proposal_datum -> proposal_addr [style = "dashed"];
+
+  //////////////////////////////////////////////////////////////////////////////
+  // user wallet in
+  user_wallet_min_ada_in
+    [ shape = ellipse
+    , label = <ADA: <I>min utxo</I>>
+    ];
+
+  user_wallet_in
+    [ shape = box
+    , label = "User Inputs"
+    , style = "bold"
+    , peripheries = 2
+    ];
+
+  user_wallet_min_ada_in
+    -> user_wallet_in
+    [ style = "dashed"
+    ];
+
+
+  tx1
+    [ shape = diamond
+    , label = "Tx1"
+    , style = "bold"
+    ];
+
+  user_wallet_in -> tx1;
+  governance_addr -> tx1;
+  proposal_addr -> tx1;
+
+  //////////////////////////////////////////////////////////////////////////////
+  // governance out
+  governance_datum_out
+    [ shape = record
+    , label =
+        "{{ GovernanceState
+        }}"
+    ];
+
+  governance_addr_out
+    [ shape = record
+    , label = "{{ Script | Governance }}"
+    , style = "bold"
+    ];
+
+
+  governance_datum_out
+    -> governance_addr_out
+    [ style = "dashed"
+    ];
+
+  //////////////////////////////////////////////////////////////////////////////
+  // proposal out
+  proposal_datum_out
+    -> proposal_addr_out
+    [ style = "dashed"
+    ];
+
+  proposal_redeemer
+    [ shape = record
+    , label =
+    "{{ ProposalAction | FinishVoting }}"
+    ];
+
+
+  proposal_datum_out
+    [ shape = record
+    , label =
+    "{{ ProposalState }}"
+    ];
+
+  proposal_addr_out
+    [ shape = record
+    , label = "{{ Script | Proposal }}"
+    , style = "bold"
+    ];
+
+
+  //////////////////////////////////////////////////////////////////////////////
+  // effect out
+  effect_governance_token_out
+    [ shape = ellipse
+    , label = <GovernanceAuthorityToken: 1>
+    ];
+
+  effect_addr_out
+    [ shape = record
+    , label = "{{ Script | Effect }}"
+    , style = "bold"
+    ];
+
+  effect_governance_token_out
+    -> effect_addr_out
+    [ style = "dashed"
+    ];
+
+  effect_min_ada_out
+    -> effect_addr_out
+    [ style = "dashed"
+    ];
+
+  effect_min_ada_out
+    [ shape = ellipse
+    , label = <ADA: <I>min utxo</I>>
+    ];
+
+  tx1 -> governance_addr_out;
+  tx1 -> proposal_addr_out;
+  tx1 -> effect_addr_out;
+
+  //////////////////////////////////////////////////////////////////////////////
+  //////////////////////////////////////////////////////////////////////////////
+
+  //////////////////////////////////////////////////////////////////////////////
+  // effect in
+  effect_addr_out2
+    [ shape = record
+    , label = "{{ Script | Effect }}"
+    , style = "bold"
+    ];
+
+  //////////////////////////////////////////////////////////////////////////////
+  // market in
+  market_addr_in
+    [ shape = record
+    , label = "{{ Script | Market }}"
+    , style = "bold"
+    ];
+
+  market_datum_in
+    [ shape = record
+    , label = "{{ MarketState | params: A }}"
+    ];
+
+  market_datum_in
+    -> market_addr_in
+    [ style = "dashed"
+    ];
+
+  //////////////////////////////////////////////////////////////////////////////
+  // market out
+  market_addr_out
+    [ shape = record
+    , label = "{{ Script | Market }}"
+    , style = "bold"
+    ];
+
+  market_datum_out
+    [ shape = record
+    , label = "{{ MarketState | params: f(A) }}"
+    ];
+
+  market_datum_out
+    -> market_addr_out
+    [ style = "dashed"
+    ];
+
+  tx2
+    [ shape = diamond
+    , label = "Tx2"
+    , style = "bold"
+    ];
+
+  user_wallet_min_ada_out
+    [ shape = ellipse
+    , label = <ADA: <I>min utxo</I>>
+    ];
+
+  user_wallet_out
+    [ shape = box
+    , label = "User Outputs"
+    , style = "bold"
+    , peripheries = 2
+    ];
+
+  user_wallet_min_ada_out
+    -> user_wallet_out
+    [ style = "dashed"
+    ];
+
+  effect_addr_out -> tx2;
+  market_addr_in -> tx2;
+  tx2 -> user_wallet_out;
+  tx2 -> effect_addr_out2;
+  tx2 -> market_addr_out;
+
+}

docs/diagrams/GovernanceAuthorityToken.svg

@@ -0,0 +1,322 @@
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"
+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">
+<!-- Generated by graphviz version 2.47.3 (0)
+ -->
+<!-- Title: GovernanceAuthorityToken Pages: 1 -->
+<svg width="1129pt" height="459pt"
+ viewBox="0.00 0.00 1128.65 459.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
+<g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 455)">
+<title>GovernanceAuthorityToken</title>
+<polygon fill="white" stroke="transparent" points="-4,4 -4,-455 1124.65,-455 1124.65,4 -4,4"/>
+<!-- governance_datum -->
+<g id="node1" class="node">
+<title>governance_datum</title>
+<polygon fill="none" stroke="black" points="7.99,-383.5 7.99,-419.5 147.99,-419.5 147.99,-383.5 7.99,-383.5"/>
+<text text-anchor="middle" x="77.99" y="-397.8" font-family="Times,serif" font-size="14.00">GovernanceState</text>
+</g>
+<!-- governance_addr -->
+<g id="node2" class="node">
+<title>governance_addr</title>
+<polygon fill="none" stroke="black" stroke-width="2" points="195.99,-378.5 195.99,-424.5 296.99,-424.5 296.99,-378.5 195.99,-378.5"/>
+<text text-anchor="middle" x="246.49" y="-409.3" font-family="Times,serif" font-size="14.00">Script</text>
+<polyline fill="none" stroke="black" stroke-width="2" points="195.99,-401.5 296.99,-401.5 "/>
+<text text-anchor="middle" x="246.49" y="-386.3" font-family="Times,serif" font-size="14.00">Governance</text>
+</g>
+<!-- governance_datum&#45;&gt;governance_addr -->
+<g id="edge2" class="edge">
+<title>governance_datum&#45;&gt;governance_addr</title>
+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M148.15,-401.5C160.65,-401.5 173.58,-401.5 185.77,-401.5"/>
+<polygon fill="black" stroke="black" points="185.82,-405 195.82,-401.5 185.82,-398 185.82,-405"/>
+</g>
+<!-- governance_redeemer -->
+<g id="node6" class="node">
+<title>governance_redeemer</title>
+<polygon fill="none" stroke="black" points="402.32,-404.5 402.32,-450.5 569.32,-450.5 569.32,-404.5 402.32,-404.5"/>
+<text text-anchor="middle" x="485.82" y="-435.3" font-family="Times,serif" font-size="14.00">GovernanceAction</text>
+<polyline fill="none" stroke="black" points="402.32,-427.5 569.32,-427.5 "/>
+<text text-anchor="middle" x="485.82" y="-412.3" font-family="Times,serif" font-size="14.00">MintAuthorityTokens</text>
+</g>
+<!-- governance_addr&#45;&gt;governance_redeemer -->
+<g id="edge3" class="edge">
+<title>governance_addr&#45;&gt;governance_redeemer</title>
+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M297.24,-406.95C327.55,-410.27 367.04,-414.6 401.97,-418.42"/>
+</g>
+<!-- tx1 -->
+<g id="node9" class="node">
+<title>tx1</title>
+<polygon fill="none" stroke="black" stroke-width="2" points="485.82,-330.5 446.28,-312.5 485.82,-294.5 525.37,-312.5 485.82,-330.5"/>
+<text text-anchor="middle" x="485.82" y="-308.8" font-family="Times,serif" font-size="14.00">Tx1</text>
+</g>
+<!-- governance_addr&#45;&gt;tx1 -->
+<g id="edge7" class="edge">
+<title>governance_addr&#45;&gt;tx1</title>
+<path fill="none" stroke="black" d="M275.17,-378.21C292.02,-365.2 314.58,-349.78 336.99,-340.5 370.45,-326.64 411.03,-319.58 441.2,-316.02"/>
+<polygon fill="black" stroke="black" points="441.85,-319.47 451.41,-314.9 441.09,-312.51 441.85,-319.47"/>
+</g>
+<!-- proposal_datum -->
+<g id="node3" class="node">
+<title>proposal_datum</title>
+<polygon fill="none" stroke="black" points="19.49,-118.5 19.49,-154.5 136.49,-154.5 136.49,-118.5 19.49,-118.5"/>
+<text text-anchor="middle" x="77.99" y="-132.8" font-family="Times,serif" font-size="14.00">ProposalState</text>
+</g>
+<!-- proposal_addr -->
+<g id="node4" class="node">
+<title>proposal_addr</title>
+<polygon fill="none" stroke="black" stroke-width="2" points="206.99,-113.5 206.99,-159.5 285.99,-159.5 285.99,-113.5 206.99,-113.5"/>
+<text text-anchor="middle" x="246.49" y="-144.3" font-family="Times,serif" font-size="14.00">Script</text>
+<polyline fill="none" stroke="black" stroke-width="2" points="206.99,-136.5 285.99,-136.5 "/>
+<text text-anchor="middle" x="246.49" y="-121.3" font-family="Times,serif" font-size="14.00">Proposal</text>
+</g>
+<!-- proposal_datum&#45;&gt;proposal_addr -->
+<g id="edge4" class="edge">
+<title>proposal_datum&#45;&gt;proposal_addr</title>
+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M136.76,-136.5C156.33,-136.5 177.98,-136.5 196.78,-136.5"/>
+<polygon fill="black" stroke="black" points="196.9,-140 206.9,-136.5 196.9,-133 196.9,-140"/>
+</g>
+<!-- proposal_redeemer -->
+<g id="node5" class="node">
+<title>proposal_redeemer</title>
+<polygon fill="none" stroke="black" points="423.82,-0.5 423.82,-46.5 547.82,-46.5 547.82,-0.5 423.82,-0.5"/>
+<text text-anchor="middle" x="485.82" y="-31.3" font-family="Times,serif" font-size="14.00">ProposalAction</text>
+<polyline fill="none" stroke="black" points="423.82,-23.5 547.82,-23.5 "/>
+<text text-anchor="middle" x="485.82" y="-8.3" font-family="Times,serif" font-size="14.00">FinishVoting</text>
+</g>
+<!-- proposal_addr&#45;&gt;proposal_redeemer -->
+<g id="edge1" class="edge">
+<title>proposal_addr&#45;&gt;proposal_redeemer</title>
+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M266.76,-113.35C283.45,-94.86 309.21,-69.76 336.99,-55.5 363.73,-41.77 396.13,-33.92 423.77,-29.43"/>
+</g>
+<!-- proposal_addr&#45;&gt;tx1 -->
+<g id="edge8" class="edge">
+<title>proposal_addr&#45;&gt;tx1</title>
+<path fill="none" stroke="black" d="M254.73,-159.73C266.38,-193.02 292.59,-253.67 336.99,-284.5 366.58,-305.05 407.19,-311.59 438.36,-313.24"/>
+<polygon fill="black" stroke="black" points="438.41,-316.75 448.54,-313.63 438.68,-309.75 438.41,-316.75"/>
+</g>
+<!-- user_wallet_min_ada_in -->
+<g id="node7" class="node">
+<title>user_wallet_min_ada_in</title>
+<ellipse fill="none" stroke="black" cx="77.99" cy="-312.5" rx="77.99" ry="18"/>
+<text text-anchor="start" x="25.99" y="-309.8" font-family="Times,serif" font-size="14.00">ADA: </text>
+<text text-anchor="start" x="65.99" y="-309.8" font-family="Times,serif" font-style="italic" font-size="14.00">min utxo</text>
+</g>
+<!-- user_wallet_in -->
+<g id="node8" class="node">
+<title>user_wallet_in</title>
+<polygon fill="none" stroke="black" stroke-width="2" points="296.99,-330.5 195.99,-330.5 195.99,-294.5 296.99,-294.5 296.99,-330.5"/>
+<polygon fill="none" stroke="black" stroke-width="2" points="300.99,-334.5 191.99,-334.5 191.99,-290.5 300.99,-290.5 300.99,-334.5"/>
+<text text-anchor="middle" x="246.49" y="-308.8" font-family="Times,serif" font-size="14.00">User Inputs</text>
+</g>
+<!-- user_wallet_min_ada_in&#45;&gt;user_wallet_in -->
+<g id="edge5" class="edge">
+<title>user_wallet_min_ada_in&#45;&gt;user_wallet_in</title>
+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M156.39,-312.5C164.75,-312.5 173.19,-312.5 181.37,-312.5"/>
+<polygon fill="black" stroke="black" points="181.56,-316 191.56,-312.5 181.56,-309 181.56,-316"/>
+</g>
+<!-- user_wallet_in&#45;&gt;tx1 -->
+<g id="edge6" class="edge">
+<title>user_wallet_in&#45;&gt;tx1</title>
+<path fill="none" stroke="black" d="M301.05,-312.5C341.58,-312.5 396.8,-312.5 436.1,-312.5"/>
+<polygon fill="black" stroke="black" points="436.24,-316 446.24,-312.5 436.24,-309 436.24,-316"/>
+</g>
+<!-- governance_addr_out -->
+<g id="node11" class="node">
+<title>governance_addr_out</title>
+<polygon fill="none" stroke="black" stroke-width="2" points="670.66,-331.5 670.66,-377.5 771.66,-377.5 771.66,-331.5 670.66,-331.5"/>
+<text text-anchor="middle" x="721.16" y="-362.3" font-family="Times,serif" font-size="14.00">Script</text>
+<polyline fill="none" stroke="black" stroke-width="2" points="670.66,-354.5 771.66,-354.5 "/>
+<text text-anchor="middle" x="721.16" y="-339.3" font-family="Times,serif" font-size="14.00">Governance</text>
+</g>
+<!-- tx1&#45;&gt;governance_addr_out -->
+<g id="edge13" class="edge">
+<title>tx1&#45;&gt;governance_addr_out</title>
+<path fill="none" stroke="black" d="M514.51,-317.48C550.27,-323.92 613.5,-335.3 660.44,-343.75"/>
+<polygon fill="black" stroke="black" points="660.03,-347.23 670.49,-345.56 661.27,-340.34 660.03,-347.23"/>
+</g>
+<!-- proposal_addr_out -->
+<g id="node13" class="node">
+<title>proposal_addr_out</title>
+<polygon fill="none" stroke="black" stroke-width="2" points="681.66,-244.5 681.66,-290.5 760.66,-290.5 760.66,-244.5 681.66,-244.5"/>
+<text text-anchor="middle" x="721.16" y="-275.3" font-family="Times,serif" font-size="14.00">Script</text>
+<polyline fill="none" stroke="black" stroke-width="2" points="681.66,-267.5 760.66,-267.5 "/>
+<text text-anchor="middle" x="721.16" y="-252.3" font-family="Times,serif" font-size="14.00">Proposal</text>
+</g>
+<!-- tx1&#45;&gt;proposal_addr_out -->
+<g id="edge14" class="edge">
+<title>tx1&#45;&gt;proposal_addr_out</title>
+<path fill="none" stroke="black" d="M514.36,-307.36C544.06,-301.8 592.73,-292.64 634.66,-284.5 646.61,-282.18 659.5,-279.64 671.55,-277.24"/>
+<polygon fill="black" stroke="black" points="672.32,-280.66 681.44,-275.28 670.95,-273.8 672.32,-280.66"/>
+</g>
+<!-- effect_addr_out -->
+<g id="node15" class="node">
+<title>effect_addr_out</title>
+<polygon fill="none" stroke="black" stroke-width="2" points="691.16,-169.5 691.16,-215.5 751.16,-215.5 751.16,-169.5 691.16,-169.5"/>
+<text text-anchor="middle" x="721.16" y="-200.3" font-family="Times,serif" font-size="14.00">Script</text>
+<polyline fill="none" stroke="black" stroke-width="2" points="691.16,-192.5 751.16,-192.5 "/>
+<text text-anchor="middle" x="721.16" y="-177.3" font-family="Times,serif" font-size="14.00">Effect</text>
+</g>
+<!-- tx1&#45;&gt;effect_addr_out -->
+<g id="edge15" class="edge">
+<title>tx1&#45;&gt;effect_addr_out</title>
+<path fill="none" stroke="black" d="M524.56,-312.91C556.23,-311.58 601.5,-305.62 634.66,-284.5 657.76,-269.79 652.08,-254.62 670.66,-234.5 674.63,-230.2 679.02,-225.92 683.5,-221.83"/>
+<polygon fill="black" stroke="black" points="685.89,-224.39 691.07,-215.14 681.26,-219.14 685.89,-224.39"/>
+</g>
+<!-- governance_datum_out -->
+<g id="node10" class="node">
+<title>governance_datum_out</title>
+<polygon fill="none" stroke="black" points="415.82,-349.5 415.82,-385.5 555.82,-385.5 555.82,-349.5 415.82,-349.5"/>
+<text text-anchor="middle" x="485.82" y="-363.8" font-family="Times,serif" font-size="14.00">GovernanceState</text>
+</g>
+<!-- governance_datum_out&#45;&gt;governance_addr_out -->
+<g id="edge9" class="edge">
+<title>governance_datum_out&#45;&gt;governance_addr_out</title>
+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M555.88,-363.65C589.11,-361.8 628.55,-359.6 660.46,-357.83"/>
+<polygon fill="black" stroke="black" points="660.75,-361.32 670.54,-357.26 660.36,-354.33 660.75,-361.32"/>
+</g>
+<!-- proposal_datum_out -->
+<g id="node12" class="node">
+<title>proposal_datum_out</title>
+<polygon fill="none" stroke="black" points="427.32,-239.5 427.32,-275.5 544.32,-275.5 544.32,-239.5 427.32,-239.5"/>
+<text text-anchor="middle" x="485.82" y="-253.8" font-family="Times,serif" font-size="14.00">ProposalState</text>
+</g>
+<!-- proposal_datum_out&#45;&gt;proposal_addr_out -->
+<g id="edge10" class="edge">
+<title>proposal_datum_out&#45;&gt;proposal_addr_out</title>
+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M544.5,-259.97C583.48,-261.64 634.39,-263.82 671.36,-265.41"/>
+<polygon fill="black" stroke="black" points="671.25,-268.91 681.39,-265.84 671.55,-261.91 671.25,-268.91"/>
+</g>
+<!-- effect_governance_token_out -->
+<g id="node14" class="node">
+<title>effect_governance_token_out</title>
+<ellipse fill="none" stroke="black" cx="485.82" cy="-202.5" rx="148.67" ry="18"/>
+<text text-anchor="start" x="379.32" y="-198.8" font-family="Times,serif" font-size="14.00">GovernanceAuthorityToken: 1</text>
+</g>
+<!-- effect_governance_token_out&#45;&gt;effect_addr_out -->
+<g id="edge11" class="edge">
+<title>effect_governance_token_out&#45;&gt;effect_addr_out</title>
+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M626.26,-196.52C646.19,-195.67 665.2,-194.86 680.83,-194.19"/>
+<polygon fill="black" stroke="black" points="681.24,-197.67 691.08,-193.75 680.94,-190.68 681.24,-197.67"/>
+</g>
+<!-- tx2 -->
+<g id="node22" class="node">
+<title>tx2</title>
+<polygon fill="none" stroke="black" stroke-width="2" points="885.65,-168.5 846.11,-150.5 885.65,-132.5 925.2,-150.5 885.65,-168.5"/>
+<text text-anchor="middle" x="885.65" y="-146.8" font-family="Times,serif" font-size="14.00">Tx2</text>
+</g>
+<!-- effect_addr_out&#45;&gt;tx2 -->
+<g id="edge19" class="edge">
+<title>effect_addr_out&#45;&gt;tx2</title>
+<path fill="none" stroke="black" d="M751.21,-184.99C778.89,-177.84 820.59,-167.06 850,-159.46"/>
+<polygon fill="black" stroke="black" points="851.04,-162.8 859.84,-156.91 849.28,-156.03 851.04,-162.8"/>
+</g>
+<!-- effect_min_ada_out -->
+<g id="node16" class="node">
+<title>effect_min_ada_out</title>
+<ellipse fill="none" stroke="black" cx="485.82" cy="-148.5" rx="77.99" ry="18"/>
+<text text-anchor="start" x="433.82" y="-145.8" font-family="Times,serif" font-size="14.00">ADA: </text>
+<text text-anchor="start" x="473.82" y="-145.8" font-family="Times,serif" font-style="italic" font-size="14.00">min utxo</text>
+</g>
+<!-- effect_min_ada_out&#45;&gt;effect_addr_out -->
+<g id="edge12" class="edge">
+<title>effect_min_ada_out&#45;&gt;effect_addr_out</title>
+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M548,-159.45C574.64,-164.28 606.21,-170.07 634.66,-175.5 649.73,-178.37 666.28,-181.64 680.76,-184.53"/>
+<polygon fill="black" stroke="black" points="680.41,-188.03 690.9,-186.56 681.78,-181.17 680.41,-188.03"/>
+</g>
+<!-- effect_addr_out2 -->
+<g id="node17" class="node">
+<title>effect_addr_out2</title>
+<polygon fill="none" stroke="black" stroke-width="2" points="1030.15,-127.5 1030.15,-173.5 1090.15,-173.5 1090.15,-127.5 1030.15,-127.5"/>
+<text text-anchor="middle" x="1060.15" y="-158.3" font-family="Times,serif" font-size="14.00">Script</text>
+<polyline fill="none" stroke="black" stroke-width="2" points="1030.15,-150.5 1090.15,-150.5 "/>
+<text text-anchor="middle" x="1060.15" y="-135.3" font-family="Times,serif" font-size="14.00">Effect</text>
+</g>
+<!-- market_addr_in -->
+<g id="node18" class="node">
+<title>market_addr_in</title>
+<polygon fill="none" stroke="black" stroke-width="2" points="687.16,-85.5 687.16,-131.5 755.16,-131.5 755.16,-85.5 687.16,-85.5"/>
+<text text-anchor="middle" x="721.16" y="-116.3" font-family="Times,serif" font-size="14.00">Script</text>
+<polyline fill="none" stroke="black" stroke-width="2" points="687.16,-108.5 755.16,-108.5 "/>
+<text text-anchor="middle" x="721.16" y="-93.3" font-family="Times,serif" font-size="14.00">Market</text>
+</g>
+<!-- market_addr_in&#45;&gt;tx2 -->
+<g id="edge20" class="edge">
+<title>market_addr_in&#45;&gt;tx2</title>
+<path fill="none" stroke="black" d="M755.43,-117.1C783.05,-124.24 822.2,-134.36 850.15,-141.58"/>
+<polygon fill="black" stroke="black" points="849.35,-144.99 859.9,-144.1 851.1,-138.21 849.35,-144.99"/>
+</g>
+<!-- market_datum_in -->
+<g id="node19" class="node">
+<title>market_datum_in</title>
+<polygon fill="none" stroke="black" points="432.32,-65.5 432.32,-111.5 539.32,-111.5 539.32,-65.5 432.32,-65.5"/>
+<text text-anchor="middle" x="485.82" y="-96.3" font-family="Times,serif" font-size="14.00">MarketState</text>
+<polyline fill="none" stroke="black" points="432.32,-88.5 539.32,-88.5 "/>
+<text text-anchor="middle" x="485.82" y="-73.3" font-family="Times,serif" font-size="14.00">params: A</text>
+</g>
+<!-- market_datum_in&#45;&gt;market_addr_in -->
+<g id="edge16" class="edge">
+<title>market_datum_in&#45;&gt;market_addr_in</title>
+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M539.48,-93.01C580.88,-96.56 637.87,-101.45 676.7,-104.77"/>
+<polygon fill="black" stroke="black" points="676.88,-108.3 687.14,-105.67 677.48,-101.33 676.88,-108.3"/>
+</g>
+<!-- market_addr_out -->
+<g id="node20" class="node">
+<title>market_addr_out</title>
+<polygon fill="none" stroke="black" stroke-width="2" points="1026.15,-192.5 1026.15,-238.5 1094.15,-238.5 1094.15,-192.5 1026.15,-192.5"/>
+<text text-anchor="middle" x="1060.15" y="-223.3" font-family="Times,serif" font-size="14.00">Script</text>
+<polyline fill="none" stroke="black" stroke-width="2" points="1026.15,-215.5 1094.15,-215.5 "/>
+<text text-anchor="middle" x="1060.15" y="-200.3" font-family="Times,serif" font-size="14.00">Market</text>
+</g>
+<!-- market_datum_out -->
+<g id="node21" class="node">
+<title>market_datum_out</title>
+<polygon fill="none" stroke="black" points="832.15,-192.5 832.15,-238.5 939.15,-238.5 939.15,-192.5 832.15,-192.5"/>
+<text text-anchor="middle" x="885.65" y="-223.3" font-family="Times,serif" font-size="14.00">MarketState</text>
+<polyline fill="none" stroke="black" points="832.15,-215.5 939.15,-215.5 "/>
+<text text-anchor="middle" x="885.65" y="-200.3" font-family="Times,serif" font-size="14.00">params: f(A)</text>
+</g>
+<!-- market_datum_out&#45;&gt;market_addr_out -->
+<g id="edge17" class="edge">
+<title>market_datum_out&#45;&gt;market_addr_out</title>
+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M939.34,-215.5C963.83,-215.5 992.59,-215.5 1015.8,-215.5"/>
+<polygon fill="black" stroke="black" points="1016.03,-219 1026.03,-215.5 1016.03,-212 1016.03,-219"/>
+</g>
+<!-- tx2&#45;&gt;effect_addr_out2 -->
+<g id="edge22" class="edge">
+<title>tx2&#45;&gt;effect_addr_out2</title>
+<path fill="none" stroke="black" d="M925.36,-150.5C953.46,-150.5 991.35,-150.5 1019.63,-150.5"/>
+<polygon fill="black" stroke="black" points="1019.96,-154 1029.96,-150.5 1019.96,-147 1019.96,-154"/>
+</g>
+<!-- tx2&#45;&gt;market_addr_out -->
+<g id="edge23" class="edge">
+<title>tx2&#45;&gt;market_addr_out</title>
+<path fill="none" stroke="black" d="M907.8,-158.47C934.78,-168.63 982.05,-186.45 1016.61,-199.47"/>
+<polygon fill="black" stroke="black" points="1015.4,-202.75 1025.99,-203.01 1017.87,-196.2 1015.4,-202.75"/>
+</g>
+<!-- user_wallet_out -->
+<g id="node24" class="node">
+<title>user_wallet_out</title>
+<polygon fill="none" stroke="black" stroke-width="2" points="1116.65,-104.5 1003.65,-104.5 1003.65,-68.5 1116.65,-68.5 1116.65,-104.5"/>
+<polygon fill="none" stroke="black" stroke-width="2" points="1120.65,-108.5 999.65,-108.5 999.65,-64.5 1120.65,-64.5 1120.65,-108.5"/>
+<text text-anchor="middle" x="1060.15" y="-82.8" font-family="Times,serif" font-size="14.00">User Outputs</text>
+</g>
+<!-- tx2&#45;&gt;user_wallet_out -->
+<g id="edge21" class="edge">
+<title>tx2&#45;&gt;user_wallet_out</title>
+<path fill="none" stroke="black" d="M908.15,-142.52C928.69,-134.9 960.76,-123 990.08,-112.12"/>
+<polygon fill="black" stroke="black" points="991.33,-115.4 999.49,-108.64 988.89,-108.83 991.33,-115.4"/>
+</g>
+<!-- user_wallet_min_ada_out -->
+<g id="node23" class="node">
+<title>user_wallet_min_ada_out</title>
+<ellipse fill="none" stroke="black" cx="885.65" cy="-86.5" rx="77.99" ry="18"/>
+<text text-anchor="start" x="833.65" y="-83.8" font-family="Times,serif" font-size="14.00">ADA: </text>
+<text text-anchor="start" x="873.65" y="-83.8" font-family="Times,serif" font-style="italic" font-size="14.00">min utxo</text>
+</g>
+<!-- user_wallet_min_ada_out&#45;&gt;user_wallet_out -->
+<g id="edge18" class="edge">
+<title>user_wallet_min_ada_out&#45;&gt;user_wallet_out</title>
+<path fill="none" stroke="black" stroke-dasharray="5,2" d="M963.82,-86.5C972.36,-86.5 981.03,-86.5 989.47,-86.5"/>
+<polygon fill="black" stroke="black" points="989.64,-90 999.64,-86.5 989.64,-83 989.64,-90"/>
+</g>
+</g>
+</svg>

docs/diagrams/UsingAgora.dot

@@ -0,0 +1,6 @@
+digraph {
+  rankdir=LR
+  Users -> Proposals [label="vote on"]
+  Proposals -> Effects [label="have one or many"]
+  Effects -> Components [label="alter"]
+}

docs/diagrams/UsingAgora.svg

@@ -0,0 +1,57 @@
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"
+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">
+<!-- Generated by graphviz version 2.49.3 (0)
+ -->
+<!-- Pages: 1 -->
+<svg width="742pt" height="44pt"
+ viewBox="0.00 0.00 742.06 44.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
+<g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 40)">
+<polygon fill="white" stroke="transparent" points="-4,4 -4,-40 738.06,-40 738.06,4 -4,4"/>
+<!-- Users -->
+<g id="node1" class="node">
+<title>Users</title>
+<ellipse fill="none" stroke="black" cx="38.35" cy="-18" rx="38.19" ry="18"/>
+<text text-anchor="middle" x="38.35" y="-14.3" font-family="Times,serif" font-size="14.00">Users</text>
+</g>
+<!-- Proposals -->
+<g id="node2" class="node">
+<title>Proposals</title>
+<ellipse fill="none" stroke="black" cx="221.59" cy="-18" rx="55.79" ry="18"/>
+<text text-anchor="middle" x="221.59" y="-14.3" font-family="Times,serif" font-size="14.00">Proposals</text>
+</g>
+<!-- Users&#45;&gt;Proposals -->
+<g id="edge1" class="edge">
+<title>Users&#45;&gt;Proposals</title>
+<path fill="none" stroke="black" d="M76.9,-18C99.51,-18 128.92,-18 155.24,-18"/>
+<polygon fill="black" stroke="black" points="155.54,-21.5 165.54,-18 155.54,-14.5 155.54,-21.5"/>
+<text text-anchor="middle" x="121.19" y="-21.8" font-family="Times,serif" font-size="14.00">vote on</text>
+</g>
+<!-- Effects -->
+<g id="node3" class="node">
+<title>Effects</title>
+<ellipse fill="none" stroke="black" cx="483.38" cy="-18" rx="42.79" ry="18"/>
+<text text-anchor="middle" x="483.38" y="-14.3" font-family="Times,serif" font-size="14.00">Effects</text>
+</g>
+<!-- Proposals&#45;&gt;Effects -->
+<g id="edge2" class="edge">
+<title>Proposals&#45;&gt;Effects</title>
+<path fill="none" stroke="black" d="M277.68,-18C322.64,-18 385.72,-18 429.94,-18"/>
+<polygon fill="black" stroke="black" points="430.19,-21.5 440.19,-18 430.19,-14.5 430.19,-21.5"/>
+<text text-anchor="middle" x="358.98" y="-21.8" font-family="Times,serif" font-size="14.00">have one or many</text>
+</g>
+<!-- Components -->
+<g id="node4" class="node">
+<title>Components</title>
+<ellipse fill="none" stroke="black" cx="665.17" cy="-18" rx="68.79" ry="18"/>
+<text text-anchor="middle" x="665.17" y="-14.3" font-family="Times,serif" font-size="14.00">Components</text>
+</g>
+<!-- Effects&#45;&gt;Components -->
+<g id="edge3" class="edge">
+<title>Effects&#45;&gt;Components</title>
+<path fill="none" stroke="black" d="M526.53,-18C544.29,-18 565.55,-18 585.99,-18"/>
+<polygon fill="black" stroke="black" points="586.25,-21.5 596.25,-18 586.25,-14.5 586.25,-21.5"/>
+<text text-anchor="middle" x="561.28" y="-21.8" font-family="Times,serif" font-size="14.00">alter</text>
+</g>
+</g>
+</svg>

docs/diagrams/gov-overview.dot

@@ -1,9 +1,7 @@
 digraph {
-  Stakes -> Proposals [label="create and vote on"]
+  Stakes -> Proposals [label="vote on"]
   Proposals -> Effects [label="have"]
-  Admin-> Governor [label="initializes"]
   Governor -> Effects [label="issues GATs to"]
   Users -> Stakes [label="lock GT in"]
   Effects -> Treasury [label="release GT from"]
-  Effects -> Components [label="alter"]
 }

docs/diagrams/gov-overview.svg

@@ -4,106 +4,80 @@
 <!-- Generated by graphviz version 2.49.3 (0)
  -->
 <!-- Pages: 1 -->
-<svg width="327pt" height="392pt"
- viewBox="0.00 0.00 327.00 392.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
+<svg width="262pt" height="392pt"
+ viewBox="0.00 0.00 261.95 392.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
 <g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 388)">
-<polygon fill="white" stroke="transparent" points="-4,4 -4,-388 323,-388 323,4 -4,4"/>
+<polygon fill="white" stroke="transparent" points="-4,4 -4,-388 257.95,-388 257.95,4 -4,4"/>
 <!-- Stakes -->
 <g id="node1" class="node">
 <title>Stakes</title>
-<ellipse fill="none" stroke="black" cx="186" cy="-279" rx="42.49" ry="18"/>
-<text text-anchor="middle" x="186" y="-275.3" font-family="Times,serif" font-size="14.00">Stakes</text>
+<ellipse fill="none" stroke="black" cx="181.95" cy="-279" rx="42.49" ry="18"/>
+<text text-anchor="middle" x="181.95" y="-275.3" font-family="Times,serif" font-size="14.00">Stakes</text>
 </g>
 <!-- Proposals -->
 <g id="node2" class="node">
 <title>Proposals</title>
-<ellipse fill="none" stroke="black" cx="186" cy="-192" rx="55.79" ry="18"/>
-<text text-anchor="middle" x="186" y="-188.3" font-family="Times,serif" font-size="14.00">Proposals</text>
+<ellipse fill="none" stroke="black" cx="181.95" cy="-192" rx="55.79" ry="18"/>
+<text text-anchor="middle" x="181.95" y="-188.3" font-family="Times,serif" font-size="14.00">Proposals</text>
 </g>
 <!-- Stakes&#45;&gt;Proposals -->
 <g id="edge1" class="edge">
 <title>Stakes&#45;&gt;Proposals</title>
-<path fill="none" stroke="black" d="M186,-260.8C186,-249.16 186,-233.55 186,-220.24"/>
-<polygon fill="black" stroke="black" points="189.5,-220.18 186,-210.18 182.5,-220.18 189.5,-220.18"/>
-<text text-anchor="middle" x="252.5" y="-231.8" font-family="Times,serif" font-size="14.00">create and vote on</text>
+<path fill="none" stroke="black" d="M181.95,-260.8C181.95,-249.16 181.95,-233.55 181.95,-220.24"/>
+<polygon fill="black" stroke="black" points="185.45,-220.18 181.95,-210.18 178.45,-220.18 185.45,-220.18"/>
+<text text-anchor="middle" x="208.45" y="-231.8" font-family="Times,serif" font-size="14.00">vote on</text>
 </g>
 <!-- Effects -->
 <g id="node3" class="node">
 <title>Effects</title>
-<ellipse fill="none" stroke="black" cx="121" cy="-105" rx="42.79" ry="18"/>
-<text text-anchor="middle" x="121" y="-101.3" font-family="Times,serif" font-size="14.00">Effects</text>
+<ellipse fill="none" stroke="black" cx="116.95" cy="-105" rx="42.79" ry="18"/>
+<text text-anchor="middle" x="116.95" y="-101.3" font-family="Times,serif" font-size="14.00">Effects</text>
 </g>
 <!-- Proposals&#45;&gt;Effects -->
 <g id="edge2" class="edge">
 <title>Proposals&#45;&gt;Effects</title>
-<path fill="none" stroke="black" d="M180.25,-173.75C176.36,-163.6 170.55,-150.86 163,-141 159.3,-136.17 154.82,-131.57 150.19,-127.38"/>
-<polygon fill="black" stroke="black" points="152.24,-124.54 142.35,-120.76 147.73,-129.88 152.24,-124.54"/>
-<text text-anchor="middle" x="188" y="-144.8" font-family="Times,serif" font-size="14.00">have</text>
+<path fill="none" stroke="black" d="M176.2,-173.75C172.31,-163.6 166.5,-150.86 158.95,-141 155.25,-136.17 150.77,-131.57 146.14,-127.38"/>
+<polygon fill="black" stroke="black" points="148.19,-124.54 138.3,-120.76 143.68,-129.88 148.19,-124.54"/>
+<text text-anchor="middle" x="183.95" y="-144.8" font-family="Times,serif" font-size="14.00">have</text>
 </g>
 <!-- Treasury -->
-<g id="node7" class="node">
+<g id="node6" class="node">
 <title>Treasury</title>
-<ellipse fill="none" stroke="black" cx="52" cy="-18" rx="51.99" ry="18"/>
-<text text-anchor="middle" x="52" y="-14.3" font-family="Times,serif" font-size="14.00">Treasury</text>
+<ellipse fill="none" stroke="black" cx="116.95" cy="-18" rx="51.99" ry="18"/>
+<text text-anchor="middle" x="116.95" y="-14.3" font-family="Times,serif" font-size="14.00">Treasury</text>
 </g>
 <!-- Effects&#45;&gt;Treasury -->
-<g id="edge6" class="edge">
+<g id="edge5" class="edge">
 <title>Effects&#45;&gt;Treasury</title>
-<path fill="none" stroke="black" d="M86.61,-94.14C74.21,-88.77 61.44,-80.75 54,-69 49.73,-62.26 48.26,-53.93 48.14,-46.01"/>
-<polygon fill="black" stroke="black" points="51.64,-46.17 48.63,-36.01 44.65,-45.83 51.64,-46.17"/>
-<text text-anchor="middle" x="111.5" y="-57.8" font-family="Times,serif" font-size="14.00">release GT from</text>
-</g>
-<!-- Components -->
-<g id="node8" class="node">
-<title>Components</title>
-<ellipse fill="none" stroke="black" cx="191" cy="-18" rx="68.79" ry="18"/>
-<text text-anchor="middle" x="191" y="-14.3" font-family="Times,serif" font-size="14.00">Components</text>
-</g>
-<!-- Effects&#45;&gt;Components -->
-<g id="edge7" class="edge">
-<title>Effects&#45;&gt;Components</title>
-<path fill="none" stroke="black" d="M145.54,-89.8C153.79,-84.13 162.53,-77.03 169,-69 174.58,-62.07 179.02,-53.5 182.41,-45.42"/>
-<polygon fill="black" stroke="black" points="185.73,-46.55 186.04,-35.96 179.19,-44.05 185.73,-46.55"/>
-<text text-anchor="middle" x="194" y="-57.8" font-family="Times,serif" font-size="14.00">alter</text>
-</g>
-<!-- Admin -->
-<g id="node4" class="node">
-<title>Admin</title>
-<ellipse fill="none" stroke="black" cx="58" cy="-279" rx="40.09" ry="18"/>
-<text text-anchor="middle" x="58" y="-275.3" font-family="Times,serif" font-size="14.00">Admin</text>
+<path fill="none" stroke="black" d="M116.95,-86.8C116.95,-75.16 116.95,-59.55 116.95,-46.24"/>
+<polygon fill="black" stroke="black" points="120.45,-46.18 116.95,-36.18 113.45,-46.18 120.45,-46.18"/>
+<text text-anchor="middle" x="174.45" y="-57.8" font-family="Times,serif" font-size="14.00">release GT from</text>
 </g>
 <!-- Governor -->
-<g id="node5" class="node">
+<g id="node4" class="node">
 <title>Governor</title>
-<ellipse fill="none" stroke="black" cx="58" cy="-192" rx="53.89" ry="18"/>
-<text text-anchor="middle" x="58" y="-188.3" font-family="Times,serif" font-size="14.00">Governor</text>
-</g>
-<!-- Admin&#45;&gt;Governor -->
-<g id="edge3" class="edge">
-<title>Admin&#45;&gt;Governor</title>
-<path fill="none" stroke="black" d="M58,-260.8C58,-249.16 58,-233.55 58,-220.24"/>
-<polygon fill="black" stroke="black" points="61.5,-220.18 58,-210.18 54.5,-220.18 61.5,-220.18"/>
-<text text-anchor="middle" x="93" y="-231.8" font-family="Times,serif" font-size="14.00">initializes</text>
+<ellipse fill="none" stroke="black" cx="53.95" cy="-192" rx="53.89" ry="18"/>
+<text text-anchor="middle" x="53.95" y="-188.3" font-family="Times,serif" font-size="14.00">Governor</text>
 </g>
 <!-- Governor&#45;&gt;Effects -->
-<g id="edge4" class="edge">
+<g id="edge3" class="edge">
 <title>Governor&#45;&gt;Effects</title>
-<path fill="none" stroke="black" d="M54.28,-173.63C53.04,-163.43 53.21,-150.69 59,-141 63.84,-132.9 71.31,-126.51 79.41,-121.54"/>
-<polygon fill="black" stroke="black" points="81.23,-124.54 88.35,-116.69 77.89,-118.38 81.23,-124.54"/>
-<text text-anchor="middle" x="111" y="-144.8" font-family="Times,serif" font-size="14.00">issues GATs to</text>
+<path fill="none" stroke="black" d="M50.23,-173.63C48.99,-163.43 49.16,-150.69 54.95,-141 59.79,-132.9 67.26,-126.51 75.36,-121.54"/>
+<polygon fill="black" stroke="black" points="77.18,-124.54 84.3,-116.69 73.84,-118.38 77.18,-124.54"/>
+<text text-anchor="middle" x="106.95" y="-144.8" font-family="Times,serif" font-size="14.00">issues GATs to</text>
 </g>
 <!-- Users -->
-<g id="node6" class="node">
+<g id="node5" class="node">
 <title>Users</title>
-<ellipse fill="none" stroke="black" cx="186" cy="-366" rx="38.19" ry="18"/>
-<text text-anchor="middle" x="186" y="-362.3" font-family="Times,serif" font-size="14.00">Users</text>
+<ellipse fill="none" stroke="black" cx="181.95" cy="-366" rx="38.19" ry="18"/>
+<text text-anchor="middle" x="181.95" y="-362.3" font-family="Times,serif" font-size="14.00">Users</text>
 </g>
 <!-- Users&#45;&gt;Stakes -->
-<g id="edge5" class="edge">
+<g id="edge4" class="edge">
 <title>Users&#45;&gt;Stakes</title>
-<path fill="none" stroke="black" d="M186,-347.8C186,-336.16 186,-320.55 186,-307.24"/>
-<polygon fill="black" stroke="black" points="189.5,-307.18 186,-297.18 182.5,-307.18 189.5,-307.18"/>
-<text text-anchor="middle" x="222" y="-318.8" font-family="Times,serif" font-size="14.00">lock GT in</text>
+<path fill="none" stroke="black" d="M181.95,-347.8C181.95,-336.16 181.95,-320.55 181.95,-307.24"/>
+<polygon fill="black" stroke="black" points="185.45,-307.18 181.95,-297.18 178.45,-307.18 185.45,-307.18"/>
+<text text-anchor="middle" x="217.95" y="-318.8" font-family="Times,serif" font-size="14.00">lock GT in</text>
 </g>
 </g>
 </svg>

docs/meta/README.md

@@ -0,0 +1,3 @@
+# Docs meta
+
+This folder includes notes to assist in the writing of documentation. Those not involved with spec writing have no need for these files.

docs/meta/status-format.md

@@ -0,0 +1,119 @@
+# Spec status format
+
+This document specifies a format used to denote the 'status' of a spec document.
+
+## Overview
+
+Each specification document should be headed by a simple table outlining aspects of its status in relation to:
+
+-   Authorship: who has contributed to it?
+-   Ownership: who is responsible for it?
+-   Implementation(s): where is it used?
+-   Completeness: is it done yet?
+
+This format should be used at the start of any documentation that may be considered a _technical specification_, with a related implementation. 
+
+## Format
+
+The format is as follows, with {substitutions} in curly braces.
+
+| Specification | Implementation | Last revision |
+|:-------------:|:--------------:|:-------------:|
+| {status}      | {status}       | {version} {date} |
+
+--------------------
+
+**Specification ownership:** {[Spec owner]}
+
+**Authors**: 
+ -   {[Spec owner]}
+ -   {[Author]}
+
+**Implementation ownership:** {[Impl owner]}
+ 
+**Current status**:
+ 
+{Short description of status regarding __both__ specification and implementation}.
+
+[Spec owner]: https://genrandom.com/cats/
+[Author]: https://genrandom.com/cats/
+[Impl owner]: https://genrandom.com/cats/
+
+```markdown
+| Specification | Implementation | Last Revision |
+|:-------------:|:--------------:|:-------------:|
+| {status}      | {status}       | {version}, {date} |
+
+--------------------
+
+**Specification ownership:** [{owner name}]
+
+**Authors**: 
+ -   [{owner name}]
+ -   [{author name}]
+
+
+**Implementation ownership:** [{impl owner name}]
+ 
+**Current status**:
+ 
+{Short description of status}
+
+[{owner name}]: {github url}
+[{author name}]: {github url}
+[{impl owner name}]: {github url}
+
+--------------------
+```
+
+### Specification/Implementation status
+
+The 'Specification' and 'Implementation' status should be one of the following:
+
+-   `WIP`: Work In Progress, currently incomplete, pending current or future work by the current owner or a future owner.
+-   `Draft`: Complete but pending further evaluation or changes to be accounted for in the future.
+-   `Final`: Complete and finalised to some degree of certainty.
+
+### Last revision
+
+-   version - An optional version/revision number for the spec document.
+-   date - date the document was last updated in [ISO 8601 format](https://www.wikiwand.com/en/ISO_8601#/Calendar_dates) (YYYY-MM-DD).
+
+### Authors
+
+The authors and contributors of the spec document.
+
+### Specification ownership
+
+The person currently, or most recently tasked with writing and maintaining the spec document.
+
+### Implementation ownership
+
+The person currently or most recently tasked with the implementation of the features described in the document.
+
+-   For individual features, this will be the person most recently assigned to related GitHub issues.
+-   For broader sections, this will be a person leading the implementation efforts for the particular system.
+
+## Example
+
+| Specification | Implementation | Last Revision |
+|:-------------:|:--------------:|:-------------:|
+| WIP   | Draft     | 0.1 2022-01-31 |
+
+--------------------
+
+**Specification ownership:** [Jack Hodgkinson]
+
+**Authors**: 
+ -   [Jack Hodgkinson]
+ -   [Emily Martins]
+
+**Implementation ownership:** [Emily Martins]
+ 
+**Current status**:
+ 
+Draft completed in project repo. Spec needs revisiting to address issues outlined in #42. Section on staking pool behaviour is out-dated. 
+
+[Jack Hodgkinson]: https://github.com/jhodgdev
+[Emily Martins]: https://github.com/emiflake
+***

docs/meta/style-guide.md

@@ -0,0 +1,52 @@
+# Agora docs style guide
+
+This document includes a couple of notes on how Agora documentation should be written and formatted.
+
+## British/American spelling and grammatical differences
+
+The difference between British and American English is wider than a lot of people presume. Authors are permitted to use whichever of the two they learned and therefore feel more comfortable with. The only exception to this is when writing changes that would result in a 'mixing' of styles e.g. having 'color' in a sentence and 'colour' in the next. In this instance please alter your use of the language to maintain consistency.
+
+## Capitalised words
+
+The following words should always in the forms below:
+
+-   Agora
+-   Liqwid
+-   LiqwidX
+-   Nix
+-   NixOS
+-   Plutus
+-   Plutarch
+
+Sensible exceptions naturally exist, including referencing shell commands (`nix-shell`) or code:
+
+```haskell
+plutarchTerm :: Term s a 
+plutarchTerm = ...
+```
+
+## Upper-case terms
+
+The following terms should always be rendered in all capital letters:
+
+-   UTXO
+-   EUTXO
+
+## Lower-case words
+
+The following words should always be rendered lower-case (unless used at the beginning of a sentence):
+
+-   governance
+
+## ADA, Ada, ada
+
+Cardano's native token suffers from a frustrating variety of acceptable forms. Reputable sources can be found using all three variants listed in the header. As such, no usage shall be mandated with two caveats:
+
+1.  Whilst the name of the currency is subject to variance, its 'symbol' is unambiguously 'ADA'. Therefore when talking about amounts e.g. 'Trillian deposits 100ADA', use 'ADA'.
+2.  Exercise _reasonable consistency_. The use of an 'Ada' at the beginning of the document and an 'ada' 3000 words later is not something worth losing sleep over. Inconsistency within paragraphs or (gasp!) _sentences_ should always be avoided.
+
+## Avoid
+
+The following practices should be avoided:
+
+-   The use of '&' apart from in proper nouns such as AT\&T.

flake.nix

@@ -1,84 +1,109 @@
 {
   description = "agora";
 
-  nixConfig = {
-    extra-experimental-features = [ "nix-command" "flakes" "ca-derivations" ];
-    extra-substituters = [ "https://cache.iog.io" "https://mlabs.cachix.org" ];
-    extra-trusted-public-keys = [ "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=" ];
-    allow-import-from-derivation = "true";
-    max-jobs = "auto";
-    auto-optimise-store = "true";
-  };
-
   inputs = {
-    nixpkgs.follows = "liqwid-nix/nixpkgs";
-    nixpkgs-latest.url = "github:NixOS/nixpkgs";
+    nixpkgs.follows = "plutarch/nixpkgs";
+    nixpkgs-latest.url = "github:NixOS/nixpkgs?rev=cf63df0364f67848083ff75bc8ac9b7ca7aa5a01";
+    # temporary fix for nix versions that have the transitive follows bug
+    # see https://github.com/NixOS/nix/issues/6013
+    nixpkgs-2111 = { url = "github:NixOS/nixpkgs/nixpkgs-21.11-darwin"; };
 
-    liqwid-nix = {
-      url = "github:Liqwid-Labs/liqwid-nix/v2.7.2";
-      inputs.nixpkgs-latest.follows = "nixpkgs-latest";
+    haskell-nix-extra-hackage.follows = "plutarch/haskell-nix-extra-hackage";
+    haskell-nix.follows = "plutarch/haskell-nix";
+    iohk-nix.follows = "plutarch/iohk-nix";
+    haskell-language-server.follows = "plutarch/haskell-language-server";
+
+    # Plutarch and its friends
+    plutarch = {
+      url = "github:Plutonomicon/plutarch-plutus?ref=staging";
+
+      inputs.emanote.follows =
+        "plutarch/haskell-nix/nixpkgs-unstable";
+      inputs.nixpkgs.follows =
+        "plutarch/haskell-nix/nixpkgs-unstable";
     };
 
-    liqwid-libs.url =
-      "github:Liqwid-Labs/liqwid-libs";
+    plutarch-numeric.url =
+      "github:Liqwid-Labs/plutarch-numeric?ref=main";
+    plutarch-safe-money.url =
+      "github:Liqwid-Labs/plutarch-safe-money?ref=main";
+    liqwid-plutarch-extra.url =
+      "github:Liqwid-Labs/liqwid-plutarch-extra?ref=plutus-v1";
+    plutarch-quickcheck.url =
+      "github:liqwid-labs/plutarch-quickcheck?ref=staging";
+    plutarch-context-builder.url =
+      "github:Liqwid-Labs/plutarch-context-builder?ref=plutus-v1";
+    plutarch-script-export.url =
+      "github:Liqwid-Labs/plutarch-script-export?ref=main";
+
+    liqwid-nix.url = "github:Liqwid-Labs/liqwid-nix?ref=main";
   };
 
-  outputs = inputs@{ self, flake-parts, ... }:
-    flake-parts.lib.mkFlake { inherit inputs; } {
-      imports = [
-        inputs.liqwid-nix.flakeModule
-      ];
-      systems = [ "x86_64-linux" "aarch64-darwin" "x86_64-darwin" "aarch64-linux" ];
-      perSystem = { config, self', inputs', pkgs, system, ... }:
-        let
-          pkgs = import inputs.nixpkgs-latest { inherit system; };
-        in
-        {
-          onchain.default = {
-            src = ./.;
-            ghc.version = "ghc925";
-            fourmolu.package = pkgs.haskell.packages.ghc943.fourmolu_0_10_1_0;
-            hlint = { };
-            cabalFmt = { };
-            hasktags = { };
-            applyRefact = { };
-            shell = { };
-            hoogleImage.enable = false;
-            enableBuildChecks = true;
-            extraHackageDeps = [
-              "${inputs.liqwid-libs}/plutarch-quickcheck"
-              "${inputs.liqwid-libs}/plutarch-context-builder"
-              "${inputs.liqwid-libs}/liqwid-plutarch-extra"
-              "${inputs.liqwid-libs}/liqwid-script-export"
-              "${inputs.liqwid-libs.inputs.ply}/ply-core"
-              "${inputs.liqwid-libs.inputs.ply}/ply-plutarch"
-            ];
+  outputs = inputs@{ liqwid-nix, ... }:
+    let
+      benchCheckOverlay = self: super: {
+        toFlake =
+          let
+            inherit (self) inputs perSystem pkgsFor';
+            flake = super.toFlake or { };
+            name = "benchCheck";
+          in
+          flake // {
+            checks = perSystem (system:
+              flake.checks.${system} // {
+                ${name} =
+                  let
+                    pkgs' = pkgsFor' system;
+                    bench = flake.packages.${system}."agora:bench:agora-bench";
+                  in
+                  pkgs'.runCommand name
+                    {
+                      nativeBuildInputs = [ pkgs'.diffutils ];
+                    } ''
+                    export LC_CTYPE=C.UTF-8
+                    export LC_ALL=C.UTF-8
+                    export LANG=C.UTF-8
+                    cd ${inputs.self}
+                    ${bench}/bin/agora-bench | diff bench.csv - \
+                      || (echo "bench.csv is outdated"; exit 1)
+                    mkdir "$out"
+                  '';
+              });
           };
-          ci.required = [ "all_onchain" ];
-          packages.export =
-            pkgs.stdenv.mkDerivation {
-              name = "export";
-              src = ./.;
-              buildInput = [
-                self'.packages."agora:exe:agora-scripts"
-              ];
-              buildPhase = ''
-                export PATH=$PATH:${self'.packages."agora:exe:agora-scripts"}/bin
-                agora-scripts file --builder raw
-                agora-scripts file --builder rawDebug
-              '';
-              installPhase = ''
-                NAME=${if self ? rev then self.shortRev else "dirty"}
-                mkdir $out
-                cp raw.json $out/agora-"$NAME".json
-                cp rawDebug.json $out/agora-debug-"$NAME".json
-              '';
-            };
-        };
-
-      flake.hydraJobs.x86_64-linux = (
-        self.checks.x86_64-linux
-        // self.packages.x86_64-linux
-      );
-    };
+      };
+    in
+    (liqwid-nix.buildProject
+      {
+        inherit inputs;
+        src = ./.;
+      }
+      [
+        liqwid-nix.haskellProject
+        liqwid-nix.plutarchProject
+        (liqwid-nix.addDependencies [
+          "${inputs.plutarch-numeric}"
+          "${inputs.plutarch-safe-money}"
+          "${inputs.plutarch-quickcheck}"
+          "${inputs.plutarch-context-builder}"
+          "${inputs.liqwid-plutarch-extra}"
+          "${inputs.plutarch-script-export}"
+        ])
+        (liqwid-nix.enableFormatCheck [
+          "-XQuasiQuotes"
+          "-XTemplateHaskell"
+          "-XTypeApplications"
+          "-XImportQualifiedPost"
+          "-XPatternSynonyms"
+          "-XOverloadedRecordDot"
+        ])
+        liqwid-nix.enableLintCheck
+        liqwid-nix.enableCabalFormatCheck
+        liqwid-nix.enableNixFormatCheck
+        liqwid-nix.addBuildChecks
+        (liqwid-nix.addCommandLineTools (pkgs: _: [
+          pkgs.haskellPackages.hasktags
+        ]))
+        benchCheckOverlay
+      ]
+    ).toFlake;
 }