From 480f25b2f27c36c2351af3b385dbf5d19f144cd7 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Wed, 13 Apr 2022 14:25:10 -0400
Subject: [PATCH 01/78] `pmapUnionWith` optimization

There is no reason to have `ps` unless the current key is a duplicate
entry.
---
 agora/Agora/Utils.hs | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index 5ac101c..83ac342 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -217,11 +217,10 @@ pmapUnionWith = phoistAcyclic $
             # plam
               ( \p -> P.do
                   pf <- plet $ pfstBuiltin # p
-                  ps <- plet $ psndBuiltin # p
                   pmatch (plookup # pf # ys) $ \case
                     PJust v ->
                       -- Data conversions here are silly, aren't they?
-                      ppairDataBuiltin # pf # pdata (f # pfromData ps # pfromData v)
+                      ppairDataBuiltin # pf # pdata (f # pfromData (psndBuiltin # p) # pfromData v)
                     PNothing -> p
               )
             # xs

From 33c7b8a342aae7475cb19765bf3cc43cb07b625c Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Thu, 14 Apr 2022 14:20:37 +0200
Subject: [PATCH 02/78] use 'formatCheck' in CI instead of the two manual
 format checks

---
 .github/format.sh                |  6 ------
 .github/workflows/integrate.yaml | 26 ++------------------------
 flake.nix                        | 11 ++++++++---
 3 files changed, 10 insertions(+), 33 deletions(-)
 delete mode 100755 .github/format.sh

diff --git a/.github/format.sh b/.github/format.sh
deleted file mode 100755
index b655d8b..0000000
--- a/.github/format.sh
+++ /dev/null
@@ -1,6 +0,0 @@
-#!/bin/bash
-
-# Extensions necessary to tell fourmolu about
-EXTENSIONS="-o -XTypeApplications -o -XTemplateHaskell -o -XImportQualifiedPost -o -XPatternSynonyms -o -XOverloadedRecordDot"
-SOURCES=$(git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.hs')
-nix run nixpkgs#haskell.packages.ghc921.fourmolu -- --mode check --check-idempotence $EXTENSIONS $SOURCES
diff --git a/.github/workflows/integrate.yaml b/.github/workflows/integrate.yaml
index 42b0d14..1f4a160 100644
--- a/.github/workflows/integrate.yaml
+++ b/.github/workflows/integrate.yaml
@@ -34,30 +34,8 @@ jobs:
           name: mlabs
           authToken: ${{ secrets.CACHIX_KEY }}
 
-      - run: ./.github/format.sh
-        name: Run fourmolu
-
-  run-linter:
-    runs-on: ubuntu-latest
-    steps:
-      - uses: actions/checkout@v2.4.0
-
-      - uses: cachix/install-nix-action@v16
-        name: Set up Nix and IOHK caches
-        with:
-          nix_path: nixpkgs=channel:nixos-unstable
-          extra_nix_config: |
-            trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=
-            substituters = https://hydra.iohk.io https://iohk.cachix.org https://cache.nixos.org/
-            experimental-features = nix-command flakes
-
-      - uses: cachix/cachix-action@v10
-        with:
-          name: mlabs
-          authToken: ${{ secrets.CACHIX_KEY }}
-
-      - run: nix run nixpkgs#haskell.packages.ghc921.hlint -- $(git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.hs')
-        name: Run hlint
+      - run: nix build .#checks.x86_64-linux.formatCheck
+        name: Run 'formatCheck' from flake.nix
 
   check-build:
     runs-on: ubuntu-latest
diff --git a/flake.nix b/flake.nix
index 9f5a7a7..4b99a66 100644
--- a/flake.nix
+++ b/flake.nix
@@ -115,15 +115,19 @@
         let
           pkgs = nixpkgsFor system;
           pkgs' = nixpkgsFor' system;
+
+          inherit (pkgs.haskell-nix.tools ghcVersion {
+            inherit (plutarch.tools) fourmolu;
+          })
+            fourmolu;
         in pkgs.runCommand "format-check" {
           nativeBuildInputs = [
             pkgs'.git
             pkgs'.fd
             pkgs'.haskellPackages.cabal-fmt
             pkgs'.nixpkgs-fmt
-            (pkgs.haskell-nix.tools ghcVersion {
-              inherit (plutarch.tools) fourmolu;
-            }).fourmolu
+            fourmolu
+            plutarch.tools.hlint
           ];
         } ''
           export LC_CTYPE=C.UTF-8
@@ -131,6 +135,7 @@
           export LANG=C.UTF-8
           cd ${self}
           make format_check || (echo "    Please run 'make format'" ; exit 1)
+          find -name '*.hs' -not -path './dist*/*' -not -path './haddock/*' | xargs hlint
           mkdir $out
         '';
     in {

From ab0a20c9d364037bd43130775a9872af99418085 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Thu, 14 Apr 2022 15:24:09 +0200
Subject: [PATCH 03/78] don't use plutarch.tools

---
 flake.nix | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/flake.nix b/flake.nix
index 4b99a66..81393b0 100644
--- a/flake.nix
+++ b/flake.nix
@@ -127,7 +127,7 @@
             pkgs'.haskellPackages.cabal-fmt
             pkgs'.nixpkgs-fmt
             fourmolu
-            plutarch.tools.hlint
+            pkgs'.haskell.packages."${ghcVersion}".hlint
           ];
         } ''
           export LC_CTYPE=C.UTF-8

From c6aa6ac5d5a9df8b1c92975652f55acba24c200c Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Thu, 14 Apr 2022 11:38:06 -0400
Subject: [PATCH 04/78] New utility functions

added `pisScriptAddress`, `pfindEffectInput`, and
`pfindEffectAddress`. These functions are commonly used by effects.
---
 agora/Agora/Utils.hs | 35 ++++++++++++++++++++++++++++++++++-
 1 file changed, 34 insertions(+), 1 deletion(-)

diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index 83ac342..4519236 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -32,6 +32,9 @@ module Agora.Utils (
   allOutputs,
   anyInput,
   allInputs,
+  pisScriptAddress,
+  pfindEffectInput,
+  pfindEffectAddress,
 ) where
 
 --------------------------------------------------------------------------------
@@ -42,10 +45,11 @@ import Plutus.V1.Ledger.Value (AssetClass (..))
 
 import Plutarch.Api.V1 (
   PAddress,
+  PCredential (PScriptCredential),
   PCurrencySymbol,
   PDatum,
   PDatumHash,
-  PMaybeData (PDJust),
+  PMaybeData (PDJust, PDNothing),
   PPubKeyHash,
   PTokenName,
   PTuple,
@@ -390,3 +394,32 @@ psingletonValue = phoistAcyclic $
         outerTup = pcon $ PMap $ psingleton #$ ppairDataBuiltin # pdata sym # pdata innerTup
         res = pcon $ PValue outerTup
      in res
+
+-- | Determine if an address is a script address
+pisScriptAddress :: Term s (PAddress :--> PBool)
+pisScriptAddress = phoistAcyclic $
+  plam $ \addr' -> P.do
+    address <- pletFields @'["credential", "stakingCredential"] addr'
+    scred <- pmatch $ pfromData address.stakingCredential
+    case scred of
+      PDNothing _ -> P.do
+        cred <- pmatch $ pfromData address.credential
+        case cred of
+          PScriptCredential _ -> pconstant True
+          _ -> pconstant False
+      _ -> pconstant False
+
+-- | Finds the TxInInfo of an effect from TxInfo and TxOutRef
+pfindEffectInput :: Term s (PTxInfo :--> PTxOutRef :--> PTxInInfo)
+pfindEffectInput = phoistAcyclic $
+  plam $ \txInfo spending' -> P.do
+    input <- plet $ pfromData $ pfield @"inputs" # txInfo
+    spending <- plet $ pdata spending'
+    PJust result <- pmatch $ pfind # plam (\x -> pfield @"outRef" # x #== spending) # input
+    pfromData result
+
+-- | Finds the address of an effect from TxInfo and TxOutRef
+pfindEffectAddress :: Term s (PTxInfo :--> PTxOutRef :--> PTxOut)
+pfindEffectAddress = phoistAcyclic $
+  plam $ \txInfo spending -> P.do
+    pfromData $ pfield @"resolved" #$ pfindEffectInput # txInfo # spending

From 22d66e8a9decc0cf882e32d09e2ef9abd24eefe2 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <sho@caligula.attlocal.net>
Date: Thu, 14 Apr 2022 17:19:18 -0500
Subject: [PATCH 05/78] More utility functions

functions that I missed from Conner's governor branch...
---
 agora/Agora/Utils.hs | 67 +++++++++++++++++++++++++++++++++-----------
 1 file changed, 51 insertions(+), 16 deletions(-)

diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index 4519236..ba22d51 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -26,15 +26,18 @@ module Agora.Utils (
   psingletonValue,
   pfindMap,
   pnotNull,
+  pisJust,
 
   -- * Functions which should (probably) not be upstreamed
   anyOutput,
   allOutputs,
   anyInput,
   allInputs,
-  pisScriptAddress,
   pfindEffectInput,
   pfindEffectAddress,
+  pscriptHashFromAddress,
+  pfindOutputsToAddress,
+  pfindTxOutDatum,
 ) where
 
 --------------------------------------------------------------------------------
@@ -49,7 +52,8 @@ import Plutarch.Api.V1 (
   PCurrencySymbol,
   PDatum,
   PDatumHash,
-  PMaybeData (PDJust, PDNothing),
+  PMap,
+  PMaybeData (PDJust),
   PPubKeyHash,
   PTokenName,
   PTuple,
@@ -57,11 +61,14 @@ import Plutarch.Api.V1 (
   PTxInfo (PTxInfo),
   PTxOut (PTxOut),
   PTxOutRef,
+  PValidatorHash,
+  PValue,
  )
 import Plutarch.Api.V1.AssocMap (PMap (PMap))
 import Plutarch.Api.V1.Value (PValue (PValue))
 import Plutarch.Builtin (ppairDataBuiltin)
 import Plutarch.Internal (punsafeCoerce)
+import Plutarch.List (pconvertLists)
 import Plutarch.Monadic qualified as P
 
 --------------------------------------------------------------------------------
@@ -147,6 +154,15 @@ pfromMaybe = phoistAcyclic $
       PJust a' -> a'
       PNothing -> e
 
+-- | Yield True is a given PMaybe is of form PJust _
+pisJust :: forall a s. Term s (PMaybe a :--> PBool)
+pisJust = phoistAcyclic $
+  plam $ \v' -> P.do
+    v <- pmatch v'
+    case v of
+      PJust _ -> pconstant True
+      PNothing -> pconstant False
+
 -- | Escape with a particular value on expecting 'Just'. For use in monadic context.
 pexpectJust ::
   forall r a s.
@@ -395,20 +411,6 @@ psingletonValue = phoistAcyclic $
         res = pcon $ PValue outerTup
      in res
 
--- | Determine if an address is a script address
-pisScriptAddress :: Term s (PAddress :--> PBool)
-pisScriptAddress = phoistAcyclic $
-  plam $ \addr' -> P.do
-    address <- pletFields @'["credential", "stakingCredential"] addr'
-    scred <- pmatch $ pfromData address.stakingCredential
-    case scred of
-      PDNothing _ -> P.do
-        cred <- pmatch $ pfromData address.credential
-        case cred of
-          PScriptCredential _ -> pconstant True
-          _ -> pconstant False
-      _ -> pconstant False
-
 -- | Finds the TxInInfo of an effect from TxInfo and TxOutRef
 pfindEffectInput :: Term s (PTxInfo :--> PTxOutRef :--> PTxInInfo)
 pfindEffectInput = phoistAcyclic $
@@ -423,3 +425,36 @@ pfindEffectAddress :: Term s (PTxInfo :--> PTxOutRef :--> PTxOut)
 pfindEffectAddress = phoistAcyclic $
   plam $ \txInfo spending -> P.do
     pfromData $ pfield @"resolved" #$ pfindEffectInput # txInfo # spending
+
+-- | Get script hash from an Address.
+pscriptHashFromAddress :: Term s (PAddress :--> PMaybe PValidatorHash)
+pscriptHashFromAddress = phoistAcyclic $
+  plam $ \addr -> P.do
+    cred <- pmatch $ pfromData $ pfield @"credential" # addr
+    case cred of
+      PScriptCredential h -> pcon $ PJust $ pfield @"_0" # h
+      _ -> pcon PNothing
+
+-- | Find all TxOuts sent to an Address
+pfindOutputsToAddress :: Term s (PTxInfo :--> PAddress :--> PList PTxOut)
+pfindOutputsToAddress = phoistAcyclic $
+  plam $ \info address' -> P.do
+    address <- plet $ pdata address'
+    let outputs = pfromData $ pfield @"outputs" # info
+        filteredOutputs =
+          pfilter
+            # ( plam $ \(pfromData -> txOut) -> P.do
+                  selfAddress <- plet $ pfield @"address" # txOut
+                  selfAddress #== address
+              )
+            # outputs
+    pmap @PList # plam pfromData #$ pconvertLists # filteredOutputs
+
+-- | Find datum in a TxOut
+pfindTxOutDatum :: Term s (PTxInfo :--> PTxOut :--> PMaybe PDatum)
+pfindTxOutDatum = phoistAcyclic $
+  plam $ \info out -> P.do
+    datumHash' <- pmatch $ pfromData $ pfield @"datumHash" # out
+    case datumHash' of
+      PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # info
+      _ -> pcon PNothing

From f3f7f131febf2f975696bd4061d1f0e69efeb078 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Thu, 14 Apr 2022 23:23:50 -0500
Subject: [PATCH 06/78] Connor's suggestions

---
 agora/Agora/Utils.hs | 46 ++++++++++++++++++--------------------------
 1 file changed, 19 insertions(+), 27 deletions(-)

diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index ba22d51..118bd0a 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -33,11 +33,10 @@ module Agora.Utils (
   allOutputs,
   anyInput,
   allInputs,
-  pfindEffectInput,
-  pfindEffectAddress,
-  pscriptHashFromAddress,
-  pfindOutputsToAddress,
-  pfindTxOutDatum,
+  findTxOutByTxOutRef,
+  scriptHashFromAddress,
+  findOutputsToAddress,
+  findTxOutDatum,
 ) where
 
 --------------------------------------------------------------------------------
@@ -154,7 +153,7 @@ pfromMaybe = phoistAcyclic $
       PJust a' -> a'
       PNothing -> e
 
--- | Yield True is a given PMaybe is of form PJust _
+-- | Yield True if a given PMaybe is of form PJust _
 pisJust :: forall a s. Term s (PMaybe a :--> PBool)
 pisJust = phoistAcyclic $
   plam $ \v' -> P.do
@@ -411,24 +410,17 @@ psingletonValue = phoistAcyclic $
         res = pcon $ PValue outerTup
      in res
 
--- | Finds the TxInInfo of an effect from TxInfo and TxOutRef
-pfindEffectInput :: Term s (PTxInfo :--> PTxOutRef :--> PTxInInfo)
-pfindEffectInput = phoistAcyclic $
-  plam $ \txInfo spending' -> P.do
-    input <- plet $ pfromData $ pfield @"inputs" # txInfo
-    spending <- plet $ pdata spending'
-    PJust result <- pmatch $ pfind # plam (\x -> pfield @"outRef" # x #== spending) # input
-    pfromData result
-
--- | Finds the address of an effect from TxInfo and TxOutRef
-pfindEffectAddress :: Term s (PTxInfo :--> PTxOutRef :--> PTxOut)
-pfindEffectAddress = phoistAcyclic $
-  plam $ \txInfo spending -> P.do
-    pfromData $ pfield @"resolved" #$ pfindEffectInput # txInfo # spending
+-- | Finds the TxOut of an effect from TxInfo and TxOutRef
+findTxOutByTxOutRef :: Term s (PTxOutRef :--> PTxInfo :--> PMaybe PTxOut)
+findTxOutByTxOutRef = phoistAcyclic $
+  plam $ \txOutRef txInfo ->
+    pmatch (pfindTxInByTxOutRef # txOutRef # txInfo) $ \case
+      PJust ((pfield @"resolved" #) -> txOut) -> pcon $ PJust txOut
+      PNothing -> pcon PNothing
 
 -- | Get script hash from an Address.
-pscriptHashFromAddress :: Term s (PAddress :--> PMaybe PValidatorHash)
-pscriptHashFromAddress = phoistAcyclic $
+scriptHashFromAddress :: Term s (PAddress :--> PMaybe PValidatorHash)
+scriptHashFromAddress = phoistAcyclic $
   plam $ \addr -> P.do
     cred <- pmatch $ pfromData $ pfield @"credential" # addr
     case cred of
@@ -436,8 +428,8 @@ pscriptHashFromAddress = phoistAcyclic $
       _ -> pcon PNothing
 
 -- | Find all TxOuts sent to an Address
-pfindOutputsToAddress :: Term s (PTxInfo :--> PAddress :--> PList PTxOut)
-pfindOutputsToAddress = phoistAcyclic $
+findOutputsToAddress :: Term s (PTxInfo :--> PAddress :--> PList PTxOut)
+findOutputsToAddress = phoistAcyclic $
   plam $ \info address' -> P.do
     address <- plet $ pdata address'
     let outputs = pfromData $ pfield @"outputs" # info
@@ -450,9 +442,9 @@ pfindOutputsToAddress = phoistAcyclic $
             # outputs
     pmap @PList # plam pfromData #$ pconvertLists # filteredOutputs
 
--- | Find datum in a TxOut
-pfindTxOutDatum :: Term s (PTxInfo :--> PTxOut :--> PMaybe PDatum)
-pfindTxOutDatum = phoistAcyclic $
+-- | Find the data corresponding to a TxOut, if there is one
+findTxOutDatum :: Term s (PTxInfo :--> PTxOut :--> PMaybe PDatum)
+findTxOutDatum = phoistAcyclic $
   plam $ \info out -> P.do
     datumHash' <- pmatch $ pfromData $ pfield @"datumHash" # out
     case datumHash' of

From 8e8411f1cb7aa79a28f160f42aa5c1a2c23908be Mon Sep 17 00:00:00 2001
From: fanghr <chfanghr@gmail.com>
Date: Thu, 14 Apr 2022 17:55:47 +0800
Subject: [PATCH 07/78] break `make format` into sub-targets

...so that the the nix env won't reload when one just want to format the haskell code

now we have:
* `format_haskell` target
* `format_nix` target
---
 Makefile | 10 +++++++---
 1 file changed, 7 insertions(+), 3 deletions(-)

diff --git a/Makefile b/Makefile
index c10c15d..da13647 100644
--- a/Makefile
+++ b/Makefile
@@ -17,10 +17,14 @@ hoogle:
 	hoogle server --local -p 8081 >> /dev/null &
 	hoogle server --local --database=hoo/local.hoo -p 8082 >> /dev/null &
 
-FORMAT_EXTENSIONS := -o -XQuasiQuotes -o -XTemplateHaskell -o -XTypeApplications -o -XImportQualifiedPost -o -XPatternSynonyms -o -XOverloadedRecordDot
-format:
-	find -name '*.hs' -not -path './dist-*/*' | xargs fourmolu $(FORMAT_EXTENSIONS) -m inplace
+format: format_haskell format_nix
+
+format_nix:
 	git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.nix' | xargs nixpkgs-fmt
+
+FORMAT_EXTENSIONS := -o -XQuasiQuotes -o -XTemplateHaskell -o -XTypeApplications -o -XImportQualifiedPost -o -XPatternSynonyms -o -XOverloadedRecordDot
+format_haskell:
+	find -name '*.hs' -not -path './dist-*/*' | xargs fourmolu $(FORMAT_EXTENSIONS) -m inplace
 	git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.cabal' | xargs cabal-fmt -i
 
 format_check:

From 96dbefc4ef62795784d5156efda39c075807668a Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Fri, 15 Apr 2022 13:41:07 +0200
Subject: [PATCH 08/78] format agora.cabal, flake.nix

---
 agora.cabal |  6 +++---
 flake.nix   | 38 ++++++++++++++++++++++----------------
 2 files changed, 25 insertions(+), 19 deletions(-)

diff --git a/agora.cabal b/agora.cabal
index 046a5c8..4c447e0 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -122,13 +122,13 @@ library
   import:          lang, deps
   exposed-modules:
     Agora.AuthorityToken
+    Agora.Effect
+    Agora.Governor
     Agora.MultiSig
+    Agora.Proposal
     Agora.SafeMoney
     Agora.Stake
-    Agora.Effect
     Agora.Treasury
-    Agora.Governor
-    Agora.Proposal
 
   other-modules:
     Agora.Utils
diff --git a/flake.nix b/flake.nix
index 81393b0..20ceebb 100644
--- a/flake.nix
+++ b/flake.nix
@@ -50,8 +50,10 @@
 
       projectFor = system:
         let pkgs = nixpkgsFor system;
-        in let pkgs' = nixpkgsFor' system;
-        in (nixpkgsFor system).haskell-nix.cabalProject' {
+        in
+        let pkgs' = nixpkgsFor' system;
+        in
+        (nixpkgsFor system).haskell-nix.cabalProject' {
           src = ./.;
           compiler-nix-name = ghcVersion;
           inherit (plutarch) cabalProjectLocal;
@@ -120,16 +122,18 @@
             inherit (plutarch.tools) fourmolu;
           })
             fourmolu;
-        in pkgs.runCommand "format-check" {
-          nativeBuildInputs = [
-            pkgs'.git
-            pkgs'.fd
-            pkgs'.haskellPackages.cabal-fmt
-            pkgs'.nixpkgs-fmt
-            fourmolu
-            pkgs'.haskell.packages."${ghcVersion}".hlint
-          ];
-        } ''
+        in
+        pkgs.runCommand "format-check"
+          {
+            nativeBuildInputs = [
+              pkgs'.git
+              pkgs'.fd
+              pkgs'.haskellPackages.cabal-fmt
+              pkgs'.nixpkgs-fmt
+              fourmolu
+              pkgs'.haskell.packages."${ghcVersion}".hlint
+            ];
+          } ''
           export LC_CTYPE=C.UTF-8
           export LC_ALL=C.UTF-8
           export LANG=C.UTF-8
@@ -138,7 +142,8 @@
           find -name '*.hs' -not -path './dist*/*' -not -path './haddock/*' | xargs hlint
           mkdir $out
         '';
-    in {
+    in
+    {
       project = perSystem projectFor;
       flake = perSystem (system: (projectFor system).flake { });
 
@@ -152,9 +157,10 @@
           agora-test = self.flake.${system}.packages."agora:test:agora-test";
         });
       check = perSystem (system:
-        (nixpkgsFor system).runCommand "combined-test" {
-          checksss = builtins.attrValues self.checks.${system};
-        } ''
+        (nixpkgsFor system).runCommand "combined-test"
+          {
+            checksss = builtins.attrValues self.checks.${system};
+          } ''
           echo $checksss
           touch $out
         '');

From b4a6cb917955380b6948124d3cd0cd3673563f2a Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Fri, 15 Apr 2022 08:52:42 -0500
Subject: [PATCH 09/78] Emily's suggestions & fixed building

---
 agora/Agora/Utils.hs | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index 118bd0a..2e6efff 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -153,7 +153,7 @@ pfromMaybe = phoistAcyclic $
       PJust a' -> a'
       PNothing -> e
 
--- | Yield True if a given PMaybe is of form PJust _
+-- | Yield True if a given PMaybe is of form PJust _.
 pisJust :: forall a s. Term s (PMaybe a :--> PBool)
 pisJust = phoistAcyclic $
   plam $ \v' -> P.do
@@ -421,26 +421,26 @@ findTxOutByTxOutRef = phoistAcyclic $
 -- | Get script hash from an Address.
 scriptHashFromAddress :: Term s (PAddress :--> PMaybe PValidatorHash)
 scriptHashFromAddress = phoistAcyclic $
-  plam $ \addr -> P.do
-    cred <- pmatch $ pfromData $ pfield @"credential" # addr
-    case cred of
+  plam $ \addr ->
+    pmatch (pfromData $ pfield @"credential" # addr) $ \case
       PScriptCredential h -> pcon $ PJust $ pfield @"_0" # h
       _ -> pcon PNothing
 
 -- | Find all TxOuts sent to an Address
-findOutputsToAddress :: Term s (PTxInfo :--> PAddress :--> PList PTxOut)
+findOutputsToAddress :: Term s (PTxInfo :--> PAddress :--> PBuiltinList PTxOut)
 findOutputsToAddress = phoistAcyclic $
   plam $ \info address' -> P.do
     address <- plet $ pdata address'
     let outputs = pfromData $ pfield @"outputs" # info
         filteredOutputs =
           pfilter
-            # ( plam $ \(pfromData -> txOut) -> P.do
+            # plam
+              ( \(pfromData -> txOut) -> P.do
                   selfAddress <- plet $ pfield @"address" # txOut
                   selfAddress #== address
               )
             # outputs
-    pmap @PList # plam pfromData #$ pconvertLists # filteredOutputs
+    pmap # plam pfromData #$ pconvertLists # filteredOutputs
 
 -- | Find the data corresponding to a TxOut, if there is one
 findTxOutDatum :: Term s (PTxInfo :--> PTxOut :--> PMaybe PDatum)

From b67a886cd243ab794402dc27d6f04a767b0bc74f Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Fri, 15 Apr 2022 09:02:16 -0500
Subject: [PATCH 10/78] fixes

---
 agora/Agora/Utils.hs | 12 ++++--------
 1 file changed, 4 insertions(+), 8 deletions(-)

diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index 2e6efff..e05e4ee 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -67,7 +67,6 @@ import Plutarch.Api.V1.AssocMap (PMap (PMap))
 import Plutarch.Api.V1.Value (PValue (PValue))
 import Plutarch.Builtin (ppairDataBuiltin)
 import Plutarch.Internal (punsafeCoerce)
-import Plutarch.List (pconvertLists)
 import Plutarch.Monadic qualified as P
 
 --------------------------------------------------------------------------------
@@ -423,11 +422,11 @@ scriptHashFromAddress :: Term s (PAddress :--> PMaybe PValidatorHash)
 scriptHashFromAddress = phoistAcyclic $
   plam $ \addr ->
     pmatch (pfromData $ pfield @"credential" # addr) $ \case
-      PScriptCredential h -> pcon $ PJust $ pfield @"_0" # h
+      PScriptCredential ((pfield @"_0" #) -> h) -> pcon $ PJust h
       _ -> pcon PNothing
 
 -- | Find all TxOuts sent to an Address
-findOutputsToAddress :: Term s (PTxInfo :--> PAddress :--> PBuiltinList PTxOut)
+findOutputsToAddress :: Term s (PTxInfo :--> PAddress :--> PBuiltinList (PAsData PTxOut))
 findOutputsToAddress = phoistAcyclic $
   plam $ \info address' -> P.do
     address <- plet $ pdata address'
@@ -435,12 +434,9 @@ findOutputsToAddress = phoistAcyclic $
         filteredOutputs =
           pfilter
             # plam
-              ( \(pfromData -> txOut) -> P.do
-                  selfAddress <- plet $ pfield @"address" # txOut
-                  selfAddress #== address
-              )
+              (\(pfromData -> txOut) -> pfield @"address" # txOut #== address)
             # outputs
-    pmap # plam pfromData #$ pconvertLists # filteredOutputs
+    filteredOutputs
 
 -- | Find the data corresponding to a TxOut, if there is one
 findTxOutDatum :: Term s (PTxInfo :--> PTxOut :--> PMaybe PDatum)

From 0e55587373de4c0642195af9dd5e43019de0d91d Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Mon, 18 Apr 2022 17:52:30 -0500
Subject: [PATCH 11/78] Little guidance for `agora-test`

I noticed `agora-test` is quote poorly documented... While it will
receive a restructure when we migrate to `plutarch-test`, these are
small notes in the meantime.
---
 agora-test/README.org | 11 +++++++++++
 1 file changed, 11 insertions(+)
 create mode 100644 agora-test/README.org

diff --git a/agora-test/README.org b/agora-test/README.org
new file mode 100644
index 0000000..adb3d6c
--- /dev/null
+++ b/agora-test/README.org
@@ -0,0 +1,11 @@
+#+Title: Agora Test
+This folder is the test suite for Agora governance system.
+
+- =/Spec= contains different tests for different elements of
+Agora.
+- =/Spec/Model= contain =apropos-tx= model for logical suite
+  generation and tests.
+- =/Spec/Sample= contains primitive hand-made example values.
+- =Util.hs= contains helper functions
+
+Currently, planning migration to =plutarch-test= with golden test.

From 99fdfcbe318c9ac5ef7538c158ab3f3cc3dc47f0 Mon Sep 17 00:00:00 2001
From: SeungheonOh <seungheon.ooh@gmail.com>
Date: Mon, 18 Apr 2022 22:57:04 +0000
Subject: [PATCH 12/78] removed random line break

---
 agora-test/README.org | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/agora-test/README.org b/agora-test/README.org
index adb3d6c..111796c 100644
--- a/agora-test/README.org
+++ b/agora-test/README.org
@@ -1,8 +1,7 @@
 #+Title: Agora Test
 This folder is the test suite for Agora governance system.
 
-- =/Spec= contains different tests for different elements of
-Agora.
+- =/Spec= contains different tests for different elements of Agora.
 - =/Spec/Model= contain =apropos-tx= model for logical suite
   generation and tests.
 - =/Spec/Sample= contains primitive hand-made example values.

From 93f5ca2752b144510850c624d25f203230840fab Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Tue, 19 Apr 2022 08:03:17 -0400
Subject: [PATCH 13/78] fix misleading information

---
 agora-test/README.org | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/agora-test/README.org b/agora-test/README.org
index 111796c..692f992 100644
--- a/agora-test/README.org
+++ b/agora-test/README.org
@@ -7,4 +7,4 @@ This folder is the test suite for Agora governance system.
 - =/Spec/Sample= contains primitive hand-made example values.
 - =Util.hs= contains helper functions
 
-Currently, planning migration to =plutarch-test= with golden test.
+Currently, planning to introduce =plutarch-test= and golden testings.

From e67ca97256790770b52f0c1864e7cf32fcaa56f2 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Tue, 19 Apr 2022 08:04:39 -0400
Subject: [PATCH 14/78] fixes

---
 agora-test/README.org | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/agora-test/README.org b/agora-test/README.org
index 692f992..d7e7d2c 100644
--- a/agora-test/README.org
+++ b/agora-test/README.org
@@ -7,4 +7,5 @@ This folder is the test suite for Agora governance system.
 - =/Spec/Sample= contains primitive hand-made example values.
 - =Util.hs= contains helper functions
 
-Currently, planning to introduce =plutarch-test= and golden testings.
+Currently, planning to introduce =plutarch-test= for unit tests,
+benchmarks, and golden tests.

From 3adc3f72a5ee7f57d8214373a1187082308b5605 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Tue, 19 Apr 2022 15:04:42 +0200
Subject: [PATCH 15/78] publish haddock in CI

- set correct subdirectory for docs
- add elucidating comment about deployment target
---
 .github/workflows/integrate.yaml | 33 +++++++++++++++++++++
 README.md                        |  2 ++
 flake.nix                        | 51 ++++++++++++++++++--------------
 3 files changed, 63 insertions(+), 23 deletions(-)

diff --git a/.github/workflows/integrate.yaml b/.github/workflows/integrate.yaml
index 1f4a160..9917a40 100644
--- a/.github/workflows/integrate.yaml
+++ b/.github/workflows/integrate.yaml
@@ -68,3 +68,36 @@ jobs:
 
       - name: Build the project
         run: nix build .#check.x86_64-linux
+
+
+
+  haddock:
+    runs-on: ubuntu-latest
+    steps:
+    - uses: actions/checkout@v2.4.0
+
+    - uses: cachix/install-nix-action@v16
+      name: Set up Nix and IOHK caches
+      with:
+        nix_path: nixpkgs=channel:nixos-unstable
+        extra_nix_config: |
+          trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=
+          substituters = https://hydra.iohk.io https://iohk.cachix.org https://cache.nixos.org/
+          experimental-features = nix-command flakes
+
+    - uses: cachix/cachix-action@v10
+      with:
+        name: mlabs
+        authToken: ${{ secrets.CACHIX_KEY }}
+
+    - run: nix build .#packages.x86_64-linux.haddock
+      name: Run 'haddock' from flake.nix
+
+    # This publishes the haddock result to the branch 'gh-pages',
+    # which is set to automatically deploy to https://liqwid-labs.github.io/agora/.
+    - name: Publish Documentation
+      uses: peaceiris/actions-gh-pages@v3
+      if: github.ref == 'refs/heads/master'
+      with:
+        github_token: ${{ secrets.GITHUB_TOKEN }}
+        publish_dir: ./result/agora/html
diff --git a/README.md b/README.md
index 11acb27..7bdec9a 100644
--- a/README.md
+++ b/README.md
@@ -25,6 +25,8 @@ Open a development shell with `nix develop` and build the project with `cabal bu
 
 Documentation for Agora may be found in [docs](./docs).
 
+Haddock is deployed on GitHub Pages [here](https://liqwid-labs.github.io/agora/).
+
 ### Using Agora for your protocol
 
 If you are a protocol wanting to use Agora, read [Using Agora](./docs/using-agora.md).
diff --git a/flake.nix b/flake.nix
index 20ceebb..c6522d6 100644
--- a/flake.nix
+++ b/flake.nix
@@ -50,10 +50,8 @@
 
       projectFor = system:
         let pkgs = nixpkgsFor system;
-        in
-        let pkgs' = nixpkgsFor' system;
-        in
-        (nixpkgsFor system).haskell-nix.cabalProject' {
+        in let pkgs' = nixpkgsFor' system;
+        in (nixpkgsFor system).haskell-nix.cabalProject' {
           src = ./.;
           compiler-nix-name = ghcVersion;
           inherit (plutarch) cabalProjectLocal;
@@ -122,18 +120,16 @@
             inherit (plutarch.tools) fourmolu;
           })
             fourmolu;
-        in
-        pkgs.runCommand "format-check"
-          {
-            nativeBuildInputs = [
-              pkgs'.git
-              pkgs'.fd
-              pkgs'.haskellPackages.cabal-fmt
-              pkgs'.nixpkgs-fmt
-              fourmolu
-              pkgs'.haskell.packages."${ghcVersion}".hlint
-            ];
-          } ''
+        in pkgs.runCommand "format-check" {
+          nativeBuildInputs = [
+            pkgs'.git
+            pkgs'.fd
+            pkgs'.haskellPackages.cabal-fmt
+            pkgs'.nixpkgs-fmt
+            fourmolu
+            pkgs'.haskell.packages."${ghcVersion}".hlint
+          ];
+        } ''
           export LC_CTYPE=C.UTF-8
           export LC_ALL=C.UTF-8
           export LANG=C.UTF-8
@@ -142,12 +138,22 @@
           find -name '*.hs' -not -path './dist*/*' -not -path './haddock/*' | xargs hlint
           mkdir $out
         '';
-    in
-    {
+
+    in {
       project = perSystem projectFor;
       flake = perSystem (system: (projectFor system).flake { });
 
-      packages = perSystem (system: self.flake.${system}.packages);
+      packages = perSystem (system:
+        self.flake.${system}.packages // {
+          haddock = let
+            agora-doc = self.flake.${system}.packages."agora:lib:agora".doc;
+            pkgs = nixpkgsFor system;
+          in pkgs.runCommand "haddock-merge" { } ''
+            cd ${self}
+            mkdir $out
+            cp -r ${agora-doc}/share/doc/* $out
+          '';
+        });
 
       # Define what we want to test
       checks = perSystem (system:
@@ -157,10 +163,9 @@
           agora-test = self.flake.${system}.packages."agora:test:agora-test";
         });
       check = perSystem (system:
-        (nixpkgsFor system).runCommand "combined-test"
-          {
-            checksss = builtins.attrValues self.checks.${system};
-          } ''
+        (nixpkgsFor system).runCommand "combined-test" {
+          checksss = builtins.attrValues self.checks.${system};
+        } ''
           echo $checksss
           touch $out
         '');

From 7c59888b452b5d9d7c9e85cd8fff3abe32168715 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Wed, 20 Apr 2022 18:36:45 +0200
Subject: [PATCH 16/78] drop `allInputs`, fix `authorityTokensValidIn`

---
 agora/Agora/AuthorityToken.hs | 30 ++++++++++++++++++------------
 agora/Agora/Utils.hs          | 25 -------------------------
 2 files changed, 18 insertions(+), 37 deletions(-)

diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs
index dadabe4..1956fb6 100644
--- a/agora/Agora/AuthorityToken.hs
+++ b/agora/Agora/AuthorityToken.hs
@@ -34,7 +34,6 @@ import Prelude
 --------------------------------------------------------------------------------
 
 import Agora.Utils (
-  allInputs,
   allOutputs,
   passert,
   passetClassValueOf,
@@ -81,15 +80,16 @@ authorityTokensValidIn = phoistAcyclic $
         pmatch (pfield @"credential" # address) $ \case
           PPubKeyCredential _ ->
             -- GATs should only be sent to Effect validators
-            pconstant False
+            ptraceIfFalse "authorityTokensValidIn: GAT incorrectly lives at PubKey" $ pconstant False
           PScriptCredential ((pfromData . (pfield @"_0" #)) -> cred) -> P.do
             PMap tokenMap <- pmatch tokenMap'
-            pall
-              # plam
-                ( \pair ->
-                    pforgetData (pfstBuiltin # pair) #== pforgetData (pdata cred)
-                )
-              # tokenMap
+            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
@@ -105,14 +105,20 @@ singleAuthorityTokenBurned gatCs txInfo mint = P.do
   let gatAmountMinted :: Term _ PInteger
       gatAmountMinted = psymbolValueOf # gatCs # mint
 
+  txInfoF <- pletFields @'["inputs"] $ txInfo
+
   foldr1
     (#&&)
     [ ptraceIfFalse "GAT not burned." $ gatAmountMinted #== -1
     , ptraceIfFalse "All inputs only have valid GATs" $
-        allInputs @PUnit # pfromData txInfo #$ plam $ \txOut _value _address _datum ->
-          authorityTokensValidIn
-            # gatCs
-            # txOut
+        pall
+          # plam
+            ( \txInInfo' -> P.do
+                PTxInInfo txInInfo <- pmatch (pfromData txInInfo')
+                let txOut' = pfield @"resolved" # txInInfo
+                authorityTokensValidIn # gatCs # pfromData txOut'
+            )
+          # txInfoF.inputs
     ]
 
 -- | Policy given 'AuthorityToken' params.
diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index e05e4ee..48e5af3 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -32,7 +32,6 @@ module Agora.Utils (
   anyOutput,
   allOutputs,
   anyInput,
-  allInputs,
   findTxOutByTxOutRef,
   scriptHashFromAddress,
   findOutputsToAddress,
@@ -376,30 +375,6 @@ anyInput = phoistAcyclic $
         )
       # pfromData txInfo.inputs
 
--- | Check if all (resolved) inputs match the predicate.
-allInputs ::
-  forall (datum :: PType) s.
-  ( PIsData datum
-  ) =>
-  Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
-allInputs = phoistAcyclic $
-  plam $ \txInfo' predicate -> P.do
-    txInfo <- pletFields @'["inputs"] txInfo'
-    pall
-      # plam
-        ( \txInInfo'' -> P.do
-            PTxInInfo txInInfo' <- pmatch (pfromData txInInfo'')
-            let txOut'' = pfield @"resolved" # txInInfo'
-            PTxOut txOut' <- pmatch (pfromData txOut'')
-            txOut <- pletFields @'["value", "datumHash", "address"] txOut'
-            PDJust dh <- pmatch txOut.datumHash
-            pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case
-              PJust datum -> P.do
-                predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum
-              PNothing -> pcon PFalse
-        )
-      # pfromData txInfo.inputs
-
 -- | Create a value with a single asset class.
 psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue)
 psingletonValue = phoistAcyclic $

From a6ef476beb5bd9fb93efbf8191c8f126db16b8d0 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Wed, 20 Apr 2022 20:06:15 +0200
Subject: [PATCH 17/78] add tests for authority token function
 'singleAuthorityTokenBurned'

---
 agora-test/Spec.hs                |   4 +
 agora-test/Spec/AuthorityToken.hs | 154 ++++++++++++++++++++++++++++++
 agora.cabal                       |   1 +
 3 files changed, 159 insertions(+)
 create mode 100644 agora-test/Spec/AuthorityToken.hs

diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs
index 6442ae8..2f443cd 100644
--- a/agora-test/Spec.hs
+++ b/agora-test/Spec.hs
@@ -8,6 +8,7 @@ import Test.Tasty (defaultMain, testGroup)
 
 --------------------------------------------------------------------------------
 
+import Spec.AuthorityToken qualified as AuthorityToken
 import Spec.Model.MultiSig qualified as MultiSig
 import Spec.Stake qualified as Stake
 
@@ -28,4 +29,7 @@ main =
               , MultiSig.genTests
               ]
           ]
+      , testGroup
+          "AuthorityToken tests"
+          AuthorityToken.tests
       ]
diff --git a/agora-test/Spec/AuthorityToken.hs b/agora-test/Spec/AuthorityToken.hs
new file mode 100644
index 0000000..da1e371
--- /dev/null
+++ b/agora-test/Spec/AuthorityToken.hs
@@ -0,0 +1,154 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+{- |
+Module     : Spec.AuthorityToken
+Maintainer : emi@haskell.fyi
+Description: Tests for Authority token functions
+
+Tests for Authority token functions
+-}
+module Spec.AuthorityToken (tests) where
+
+--------------------------------------------------------------------------------
+
+import Agora.AuthorityToken (singleAuthorityTokenBurned)
+import Plutarch
+import Test.Tasty (TestTree, testGroup)
+import Prelude
+
+--------------------------------------------------------------------------------
+
+import Plutus.V1.Ledger.Api (
+  Address (Address),
+  Credential (PubKeyCredential, ScriptCredential),
+  CurrencySymbol,
+  Script,
+  TxInInfo (TxInInfo),
+  TxInfo (..),
+  TxOut (TxOut),
+  TxOutRef (TxOutRef),
+  ValidatorHash (ValidatorHash),
+  Value,
+ )
+import Plutus.V1.Ledger.Interval qualified as Interval
+import Plutus.V1.Ledger.Value qualified as Value
+import PlutusTx.AssocMap qualified as AssocMap
+import Spec.Util (scriptFails, scriptSucceeds)
+
+currencySymbol :: CurrencySymbol
+currencySymbol = "deadbeef"
+
+mkTxInfo :: Value -> [TxOut] -> TxInfo
+mkTxInfo mint outs =
+  TxInfo
+    { txInfoInputs = fmap (TxInInfo (TxOutRef "" 0)) outs
+    , txInfoOutputs = []
+    , txInfoFee = Value.singleton "" "" 1000
+    , txInfoMint = mint
+    , txInfoDCert = []
+    , txInfoWdrl = []
+    , txInfoValidRange = Interval.always
+    , txInfoSignatories = []
+    , txInfoData = []
+    , txInfoId = ""
+    }
+
+singleAuthorityTokenBurnedTest :: Value -> [TxOut] -> Script
+singleAuthorityTokenBurnedTest mint outs =
+  let actual :: ClosedTerm PBool
+      actual = singleAuthorityTokenBurned (pconstant currencySymbol) (pconstantData (mkTxInfo mint outs)) (pconstant mint)
+      s :: ClosedTerm POpaque
+      s =
+        pif
+          actual
+          (popaque (pconstant ()))
+          perror
+   in compile s
+
+tests :: [TestTree]
+tests =
+  [ -- This is better suited for plutarch-test
+    testGroup
+      "singleAuthorityTokenBurned"
+      [ scriptSucceeds
+          "Correct simple"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "deadbeef" (-1)
+                  <> Value.singleton "aa" "USDC" 100_000
+              )
+              [ TxOut
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "deadbeef" 1)
+                  Nothing
+              ]
+          )
+      , scriptSucceeds
+          "Correct many inputs"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "deadbeef" (-1)
+                  <> Value.singleton "aa" "USDC" 100_000
+              )
+              [ TxOut
+                  (Address (PubKeyCredential "") Nothing)
+                  (Value.singleton "aaabcc" "hello-token" 1)
+                  Nothing
+              , TxOut
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "deadbeef" 1)
+                  Nothing
+              , TxOut
+                  (Address (PubKeyCredential "") Nothing)
+                  (Value.singleton "" "" 1_000_000_000)
+                  Nothing
+              ]
+          )
+      , scriptFails
+          "Incorrect no burn"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.Value AssocMap.empty
+              )
+              []
+          )
+      , scriptFails
+          "Incorrect no GAT burn"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton "aabbcc" "not a GAT!" (-100)
+              )
+              []
+          )
+      , 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
+              ( Value.singleton currencySymbol "doesn't matter" (-1)
+              )
+              [ TxOut
+                  (Address (PubKeyCredential "") Nothing)
+                  (Value.singleton currencySymbol "doesn't matter" 1)
+                  Nothing
+              ]
+          )
+      , scriptFails
+          "Incorrect two GATs"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "deadbeef" (-2)
+                  <> Value.singleton "aa" "USDC" 100_000
+              )
+              [ TxOut
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "deadbeef" 2)
+                  Nothing
+              ]
+          )
+      ]
+  ]
diff --git a/agora.cabal b/agora.cabal
index 4c447e0..041af40 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -155,6 +155,7 @@ test-suite agora-test
     Spec.Sample.Stake
     Spec.Stake
     Spec.Util
+    Spec.AuthorityToken
 
   build-depends:  agora
 

From b8b62695919f11dcb1901d99b52cedbc0454aa6a Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Thu, 21 Apr 2022 11:09:07 +0200
Subject: [PATCH 18/78] improve trace error message

---
 agora/Agora/AuthorityToken.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs
index 1956fb6..8239242 100644
--- a/agora/Agora/AuthorityToken.hs
+++ b/agora/Agora/AuthorityToken.hs
@@ -109,8 +109,8 @@ singleAuthorityTokenBurned gatCs txInfo mint = P.do
 
   foldr1
     (#&&)
-    [ ptraceIfFalse "GAT not burned." $ gatAmountMinted #== -1
-    , ptraceIfFalse "All inputs only have valid GATs" $
+    [ ptraceIfFalse "singleAuthorityTokenBurned: Must burn exactly 1 GAT" $ gatAmountMinted #== -1
+    , ptraceIfFalse "singleAuthorityTokenBurned: All GAT tokens must be valid at the inputs" $
         pall
           # plam
             ( \txInInfo' -> P.do

From f9d7db93232c345a41c6c672bbcb2b1af75468c3 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <sho@caligula.attlocal.net>
Date: Mon, 11 Apr 2022 18:25:39 -0500
Subject: [PATCH 19/78] Rebase master to Treasury Withdrawal Effect

Liqwid-Labs/agora#46
---
 agora.cabal                              |  1 +
 agora/Agora/Effect/TreasuryWithdrawal.hs | 51 ++++++++++++++++++++++++
 2 files changed, 52 insertions(+)
 create mode 100644 agora/Agora/Effect/TreasuryWithdrawal.hs

diff --git a/agora.cabal b/agora.cabal
index 041af40..aae5776 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -123,6 +123,7 @@ library
   exposed-modules:
     Agora.AuthorityToken
     Agora.Effect
+    Agora.Effect.TreasuryWithdrawal
     Agora.Governor
     Agora.MultiSig
     Agora.Proposal
diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
new file mode 100644
index 0000000..9a32143
--- /dev/null
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -0,0 +1,51 @@
+{- |
+Module     : Agora.Effect.TreasuryWithdrawal
+Maintainer : seungheon.ooh@gmail.com
+Description: An Effect that withdraws treasury deposit
+-}
+module Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalDatum) where
+
+import GHC.Generics qualified as GHC
+import Generics.SOP
+
+import Agora.Effect
+import Agora.Utils
+import Plutus.V1.Ledger.Value
+import Plutarch
+import qualified Plutarch.Monadic as P
+import Plutarch.Api.V1
+import Plutarch.DataRepr
+
+data PTreasuryWithdrawalDatum (s :: S)
+  = PTreasuryWithdrawalDatum
+      ( Term
+          s
+          (PDataRecord
+           '[ "receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue)) ]
+          )
+      )
+  deriving stock (GHC.Generic)
+  deriving anyclass (Generic, PIsDataRepr)
+  deriving
+    (PlutusType, PIsData, PDataFields)
+    via PIsDataReprInstances PTreasuryWithdrawalDatum
+
+treasuryWithdrawalDatum :: forall {s :: S}. CurrencySymbol -> Term s PValidator
+treasuryWithdrawalDatum currSymbol = makeEffect currSymbol $
+  \_cs (_datum :: Term _ PTreasuryWithdrawalDatum) _txOutRef _txInfo -> P.do
+  let outputs = pmap #
+                plam (\_out -> P.do
+                       out <- pletFields @'["address", "value"] $ pfromData _out
+                       cred <- pletFields @'["credential"] $ pfromData out.address
+                       pdata $ ptuple # cred.credential # out.value
+                     ) #$
+                pfield @"outputs" # _txInfo
+      recivers = pfromData (pfield @"receivers" # _datum)
+      checkOutputs = pall # plam id #$ pmap #
+                     plam (\_out -> P.do
+                            pelem # _out # outputs
+                          ) #$
+                     recivers
+  passert "Transaction output does not match receivers" checkOutputs
+  popaque $ pconstant ()
+

From fecbf6678282732aff01c21ea6de62630df1fb2b Mon Sep 17 00:00:00 2001
From: Seungheon Oh <sho@caligula.attlocal.net>
Date: Mon, 11 Apr 2022 18:43:50 -0500
Subject: [PATCH 20/78] formatted Treasury Withdrawal Effect

---
 agora/Agora/Effect/TreasuryWithdrawal.hs | 68 ++++++++++++++----------
 1 file changed, 39 insertions(+), 29 deletions(-)

diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 9a32143..f56391c 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -3,25 +3,31 @@ Module     : Agora.Effect.TreasuryWithdrawal
 Maintainer : seungheon.ooh@gmail.com
 Description: An Effect that withdraws treasury deposit
 -}
-module Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalDatum) where
+module Agora.Effect.TreasuryWithdrawal (PTreasuryWithdrawalDatum, treasuryWithdrawalValidator) where
 
 import GHC.Generics qualified as GHC
-import Generics.SOP
+import Generics.SOP (Generic, I (I))
 
-import Agora.Effect
-import Agora.Utils
-import Plutus.V1.Ledger.Value
-import Plutarch
-import qualified Plutarch.Monadic as P
-import Plutarch.Api.V1
-import Plutarch.DataRepr
+import Agora.Effect (makeEffect)
+import Agora.Utils (passert)
+import Plutarch (popaque)
+import Plutarch.Api.V1 (
+  PCredential,
+  PTuple,
+  PValidator,
+  PValue,
+  ptuple,
+ )
+import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..))
+import Plutarch.Monadic qualified as P
+import Plutus.V1.Ledger.Value (CurrencySymbol)
 
 data PTreasuryWithdrawalDatum (s :: S)
   = PTreasuryWithdrawalDatum
       ( Term
           s
-          (PDataRecord
-           '[ "receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue)) ]
+          ( PDataRecord
+              '["receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue))]
           )
       )
   deriving stock (GHC.Generic)
@@ -30,22 +36,26 @@ data PTreasuryWithdrawalDatum (s :: S)
     (PlutusType, PIsData, PDataFields)
     via PIsDataReprInstances PTreasuryWithdrawalDatum
 
-treasuryWithdrawalDatum :: forall {s :: S}. CurrencySymbol -> Term s PValidator
-treasuryWithdrawalDatum currSymbol = makeEffect currSymbol $
+treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
+treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
   \_cs (_datum :: Term _ PTreasuryWithdrawalDatum) _txOutRef _txInfo -> P.do
-  let outputs = pmap #
-                plam (\_out -> P.do
-                       out <- pletFields @'["address", "value"] $ pfromData _out
-                       cred <- pletFields @'["credential"] $ pfromData out.address
-                       pdata $ ptuple # cred.credential # out.value
-                     ) #$
-                pfield @"outputs" # _txInfo
-      recivers = pfromData (pfield @"receivers" # _datum)
-      checkOutputs = pall # plam id #$ pmap #
-                     plam (\_out -> P.do
-                            pelem # _out # outputs
-                          ) #$
-                     recivers
-  passert "Transaction output does not match receivers" checkOutputs
-  popaque $ pconstant ()
-
+    let outputs =
+          pmap
+            # plam
+              ( \_out -> P.do
+                  out <- pletFields @'["address", "value"] $ pfromData _out
+                  cred <- pletFields @'["credential"] $ pfromData out.address
+                  pdata $ ptuple # cred.credential # out.value
+              )
+            #$ pfield @"outputs"
+            # _txInfo
+        recivers = pfromData $ pfield @"receivers" # _datum
+        checkOutputs =
+          pall # plam id #$ pmap
+            # plam
+              ( \_out -> P.do
+                  pelem # _out # outputs
+              )
+            #$ recivers
+    passert "Transaction output does not match receivers" checkOutputs
+    popaque $ pconstant ()

From 2fc54b3fc5cfd26c6b70983502a7063303625e7c Mon Sep 17 00:00:00 2001
From: Seungheon Oh <sho@caligula.attlocal.net>
Date: Tue, 12 Apr 2022 19:38:33 -0500
Subject: [PATCH 21/78] Treasury Withdrawal Effect

ensures exact number of outputs, Haskell-level datum
---
 agora/Agora/Effect/TreasuryWithdrawal.hs | 56 +++++++++++++++++-------
 1 file changed, 41 insertions(+), 15 deletions(-)

diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index f56391c..567a13a 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -1,12 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 {- |
 Module     : Agora.Effect.TreasuryWithdrawal
 Maintainer : seungheon.ooh@gmail.com
 Description: An Effect that withdraws treasury deposit
 -}
-module Agora.Effect.TreasuryWithdrawal (PTreasuryWithdrawalDatum, treasuryWithdrawalValidator) where
+module Agora.Effect.TreasuryWithdrawal (TreasuryWithdrawalDatum, PTreasuryWithdrawalDatum, treasuryWithdrawalValidator) where
 
 import GHC.Generics qualified as GHC
-import Generics.SOP (Generic, I (I))
+import Generics.SOP ( I(I), Generic )
 
 import Agora.Effect (makeEffect)
 import Agora.Utils (passert)
@@ -18,9 +20,22 @@ import Plutarch.Api.V1 (
   PValue,
   ptuple,
  )
-import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..))
+import Plutarch.DataRepr
+    ( PDataFields,
+      PIsDataReprInstances(..),
+      DerivePConstantViaData(..) )
+import Plutarch.Lift ( PUnsafeLiftDecl(..) )
 import Plutarch.Monadic qualified as P
-import Plutus.V1.Ledger.Value (CurrencySymbol)
+import Plutus.V1.Ledger.Credential ( Credential )
+import Plutus.V1.Ledger.Value ( CurrencySymbol, Value )
+import PlutusTx qualified
+
+data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum {receivers :: [(Credential, Value)]}
+  deriving stock (Show, GHC.Generic)
+  deriving anyclass (Generic)
+
+PlutusTx.makeLift ''TreasuryWithdrawalDatum
+PlutusTx.unstableMakeIsData ''TreasuryWithdrawalDatum
 
 data PTreasuryWithdrawalDatum (s :: S)
   = PTreasuryWithdrawalDatum
@@ -36,10 +51,19 @@ data PTreasuryWithdrawalDatum (s :: S)
     (PlutusType, PIsData, PDataFields)
     via PIsDataReprInstances PTreasuryWithdrawalDatum
 
+instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where
+  type PLifted PTreasuryWithdrawalDatum = TreasuryWithdrawalDatum
+deriving via
+  (DerivePConstantViaData TreasuryWithdrawalDatum PTreasuryWithdrawalDatum)
+  instance
+    (PConstant TreasuryWithdrawalDatum)
+
 treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
 treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
   \_cs (_datum :: Term _ PTreasuryWithdrawalDatum) _txOutRef _txInfo -> P.do
-    let outputs =
+    receivers <- plet $ pfromData $ pfield @"receivers" # _datum
+    txInfo <- pletFields @'["outputs"] _txInfo
+    let outputValues =
           pmap
             # plam
               ( \_out -> P.do
@@ -47,15 +71,17 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
                   cred <- pletFields @'["credential"] $ pfromData out.address
                   pdata $ ptuple # cred.credential # out.value
               )
-            #$ pfield @"outputs"
-            # _txInfo
-        recivers = pfromData $ pfield @"receivers" # _datum
-        checkOutputs =
+            #$ txInfo.outputs
+        outputContentMatchesRecivers =
           pall # plam id #$ pmap
-            # plam
-              ( \_out -> P.do
-                  pelem # _out # outputs
-              )
-            #$ recivers
-    passert "Transaction output does not match receivers" checkOutputs
+            # plam (\_out -> pelem # _out # outputValues)
+            #$ receivers
+        outputNumberMatchesRecivers = plength # receivers #== plength # (pfromData txInfo.outputs)
+        outputIsNotPayingToEffect = pconstant True -- How to check if it's not paying to effect itself?
+
+    passert "Transaction output does not match receivers"
+      $     outputContentMatchesRecivers
+        #&& outputNumberMatchesRecivers
+        #&& outputIsNotPayingToEffect
+
     popaque $ pconstant ()

From 1f6d8573a0a6750f16c42c0b4c837c4a73d98fe7 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Wed, 13 Apr 2022 11:52:14 -0400
Subject: [PATCH 22/78] Treasury Withdrawal Effect Constraint

It checks for output that pays to effect itself.
---
 agora/Agora/Effect/TreasuryWithdrawal.hs | 63 +++++++++++++++++-------
 1 file changed, 45 insertions(+), 18 deletions(-)

diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 567a13a..7aa7646 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -8,26 +8,30 @@ Description: An Effect that withdraws treasury deposit
 module Agora.Effect.TreasuryWithdrawal (TreasuryWithdrawalDatum, PTreasuryWithdrawalDatum, treasuryWithdrawalValidator) where
 
 import GHC.Generics qualified as GHC
-import Generics.SOP ( I(I), Generic )
+import Generics.SOP (Generic, I (I))
 
 import Agora.Effect (makeEffect)
-import Agora.Utils (passert)
+import Agora.Utils ( passert, passetClassValueOf' )
 import Plutarch (popaque)
-import Plutarch.Api.V1 (
-  PCredential,
-  PTuple,
-  PValidator,
-  PValue,
-  ptuple,
+import Plutarch.Api.V1
+    ( PTxInfo,
+      PTxOutRef,
+      PValidator,
+      PTuple,
+      PValue,
+      PCredential,
+      ptuple,
+      PTxInInfo,
+      PTxOut )
+import Plutarch.DataRepr (
+  DerivePConstantViaData (..),
+  PDataFields,
+  PIsDataReprInstances (..),
  )
-import Plutarch.DataRepr
-    ( PDataFields,
-      PIsDataReprInstances(..),
-      DerivePConstantViaData(..) )
-import Plutarch.Lift ( PUnsafeLiftDecl(..) )
+import Plutarch.Lift (PUnsafeLiftDecl (..))
 import Plutarch.Monadic qualified as P
-import Plutus.V1.Ledger.Credential ( Credential )
-import Plutus.V1.Ledger.Value ( CurrencySymbol, Value )
+import Plutus.V1.Ledger.Credential (Credential)
+import Plutus.V1.Ledger.Value (AssetClass (..), CurrencySymbol, Value)
 import PlutusTx qualified
 
 data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum {receivers :: [(Credential, Value)]}
@@ -58,6 +62,19 @@ deriving via
   instance
     (PConstant TreasuryWithdrawalDatum)
 
+findOwnInput :: Term s (PTxInfo :--> PTxOutRef :--> PTxInInfo)
+findOwnInput = phoistAcyclic $
+  plam $ \txInfo spending' -> P.do
+    input <- plet $ pfromData $ pfield @"inputs" # txInfo
+    spending <- plet $ pdata spending'
+    PJust result <- pmatch $ pfind # plam (\x -> pfield @"outRef" # x #== spending) # input
+    pfromData result
+
+findOwnAddress :: Term s (PTxInfo :--> PTxOutRef :--> PTxOut)
+findOwnAddress = phoistAcyclic $
+  plam $ \txInfo spending -> P.do
+    pfromData $ pfield @"resolved" #$ findOwnInput # txInfo # spending
+
 treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
 treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
   \_cs (_datum :: Term _ PTreasuryWithdrawalDatum) _txOutRef _txInfo -> P.do
@@ -77,10 +94,20 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
             # plam (\_out -> pelem # _out # outputValues)
             #$ receivers
         outputNumberMatchesRecivers = plength # receivers #== plength # (pfromData txInfo.outputs)
-        outputIsNotPayingToEffect = pconstant True -- How to check if it's not paying to effect itself?
+        outputIsNotPayingToEffect = P.do
+          input <- pletFields @'["address", "value"] $ findOwnAddress # pfromData _txInfo # _txOutRef
+          let correctMinimum = passetClassValueOf' (AssetClass ("", "")) # input.value #== 2000000
+              notPayingToEffect =
+                pnot #$ pany
+                  # plam
+                    ( \x ->
+                        input.address #== pfield @"address" # pfromData x
+                    )
+                  # pfromData txInfo.outputs
+          correctMinimum #&& notPayingToEffect
 
-    passert "Transaction output does not match receivers"
-      $     outputContentMatchesRecivers
+    passert "Transaction output does not match receivers" $
+      outputContentMatchesRecivers
         #&& outputNumberMatchesRecivers
         #&& outputIsNotPayingToEffect
 

From 81dccdb858f35e64e8c9661b8a25378d76801209 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Thu, 14 Apr 2022 11:20:16 -0400
Subject: [PATCH 23/78] Simple fixes for Treasury Withdrawal Effect

Some simple fixes: naming convention, proper comment for haddoc
---
 agora/Agora/Effect/TreasuryWithdrawal.hs | 16 +++++++++-------
 1 file changed, 9 insertions(+), 7 deletions(-)

diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 7aa7646..6ba6375 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -4,6 +4,8 @@
 Module     : Agora.Effect.TreasuryWithdrawal
 Maintainer : seungheon.ooh@gmail.com
 Description: An Effect that withdraws treasury deposit
+
+An Effect that withdraws treasury deposit
 -}
 module Agora.Effect.TreasuryWithdrawal (TreasuryWithdrawalDatum, PTreasuryWithdrawalDatum, treasuryWithdrawalValidator) where
 
@@ -77,25 +79,25 @@ findOwnAddress = phoistAcyclic $
 
 treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
 treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
-  \_cs (_datum :: Term _ PTreasuryWithdrawalDatum) _txOutRef _txInfo -> P.do
-    receivers <- plet $ pfromData $ pfield @"receivers" # _datum
-    txInfo <- pletFields @'["outputs"] _txInfo
+  \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do
+    receivers <- plet $ pfromData $ pfield @"receivers" # datum'
+    txInfo <- pletFields @'["outputs"] txInfo'
     let outputValues =
           pmap
             # plam
-              ( \_out -> P.do
-                  out <- pletFields @'["address", "value"] $ pfromData _out
+              ( \out' -> P.do
+                  out <- pletFields @'["address", "value"] $ pfromData out'
                   cred <- pletFields @'["credential"] $ pfromData out.address
                   pdata $ ptuple # cred.credential # out.value
               )
             #$ txInfo.outputs
         outputContentMatchesRecivers =
           pall # plam id #$ pmap
-            # plam (\_out -> pelem # _out # outputValues)
+            # plam (\out -> pelem # out # outputValues)
             #$ receivers
         outputNumberMatchesRecivers = plength # receivers #== plength # (pfromData txInfo.outputs)
         outputIsNotPayingToEffect = P.do
-          input <- pletFields @'["address", "value"] $ findOwnAddress # pfromData _txInfo # _txOutRef
+          input <- pletFields @'["address", "value"] $ findOwnAddress # pfromData txInfo' # txOutRef'
           let correctMinimum = passetClassValueOf' (AssetClass ("", "")) # input.value #== 2000000
               notPayingToEffect =
                 pnot #$ pany

From a3a76a2461974c61dc8072da3f1065ae0aa224de Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Fri, 15 Apr 2022 08:43:47 -0500
Subject: [PATCH 24/78] small fixes for Treasury Withdrawal Effect

---
 agora/Agora/Effect/TreasuryWithdrawal.hs | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 6ba6375..8f475f6 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -64,6 +64,7 @@ deriving via
   instance
     (PConstant TreasuryWithdrawalDatum)
 
+-- These functions can be replaced with ones on Utils.hs once seungheonoh/util branch get merged.
 findOwnInput :: Term s (PTxInfo :--> PTxOutRef :--> PTxInInfo)
 findOwnInput = phoistAcyclic $
   plam $ \txInfo spending' -> P.do
@@ -95,7 +96,7 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
           pall # plam id #$ pmap
             # plam (\out -> pelem # out # outputValues)
             #$ receivers
-        outputNumberMatchesRecivers = plength # receivers #== plength # (pfromData txInfo.outputs)
+        outputNumberMatchesReceivers = plength # receivers #== plength # (pfromData txInfo.outputs)
         outputIsNotPayingToEffect = P.do
           input <- pletFields @'["address", "value"] $ findOwnAddress # pfromData txInfo' # txOutRef'
           let correctMinimum = passetClassValueOf' (AssetClass ("", "")) # input.value #== 2000000
@@ -108,9 +109,8 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
                   # pfromData txInfo.outputs
           correctMinimum #&& notPayingToEffect
 
-    passert "Transaction output does not match receivers" $
-      outputContentMatchesRecivers
-        #&& outputNumberMatchesRecivers
-        #&& outputIsNotPayingToEffect
+    passert "Transaction output does not match receivers" outputContentMatchesRecivers
+    passert "" outputNumberMatchesReceivers
+    passert "" outputIsNotPayingToEffect
 
     popaque $ pconstant ()

From 4d2c3af2bafe9094274903a450014bf8659a64a0 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Sat, 16 Apr 2022 00:07:32 -0500
Subject: [PATCH 25/78] Minor fixes

Using Utils.hs, fixing fusioning issue, fixing CI build
---
 agora/Agora/Effect/TreasuryWithdrawal.hs | 51 ++++++++----------------
 1 file changed, 17 insertions(+), 34 deletions(-)

diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 8f475f6..66724be 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -13,18 +13,16 @@ import GHC.Generics qualified as GHC
 import Generics.SOP (Generic, I (I))
 
 import Agora.Effect (makeEffect)
-import Agora.Utils ( passert, passetClassValueOf' )
+import Agora.Utils (findTxOutByTxOutRef, passert)
 import Plutarch (popaque)
-import Plutarch.Api.V1
-    ( PTxInfo,
-      PTxOutRef,
-      PValidator,
-      PTuple,
-      PValue,
-      PCredential,
-      ptuple,
-      PTxInInfo,
-      PTxOut )
+import Plutarch.Api.V1 (
+  PCredential,
+  PTuple,
+  PValidator,
+  PValue,
+  ptuple,
+ )
+
 import Plutarch.DataRepr (
   DerivePConstantViaData (..),
   PDataFields,
@@ -33,17 +31,17 @@ import Plutarch.DataRepr (
 import Plutarch.Lift (PUnsafeLiftDecl (..))
 import Plutarch.Monadic qualified as P
 import Plutus.V1.Ledger.Credential (Credential)
-import Plutus.V1.Ledger.Value (AssetClass (..), CurrencySymbol, Value)
+import Plutus.V1.Ledger.Value (CurrencySymbol, Value)
 import PlutusTx qualified
 
-data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum {receivers :: [(Credential, Value)]}
+newtype TreasuryWithdrawalDatum = TreasuryWithdrawalDatum {receivers :: [(Credential, Value)]}
   deriving stock (Show, GHC.Generic)
   deriving anyclass (Generic)
 
 PlutusTx.makeLift ''TreasuryWithdrawalDatum
 PlutusTx.unstableMakeIsData ''TreasuryWithdrawalDatum
 
-data PTreasuryWithdrawalDatum (s :: S)
+newtype PTreasuryWithdrawalDatum (s :: S)
   = PTreasuryWithdrawalDatum
       ( Term
           s
@@ -64,20 +62,6 @@ deriving via
   instance
     (PConstant TreasuryWithdrawalDatum)
 
--- These functions can be replaced with ones on Utils.hs once seungheonoh/util branch get merged.
-findOwnInput :: Term s (PTxInfo :--> PTxOutRef :--> PTxInInfo)
-findOwnInput = phoistAcyclic $
-  plam $ \txInfo spending' -> P.do
-    input <- plet $ pfromData $ pfield @"inputs" # txInfo
-    spending <- plet $ pdata spending'
-    PJust result <- pmatch $ pfind # plam (\x -> pfield @"outRef" # x #== spending) # input
-    pfromData result
-
-findOwnAddress :: Term s (PTxInfo :--> PTxOutRef :--> PTxOut)
-findOwnAddress = phoistAcyclic $
-  plam $ \txInfo spending -> P.do
-    pfromData $ pfield @"resolved" #$ findOwnInput # txInfo # spending
-
 treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
 treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
   \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do
@@ -93,21 +77,20 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
               )
             #$ txInfo.outputs
         outputContentMatchesRecivers =
-          pall # plam id #$ pmap
-            # plam (\out -> pelem # out # outputValues)
+          pall # plam (\out -> pelem # out # outputValues)
             #$ receivers
         outputNumberMatchesReceivers = plength # receivers #== plength # (pfromData txInfo.outputs)
         outputIsNotPayingToEffect = P.do
-          input <- pletFields @'["address", "value"] $ findOwnAddress # pfromData txInfo' # txOutRef'
-          let correctMinimum = passetClassValueOf' (AssetClass ("", "")) # input.value #== 2000000
-              notPayingToEffect =
+          PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo'
+          input <- pletFields @'["address", "value"] $ txOut
+          let notPayingToEffect =
                 pnot #$ pany
                   # plam
                     ( \x ->
                         input.address #== pfield @"address" # pfromData x
                     )
                   # pfromData txInfo.outputs
-          correctMinimum #&& notPayingToEffect
+          notPayingToEffect
 
     passert "Transaction output does not match receivers" outputContentMatchesRecivers
     passert "" outputNumberMatchesReceivers

From 1e4d6e554ded29abcbda462e63a8585cc9196fe2 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Sat, 16 Apr 2022 00:33:23 -0500
Subject: [PATCH 26/78] Treasury Withdrawal Effect simple Haddock comment

---
 agora/Agora/Effect/TreasuryWithdrawal.hs | 14 ++++++++++++++
 1 file changed, 14 insertions(+)

diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 66724be..52f3009 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -62,6 +62,20 @@ deriving via
   instance
     (PConstant TreasuryWithdrawalDatum)
 
+{- | Withdraws given list of values to specific target addresses.
+It can be evoked by burning GAT. The transaction should have correct
+outputs to the users and any left overs should be paid back to the treasury.
+
+The validator does not accept any Redeemer as all "parameters" are provided
+via encoded Datum.
+
+Note:
+It should check...
+1. Transaction outputs should contain all of what Datum specified
+2. Left over assests should be redirected back to Treasury
+It can be more flexiable over...
+- The number of outputs themselves
+-}
 treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
 treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
   \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do

From bf67f387823d1a7e51aafa06d42a90987df6c867 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Mon, 18 Apr 2022 13:03:10 -0500
Subject: [PATCH 27/78] Treasury Withdrawal Effect checks if remainder is to
 the treasury

It checks if transaction is paying the remainders to the treasury.
---
 agora/Agora/Effect/TreasuryWithdrawal.hs | 67 +++++++++++++++---------
 1 file changed, 42 insertions(+), 25 deletions(-)

diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 52f3009..467733b 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -13,15 +13,16 @@ import GHC.Generics qualified as GHC
 import Generics.SOP (Generic, I (I))
 
 import Agora.Effect (makeEffect)
-import Agora.Utils (findTxOutByTxOutRef, passert)
+import Agora.Utils ( paddValue, passert ) 
 import Plutarch (popaque)
-import Plutarch.Api.V1 (
-  PCredential,
-  PTuple,
-  PValidator,
-  PValue,
-  ptuple,
- )
+import Plutarch.Api.V1
+    ( PCredential,
+      PValue,
+      PTxOut(PTxOut),
+      PTxInInfo(PTxInInfo),
+      PTuple,
+      ptuple,
+      PValidator )
 
 import Plutarch.DataRepr (
   DerivePConstantViaData (..),
@@ -78,9 +79,9 @@ It can be more flexiable over...
 -}
 treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
 treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
-  \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do
+  \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) _txOutRef' txInfo' -> P.do
     receivers <- plet $ pfromData $ pfield @"receivers" # datum'
-    txInfo <- pletFields @'["outputs"] txInfo'
+    txInfo <- pletFields @'["outputs", "inputs"] txInfo'
     let outputValues =
           pmap
             # plam
@@ -89,25 +90,41 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
                   cred <- pletFields @'["credential"] $ pfromData out.address
                   pdata $ ptuple # cred.credential # out.value
               )
-            #$ txInfo.outputs
+            # txInfo.outputs
         outputContentMatchesRecivers =
           pall # plam (\out -> pelem # out # outputValues)
             #$ receivers
-        outputNumberMatchesReceivers = plength # receivers #== plength # (pfromData txInfo.outputs)
-        outputIsNotPayingToEffect = P.do
-          PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo'
-          input <- pletFields @'["address", "value"] $ txOut
-          let notPayingToEffect =
-                pnot #$ pany
-                  # plam
-                    ( \x ->
-                        input.address #== pfield @"address" # pfromData x
-                    )
-                  # pfromData txInfo.outputs
-          notPayingToEffect
+        sumValues = 
+          pfoldr
+            # plam
+              ( \((pfield @"_1" #) . pfromData -> x) y -> P.do
+                  paddValue # (pfromData x) # y
+              )
+            # (pconstant (mempty :: Value))
+        inputCred =
+          pmap
+            # plam (\inInfo -> P.do
+                     PTxInInfo inInfo' <- pmatch $ pfromData inInfo
+                     PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # inInfo'
+                     let addr = pfromData $ pfield @"address" # out
+                     pfield @"credential" # addr)
+            # pfromData txInfo.inputs
+        totalInput =
+          pfoldr
+            # plam (\x' y -> P.do
+                   PTxInInfo x <- pmatch $ pfromData x'
+                   PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # x
+                   paddValue # (pfromData $ pfield @"value" # out) # y)
+            # (pconstant (mempty :: Value))
+            # pfromData txInfo.inputs
+        sumOutputsToInputAddr = sumValues #$
+          pfilter
+            # plam (\((pfield @"_0" #) . pfromData -> addr) -> pelem # (addr) # inputCred) # outputValues
+        sumReceivers = sumValues # receivers
+-- TODO: Probably need to check/exclude the effect input...
+        excessShouldBePaidToInputs = pdata (paddValue # sumReceivers # sumOutputsToInputAddr) #== pdata totalInput
 
     passert "Transaction output does not match receivers" outputContentMatchesRecivers
-    passert "" outputNumberMatchesReceivers
-    passert "" outputIsNotPayingToEffect
+    passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs
 
     popaque $ pconstant ()

From a82fa6f31d4a984e1aa85636b2812bd9c87cbab5 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Mon, 18 Apr 2022 13:59:59 -0500
Subject: [PATCH 28/78] Treasury Withdrawal Effect: Only check treasury inputs

Tried to make it so that its only checking treasury inputs when
checking if transaction is correctly returning the remainders to treasury.
---
 agora/Agora/Effect/TreasuryWithdrawal.hs | 88 +++++++++++++++---------
 1 file changed, 56 insertions(+), 32 deletions(-)

diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 467733b..f9623bd 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -13,16 +13,17 @@ import GHC.Generics qualified as GHC
 import Generics.SOP (Generic, I (I))
 
 import Agora.Effect (makeEffect)
-import Agora.Utils ( paddValue, passert ) 
+import Agora.Utils (findTxOutByTxOutRef, paddValue, passert)
 import Plutarch (popaque)
-import Plutarch.Api.V1
-    ( PCredential,
-      PValue,
-      PTxOut(PTxOut),
-      PTxInInfo(PTxInInfo),
-      PTuple,
-      ptuple,
-      PValidator )
+import Plutarch.Api.V1 (
+  PCredential,
+  PTuple,
+  PTxInInfo (PTxInInfo),
+  PTxOut (PTxOut),
+  PValidator,
+  PValue,
+  ptuple,
+ )
 
 import Plutarch.DataRepr (
   DerivePConstantViaData (..),
@@ -79,9 +80,11 @@ It can be more flexiable over...
 -}
 treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
 treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
-  \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) _txOutRef' txInfo' -> P.do
+  \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do
     receivers <- plet $ pfromData $ pfield @"receivers" # datum'
     txInfo <- pletFields @'["outputs", "inputs"] txInfo'
+    PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo'
+    effInput <- pletFields @'["address", "value"] $ txOut
     let outputValues =
           pmap
             # plam
@@ -94,37 +97,58 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
         outputContentMatchesRecivers =
           pall # plam (\out -> pelem # out # outputValues)
             #$ receivers
-        sumValues = 
+        sumValues =
           pfoldr
             # plam
               ( \((pfield @"_1" #) . pfromData -> x) y -> P.do
-                  paddValue # (pfromData x) # y
+                  paddValue # pfromData x # y
               )
-            # (pconstant (mempty :: Value))
+            # pconstant (mempty :: Value)
         inputCred =
           pmap
-            # plam (\inInfo -> P.do
-                     PTxInInfo inInfo' <- pmatch $ pfromData inInfo
-                     PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # inInfo'
-                     let addr = pfromData $ pfield @"address" # out
-                     pfield @"credential" # addr)
+            # plam
+              ( \inInfo -> P.do
+                  PTxInInfo inInfo' <- pmatch $ pfromData inInfo
+                  PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # inInfo'
+                  let addr = pfromData $ pfield @"address" # out
+                  pfield @"credential" # addr
+              )
             # pfromData txInfo.inputs
-        totalInput =
+        totalTreasuryInputs =
           pfoldr
-            # plam (\x' y -> P.do
-                   PTxInInfo x <- pmatch $ pfromData x'
-                   PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # x
-                   paddValue # (pfromData $ pfield @"value" # out) # y)
-            # (pconstant (mempty :: Value))
+            # plam
+              ( \x' y -> P.do
+                  PTxInInfo x <- pmatch $ pfromData x'
+                  PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # x
+                  -- only take ones from treasury
+                  pif
+                    (effInput.address #== pfield @"address" # out)
+                    (paddValue # pfromData (pfield @"value" # out) # y)
+                    y
+              )
+            # pconstant (mempty :: Value)
             # pfromData txInfo.inputs
-        sumOutputsToInputAddr = sumValues #$
-          pfilter
-            # plam (\((pfield @"_0" #) . pfromData -> addr) -> pelem # (addr) # inputCred) # outputValues
-        sumReceivers = sumValues # receivers
--- TODO: Probably need to check/exclude the effect input...
-        excessShouldBePaidToInputs = pdata (paddValue # sumReceivers # sumOutputsToInputAddr) #== pdata totalInput
+        sumOutputsToTreasury =
+          sumValues
+            #$ pfilter
+            # plam
+              ( \((pfield @"_0" #) . pfromData -> addr) ->
+                  pelem # addr # inputCred
+                    #&& pnot # (addr #== pfield @"credential" # effInput.address)
+              )
+            # outputValues
+        -- TODO: Probably need to check/exclude the effect input...
+        excessShouldBePaidToInputs =
+          pdata (paddValue # (sumValues # receivers) # sumOutputsToTreasury) #== pdata totalTreasuryInputs
+        shouldNotPayToEffect =
+          pnot #$ pany
+            # plam
+              ( \x ->
+                  effInput.address #== pfield @"address" # pfromData x
+              )
+            # pfromData txInfo.outputs
 
     passert "Transaction output does not match receivers" outputContentMatchesRecivers
-    passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs
-
+    passert "Transaction should not pay to effects" shouldNotPayToEffect
+    passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs -- We might not need this.
     popaque $ pconstant ()

From c52b65a3351ed9a4088235c37eaee58992fd8716 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Mon, 18 Apr 2022 19:15:41 -0500
Subject: [PATCH 29/78] first step to the Test for Treasury Withdrawal Effect

---
 .../Spec/Effect/TreasuryWithdrawalEffect.hs   | 59 +++++++++++++++++++
 agora.cabal                                   |  1 +
 2 files changed, 60 insertions(+)
 create mode 100644 agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs

diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
new file mode 100644
index 0000000..2113624
--- /dev/null
+++ b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
@@ -0,0 +1,59 @@
+{- |
+Module     : Spec.Effect.TreasuryWithdrawalEffect
+Maintainer : seungheon.ooh@gmail.com
+Description: Sample based testing for Treasury Withdrawal Effect
+
+This module tests the Treasury Withdrawal Effect.
+-}
+
+module Spec.Effect.TreasuryWithdrawalEffect(currSymbol, signer, validator, validatorHashTN, withdrawalEffect) where
+
+import Plutarch.Api.V1
+import Plutus.V1.Ledger.Api
+import Plutus.V1.Ledger.Value qualified as Value
+import Plutus.V1.Ledger.Interval qualified as Interval
+
+import Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalValidator)
+
+-- | A sample Currency Symbol
+currSymbol :: CurrencySymbol
+currSymbol = CurrencySymbol "Orange19721121"
+
+-- | A sample 'PubKeyHash'.
+signer :: PubKeyHash
+signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
+
+-- | Effect validator instance.
+validator :: Validator
+validator = mkValidator $ treasuryWithdrawalValidator currSymbol
+
+-- | 'TokenName' that represents the hash of the 'Stake' validator.
+validatorHashTN :: TokenName
+validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
+
+withdrawalEffect :: ScriptContext
+withdrawalEffect =
+  ScriptContext
+    { scriptContextTxInfo  =
+        TxInfo
+              { txInfoInputs =
+                  [ TxInInfo
+                      (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+                      TxOut
+                        { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                        , txOutValue = Value.singleton currSymbol validatorHashTN 1
+                        , txOutDatumHash = Nothing
+                        }
+                  ]
+              , txInfoOutputs = []
+              , txInfoFee = Value.singleton "" "" 2
+              , txInfoMint = mempty
+              , txInfoDCert = []
+              , txInfoWdrl = []
+              , txInfoValidRange = Interval.always
+              , txInfoSignatories = [signer]
+              , txInfoData = []
+              , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+              }
+    , scriptContextPurpose = Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+    }
diff --git a/agora.cabal b/agora.cabal
index aae5776..689ce97 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -154,6 +154,7 @@ test-suite agora-test
   other-modules:
     Spec.Model.MultiSig
     Spec.Sample.Stake
+    Spec.Effect.TreasuryWithdrawalEffect
     Spec.Stake
     Spec.Util
     Spec.AuthorityToken

From 5584a47528e3b385a697877a1d81c73f7ba9adbd Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Mon, 18 Apr 2022 19:17:36 -0500
Subject: [PATCH 30/78] format...

---
 .../Spec/Effect/TreasuryWithdrawalEffect.hs   | 45 +++++++++----------
 agora.cabal                                   |  2 +-
 2 files changed, 23 insertions(+), 24 deletions(-)

diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
index 2113624..cba91e8 100644
--- a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
+++ b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
@@ -5,13 +5,12 @@ Description: Sample based testing for Treasury Withdrawal Effect
 
 This module tests the Treasury Withdrawal Effect.
 -}
-
-module Spec.Effect.TreasuryWithdrawalEffect(currSymbol, signer, validator, validatorHashTN, withdrawalEffect) where
+module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, withdrawalEffect) where
 
 import Plutarch.Api.V1
 import Plutus.V1.Ledger.Api
-import Plutus.V1.Ledger.Value qualified as Value
 import Plutus.V1.Ledger.Interval qualified as Interval
+import Plutus.V1.Ledger.Value qualified as Value
 
 import Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalValidator)
 
@@ -34,26 +33,26 @@ validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
 withdrawalEffect :: ScriptContext
 withdrawalEffect =
   ScriptContext
-    { scriptContextTxInfo  =
+    { scriptContextTxInfo =
         TxInfo
-              { txInfoInputs =
-                  [ TxInInfo
-                      (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
-                      TxOut
-                        { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
-                        , txOutValue = Value.singleton currSymbol validatorHashTN 1
-                        , txOutDatumHash = Nothing
-                        }
-                  ]
-              , txInfoOutputs = []
-              , txInfoFee = Value.singleton "" "" 2
-              , txInfoMint = mempty
-              , txInfoDCert = []
-              , txInfoWdrl = []
-              , txInfoValidRange = Interval.always
-              , txInfoSignatories = [signer]
-              , txInfoData = []
-              , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
-              }
+          { txInfoInputs =
+              [ TxInInfo
+                  (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+                  TxOut
+                    { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                    , txOutValue = Value.singleton currSymbol validatorHashTN 1
+                    , txOutDatumHash = Nothing
+                    }
+              ]
+          , txInfoOutputs = []
+          , txInfoFee = Value.singleton "" "" 2
+          , txInfoMint = mempty
+          , txInfoDCert = []
+          , txInfoWdrl = []
+          , txInfoValidRange = Interval.always
+          , txInfoSignatories = [signer]
+          , txInfoData = []
+          , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+          }
     , scriptContextPurpose = Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
     }
diff --git a/agora.cabal b/agora.cabal
index 689ce97..3f47333 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -152,9 +152,9 @@ test-suite agora-test
   main-is:        Spec.hs
   hs-source-dirs: agora-test
   other-modules:
+    Spec.Effect.TreasuryWithdrawalEffect
     Spec.Model.MultiSig
     Spec.Sample.Stake
-    Spec.Effect.TreasuryWithdrawalEffect
     Spec.Stake
     Spec.Util
     Spec.AuthorityToken

From 27d364bda1d28bf85092f7e95de9e71e935ba052 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Tue, 19 Apr 2022 22:32:06 -0400
Subject: [PATCH 31/78] TWE test

---
 .../Spec/Effect/TreasuryWithdrawalEffect.hs   | 36 +++++++++++++++----
 agora/Agora/Effect/TreasuryWithdrawal.hs      |  6 +++-
 2 files changed, 35 insertions(+), 7 deletions(-)

diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
index cba91e8..e8e3476 100644
--- a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
+++ b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
@@ -12,11 +12,20 @@ import Plutus.V1.Ledger.Api
 import Plutus.V1.Ledger.Interval qualified as Interval
 import Plutus.V1.Ledger.Value qualified as Value
 
-import Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalValidator)
+import Agora.Effect.TreasuryWithdrawal
+
+--receiverList :: TreasuryWithdrawalDatum
+--receiverList = TreasuryWithdrawalDatum [(mempty, mempty)]
+
+_datum :: TreasuryWithdrawalDatum
+_datum =
+  TreasuryWithdrawalDatum
+  [ (PubKeyCredential signer, Value.singleton currSymbol validatorHashTN 1)
+  ]
 
 -- | A sample Currency Symbol
 currSymbol :: CurrencySymbol
-currSymbol = CurrencySymbol "Orange19721121"
+currSymbol = CurrencySymbol "Orangebottle19721121"
 
 -- | A sample 'PubKeyHash'.
 signer :: PubKeyHash
@@ -36,11 +45,25 @@ withdrawalEffect =
     { scriptContextTxInfo =
         TxInfo
           { txInfoInputs =
-              [ TxInInfo
-                  (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+              [ TxInInfo -- Initiator
+                  (TxOutRef "Initiator" 1)
                   TxOut
                     { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
-                    , txOutValue = Value.singleton currSymbol validatorHashTN 1
+                    , txOutValue = Value.singleton "" "" 2000000
+                    , txOutDatumHash = Nothing
+                    }
+              , TxInInfo -- Treasury 1
+                  (TxOutRef "Treasury 1" 1)
+                  TxOut
+                    { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                    , txOutValue = Value.singleton currSymbol validatorHashTN 10
+                    , txOutDatumHash = Nothing
+                    }
+              , TxInInfo -- Treasury 2
+                  (TxOutRef "Treasury 2" 1)
+                  TxOut
+                    { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                    , txOutValue = Value.singleton currSymbol validatorHashTN 10
                     , txOutDatumHash = Nothing
                     }
               ]
@@ -54,5 +77,6 @@ withdrawalEffect =
           , txInfoData = []
           , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
           }
-    , scriptContextPurpose = Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+    , scriptContextPurpose =
+        Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
     }
diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index f9623bd..536c0e3 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -7,7 +7,11 @@ Description: An Effect that withdraws treasury deposit
 
 An Effect that withdraws treasury deposit
 -}
-module Agora.Effect.TreasuryWithdrawal (TreasuryWithdrawalDatum, PTreasuryWithdrawalDatum, treasuryWithdrawalValidator) where
+module Agora.Effect.TreasuryWithdrawal (
+  TreasuryWithdrawalDatum(..),
+  PTreasuryWithdrawalDatum(..),
+  treasuryWithdrawalValidator,
+  ) where
 
 import GHC.Generics qualified as GHC
 import Generics.SOP (Generic, I (I))

From 0464a03989e7025d43bf64154afdbd1cd8c4a0b6 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Tue, 19 Apr 2022 23:02:51 -0400
Subject: [PATCH 32/78] now proper a proper script context..

and some formatting fixes
---
 .../Spec/Effect/TreasuryWithdrawalEffect.hs   | 56 ++++++++++++++-----
 agora/Agora/Effect/TreasuryWithdrawal.hs      |  6 +-
 2 files changed, 46 insertions(+), 16 deletions(-)

diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
index e8e3476..751a3bc 100644
--- a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
+++ b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
@@ -5,25 +5,21 @@ Description: Sample based testing for Treasury Withdrawal Effect
 
 This module tests the Treasury Withdrawal Effect.
 -}
-module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, withdrawalEffect) where
+module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, scriptContext1) where
 
 import Plutarch.Api.V1
 import Plutus.V1.Ledger.Api
 import Plutus.V1.Ledger.Interval qualified as Interval
 import Plutus.V1.Ledger.Value qualified as Value
 
+import Data.ByteString.Hash
+
 import Agora.Effect.TreasuryWithdrawal
 
---receiverList :: TreasuryWithdrawalDatum
---receiverList = TreasuryWithdrawalDatum [(mempty, mempty)]
+-- receiverList :: TreasuryWithdrawalDatum
+-- receiverList = TreasuryWithdrawalDatum [(mempty, mempty)]
 
-_datum :: TreasuryWithdrawalDatum
-_datum =
-  TreasuryWithdrawalDatum
-  [ (PubKeyCredential signer, Value.singleton currSymbol validatorHashTN 1)
-  ]
-
--- | A sample Currency Symbol
+-- | A sample Currency Symbol.
 currSymbol :: CurrencySymbol
 currSymbol = CurrencySymbol "Orangebottle19721121"
 
@@ -31,6 +27,24 @@ currSymbol = CurrencySymbol "Orangebottle19721121"
 signer :: PubKeyHash
 signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
 
+-- | List of users who the effect will pay to.
+users :: [Credential]
+users =
+  PubKeyCredential . PubKeyHash . toBuiltin . sha2
+    <$> [ "Hello world"
+        , "Hello Agora"
+        , "Hello Plutarch"
+        ]
+
+-- | Datum for Treasury Withdrawal Effect Validator.
+_datum :: TreasuryWithdrawalDatum
+_datum =
+  TreasuryWithdrawalDatum
+    [ (users !! 0, Value.singleton currSymbol validatorHashTN 1)
+    , (users !! 1, Value.singleton currSymbol validatorHashTN 1)
+    , (users !! 2, Value.singleton currSymbol validatorHashTN 1)
+    ]
+
 -- | Effect validator instance.
 validator :: Validator
 validator = mkValidator $ treasuryWithdrawalValidator currSymbol
@@ -39,8 +53,8 @@ validator = mkValidator $ treasuryWithdrawalValidator currSymbol
 validatorHashTN :: TokenName
 validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
 
-withdrawalEffect :: ScriptContext
-withdrawalEffect =
+scriptContext1 :: ScriptContext
+scriptContext1 =
   ScriptContext
     { scriptContextTxInfo =
         TxInfo
@@ -67,7 +81,23 @@ withdrawalEffect =
                     , txOutDatumHash = Nothing
                     }
               ]
-          , txInfoOutputs = []
+          , txInfoOutputs =
+              [ TxOut
+                  { txOutAddress = Address (users !! 0) Nothing
+                  , txOutValue = Value.singleton currSymbol validatorHashTN 1
+                  , txOutDatumHash = Nothing
+                  }
+              , TxOut
+                  { txOutAddress = Address (users !! 1) Nothing
+                  , txOutValue = Value.singleton currSymbol validatorHashTN 1
+                  , txOutDatumHash = Nothing
+                  }
+              , TxOut
+                  { txOutAddress = Address (users !! 2) Nothing
+                  , txOutValue = Value.singleton currSymbol validatorHashTN 1
+                  , txOutDatumHash = Nothing
+                  }
+              ]
           , txInfoFee = Value.singleton "" "" 2
           , txInfoMint = mempty
           , txInfoDCert = []
diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 536c0e3..1156a3c 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -8,10 +8,10 @@ Description: An Effect that withdraws treasury deposit
 An Effect that withdraws treasury deposit
 -}
 module Agora.Effect.TreasuryWithdrawal (
-  TreasuryWithdrawalDatum(..),
-  PTreasuryWithdrawalDatum(..),
+  TreasuryWithdrawalDatum (..),
+  PTreasuryWithdrawalDatum (..),
   treasuryWithdrawalValidator,
-  ) where
+) where
 
 import GHC.Generics qualified as GHC
 import Generics.SOP (Generic, I (I))

From 57a0c104048844ae8f8ef95f93e9d503d2698a92 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Wed, 20 Apr 2022 08:43:22 -0400
Subject: [PATCH 33/78] added test entree

Something is wrong. It does not work.
---
 .../Spec/Effect/TreasuryWithdrawalEffect.hs   | 67 +++++++++++++++----
 agora-test/Spec/Util.hs                       | 41 ++++++++++++
 2 files changed, 96 insertions(+), 12 deletions(-)

diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
index 751a3bc..f96fb65 100644
--- a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
+++ b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
@@ -5,8 +5,10 @@ Description: Sample based testing for Treasury Withdrawal Effect
 
 This module tests the Treasury Withdrawal Effect.
 -}
-module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, scriptContext1) where
+module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, scriptContext1, tests) where
 
+import Plutarch.Evaluate
+import Plutarch.Builtin
 import Plutarch.Api.V1
 import Plutus.V1.Ledger.Api
 import Plutus.V1.Ledger.Interval qualified as Interval
@@ -16,12 +18,16 @@ import Data.ByteString.Hash
 
 import Agora.Effect.TreasuryWithdrawal
 
+import Spec.Util
+
+import Test.Tasty
+
 -- receiverList :: TreasuryWithdrawalDatum
 -- receiverList = TreasuryWithdrawalDatum [(mempty, mempty)]
 
 -- | A sample Currency Symbol.
 currSymbol :: CurrencySymbol
-currSymbol = CurrencySymbol "Orangebottle19721121"
+currSymbol = CurrencySymbol "ff"
 
 -- | A sample 'PubKeyHash'.
 signer :: PubKeyHash
@@ -31,14 +37,23 @@ signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
 users :: [Credential]
 users =
   PubKeyCredential . PubKeyHash . toBuiltin . sha2
-    <$> [ "Hello world"
-        , "Hello Agora"
-        , "Hello Plutarch"
+    <$> [ "Orange"
+        , "Bottle"
+        , "Hello"
+        ]
+
+-- | List of users who the effect will pay to.
+treasuries :: [Credential]
+treasuries =
+  ScriptCredential . ValidatorHash . toBuiltin . sha2
+    <$> [ "1234"
+        , "qwer"
+        , "asdf"
         ]
 
 -- | Datum for Treasury Withdrawal Effect Validator.
-_datum :: TreasuryWithdrawalDatum
-_datum =
+datum :: TreasuryWithdrawalDatum
+datum =
   TreasuryWithdrawalDatum
     [ (users !! 0, Value.singleton currSymbol validatorHashTN 1)
     , (users !! 1, Value.singleton currSymbol validatorHashTN 1)
@@ -60,23 +75,23 @@ scriptContext1 =
         TxInfo
           { txInfoInputs =
               [ TxInInfo -- Initiator
-                  (TxOutRef "Initiator" 1)
+                  (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
                   TxOut
                     { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
                     , txOutValue = Value.singleton "" "" 2000000
                     , txOutDatumHash = Nothing
                     }
               , TxInInfo -- Treasury 1
-                  (TxOutRef "Treasury 1" 1)
+                  (TxOutRef "Treasury 1" 2)
                   TxOut
-                    { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                    { txOutAddress = Address (treasuries !! 0) Nothing
                     , txOutValue = Value.singleton currSymbol validatorHashTN 10
                     , txOutDatumHash = Nothing
                     }
               , TxInInfo -- Treasury 2
-                  (TxOutRef "Treasury 2" 1)
+                  (TxOutRef "Treasury 2" 3)
                   TxOut
-                    { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                    { txOutAddress = Address (treasuries !! 1) Nothing
                     , txOutValue = Value.singleton currSymbol validatorHashTN 10
                     , txOutDatumHash = Nothing
                     }
@@ -97,6 +112,17 @@ scriptContext1 =
                   , txOutValue = Value.singleton currSymbol validatorHashTN 1
                   , txOutDatumHash = Nothing
                   }
+              -- Send left overs to treasuries
+              , TxOut
+                  { txOutAddress = Address (treasuries !! 0) Nothing
+                  , txOutValue = Value.singleton currSymbol validatorHashTN 7
+                  , txOutDatumHash = Nothing
+                  }
+              , TxOut
+                  { txOutAddress = Address (treasuries !! 1) Nothing
+                  , txOutValue = Value.singleton currSymbol validatorHashTN 10
+                  , txOutDatumHash = Nothing
+                  }                  
               ]
           , txInfoFee = Value.singleton "" "" 2
           , txInfoMint = mempty
@@ -110,3 +136,20 @@ scriptContext1 =
     , scriptContextPurpose =
         Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
     }
+
+
+tests :: [TestTree]
+tests =
+  [ testGroup
+    "effect"
+    [ effectFailsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1]
+  ]
+
+_asdfa :: IO ()
+_asdfa = do
+    let (res, _budget, traces) = evalScript $ compile ((treasuryWithdrawalValidator currSymbol) # pforgetData (pconstantData datum) # pforgetData (pconstantData ()) # pconstant scriptContext1)
+    case res of
+      Left e -> do
+        putStrLn $ show e <> " Traces: " <> show traces
+      Right _v ->
+        pure ()
diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs
index 4350e45..1ebdc07 100644
--- a/agora-test/Spec/Util.hs
+++ b/agora-test/Spec/Util.hs
@@ -13,6 +13,8 @@ module Spec.Util (
   policyFailsWith,
   validatorSucceedsWith,
   validatorFailsWith,
+  effectSucceedsWith,
+  effectFailsWith,
 
   -- * Plutus-land utils
   datumHash,
@@ -129,6 +131,45 @@ validatorFailsWith tag policy datum redeemer scriptContext =
           # pconstant scriptContext
       )
 
+
+-- | Check that a validator script succeeds, given a name and arguments.
+effectSucceedsWith ::
+  ( PLift datum
+  , PlutusTx.ToData (PLifted datum)
+  ) =>
+  String ->
+  ClosedTerm PValidator ->
+  PLifted datum ->
+  ScriptContext ->
+  TestTree
+effectSucceedsWith tag eff datum scriptContext =
+  scriptSucceeds tag $
+    compile
+      ( eff
+          # pforgetData (pconstantData datum)
+          # pforgetData (pconstantData ())
+          # pconstant scriptContext
+      )
+
+-- | Check that a validator script fails, given a name and arguments.
+effectFailsWith ::
+  ( PLift datum
+  , PlutusTx.ToData (PLifted datum)
+  ) =>
+  String ->
+  ClosedTerm PValidator ->
+  PLifted datum ->
+  ScriptContext ->
+  TestTree
+effectFailsWith tag eff datum scriptContext =
+  scriptFails tag $
+    compile
+      ( eff
+          # pforgetData (pconstantData datum)
+          # pforgetData (pconstantData ())
+          # pconstant scriptContext
+      )
+
 -- | Check that an arbitrary script doesn't error when evaluated, given a name.
 scriptSucceeds :: String -> Script -> TestTree
 scriptSucceeds name script = testCase name $ do

From 6c62c007f1453a6b5c0e5dfd5fdeb74ea08dc3bb Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Wed, 20 Apr 2022 12:06:16 -0400
Subject: [PATCH 34/78] more testings

---
 .../Spec/Effect/TreasuryWithdrawalEffect.hs   | 150 ++++++++++++++----
 1 file changed, 122 insertions(+), 28 deletions(-)

diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
index f96fb65..96dbc35 100644
--- a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
+++ b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
@@ -17,6 +17,7 @@ import Plutus.V1.Ledger.Value qualified as Value
 import Data.ByteString.Hash
 
 import Agora.Effect.TreasuryWithdrawal
+import Agora.AuthorityToken
 
 import Spec.Util
 
@@ -27,7 +28,13 @@ import Test.Tasty
 
 -- | A sample Currency Symbol.
 currSymbol :: CurrencySymbol
-currSymbol = CurrencySymbol "ff"
+currSymbol = CurrencySymbol "12312099"
+
+gtSymbol :: CurrencySymbol
+gtSymbol = CurrencySymbol "abb"
+
+gtToken :: TokenName
+gtToken = TokenName "hey"
 
 -- | A sample 'PubKeyHash'.
 signer :: PubKeyHash
@@ -51,13 +58,16 @@ treasuries =
         , "asdf"
         ]
 
+_aa :: [Credential]
+_aa = treasuries
+
 -- | Datum for Treasury Withdrawal Effect Validator.
 datum :: TreasuryWithdrawalDatum
 datum =
   TreasuryWithdrawalDatum
-    [ (users !! 0, Value.singleton currSymbol validatorHashTN 1)
-    , (users !! 1, Value.singleton currSymbol validatorHashTN 1)
-    , (users !! 2, Value.singleton currSymbol validatorHashTN 1)
+    [ (users !! 0, Value.singleton gtSymbol gtToken 1)
+    , (users !! 1, Value.singleton gtSymbol gtToken 1)
+    , (users !! 2, Value.singleton gtSymbol gtToken 1)
     ]
 
 -- | Effect validator instance.
@@ -73,59 +83,59 @@ scriptContext1 =
   ScriptContext
     { scriptContextTxInfo =
         TxInfo
-          { txInfoInputs =
+          { txInfoInputs = 
               [ TxInInfo -- Initiator
                   (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
                   TxOut
                     { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
-                    , txOutValue = Value.singleton "" "" 2000000
-                    , txOutDatumHash = Nothing
-                    }
-              , TxInInfo -- Treasury 1
-                  (TxOutRef "Treasury 1" 2)
-                  TxOut
-                    { txOutAddress = Address (treasuries !! 0) Nothing
-                    , txOutValue = Value.singleton currSymbol validatorHashTN 10
-                    , txOutDatumHash = Nothing
-                    }
-              , TxInInfo -- Treasury 2
-                  (TxOutRef "Treasury 2" 3)
-                  TxOut
-                    { txOutAddress = Address (treasuries !! 1) Nothing
-                    , txOutValue = Value.singleton currSymbol validatorHashTN 10
-                    , txOutDatumHash = Nothing
+                    , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST
+                    , txOutDatumHash = Just (DatumHash "")
                     }
+              -- , TxInInfo -- Treasury 1
+              --     (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2)
+              --     TxOut
+              --       { txOutAddress = Address (treasuries !! 0) Nothing
+              --       , txOutValue = Value.singleton gtSymbol gtToken 10
+              --       , txOutDatumHash = Just (DatumHash "")
+              --       }
+              -- , TxInInfo -- Treasury 2
+              --     (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3)
+              --     TxOut
+              --       { txOutAddress = Address (treasuries !! 1) Nothing
+              --       , txOutValue = Value.singleton "1234ab" "LQLQLQL" 10
+              --       , txOutDatumHash = Just (DatumHash "")
+              --       }
               ]
-          , txInfoOutputs =
+          , txInfoOutputs = 
               [ TxOut
                   { txOutAddress = Address (users !! 0) Nothing
-                  , txOutValue = Value.singleton currSymbol validatorHashTN 1
+                  , txOutValue = Value.singleton gtSymbol gtToken 1
                   , txOutDatumHash = Nothing
                   }
               , TxOut
                   { txOutAddress = Address (users !! 1) Nothing
-                  , txOutValue = Value.singleton currSymbol validatorHashTN 1
+                  , txOutValue = Value.singleton gtSymbol gtToken 1
                   , txOutDatumHash = Nothing
                   }
               , TxOut
                   { txOutAddress = Address (users !! 2) Nothing
-                  , txOutValue = Value.singleton currSymbol validatorHashTN 1
+                  , txOutValue = Value.singleton gtSymbol gtToken 1
                   , txOutDatumHash = Nothing
                   }
               -- Send left overs to treasuries
               , TxOut
                   { txOutAddress = Address (treasuries !! 0) Nothing
-                  , txOutValue = Value.singleton currSymbol validatorHashTN 7
+                  , txOutValue = Value.singleton gtSymbol gtToken 7
                   , txOutDatumHash = Nothing
                   }
               , TxOut
                   { txOutAddress = Address (treasuries !! 1) Nothing
-                  , txOutValue = Value.singleton currSymbol validatorHashTN 10
+                  , txOutValue = Value.singleton gtSymbol gtToken 10
                   , txOutDatumHash = Nothing
                   }                  
               ]
           , txInfoFee = Value.singleton "" "" 2
-          , txInfoMint = mempty
+          , txInfoMint = Value.singleton currSymbol validatorHashTN (-1)
           , txInfoDCert = []
           , txInfoWdrl = []
           , txInfoValidRange = Interval.always
@@ -153,3 +163,87 @@ _asdfa = do
         putStrLn $ show e <> " Traces: " <> show traces
       Right _v ->
         pure ()
+
+_test :: IO ()
+_test = do
+    let (res, _budget, traces) = evalScript $ compile (authorityTokensValidIn # pconstant currSymbol # (pconstant $
+                                            TxOut { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing ,
+                                                    txOutValue = Value.singleton currSymbol validatorHashTN 1,
+                                                    txOutDatumHash = Just (DatumHash "")}))
+    case res of
+      Left e -> do
+        putStrLn $ show e <> " Traces: " <> show traces
+      Right _v ->
+        pure ()
+
+_test2 :: IO()
+_test2 = do
+    let (res, _budget, traces) = evalScript $ compile (singleAuthorityTokenBurned (pconstant currSymbol) (pconstantData tinfo) (pconstant mv))
+    case res of
+      Left e -> do
+        putStrLn $ show e <> " Traces: " <> show traces
+      Right _v ->
+        putStrLn $ show res
+    where
+      mv = mempty -- Value.singleton currSymbol validatorHashTN (1)
+      tinfo =         TxInfo
+          { txInfoInputs = 
+              [ TxInInfo -- Initiator
+                  (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+                  TxOut
+                    { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                    , txOutValue = mempty
+                    , txOutDatumHash = Just (DatumHash "")
+                    }
+              , TxInInfo -- Treasury 1
+                  (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2)
+                  TxOut
+                    { txOutAddress = Address (treasuries !! 0) Nothing
+                    , txOutValue = Value.singleton gtSymbol gtToken 10
+                    , txOutDatumHash = Just (DatumHash "")
+                    }
+              , TxInInfo -- Treasury 2
+                  (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3)
+                  TxOut
+                    { txOutAddress = Address (treasuries !! 1) Nothing
+                    , txOutValue = Value.singleton "1234ab" "LQLQLQL" 10
+                    , txOutDatumHash = Just (DatumHash "")
+                    }
+              ]
+          , txInfoOutputs = 
+              [ TxOut
+                  { txOutAddress = Address (users !! 0) Nothing
+                  , txOutValue = Value.singleton gtSymbol gtToken 1
+                  , txOutDatumHash = Nothing
+                  }
+              , TxOut
+                  { txOutAddress = Address (users !! 1) Nothing
+                  , txOutValue = Value.singleton gtSymbol gtToken 1
+                  , txOutDatumHash = Nothing
+                  }
+              , TxOut
+                  { txOutAddress = Address (users !! 2) Nothing
+                  , txOutValue = Value.singleton gtSymbol gtToken 1
+                  , txOutDatumHash = Nothing
+                  }
+              -- Send left overs to treasuries
+              , TxOut
+                  { txOutAddress = Address (treasuries !! 0) Nothing
+                  , txOutValue = Value.singleton gtSymbol gtToken 7
+                  , txOutDatumHash = Nothing
+                  }
+              , TxOut
+                  { txOutAddress = Address (treasuries !! 1) Nothing
+                  , txOutValue = Value.singleton gtSymbol gtToken 10
+                  , txOutDatumHash = Nothing
+                  }                  
+              ]
+          , txInfoFee = Value.singleton "" "" 2
+          , txInfoMint = mempty -- Value.singleton currSymbol validatorHashTN (-1)
+          , txInfoDCert = []
+          , txInfoWdrl = []
+          , txInfoValidRange = Interval.always
+          , txInfoSignatories = [signer]
+          , txInfoData = []
+          , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+          }

From fe5c18969e60d0c727ffb6c970f52e17f3b6ecf9 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Wed, 20 Apr 2022 19:57:14 -0500
Subject: [PATCH 35/78] withdrawal effect that actually passes tests

---
 .../Spec/Effect/TreasuryWithdrawalEffect.hs   | 238 +++++++++---------
 agora-test/Spec/Util.hs                       |   1 -
 agora/Agora/Effect/TreasuryWithdrawal.hs      |  89 ++++---
 3 files changed, 165 insertions(+), 163 deletions(-)

diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
index 96dbc35..f3e9396 100644
--- a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
+++ b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
@@ -7,17 +7,17 @@ This module tests the Treasury Withdrawal Effect.
 -}
 module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, scriptContext1, tests) where
 
-import Plutarch.Evaluate
-import Plutarch.Builtin
 import Plutarch.Api.V1
+import Plutarch.Builtin
+import Plutarch.Evaluate
 import Plutus.V1.Ledger.Api
 import Plutus.V1.Ledger.Interval qualified as Interval
 import Plutus.V1.Ledger.Value qualified as Value
 
 import Data.ByteString.Hash
 
-import Agora.Effect.TreasuryWithdrawal
 import Agora.AuthorityToken
+import Agora.Effect.TreasuryWithdrawal
 
 import Spec.Util
 
@@ -65,9 +65,9 @@ _aa = treasuries
 datum :: TreasuryWithdrawalDatum
 datum =
   TreasuryWithdrawalDatum
-    [ (users !! 0, Value.singleton gtSymbol gtToken 1)
-    , (users !! 1, Value.singleton gtSymbol gtToken 1)
-    , (users !! 2, Value.singleton gtSymbol gtToken 1)
+    [ (users !! 0, Value.singleton "1234ab" "LQ" 1)
+    , (users !! 1, Value.singleton "1234ab" "LQ" 1)
+    , (users !! 2, Value.singleton "1234ab" "LQ" 1)
     ]
 
 -- | Effect validator instance.
@@ -83,7 +83,7 @@ scriptContext1 =
   ScriptContext
     { scriptContextTxInfo =
         TxInfo
-          { txInfoInputs = 
+          { txInfoInputs =
               [ TxInInfo -- Initiator
                   (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
                   TxOut
@@ -91,48 +91,48 @@ scriptContext1 =
                     , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST
                     , txOutDatumHash = Just (DatumHash "")
                     }
-              -- , TxInInfo -- Treasury 1
-              --     (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2)
-              --     TxOut
-              --       { txOutAddress = Address (treasuries !! 0) Nothing
-              --       , txOutValue = Value.singleton gtSymbol gtToken 10
-              --       , txOutDatumHash = Just (DatumHash "")
-              --       }
-              -- , TxInInfo -- Treasury 2
-              --     (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3)
-              --     TxOut
-              --       { txOutAddress = Address (treasuries !! 1) Nothing
-              --       , txOutValue = Value.singleton "1234ab" "LQLQLQL" 10
-              --       , txOutDatumHash = Just (DatumHash "")
-              --       }
+              , TxInInfo -- Treasury 1
+                  (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2)
+                  TxOut
+                    { txOutAddress = Address (treasuries !! 0) Nothing
+                    , txOutValue = Value.singleton "1234ab" "LQ" 10
+                    , txOutDatumHash = Just (DatumHash "")
+                    }
+              , TxInInfo -- Treasury 2
+                  (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3)
+                  TxOut
+                    { txOutAddress = Address (treasuries !! 1) Nothing
+                    , txOutValue = Value.singleton "1234ab" "LQ" 10
+                    , txOutDatumHash = Just (DatumHash "")
+                    }
               ]
-          , txInfoOutputs = 
+          , txInfoOutputs =
               [ TxOut
                   { txOutAddress = Address (users !! 0) Nothing
-                  , txOutValue = Value.singleton gtSymbol gtToken 1
+                  , txOutValue = Value.singleton "1234ab" "LQ" 1
                   , txOutDatumHash = Nothing
                   }
               , TxOut
                   { txOutAddress = Address (users !! 1) Nothing
-                  , txOutValue = Value.singleton gtSymbol gtToken 1
+                  , txOutValue = Value.singleton "1234ab" "LQ" 1
                   , txOutDatumHash = Nothing
                   }
               , TxOut
                   { txOutAddress = Address (users !! 2) Nothing
-                  , txOutValue = Value.singleton gtSymbol gtToken 1
+                  , txOutValue = Value.singleton "1234ab" "LQ" 1
                   , txOutDatumHash = Nothing
                   }
-              -- Send left overs to treasuries
-              , TxOut
+              , -- Send left overs to treasuries
+                TxOut
                   { txOutAddress = Address (treasuries !! 0) Nothing
-                  , txOutValue = Value.singleton gtSymbol gtToken 7
+                  , txOutValue = Value.singleton "1234ab" "LQ" 7
                   , txOutDatumHash = Nothing
                   }
               , TxOut
                   { txOutAddress = Address (treasuries !! 1) Nothing
-                  , txOutValue = Value.singleton gtSymbol gtToken 10
+                  , txOutValue = Value.singleton "1234ab" "LQ" 10
                   , txOutDatumHash = Nothing
-                  }                  
+                  }
               ]
           , txInfoFee = Value.singleton "" "" 2
           , txInfoMint = Value.singleton currSymbol validatorHashTN (-1)
@@ -147,103 +147,111 @@ scriptContext1 =
         Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
     }
 
-
 tests :: [TestTree]
 tests =
   [ testGroup
-    "effect"
-    [ effectFailsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1]
+      "effect"
+      [effectSucceedsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1]
   ]
 
 _asdfa :: IO ()
 _asdfa = do
-    let (res, _budget, traces) = evalScript $ compile ((treasuryWithdrawalValidator currSymbol) # pforgetData (pconstantData datum) # pforgetData (pconstantData ()) # pconstant scriptContext1)
-    case res of
-      Left e -> do
-        putStrLn $ show e <> " Traces: " <> show traces
-      Right _v ->
-        pure ()
+  let (res, _budget, traces) = evalScript $ compile ((treasuryWithdrawalValidator currSymbol) # pforgetData (pconstantData datum) # pforgetData (pconstantData ()) # pconstant scriptContext1)
+  case res of
+    Left e -> do
+      putStrLn $ show e <> " Traces: " <> show traces
+    Right _v ->
+      pure ()
 
 _test :: IO ()
 _test = do
-    let (res, _budget, traces) = evalScript $ compile (authorityTokensValidIn # pconstant currSymbol # (pconstant $
-                                            TxOut { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing ,
-                                                    txOutValue = Value.singleton currSymbol validatorHashTN 1,
-                                                    txOutDatumHash = Just (DatumHash "")}))
-    case res of
-      Left e -> do
-        putStrLn $ show e <> " Traces: " <> show traces
-      Right _v ->
-        pure ()
+  let (res, _budget, traces) =
+        evalScript $
+          compile
+            ( authorityTokensValidIn # pconstant currSymbol
+                # ( pconstant $
+                      TxOut
+                        { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                        , txOutValue = Value.singleton currSymbol validatorHashTN 1
+                        , txOutDatumHash = Just (DatumHash "")
+                        }
+                  )
+            )
+  case res of
+    Left e -> do
+      putStrLn $ show e <> " Traces: " <> show traces
+    Right _v ->
+      pure ()
 
-_test2 :: IO()
+_test2 :: IO ()
 _test2 = do
-    let (res, _budget, traces) = evalScript $ compile (singleAuthorityTokenBurned (pconstant currSymbol) (pconstantData tinfo) (pconstant mv))
-    case res of
-      Left e -> do
-        putStrLn $ show e <> " Traces: " <> show traces
-      Right _v ->
-        putStrLn $ show res
-    where
-      mv = mempty -- Value.singleton currSymbol validatorHashTN (1)
-      tinfo =         TxInfo
-          { txInfoInputs = 
-              [ TxInInfo -- Initiator
-                  (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
-                  TxOut
-                    { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
-                    , txOutValue = mempty
-                    , txOutDatumHash = Just (DatumHash "")
-                    }
-              , TxInInfo -- Treasury 1
-                  (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2)
-                  TxOut
-                    { txOutAddress = Address (treasuries !! 0) Nothing
-                    , txOutValue = Value.singleton gtSymbol gtToken 10
-                    , txOutDatumHash = Just (DatumHash "")
-                    }
-              , TxInInfo -- Treasury 2
-                  (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3)
-                  TxOut
-                    { txOutAddress = Address (treasuries !! 1) Nothing
-                    , txOutValue = Value.singleton "1234ab" "LQLQLQL" 10
-                    , txOutDatumHash = Just (DatumHash "")
-                    }
-              ]
-          , txInfoOutputs = 
-              [ TxOut
-                  { txOutAddress = Address (users !! 0) Nothing
-                  , txOutValue = Value.singleton gtSymbol gtToken 1
-                  , txOutDatumHash = Nothing
+  let (res, _budget, traces) = evalScript $ compile (singleAuthorityTokenBurned (pconstant currSymbol) (pconstantData tinfo) (pconstant mv))
+  case res of
+    Left e -> do
+      putStrLn $ show e <> " Traces: " <> show traces
+    Right _v ->
+      putStrLn $ show res
+  where
+    mv = mempty -- Value.singleton currSymbol validatorHashTN (1)
+    tinfo =
+      TxInfo
+        { txInfoInputs =
+            [ TxInInfo -- Initiator
+                (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+                TxOut
+                  { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                  , txOutValue = mempty
+                  , txOutDatumHash = Just (DatumHash "")
                   }
-              , TxOut
-                  { txOutAddress = Address (users !! 1) Nothing
-                  , txOutValue = Value.singleton gtSymbol gtToken 1
-                  , txOutDatumHash = Nothing
-                  }
-              , TxOut
-                  { txOutAddress = Address (users !! 2) Nothing
-                  , txOutValue = Value.singleton gtSymbol gtToken 1
-                  , txOutDatumHash = Nothing
-                  }
-              -- Send left overs to treasuries
-              , TxOut
+            , TxInInfo -- Treasury 1
+                (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2)
+                TxOut
                   { txOutAddress = Address (treasuries !! 0) Nothing
-                  , txOutValue = Value.singleton gtSymbol gtToken 7
-                  , txOutDatumHash = Nothing
-                  }
-              , TxOut
-                  { txOutAddress = Address (treasuries !! 1) Nothing
                   , txOutValue = Value.singleton gtSymbol gtToken 10
-                  , txOutDatumHash = Nothing
-                  }                  
-              ]
-          , txInfoFee = Value.singleton "" "" 2
-          , txInfoMint = mempty -- Value.singleton currSymbol validatorHashTN (-1)
-          , txInfoDCert = []
-          , txInfoWdrl = []
-          , txInfoValidRange = Interval.always
-          , txInfoSignatories = [signer]
-          , txInfoData = []
-          , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
-          }
+                  , txOutDatumHash = Just (DatumHash "")
+                  }
+            , TxInInfo -- Treasury 2
+                (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3)
+                TxOut
+                  { txOutAddress = Address (treasuries !! 1) Nothing
+                  , txOutValue = Value.singleton "1234ab" "LQLQLQL" 10
+                  , txOutDatumHash = Just (DatumHash "")
+                  }
+            ]
+        , txInfoOutputs =
+            [ TxOut
+                { txOutAddress = Address (users !! 0) Nothing
+                , txOutValue = Value.singleton gtSymbol gtToken 1
+                , txOutDatumHash = Nothing
+                }
+            , TxOut
+                { txOutAddress = Address (users !! 1) Nothing
+                , txOutValue = Value.singleton gtSymbol gtToken 1
+                , txOutDatumHash = Nothing
+                }
+            , TxOut
+                { txOutAddress = Address (users !! 2) Nothing
+                , txOutValue = Value.singleton gtSymbol gtToken 1
+                , txOutDatumHash = Nothing
+                }
+            , -- Send left overs to treasuries
+              TxOut
+                { txOutAddress = Address (treasuries !! 0) Nothing
+                , txOutValue = Value.singleton gtSymbol gtToken 7
+                , txOutDatumHash = Nothing
+                }
+            , TxOut
+                { txOutAddress = Address (treasuries !! 1) Nothing
+                , txOutValue = Value.singleton gtSymbol gtToken 10
+                , txOutDatumHash = Nothing
+                }
+            ]
+        , txInfoFee = Value.singleton "" "" 2
+        , txInfoMint = mempty -- Value.singleton currSymbol validatorHashTN (-1)
+        , txInfoDCert = []
+        , txInfoWdrl = []
+        , txInfoValidRange = Interval.always
+        , txInfoSignatories = [signer]
+        , txInfoData = []
+        , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+        }
diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs
index 1ebdc07..32fa1b1 100644
--- a/agora-test/Spec/Util.hs
+++ b/agora-test/Spec/Util.hs
@@ -131,7 +131,6 @@ validatorFailsWith tag policy datum redeemer scriptContext =
           # pconstant scriptContext
       )
 
-
 -- | Check that a validator script succeeds, given a name and arguments.
 effectSucceedsWith ::
   ( PLift datum
diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 1156a3c..ddf3f32 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -22,8 +22,6 @@ import Plutarch (popaque)
 import Plutarch.Api.V1 (
   PCredential,
   PTuple,
-  PTxInInfo (PTxInInfo),
-  PTxOut (PTxOut),
   PValidator,
   PValue,
   ptuple,
@@ -92,58 +90,55 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
     let outputValues =
           pmap
             # plam
-              ( \out' -> P.do
-                  out <- pletFields @'["address", "value"] $ pfromData out'
+              ( \(pfromData -> out') -> P.do
+                  out <- pletFields @'["address", "value"] $ out'
                   cred <- pletFields @'["credential"] $ pfromData out.address
                   pdata $ ptuple # cred.credential # out.value
               )
             # txInfo.outputs
+        inputValues =
+          pmap
+            # plam
+              ( \((pfield @"resolved" #) . pfromData -> txOut') -> P.do
+                  txOut <- pletFields @'["address", "value"] $ txOut'
+                  pdata $ ptuple # txOut.address # txOut.value
+              )
+            # txInfo.inputs
+        treasuryInputValues =
+          pfilter
+            # plam (\((pfield @"_0" #) . pfromData -> addr) -> pnot #$ addr #== effInput.address)
+            # inputValues
+        treasuryCredentials =
+          pmap
+            # plam ((pfield @"credential" #) . pfromData . (pfield @"_0" #) . pfromData)
+            # treasuryInputValues
+        treasuryOutputValues =
+          pfilter
+            # plam
+              ( \((pfield @"_0" #) . pfromData -> addr) -> P.do
+                  pelem # addr # treasuryCredentials
+              )
+            # outputValues
+        treasuryInputValuesSum =
+          pfoldr
+            # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
+            # pconstant (mempty :: Value)
+            # treasuryInputValues
+        treasuryOutputValuesSum =
+          pfoldr
+            # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
+            # pconstant (mempty :: Value)
+            # treasuryOutputValues
+        receiverValuesSum =
+          pfoldr
+            # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
+            # pconstant (mempty :: Value)
+            # receivers
         outputContentMatchesRecivers =
           pall # plam (\out -> pelem # out # outputValues)
             #$ receivers
-        sumValues =
-          pfoldr
-            # plam
-              ( \((pfield @"_1" #) . pfromData -> x) y -> P.do
-                  paddValue # pfromData x # y
-              )
-            # pconstant (mempty :: Value)
-        inputCred =
-          pmap
-            # plam
-              ( \inInfo -> P.do
-                  PTxInInfo inInfo' <- pmatch $ pfromData inInfo
-                  PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # inInfo'
-                  let addr = pfromData $ pfield @"address" # out
-                  pfield @"credential" # addr
-              )
-            # pfromData txInfo.inputs
-        totalTreasuryInputs =
-          pfoldr
-            # plam
-              ( \x' y -> P.do
-                  PTxInInfo x <- pmatch $ pfromData x'
-                  PTxOut out <- pmatch $ pfromData $ pfield @"resolved" # x
-                  -- only take ones from treasury
-                  pif
-                    (effInput.address #== pfield @"address" # out)
-                    (paddValue # pfromData (pfield @"value" # out) # y)
-                    y
-              )
-            # pconstant (mempty :: Value)
-            # pfromData txInfo.inputs
-        sumOutputsToTreasury =
-          sumValues
-            #$ pfilter
-            # plam
-              ( \((pfield @"_0" #) . pfromData -> addr) ->
-                  pelem # addr # inputCred
-                    #&& pnot # (addr #== pfield @"credential" # effInput.address)
-              )
-            # outputValues
-        -- TODO: Probably need to check/exclude the effect input...
         excessShouldBePaidToInputs =
-          pdata (paddValue # (sumValues # receivers) # sumOutputsToTreasury) #== pdata totalTreasuryInputs
+          pdata (paddValue # receiverValuesSum # treasuryOutputValuesSum) #== pdata treasuryInputValuesSum
         shouldNotPayToEffect =
           pnot #$ pany
             # plam
@@ -154,5 +149,5 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
 
     passert "Transaction output does not match receivers" outputContentMatchesRecivers
     passert "Transaction should not pay to effects" shouldNotPayToEffect
-    passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs -- We might not need this.
+    passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs
     popaque $ pconstant ()

From 82dd53efcf8ff3fcc4a82c5b636ae16f4ca9ac6b Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Thu, 21 Apr 2022 16:44:59 -0500
Subject: [PATCH 36/78] Restructured Testings

Separated the samples and test sets
---
 agora-test/Spec.hs                            |   7 +
 agora-test/Spec/Effect/TreasuryWithdrawal.hs  |  24 ++
 .../Spec/Effect/TreasuryWithdrawalEffect.hs   | 257 ------------------
 .../Spec/Sample/Effect/TreasuryWithdrawal.hs  | 132 +++++++++
 agora.cabal                                   |   3 +-
 5 files changed, 165 insertions(+), 258 deletions(-)
 create mode 100644 agora-test/Spec/Effect/TreasuryWithdrawal.hs
 delete mode 100644 agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
 create mode 100644 agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs

diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs
index 2f443cd..02394bc 100644
--- a/agora-test/Spec.hs
+++ b/agora-test/Spec.hs
@@ -8,6 +8,7 @@ import Test.Tasty (defaultMain, testGroup)
 
 --------------------------------------------------------------------------------
 
+import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal
 import Spec.AuthorityToken qualified as AuthorityToken
 import Spec.Model.MultiSig qualified as MultiSig
 import Spec.Stake qualified as Stake
@@ -19,6 +20,12 @@ main =
     testGroup
       "test suite"
       [ testGroup
+          "Effects"
+          [ testGroup
+              "Treasury Withdrawal Effect"
+              TreasuryWithdrawal.tests
+          ]
+      , testGroup
           "Stake tests"
           Stake.tests
       , testGroup
diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs
new file mode 100644
index 0000000..77ceb92
--- /dev/null
+++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs
@@ -0,0 +1,24 @@
+{- |
+Module     : Spec.Effect.TreasuryWithdrawalEffect
+Maintainer : seungheon.ooh@gmail.com
+Description: Sample based testing for Treasury Withdrawal Effect
+
+This module tests the Treasury Withdrawal Effect.
+-}
+module Spec.Effect.TreasuryWithdrawal (currSymbol, signer, validator, validatorHashTN, scriptContext1, tests) where
+
+import Spec.Sample.Effect.TreasuryWithdrawal
+
+
+import Agora.Effect.TreasuryWithdrawal
+
+import Spec.Util
+
+import Test.Tasty
+
+tests :: [TestTree]
+tests =
+  [ testGroup
+      "effect"
+      [effectSucceedsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1]
+  ]
diff --git a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs b/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
deleted file mode 100644
index f3e9396..0000000
--- a/agora-test/Spec/Effect/TreasuryWithdrawalEffect.hs
+++ /dev/null
@@ -1,257 +0,0 @@
-{- |
-Module     : Spec.Effect.TreasuryWithdrawalEffect
-Maintainer : seungheon.ooh@gmail.com
-Description: Sample based testing for Treasury Withdrawal Effect
-
-This module tests the Treasury Withdrawal Effect.
--}
-module Spec.Effect.TreasuryWithdrawalEffect (currSymbol, signer, validator, validatorHashTN, scriptContext1, tests) where
-
-import Plutarch.Api.V1
-import Plutarch.Builtin
-import Plutarch.Evaluate
-import Plutus.V1.Ledger.Api
-import Plutus.V1.Ledger.Interval qualified as Interval
-import Plutus.V1.Ledger.Value qualified as Value
-
-import Data.ByteString.Hash
-
-import Agora.AuthorityToken
-import Agora.Effect.TreasuryWithdrawal
-
-import Spec.Util
-
-import Test.Tasty
-
--- receiverList :: TreasuryWithdrawalDatum
--- receiverList = TreasuryWithdrawalDatum [(mempty, mempty)]
-
--- | A sample Currency Symbol.
-currSymbol :: CurrencySymbol
-currSymbol = CurrencySymbol "12312099"
-
-gtSymbol :: CurrencySymbol
-gtSymbol = CurrencySymbol "abb"
-
-gtToken :: TokenName
-gtToken = TokenName "hey"
-
--- | A sample 'PubKeyHash'.
-signer :: PubKeyHash
-signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
-
--- | List of users who the effect will pay to.
-users :: [Credential]
-users =
-  PubKeyCredential . PubKeyHash . toBuiltin . sha2
-    <$> [ "Orange"
-        , "Bottle"
-        , "Hello"
-        ]
-
--- | List of users who the effect will pay to.
-treasuries :: [Credential]
-treasuries =
-  ScriptCredential . ValidatorHash . toBuiltin . sha2
-    <$> [ "1234"
-        , "qwer"
-        , "asdf"
-        ]
-
-_aa :: [Credential]
-_aa = treasuries
-
--- | Datum for Treasury Withdrawal Effect Validator.
-datum :: TreasuryWithdrawalDatum
-datum =
-  TreasuryWithdrawalDatum
-    [ (users !! 0, Value.singleton "1234ab" "LQ" 1)
-    , (users !! 1, Value.singleton "1234ab" "LQ" 1)
-    , (users !! 2, Value.singleton "1234ab" "LQ" 1)
-    ]
-
--- | Effect validator instance.
-validator :: Validator
-validator = mkValidator $ treasuryWithdrawalValidator currSymbol
-
--- | 'TokenName' that represents the hash of the 'Stake' validator.
-validatorHashTN :: TokenName
-validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
-
-scriptContext1 :: ScriptContext
-scriptContext1 =
-  ScriptContext
-    { scriptContextTxInfo =
-        TxInfo
-          { txInfoInputs =
-              [ TxInInfo -- Initiator
-                  (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
-                  TxOut
-                    { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
-                    , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST
-                    , txOutDatumHash = Just (DatumHash "")
-                    }
-              , TxInInfo -- Treasury 1
-                  (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2)
-                  TxOut
-                    { txOutAddress = Address (treasuries !! 0) Nothing
-                    , txOutValue = Value.singleton "1234ab" "LQ" 10
-                    , txOutDatumHash = Just (DatumHash "")
-                    }
-              , TxInInfo -- Treasury 2
-                  (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3)
-                  TxOut
-                    { txOutAddress = Address (treasuries !! 1) Nothing
-                    , txOutValue = Value.singleton "1234ab" "LQ" 10
-                    , txOutDatumHash = Just (DatumHash "")
-                    }
-              ]
-          , txInfoOutputs =
-              [ TxOut
-                  { txOutAddress = Address (users !! 0) Nothing
-                  , txOutValue = Value.singleton "1234ab" "LQ" 1
-                  , txOutDatumHash = Nothing
-                  }
-              , TxOut
-                  { txOutAddress = Address (users !! 1) Nothing
-                  , txOutValue = Value.singleton "1234ab" "LQ" 1
-                  , txOutDatumHash = Nothing
-                  }
-              , TxOut
-                  { txOutAddress = Address (users !! 2) Nothing
-                  , txOutValue = Value.singleton "1234ab" "LQ" 1
-                  , txOutDatumHash = Nothing
-                  }
-              , -- Send left overs to treasuries
-                TxOut
-                  { txOutAddress = Address (treasuries !! 0) Nothing
-                  , txOutValue = Value.singleton "1234ab" "LQ" 7
-                  , txOutDatumHash = Nothing
-                  }
-              , TxOut
-                  { txOutAddress = Address (treasuries !! 1) Nothing
-                  , txOutValue = Value.singleton "1234ab" "LQ" 10
-                  , txOutDatumHash = Nothing
-                  }
-              ]
-          , 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)
-    }
-
-tests :: [TestTree]
-tests =
-  [ testGroup
-      "effect"
-      [effectSucceedsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1]
-  ]
-
-_asdfa :: IO ()
-_asdfa = do
-  let (res, _budget, traces) = evalScript $ compile ((treasuryWithdrawalValidator currSymbol) # pforgetData (pconstantData datum) # pforgetData (pconstantData ()) # pconstant scriptContext1)
-  case res of
-    Left e -> do
-      putStrLn $ show e <> " Traces: " <> show traces
-    Right _v ->
-      pure ()
-
-_test :: IO ()
-_test = do
-  let (res, _budget, traces) =
-        evalScript $
-          compile
-            ( authorityTokensValidIn # pconstant currSymbol
-                # ( pconstant $
-                      TxOut
-                        { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
-                        , txOutValue = Value.singleton currSymbol validatorHashTN 1
-                        , txOutDatumHash = Just (DatumHash "")
-                        }
-                  )
-            )
-  case res of
-    Left e -> do
-      putStrLn $ show e <> " Traces: " <> show traces
-    Right _v ->
-      pure ()
-
-_test2 :: IO ()
-_test2 = do
-  let (res, _budget, traces) = evalScript $ compile (singleAuthorityTokenBurned (pconstant currSymbol) (pconstantData tinfo) (pconstant mv))
-  case res of
-    Left e -> do
-      putStrLn $ show e <> " Traces: " <> show traces
-    Right _v ->
-      putStrLn $ show res
-  where
-    mv = mempty -- Value.singleton currSymbol validatorHashTN (1)
-    tinfo =
-      TxInfo
-        { txInfoInputs =
-            [ TxInInfo -- Initiator
-                (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
-                TxOut
-                  { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
-                  , txOutValue = mempty
-                  , txOutDatumHash = Just (DatumHash "")
-                  }
-            , TxInInfo -- Treasury 1
-                (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2)
-                TxOut
-                  { txOutAddress = Address (treasuries !! 0) Nothing
-                  , txOutValue = Value.singleton gtSymbol gtToken 10
-                  , txOutDatumHash = Just (DatumHash "")
-                  }
-            , TxInInfo -- Treasury 2
-                (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3)
-                TxOut
-                  { txOutAddress = Address (treasuries !! 1) Nothing
-                  , txOutValue = Value.singleton "1234ab" "LQLQLQL" 10
-                  , txOutDatumHash = Just (DatumHash "")
-                  }
-            ]
-        , txInfoOutputs =
-            [ TxOut
-                { txOutAddress = Address (users !! 0) Nothing
-                , txOutValue = Value.singleton gtSymbol gtToken 1
-                , txOutDatumHash = Nothing
-                }
-            , TxOut
-                { txOutAddress = Address (users !! 1) Nothing
-                , txOutValue = Value.singleton gtSymbol gtToken 1
-                , txOutDatumHash = Nothing
-                }
-            , TxOut
-                { txOutAddress = Address (users !! 2) Nothing
-                , txOutValue = Value.singleton gtSymbol gtToken 1
-                , txOutDatumHash = Nothing
-                }
-            , -- Send left overs to treasuries
-              TxOut
-                { txOutAddress = Address (treasuries !! 0) Nothing
-                , txOutValue = Value.singleton gtSymbol gtToken 7
-                , txOutDatumHash = Nothing
-                }
-            , TxOut
-                { txOutAddress = Address (treasuries !! 1) Nothing
-                , txOutValue = Value.singleton gtSymbol gtToken 10
-                , txOutDatumHash = Nothing
-                }
-            ]
-        , txInfoFee = Value.singleton "" "" 2
-        , txInfoMint = mempty -- Value.singleton currSymbol validatorHashTN (-1)
-        , txInfoDCert = []
-        , txInfoWdrl = []
-        , txInfoValidRange = Interval.always
-        , txInfoSignatories = [signer]
-        , txInfoData = []
-        , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
-        }
diff --git a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
new file mode 100644
index 0000000..0f5d5a1
--- /dev/null
+++ b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
@@ -0,0 +1,132 @@
+{- |
+Module     : Spec.Sample.Effect.TreasuryWithdrawalEffect
+Maintainer : seungheon.ooh@gmail.com
+Description: Sample based testing for Treasury Withdrawal Effect
+
+This module provides smaples for Treasury Withdrawal Effect tests.
+-}
+module Spec.Sample.Effect.TreasuryWithdrawal (datum, currSymbol, signer, validator, validatorHashTN, scriptContext1) where
+
+import Plutarch.Api.V1
+import Plutus.V1.Ledger.Api
+import Plutus.V1.Ledger.Interval qualified as Interval
+import Plutus.V1.Ledger.Value qualified as Value
+
+import Data.ByteString.Hash
+
+import Agora.Effect.TreasuryWithdrawal
+
+-- | A sample Currency Symbol.
+currSymbol :: CurrencySymbol
+currSymbol = CurrencySymbol "12312099"
+
+-- | A sample 'PubKeyHash'.
+signer :: PubKeyHash
+signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
+
+-- | List of users who the effect will pay to.
+users :: [Credential]
+users =
+  PubKeyCredential . PubKeyHash . toBuiltin . sha2
+    <$> [ "Orange"
+        , "Bottle"
+        , "Hello"
+        ]
+
+-- | List of users who the effect will pay to.
+treasuries :: [Credential]
+treasuries =
+  ScriptCredential . ValidatorHash . toBuiltin . sha2
+    <$> [ "1234"
+        , "qwer"
+        , "asdf"
+        ]
+
+_aa :: [Credential]
+_aa = treasuries
+
+-- | Datum for Treasury Withdrawal Effect Validator.
+datum :: TreasuryWithdrawalDatum
+datum =
+  TreasuryWithdrawalDatum
+    [ (users !! 0, Value.singleton "1234ab" "LQ" 1)
+    , (users !! 1, Value.singleton "1234ab" "LQ" 1)
+    , (users !! 2, Value.singleton "1234ab" "LQ" 1)
+    ]
+
+-- | Effect validator instance.
+validator :: Validator
+validator = mkValidator $ treasuryWithdrawalValidator currSymbol
+
+-- | 'TokenName' that represents the hash of the 'Stake' validator.
+validatorHashTN :: TokenName
+validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
+
+scriptContext1 :: ScriptContext
+scriptContext1 =
+  ScriptContext
+    { scriptContextTxInfo =
+        TxInfo
+          { txInfoInputs =
+              [ TxInInfo -- Initiator
+                  (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+                  TxOut
+                    { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                    , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST
+                    , txOutDatumHash = Just (DatumHash "")
+                    }
+              , TxInInfo -- Treasury 1
+                  (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2)
+                  TxOut
+                    { txOutAddress = Address (treasuries !! 0) Nothing
+                    , txOutValue = Value.singleton "1234ab" "LQ" 10
+                    , txOutDatumHash = Just (DatumHash "")
+                    }
+              , TxInInfo -- Treasury 2
+                  (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3)
+                  TxOut
+                    { txOutAddress = Address (treasuries !! 1) Nothing
+                    , txOutValue = Value.singleton "1234ab" "LQ" 10
+                    , txOutDatumHash = Just (DatumHash "")
+                    }
+              ]
+          , txInfoOutputs =
+              [ TxOut
+                  { txOutAddress = Address (users !! 0) Nothing
+                  , txOutValue = Value.singleton "1234ab" "LQ" 1
+                  , txOutDatumHash = Nothing
+                  }
+              , TxOut
+                  { txOutAddress = Address (users !! 1) Nothing
+                  , txOutValue = Value.singleton "1234ab" "LQ" 1
+                  , txOutDatumHash = Nothing
+                  }
+              , TxOut
+                  { txOutAddress = Address (users !! 2) Nothing
+                  , txOutValue = Value.singleton "1234ab" "LQ" 1
+                  , txOutDatumHash = Nothing
+                  }
+              , -- Send left overs to treasuries
+                TxOut
+                  { txOutAddress = Address (treasuries !! 0) Nothing
+                  , txOutValue = Value.singleton "1234ab" "LQ" 7
+                  , txOutDatumHash = Nothing
+                  }
+              , TxOut
+                  { txOutAddress = Address (treasuries !! 1) Nothing
+                  , txOutValue = Value.singleton "1234ab" "LQ" 10
+                  , txOutDatumHash = Nothing
+                  }
+              ]
+          , 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)
+    }
diff --git a/agora.cabal b/agora.cabal
index 3f47333..0ace2a8 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -152,7 +152,8 @@ test-suite agora-test
   main-is:        Spec.hs
   hs-source-dirs: agora-test
   other-modules:
-    Spec.Effect.TreasuryWithdrawalEffect
+    Spec.Effect.TreasuryWithdrawal
+    Spec.Sample.Effect.TreasuryWithdrawal
     Spec.Model.MultiSig
     Spec.Sample.Stake
     Spec.Stake

From 7f6ccc0dee15046ac642282d14ffec4d304caacf Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Thu, 21 Apr 2022 19:02:10 -0500
Subject: [PATCH 37/78] Yeah! Treasury Withdrawal Effect works with good tests

---
 agora-test/Spec.hs                            |   2 +-
 agora-test/Spec/Effect/TreasuryWithdrawal.hs  | 111 ++++++++++-
 .../Spec/Sample/Effect/TreasuryWithdrawal.hs  | 178 ++++++++++--------
 3 files changed, 203 insertions(+), 88 deletions(-)

diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs
index 02394bc..40a7b7f 100644
--- a/agora-test/Spec.hs
+++ b/agora-test/Spec.hs
@@ -8,8 +8,8 @@ import Test.Tasty (defaultMain, testGroup)
 
 --------------------------------------------------------------------------------
 
-import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal
 import Spec.AuthorityToken qualified as AuthorityToken
+import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal
 import Spec.Model.MultiSig qualified as MultiSig
 import Spec.Stake qualified as Stake
 
diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs
index 77ceb92..09bf1dc 100644
--- a/agora-test/Spec/Effect/TreasuryWithdrawal.hs
+++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs
@@ -5,20 +5,117 @@ Description: Sample based testing for Treasury Withdrawal Effect
 
 This module tests the Treasury Withdrawal Effect.
 -}
-module Spec.Effect.TreasuryWithdrawal (currSymbol, signer, validator, validatorHashTN, scriptContext1, tests) where
+module Spec.Effect.TreasuryWithdrawal (tests) where
 
-import Spec.Sample.Effect.TreasuryWithdrawal
+import Spec.Sample.Effect.TreasuryWithdrawal (
+  buildReceiversOutputFromDatum,
+  buildScriptContext,
+  currSymbol,
+  inputGAT,
+  inputTreasury,
+  outputTreasury,
+  outputUser,
+  users,
+ )
 
+import Agora.Effect.TreasuryWithdrawal (
+  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
+  treasuryWithdrawalValidator,
+ )
 
-import Agora.Effect.TreasuryWithdrawal
+import Plutus.V1.Ledger.Value qualified as Value
+import Spec.Util (effectFailsWith, effectSucceedsWith)
 
-import Spec.Util
-
-import Test.Tasty
+import Test.Tasty (TestTree, testGroup)
 
 tests :: [TestTree]
 tests =
   [ testGroup
       "effect"
-      [effectSucceedsWith "test1" (treasuryWithdrawalValidator currSymbol) datum scriptContext1]
+      [ effectSucceedsWith
+          "Simple"
+          (treasuryWithdrawalValidator currSymbol)
+          datum1
+          ( buildScriptContext
+              [ inputGAT
+              , inputTreasury 1 (asset1 10)
+              ]
+              $ outputTreasury 1 (asset1 7) :
+              buildReceiversOutputFromDatum datum1
+          )
+      , effectSucceedsWith
+          "Simple with multiple treasuries "
+          (treasuryWithdrawalValidator currSymbol)
+          datum1
+          ( buildScriptContext
+              [ inputGAT
+              , 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"
+          (treasuryWithdrawalValidator currSymbol)
+          datum2
+          ( buildScriptContext
+              [ inputGAT
+              , inputTreasury 1 (asset1 20)
+              , inputTreasury 2 (asset2 20)
+              ]
+              $ [ outputTreasury 1 (asset1 13)
+                , outputTreasury 2 (asset2 14)
+                ]
+                ++ buildReceiversOutputFromDatum datum2
+          )
+      , effectFailsWith
+          "Pay to uknown 3rd party"
+          (treasuryWithdrawalValidator currSymbol)
+          datum2
+          ( buildScriptContext
+              [ inputGAT
+              , 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"
+          (treasuryWithdrawalValidator currSymbol)
+          datum2
+          ( buildScriptContext
+              [ inputGAT
+              , inputTreasury 1 (asset1 20)
+              , inputTreasury 2 (asset2 20)
+              ]
+              $ [ outputTreasury 1 (asset1 13)
+                , outputTreasury 2 (asset2 14)
+                ]
+                ++ drop 1 (buildReceiversOutputFromDatum datum2)
+          )
+      ]
   ]
+  where
+    asset1 = Value.singleton "abbc12" "OrangeBottle"
+    asset2 = Value.singleton "abbc12" "19721121"
+    datum1 =
+      TreasuryWithdrawalDatum
+        [ (head users, asset1 1)
+        , (users !! 1, asset1 1)
+        , (users !! 2, asset1 1)
+        ]
+    datum2 =
+      TreasuryWithdrawalDatum
+        [ (head users, asset1 4 <> asset2 5)
+        , (users !! 1, asset1 2 <> asset2 1)
+        , (users !! 2, asset1 1)
+        ]
diff --git a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
index 0f5d5a1..c228dc5 100644
--- a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
+++ b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
@@ -5,16 +5,59 @@ Description: Sample based testing for Treasury Withdrawal Effect
 
 This module provides smaples for Treasury Withdrawal Effect tests.
 -}
-module Spec.Sample.Effect.TreasuryWithdrawal (datum, currSymbol, signer, validator, validatorHashTN, scriptContext1) where
+module Spec.Sample.Effect.TreasuryWithdrawal (
+  inputTreasury,
+  inputGAT,
+  outputTreasury,
+  outputUser,
+  buildReceiversOutputFromDatum,
+  currSymbol,
+  users,
+  treasuries,
+  buildScriptContext,
+) where
 
-import Plutarch.Api.V1
-import Plutus.V1.Ledger.Api
+import Plutarch.Api.V1 (mkValidator, validatorHash)
+import Plutus.V1.Ledger.Api (
+  Address (Address),
+  Credential (..),
+  CurrencySymbol (CurrencySymbol),
+  DatumHash (DatumHash),
+  PubKeyHash (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,
+  toBuiltin,
+ )
 import Plutus.V1.Ledger.Interval qualified as Interval
 import Plutus.V1.Ledger.Value qualified as Value
 
-import Data.ByteString.Hash
+import Data.ByteString.Char8 qualified as C
+import Data.ByteString.Hash (sha2)
 
-import Agora.Effect.TreasuryWithdrawal
+import Agora.Effect.TreasuryWithdrawal (
+  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
+  treasuryWithdrawalValidator,
+ )
 
 -- | A sample Currency Symbol.
 currSymbol :: CurrencySymbol
@@ -26,33 +69,57 @@ signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
 
 -- | List of users who the effect will pay to.
 users :: [Credential]
-users =
-  PubKeyCredential . PubKeyHash . toBuiltin . sha2
-    <$> [ "Orange"
-        , "Bottle"
-        , "Hello"
-        ]
+users = PubKeyCredential . PubKeyHash . toBuiltin . sha2 . C.pack . show <$> ([1 ..] :: [Integer])
 
 -- | List of users who the effect will pay to.
 treasuries :: [Credential]
-treasuries =
-  ScriptCredential . ValidatorHash . toBuiltin . sha2
-    <$> [ "1234"
-        , "qwer"
-        , "asdf"
-        ]
+treasuries = ScriptCredential . ValidatorHash . toBuiltin . sha2 . C.pack . show <$> ([1 ..] :: [Integer])
 
-_aa :: [Credential]
-_aa = treasuries
+inputGAT :: TxInInfo
+inputGAT =
+  TxInInfo -- Initiator
+    (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+    TxOut
+      { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+      , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST
+      , txOutDatumHash = Just (DatumHash "")
+      }
 
--- | Datum for Treasury Withdrawal Effect Validator.
-datum :: TreasuryWithdrawalDatum
-datum =
-  TreasuryWithdrawalDatum
-    [ (users !! 0, Value.singleton "1234ab" "LQ" 1)
-    , (users !! 1, Value.singleton "1234ab" "LQ" 1)
-    , (users !! 2, Value.singleton "1234ab" "LQ" 1)
-    ]
+inputTreasury :: Int -> Value -> TxInInfo
+inputTreasury indx val =
+  TxInInfo -- Initiator
+    (TxOutRef "" 1)
+    TxOut
+      { txOutAddress = Address (treasuries !! indx) Nothing
+      , txOutValue = val
+      , txOutDatumHash = Just (DatumHash "")
+      }
+
+outputTreasury :: Int -> Value -> TxOut
+outputTreasury indx val =
+  TxOut
+    { txOutAddress = Address (treasuries !! indx) Nothing
+    , txOutValue = val
+    , txOutDatumHash = Nothing
+    }
+
+outputUser :: Int -> Value -> TxOut
+outputUser indx val =
+  TxOut
+    { txOutAddress = Address (users !! indx) Nothing
+    , txOutValue = val
+    , txOutDatumHash = Nothing
+    }
+
+buildReceiversOutputFromDatum :: TreasuryWithdrawalDatum -> [TxOut]
+buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs) = f <$> xs
+  where
+    f x =
+      TxOut
+        { txOutAddress = Address (fst x) Nothing
+        , txOutValue = snd x
+        , txOutDatumHash = Nothing
+        }
 
 -- | Effect validator instance.
 validator :: Validator
@@ -62,62 +129,13 @@ validator = mkValidator $ treasuryWithdrawalValidator currSymbol
 validatorHashTN :: TokenName
 validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
 
-scriptContext1 :: ScriptContext
-scriptContext1 =
+buildScriptContext :: [TxInInfo] -> [TxOut] -> ScriptContext
+buildScriptContext inputs outputs =
   ScriptContext
     { scriptContextTxInfo =
         TxInfo
-          { txInfoInputs =
-              [ TxInInfo -- Initiator
-                  (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
-                  TxOut
-                    { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
-                    , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST
-                    , txOutDatumHash = Just (DatumHash "")
-                    }
-              , TxInInfo -- Treasury 1
-                  (TxOutRef "0b121212121212121212121212121212121212121212121212121221" 2)
-                  TxOut
-                    { txOutAddress = Address (treasuries !! 0) Nothing
-                    , txOutValue = Value.singleton "1234ab" "LQ" 10
-                    , txOutDatumHash = Just (DatumHash "")
-                    }
-              , TxInInfo -- Treasury 2
-                  (TxOutRef "0b121212121212121212a41212121212121212121212121212121221" 3)
-                  TxOut
-                    { txOutAddress = Address (treasuries !! 1) Nothing
-                    , txOutValue = Value.singleton "1234ab" "LQ" 10
-                    , txOutDatumHash = Just (DatumHash "")
-                    }
-              ]
-          , txInfoOutputs =
-              [ TxOut
-                  { txOutAddress = Address (users !! 0) Nothing
-                  , txOutValue = Value.singleton "1234ab" "LQ" 1
-                  , txOutDatumHash = Nothing
-                  }
-              , TxOut
-                  { txOutAddress = Address (users !! 1) Nothing
-                  , txOutValue = Value.singleton "1234ab" "LQ" 1
-                  , txOutDatumHash = Nothing
-                  }
-              , TxOut
-                  { txOutAddress = Address (users !! 2) Nothing
-                  , txOutValue = Value.singleton "1234ab" "LQ" 1
-                  , txOutDatumHash = Nothing
-                  }
-              , -- Send left overs to treasuries
-                TxOut
-                  { txOutAddress = Address (treasuries !! 0) Nothing
-                  , txOutValue = Value.singleton "1234ab" "LQ" 7
-                  , txOutDatumHash = Nothing
-                  }
-              , TxOut
-                  { txOutAddress = Address (treasuries !! 1) Nothing
-                  , txOutValue = Value.singleton "1234ab" "LQ" 10
-                  , txOutDatumHash = Nothing
-                  }
-              ]
+          { txInfoInputs = inputs
+          , txInfoOutputs = outputs
           , txInfoFee = Value.singleton "" "" 2
           , txInfoMint = Value.singleton currSymbol validatorHashTN (-1)
           , txInfoDCert = []

From 9866845f04135053be2e4da9ebc9c216d22bf7d9 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Thu, 21 Apr 2022 19:03:14 -0500
Subject: [PATCH 38/78] formatting

---
 agora.cabal |  4 ++--
 flake.nix   | 56 ++++++++++++++++++++++++++++++-----------------------
 2 files changed, 34 insertions(+), 26 deletions(-)

diff --git a/agora.cabal b/agora.cabal
index 0ace2a8..baa6b5c 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -152,13 +152,13 @@ test-suite agora-test
   main-is:        Spec.hs
   hs-source-dirs: agora-test
   other-modules:
+    Spec.AuthorityToken
     Spec.Effect.TreasuryWithdrawal
-    Spec.Sample.Effect.TreasuryWithdrawal
     Spec.Model.MultiSig
+    Spec.Sample.Effect.TreasuryWithdrawal
     Spec.Sample.Stake
     Spec.Stake
     Spec.Util
-    Spec.AuthorityToken
 
   build-depends:  agora
 
diff --git a/flake.nix b/flake.nix
index c6522d6..3b1756a 100644
--- a/flake.nix
+++ b/flake.nix
@@ -50,8 +50,10 @@
 
       projectFor = system:
         let pkgs = nixpkgsFor system;
-        in let pkgs' = nixpkgsFor' system;
-        in (nixpkgsFor system).haskell-nix.cabalProject' {
+        in
+        let pkgs' = nixpkgsFor' system;
+        in
+        (nixpkgsFor system).haskell-nix.cabalProject' {
           src = ./.;
           compiler-nix-name = ghcVersion;
           inherit (plutarch) cabalProjectLocal;
@@ -120,16 +122,18 @@
             inherit (plutarch.tools) fourmolu;
           })
             fourmolu;
-        in pkgs.runCommand "format-check" {
-          nativeBuildInputs = [
-            pkgs'.git
-            pkgs'.fd
-            pkgs'.haskellPackages.cabal-fmt
-            pkgs'.nixpkgs-fmt
-            fourmolu
-            pkgs'.haskell.packages."${ghcVersion}".hlint
-          ];
-        } ''
+        in
+        pkgs.runCommand "format-check"
+          {
+            nativeBuildInputs = [
+              pkgs'.git
+              pkgs'.fd
+              pkgs'.haskellPackages.cabal-fmt
+              pkgs'.nixpkgs-fmt
+              fourmolu
+              pkgs'.haskell.packages."${ghcVersion}".hlint
+            ];
+          } ''
           export LC_CTYPE=C.UTF-8
           export LC_ALL=C.UTF-8
           export LANG=C.UTF-8
@@ -139,20 +143,23 @@
           mkdir $out
         '';
 
-    in {
+    in
+    {
       project = perSystem projectFor;
       flake = perSystem (system: (projectFor system).flake { });
 
       packages = perSystem (system:
         self.flake.${system}.packages // {
-          haddock = let
-            agora-doc = self.flake.${system}.packages."agora:lib:agora".doc;
-            pkgs = nixpkgsFor system;
-          in pkgs.runCommand "haddock-merge" { } ''
-            cd ${self}
-            mkdir $out
-            cp -r ${agora-doc}/share/doc/* $out
-          '';
+          haddock =
+            let
+              agora-doc = self.flake.${system}.packages."agora:lib:agora".doc;
+              pkgs = nixpkgsFor system;
+            in
+            pkgs.runCommand "haddock-merge" { } ''
+              cd ${self}
+              mkdir $out
+              cp -r ${agora-doc}/share/doc/* $out
+            '';
         });
 
       # Define what we want to test
@@ -163,9 +170,10 @@
           agora-test = self.flake.${system}.packages."agora:test:agora-test";
         });
       check = perSystem (system:
-        (nixpkgsFor system).runCommand "combined-test" {
-          checksss = builtins.attrValues self.checks.${system};
-        } ''
+        (nixpkgsFor system).runCommand "combined-test"
+          {
+            checksss = builtins.attrValues self.checks.${system};
+          } ''
           echo $checksss
           touch $out
         '');

From efb0776730709c69845224efd7a10d546fd432ed Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Fri, 22 Apr 2022 08:23:54 -0400
Subject: [PATCH 39/78] simple fixes suggested from review

---
 agora-test/Spec/Util.hs                  | 18 +++-----------
 agora/Agora/Effect/TreasuryWithdrawal.hs | 30 ++++++++++++------------
 2 files changed, 18 insertions(+), 30 deletions(-)

diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs
index 32fa1b1..069c7e3 100644
--- a/agora-test/Spec/Util.hs
+++ b/agora-test/Spec/Util.hs
@@ -142,13 +142,7 @@ effectSucceedsWith ::
   ScriptContext ->
   TestTree
 effectSucceedsWith tag eff datum scriptContext =
-  scriptSucceeds tag $
-    compile
-      ( eff
-          # pforgetData (pconstantData datum)
-          # pforgetData (pconstantData ())
-          # pconstant scriptContext
-      )
+  validatorSucceedsWith tag eff datum () scriptContext
 
 -- | Check that a validator script fails, given a name and arguments.
 effectFailsWith ::
@@ -161,14 +155,8 @@ effectFailsWith ::
   ScriptContext ->
   TestTree
 effectFailsWith tag eff datum scriptContext =
-  scriptFails tag $
-    compile
-      ( eff
-          # pforgetData (pconstantData datum)
-          # pforgetData (pconstantData ())
-          # pconstant scriptContext
-      )
-
+  validatorFailsWith tag eff datum () scriptContext
+  
 -- | Check that an arbitrary script doesn't error when evaluated, given a name.
 scriptSucceeds :: String -> Script -> TestTree
 scriptSucceeds name script = testCase name $ do
diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index ddf3f32..d8a496a 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -67,18 +67,18 @@ deriving via
     (PConstant TreasuryWithdrawalDatum)
 
 {- | Withdraws given list of values to specific target addresses.
-It can be evoked by burning GAT. The transaction should have correct
-outputs to the users and any left overs should be paid back to the treasury.
+     It can be evoked by burning GAT. The transaction should have correct
+     outputs to the users and any left overs should be paid back to the treasury.
 
-The validator does not accept any Redeemer as all "parameters" are provided
-via encoded Datum.
+     The validator does not accept any Redeemer as all "parameters" are provided
+     via encoded Datum.
 
-Note:
-It should check...
-1. Transaction outputs should contain all of what Datum specified
-2. Left over assests should be redirected back to Treasury
-It can be more flexiable over...
-- The number of outputs themselves
+     Note:
+     It should check...
+     1. Transaction outputs should contain all of what Datum specified
+     2. Left over assests should be redirected back to Treasury
+     It can be more flexiable over...
+     - The number of outputs themselves
 -}
 treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
 treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
@@ -104,11 +104,11 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
                   pdata $ ptuple # txOut.address # txOut.value
               )
             # txInfo.inputs
-        treasuryInputValues =
-          pfilter
-            # plam (\((pfield @"_0" #) . pfromData -> addr) -> pnot #$ addr #== effInput.address)
-            # inputValues
-        treasuryCredentials =
+    treasuryInputValues <- plet $ 
+      pfilter
+        # plam (\((pfield @"_0" #) . pfromData -> addr) -> pnot #$ addr #== effInput.address)
+        # inputValues
+    let treasuryCredentials =
           pmap
             # plam ((pfield @"credential" #) . pfromData . (pfield @"_0" #) . pfromData)
             # treasuryInputValues

From e91dcb7ce1dcbbb5cfec1440319143193b6c7bd5 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Fri, 22 Apr 2022 11:18:38 -0400
Subject: [PATCH 40/78] Now it checks specific treasury

Emily's suggestion on the review
---
 agora-test/Spec/Effect/TreasuryWithdrawal.hs  | 48 +++++++++++++++----
 .../Spec/Sample/Effect/TreasuryWithdrawal.hs  |  2 +-
 agora-test/Spec/Util.hs                       |  2 +-
 agora/Agora/Effect/TreasuryWithdrawal.hs      | 46 +++++++++---------
 4 files changed, 64 insertions(+), 34 deletions(-)

diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs
index 09bf1dc..9df0310 100644
--- a/agora-test/Spec/Effect/TreasuryWithdrawal.hs
+++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs
@@ -7,16 +7,16 @@ This module tests the Treasury Withdrawal Effect.
 -}
 module Spec.Effect.TreasuryWithdrawal (tests) where
 
-import Spec.Sample.Effect.TreasuryWithdrawal (
-  buildReceiversOutputFromDatum,
-  buildScriptContext,
-  currSymbol,
-  inputGAT,
-  inputTreasury,
-  outputTreasury,
-  outputUser,
-  users,
- )
+import Spec.Sample.Effect.TreasuryWithdrawal
+    ( currSymbol,
+      users,
+      treasuries,
+      inputGAT,
+      inputTreasury,
+      outputTreasury,
+      outputUser,
+      buildReceiversOutputFromDatum,
+      buildScriptContext )
 
 import Agora.Effect.TreasuryWithdrawal (
   TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
@@ -102,6 +102,18 @@ tests =
                 ]
                 ++ drop 1 (buildReceiversOutputFromDatum datum2)
           )
+      , effectFailsWith
+          "Unauthorized treasury"
+          (treasuryWithdrawalValidator currSymbol)
+          datum3
+          ( buildScriptContext
+              [ inputGAT
+              , inputTreasury 999 (asset1 20)
+              ]
+              $ [ outputTreasury 999 (asset1 17)
+                ]
+                ++ buildReceiversOutputFromDatum datum3
+          )          
       ]
   ]
   where
@@ -112,10 +124,26 @@ tests =
         [ (head users, asset1 1)
         , (users !! 1, asset1 1)
         , (users !! 2, asset1 1)
+        ] $
+        [ head treasuries
+        , treasuries !! 1
+        , treasuries !! 2
         ]
     datum2 =
       TreasuryWithdrawalDatum
         [ (head users, asset1 4 <> asset2 5)
         , (users !! 1, asset1 2 <> asset2 1)
         , (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
+        ]        
diff --git a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
index c228dc5..6469953 100644
--- a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
+++ b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
@@ -112,7 +112,7 @@ outputUser indx val =
     }
 
 buildReceiversOutputFromDatum :: TreasuryWithdrawalDatum -> [TxOut]
-buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs) = f <$> xs
+buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs _) = f <$> xs
   where
     f x =
       TxOut
diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs
index 069c7e3..df20043 100644
--- a/agora-test/Spec/Util.hs
+++ b/agora-test/Spec/Util.hs
@@ -156,7 +156,7 @@ effectFailsWith ::
   TestTree
 effectFailsWith tag eff datum scriptContext =
   validatorFailsWith tag eff datum () scriptContext
-  
+
 -- | Check that an arbitrary script doesn't error when evaluated, given a name.
 scriptSucceeds :: String -> Script -> TestTree
 scriptSucceeds name script = testCase name $ do
diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index d8a496a..5468112 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -38,7 +38,11 @@ import Plutus.V1.Ledger.Credential (Credential)
 import Plutus.V1.Ledger.Value (CurrencySymbol, Value)
 import PlutusTx qualified
 
-newtype TreasuryWithdrawalDatum = TreasuryWithdrawalDatum {receivers :: [(Credential, Value)]}
+data TreasuryWithdrawalDatum =
+  TreasuryWithdrawalDatum
+    { receivers :: [(Credential, Value)]
+    , treasuries :: [Credential]
+    }
   deriving stock (Show, GHC.Generic)
   deriving anyclass (Generic)
 
@@ -50,7 +54,9 @@ newtype PTreasuryWithdrawalDatum (s :: S)
       ( Term
           s
           ( PDataRecord
-              '["receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue))]
+              '[ "receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue))
+               , "treasuries" ':= PBuiltinList (PAsData PCredential)
+               ]
           )
       )
   deriving stock (GHC.Generic)
@@ -83,17 +89,17 @@ deriving via
 treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
 treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
   \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do
-    receivers <- plet $ pfromData $ pfield @"receivers" # datum'
+    datum <- pletFields @'["receivers", "treasuries"] datum'
     txInfo <- pletFields @'["outputs", "inputs"] txInfo'
     PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo'
     effInput <- pletFields @'["address", "value"] $ txOut
     let outputValues =
           pmap
             # plam
-              ( \(pfromData -> out') -> P.do
-                  out <- pletFields @'["address", "value"] $ out'
-                  cred <- pletFields @'["credential"] $ pfromData out.address
-                  pdata $ ptuple # cred.credential # out.value
+              ( \(pfromData -> txOut') -> P.do
+                  txOut <- pletFields @'["address", "value"] $ txOut'
+                  let cred = pfield @"credential" # pfromData txOut.address
+                  pdata $ ptuple # cred # txOut.value
               )
             # txInfo.outputs
         inputValues =
@@ -101,23 +107,19 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
             # plam
               ( \((pfield @"resolved" #) . pfromData -> txOut') -> P.do
                   txOut <- pletFields @'["address", "value"] $ txOut'
-                  pdata $ ptuple # txOut.address # txOut.value
+                  let cred = pfield @"credential" # pfromData txOut.address
+                  pdata $ ptuple # cred # txOut.value
               )
             # txInfo.inputs
-    treasuryInputValues <- plet $ 
-      pfilter
-        # plam (\((pfield @"_0" #) . pfromData -> addr) -> pnot #$ addr #== effInput.address)
-        # inputValues
-    let treasuryCredentials =
-          pmap
-            # plam ((pfield @"credential" #) . pfromData . (pfield @"_0" #) . pfromData)
-            # treasuryInputValues
-        treasuryOutputValues =
+    treasuryInputValues <-
+      plet $
+        pfilter
+          # plam (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
+          # inputValues
+    let treasuryOutputValues =
           pfilter
             # plam
-              ( \((pfield @"_0" #) . pfromData -> addr) -> P.do
-                  pelem # addr # treasuryCredentials
-              )
+              ( \((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
             # outputValues
         treasuryInputValuesSum =
           pfoldr
@@ -133,10 +135,10 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
           pfoldr
             # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
             # pconstant (mempty :: Value)
-            # receivers
+            # datum.receivers
         outputContentMatchesRecivers =
           pall # plam (\out -> pelem # out # outputValues)
-            #$ receivers
+            #$ datum.receivers
         excessShouldBePaidToInputs =
           pdata (paddValue # receiverValuesSum # treasuryOutputValuesSum) #== pdata treasuryInputValuesSum
         shouldNotPayToEffect =

From 05a6808767b20fa306738f69456526719d776d47 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Fri, 22 Apr 2022 19:01:36 -0500
Subject: [PATCH 41/78] stricter constraints over inputs

It will only allow treasuries given in the datum as input. It prevents
unwanted change in the system.
---
 agora-test/Spec/Effect/TreasuryWithdrawal.hs  | 52 ++++++++++++-------
 .../Spec/Sample/Effect/TreasuryWithdrawal.hs  | 15 +++++-
 agora-test/Spec/Util.hs                       |  6 +--
 agora/Agora/Effect/TreasuryWithdrawal.hs      | 36 ++++++-------
 4 files changed, 66 insertions(+), 43 deletions(-)

diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs
index 9df0310..67ae244 100644
--- a/agora-test/Spec/Effect/TreasuryWithdrawal.hs
+++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs
@@ -7,16 +7,18 @@ This module tests the Treasury Withdrawal Effect.
 -}
 module Spec.Effect.TreasuryWithdrawal (tests) where
 
-import Spec.Sample.Effect.TreasuryWithdrawal
-    ( currSymbol,
-      users,
-      treasuries,
-      inputGAT,
-      inputTreasury,
-      outputTreasury,
-      outputUser,
-      buildReceiversOutputFromDatum,
-      buildScriptContext )
+import Spec.Sample.Effect.TreasuryWithdrawal (
+  buildReceiversOutputFromDatum,
+  buildScriptContext,
+  currSymbol,
+  inputGAT,
+  inputTreasury,
+  inputUser,
+  outputTreasury,
+  outputUser,
+  treasuries,
+  users,
+ )
 
 import Agora.Effect.TreasuryWithdrawal (
   TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
@@ -110,10 +112,23 @@ tests =
               [ inputGAT
               , inputTreasury 999 (asset1 20)
               ]
-              $ [ outputTreasury 999 (asset1 17)
+              $ outputTreasury 999 (asset1 17) :
+              buildReceiversOutputFromDatum datum3
+          )
+      , effectFailsWith
+          "Prevent transactions besides the withdrawal"
+          (treasuryWithdrawalValidator currSymbol)
+          datum3
+          ( buildScriptContext
+              [ inputGAT
+              , inputTreasury 1 (asset1 20)
+              , inputUser 99 (asset2 100)
+              ]
+              $ [ outputTreasury 1 (asset1 17)
+                , outputUser 100 (asset2 100)
                 ]
                 ++ buildReceiversOutputFromDatum datum3
-          )          
+          )
       ]
   ]
   where
@@ -124,17 +139,17 @@ tests =
         [ (head users, asset1 1)
         , (users !! 1, asset1 1)
         , (users !! 2, asset1 1)
-        ] $
-        [ head treasuries
-        , treasuries !! 1
+        ]
+        [ treasuries !! 1
         , treasuries !! 2
+        , treasuries !! 3
         ]
     datum2 =
       TreasuryWithdrawalDatum
         [ (head users, asset1 4 <> asset2 5)
         , (users !! 1, asset1 2 <> asset2 1)
         , (users !! 2, asset1 1)
-        ] $
+        ]
         [ head treasuries
         , treasuries !! 1
         , treasuries !! 2
@@ -144,6 +159,5 @@ tests =
         [ (head users, asset1 1)
         , (users !! 1, asset1 1)
         , (users !! 2, asset1 1)
-        ] $
-        [ treasuries !! 1
-        ]        
+        ]
+        [treasuries !! 1]
diff --git a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
index 6469953..37aa634 100644
--- a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
+++ b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
@@ -7,6 +7,7 @@ This module provides smaples for Treasury Withdrawal Effect tests.
 -}
 module Spec.Sample.Effect.TreasuryWithdrawal (
   inputTreasury,
+  inputUser,
   inputGAT,
   outputTreasury,
   outputUser,
@@ -77,7 +78,7 @@ treasuries = ScriptCredential . ValidatorHash . toBuiltin . sha2 . C.pack . show
 
 inputGAT :: TxInInfo
 inputGAT =
-  TxInInfo -- Initiator
+  TxInInfo
     (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
     TxOut
       { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
@@ -87,7 +88,7 @@ inputGAT =
 
 inputTreasury :: Int -> Value -> TxInInfo
 inputTreasury indx val =
-  TxInInfo -- Initiator
+  TxInInfo
     (TxOutRef "" 1)
     TxOut
       { txOutAddress = Address (treasuries !! indx) Nothing
@@ -95,6 +96,16 @@ inputTreasury indx val =
       , txOutDatumHash = Just (DatumHash "")
       }
 
+inputUser :: Int -> Value -> TxInInfo
+inputUser indx val =
+  TxInInfo
+    (TxOutRef "" 1)
+    TxOut
+      { txOutAddress = Address (users !! indx) Nothing
+      , txOutValue = val
+      , txOutDatumHash = Just (DatumHash "")
+      }
+
 outputTreasury :: Int -> Value -> TxOut
 outputTreasury indx val =
   TxOut
diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs
index df20043..f36b3ba 100644
--- a/agora-test/Spec/Util.hs
+++ b/agora-test/Spec/Util.hs
@@ -141,8 +141,7 @@ effectSucceedsWith ::
   PLifted datum ->
   ScriptContext ->
   TestTree
-effectSucceedsWith tag eff datum scriptContext =
-  validatorSucceedsWith tag eff datum () scriptContext
+effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum ()
 
 -- | Check that a validator script fails, given a name and arguments.
 effectFailsWith ::
@@ -154,8 +153,7 @@ effectFailsWith ::
   PLifted datum ->
   ScriptContext ->
   TestTree
-effectFailsWith tag eff datum scriptContext =
-  validatorFailsWith tag eff datum () scriptContext
+effectFailsWith tag eff datum = validatorFailsWith tag eff datum ()
 
 -- | Check that an arbitrary script doesn't error when evaluated, given a name.
 scriptSucceeds :: String -> Script -> TestTree
diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 5468112..29a269d 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -38,11 +38,10 @@ import Plutus.V1.Ledger.Credential (Credential)
 import Plutus.V1.Ledger.Value (CurrencySymbol, Value)
 import PlutusTx qualified
 
-data TreasuryWithdrawalDatum =
-  TreasuryWithdrawalDatum
-    { receivers :: [(Credential, Value)]
-    , treasuries :: [Credential]
-    }
+data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum
+  { receivers :: [(Credential, Value)]
+  , treasuries :: [Credential]
+  }
   deriving stock (Show, GHC.Generic)
   deriving anyclass (Generic)
 
@@ -119,23 +118,15 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
     let treasuryOutputValues =
           pfilter
             # plam
-              ( \((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
+              (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
             # outputValues
-        treasuryInputValuesSum =
+        sumValues =
           pfoldr
             # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
             # pconstant (mempty :: Value)
-            # treasuryInputValues
-        treasuryOutputValuesSum =
-          pfoldr
-            # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
-            # pconstant (mempty :: Value)
-            # treasuryOutputValues
-        receiverValuesSum =
-          pfoldr
-            # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
-            # pconstant (mempty :: Value)
-            # datum.receivers
+        treasuryInputValuesSum = sumValues # treasuryInputValues
+        treasuryOutputValuesSum = sumValues # treasuryOutputValues
+        receiverValuesSum = sumValues # datum.receivers
         outputContentMatchesRecivers =
           pall # plam (\out -> pelem # out # outputValues)
             #$ datum.receivers
@@ -148,8 +139,17 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
                   effInput.address #== pfield @"address" # pfromData x
               )
             # pfromData txInfo.outputs
+        inputsAreOnlyTreasuries =
+          pall
+            # plam
+              ( \((pfield @"_0" #) . pfromData -> cred) ->
+                  cred #== pfield @"credential" # effInput.address
+                    #|| pelem # cred # datum.treasuries
+              )
+            # inputValues
 
     passert "Transaction output does not match receivers" outputContentMatchesRecivers
     passert "Transaction should not pay to effects" shouldNotPayToEffect
+    passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuries
     passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs
     popaque $ pconstant ()

From 75f5e83bcfca6c999654e58cb177f9e2b4c9f1d2 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Fri, 22 Apr 2022 20:09:23 -0500
Subject: [PATCH 42/78] optimized validator

---
 agora/Agora/Effect/TreasuryWithdrawal.hs | 57 +++++++++++-------------
 1 file changed, 27 insertions(+), 30 deletions(-)

diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 29a269d..3f980c4 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -92,41 +92,38 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
     txInfo <- pletFields @'["outputs", "inputs"] txInfo'
     PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo'
     effInput <- pletFields @'["address", "value"] $ txOut
-    let outputValues =
-          pmap
-            # plam
-              ( \(pfromData -> txOut') -> P.do
-                  txOut <- pletFields @'["address", "value"] $ txOut'
-                  let cred = pfield @"credential" # pfromData txOut.address
-                  pdata $ ptuple # cred # txOut.value
-              )
-            # txInfo.outputs
-        inputValues =
-          pmap
-            # plam
-              ( \((pfield @"resolved" #) . pfromData -> txOut') -> P.do
-                  txOut <- pletFields @'["address", "value"] $ txOut'
-                  let cred = pfield @"credential" # pfromData txOut.address
-                  pdata $ ptuple # cred # txOut.value
-              )
-            # txInfo.inputs
-    treasuryInputValues <-
+    outputValues <-
       plet $
-        pfilter
-          # plam (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
-          # inputValues
-    let treasuryOutputValues =
+        pmap
+          # plam
+            ( \(pfromData -> txOut') -> P.do
+                txOut <- pletFields @'["address", "value"] $ txOut'
+                let cred = pfield @"credential" # pfromData txOut.address
+                pdata $ ptuple # cred # txOut.value
+            )
+          # txInfo.outputs
+    inputValues <-
+      plet $
+        pmap
+          # plam
+            ( \((pfield @"resolved" #) . pfromData -> txOut') -> P.do
+                txOut <- pletFields @'["address", "value"] $ txOut'
+                let cred = pfield @"credential" # pfromData txOut.address
+                pdata $ ptuple # cred # txOut.value
+            )
+          # txInfo.inputs
+    let ofTreasury =
           pfilter
-            # plam
-              (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
-            # outputValues
+            # plam (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
         sumValues =
           pfoldr
             # plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
             # pconstant (mempty :: Value)
-        treasuryInputValuesSum = sumValues # treasuryInputValues
-        treasuryOutputValuesSum = sumValues # treasuryOutputValues
+        treasuryInputValuesSum = sumValues #$ ofTreasury # inputValues
+        treasuryOutputValuesSum = sumValues #$ ofTreasury # outputValues
         receiverValuesSum = sumValues # datum.receivers
+
+        -- Constraints
         outputContentMatchesRecivers =
           pall # plam (\out -> pelem # out # outputValues)
             #$ datum.receivers
@@ -148,8 +145,8 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
               )
             # inputValues
 
-    passert "Transaction output does not match receivers" outputContentMatchesRecivers
     passert "Transaction should not pay to effects" shouldNotPayToEffect
-    passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuries
+    passert "Transaction output does not match receivers" outputContentMatchesRecivers
     passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs
+    passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuries
     popaque $ pconstant ()

From 04b57dce8535d9560cc9fe25ed3641eb9d691c17 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Fri, 22 Apr 2022 23:34:33 -0500
Subject: [PATCH 43/78] Now `makeEffect` boilerplate requires datum to implemt
 `PTryFrom`

It will free `makeEffect` from using `unsafeCoerce` and force each
effect datums to implement their own "parsers".
---
 agora.cabal                |  3 +-
 agora/Agora/Effect.hs      | 24 +++-------------
 agora/Agora/Effect/NoOp.hs | 33 ++++++++++++++++++++++
 flake.nix                  | 56 ++++++++++++++++++++++----------------
 4 files changed, 71 insertions(+), 45 deletions(-)
 create mode 100644 agora/Agora/Effect/NoOp.hs

diff --git a/agora.cabal b/agora.cabal
index 041af40..ea06771 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -123,6 +123,7 @@ library
   exposed-modules:
     Agora.AuthorityToken
     Agora.Effect
+    Agora.Effect.NoOp
     Agora.Governor
     Agora.MultiSig
     Agora.Proposal
@@ -151,11 +152,11 @@ test-suite agora-test
   main-is:        Spec.hs
   hs-source-dirs: agora-test
   other-modules:
+    Spec.AuthorityToken
     Spec.Model.MultiSig
     Spec.Sample.Stake
     Spec.Stake
     Spec.Util
-    Spec.AuthorityToken
 
   build-depends:  agora
 
diff --git a/agora/Agora/Effect.hs b/agora/Agora/Effect.hs
index e8c3794..db69492 100644
--- a/agora/Agora/Effect.hs
+++ b/agora/Agora/Effect.hs
@@ -5,17 +5,13 @@ Description: Helpers for constructing effects
 
 Helpers for constructing effects.
 -}
-module Agora.Effect (
-  makeEffect,
-  noopEffect,
-) where
+module Agora.Effect (makeEffect) where
 
 import Agora.AuthorityToken (singleAuthorityTokenBurned)
 import Agora.Utils (passert)
-import Plutarch (popaque)
 import Plutarch.Api.V1 (PCurrencySymbol, PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator, PValue)
-import Plutarch.Internal (punsafeCoerce)
 import Plutarch.Monadic qualified as P
+import Plutarch.TryFrom (PTryFrom, ptryFrom)
 import Plutus.V1.Ledger.Value (CurrencySymbol)
 
 --------------------------------------------------------------------------------
@@ -28,7 +24,7 @@ import Plutus.V1.Ledger.Value (CurrencySymbol)
 -}
 makeEffect ::
   forall (datum :: PType).
-  PIsData datum =>
+  (PIsData datum, PTryFrom PData datum) =>
   CurrencySymbol ->
   (forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
   ClosedTerm PValidator
@@ -37,9 +33,7 @@ makeEffect gatCs' f =
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
     txInfo' <- plet ctx.txInfo
 
-    -- TODO: Use PTryFrom
-    let datum' :: Term _ datum
-        datum' = pfromData $ punsafeCoerce datum
+    (datum', _) <- ptryFrom @datum datum
 
     PSpending txOutRef <- pmatch $ pfromData ctx.purpose
     txOutRef' <- plet (pfield @"_0" # txOutRef)
@@ -53,13 +47,3 @@ makeEffect gatCs' f =
     passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint
 
     f gatCs datum' txOutRef' txInfo'
-
---------------------------------------------------------------------------------
-
--- | Dummy effect which can only burn its GAT.
-noopEffect :: CurrencySymbol -> ClosedTerm PValidator
-noopEffect =
-  ( `makeEffect`
-      \_gatCs (_datum :: Term _ PUnit) _txOutRef _txInfo -> P.do
-        popaque (pconstant ())
-  )
diff --git a/agora/Agora/Effect/NoOp.hs b/agora/Agora/Effect/NoOp.hs
new file mode 100644
index 0000000..90782e9
--- /dev/null
+++ b/agora/Agora/Effect/NoOp.hs
@@ -0,0 +1,33 @@
+{- |
+Module     : Agora.Effect.NoOp
+Maintainer : seungheon.ooh@gmail.com
+Description: Dummy dumb dumb effect.
+
+A dumb effect that only burns its GAT.
+-}
+module Agora.Effect.NoOp (noOpValidator, PNoOp) where
+
+import Control.Applicative (Const)
+
+import Agora.Effect (makeEffect)
+import Plutarch (popaque)
+import Plutarch.Api.V1 (PValidator)
+import Plutarch.TryFrom (PTryFrom (..))
+import Plutus.V1.Ledger.Value (CurrencySymbol)
+
+newtype PNoOp (s :: S) = PNoOp (Term s PUnit)
+  deriving (PlutusType, PIsData) via (DerivePNewtype PNoOp PUnit)
+
+instance PTryFrom PData PNoOp where
+  type PTryFromExcess PData PNoOp = Const ()
+  ptryFrom' _ cont =
+    -- JUSTIFICATION:
+    -- We don't care anything about data.
+    -- It should always be reduced to Unit.
+    cont (pcon $ PNoOp (pconstant ()), ())
+
+-- | Dummy effect which can only burn its GAT.
+noOpValidator :: CurrencySymbol -> ClosedTerm PValidator
+noOpValidator curr = makeEffect curr $
+  \_ (_datum :: Term s PNoOp) _ _ -> P.do
+    popaque (pconstant ())
diff --git a/flake.nix b/flake.nix
index c6522d6..3b1756a 100644
--- a/flake.nix
+++ b/flake.nix
@@ -50,8 +50,10 @@
 
       projectFor = system:
         let pkgs = nixpkgsFor system;
-        in let pkgs' = nixpkgsFor' system;
-        in (nixpkgsFor system).haskell-nix.cabalProject' {
+        in
+        let pkgs' = nixpkgsFor' system;
+        in
+        (nixpkgsFor system).haskell-nix.cabalProject' {
           src = ./.;
           compiler-nix-name = ghcVersion;
           inherit (plutarch) cabalProjectLocal;
@@ -120,16 +122,18 @@
             inherit (plutarch.tools) fourmolu;
           })
             fourmolu;
-        in pkgs.runCommand "format-check" {
-          nativeBuildInputs = [
-            pkgs'.git
-            pkgs'.fd
-            pkgs'.haskellPackages.cabal-fmt
-            pkgs'.nixpkgs-fmt
-            fourmolu
-            pkgs'.haskell.packages."${ghcVersion}".hlint
-          ];
-        } ''
+        in
+        pkgs.runCommand "format-check"
+          {
+            nativeBuildInputs = [
+              pkgs'.git
+              pkgs'.fd
+              pkgs'.haskellPackages.cabal-fmt
+              pkgs'.nixpkgs-fmt
+              fourmolu
+              pkgs'.haskell.packages."${ghcVersion}".hlint
+            ];
+          } ''
           export LC_CTYPE=C.UTF-8
           export LC_ALL=C.UTF-8
           export LANG=C.UTF-8
@@ -139,20 +143,23 @@
           mkdir $out
         '';
 
-    in {
+    in
+    {
       project = perSystem projectFor;
       flake = perSystem (system: (projectFor system).flake { });
 
       packages = perSystem (system:
         self.flake.${system}.packages // {
-          haddock = let
-            agora-doc = self.flake.${system}.packages."agora:lib:agora".doc;
-            pkgs = nixpkgsFor system;
-          in pkgs.runCommand "haddock-merge" { } ''
-            cd ${self}
-            mkdir $out
-            cp -r ${agora-doc}/share/doc/* $out
-          '';
+          haddock =
+            let
+              agora-doc = self.flake.${system}.packages."agora:lib:agora".doc;
+              pkgs = nixpkgsFor system;
+            in
+            pkgs.runCommand "haddock-merge" { } ''
+              cd ${self}
+              mkdir $out
+              cp -r ${agora-doc}/share/doc/* $out
+            '';
         });
 
       # Define what we want to test
@@ -163,9 +170,10 @@
           agora-test = self.flake.${system}.packages."agora:test:agora-test";
         });
       check = perSystem (system:
-        (nixpkgsFor system).runCommand "combined-test" {
-          checksss = builtins.attrValues self.checks.${system};
-        } ''
+        (nixpkgsFor system).runCommand "combined-test"
+          {
+            checksss = builtins.attrValues self.checks.${system};
+          } ''
           echo $checksss
           touch $out
         '');

From 35b862153c3407422ab68fde5375bc1cc4e1a4d5 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Mon, 25 Apr 2022 08:46:58 -0400
Subject: [PATCH 44/78] take collaterals into account

---
 agora-test/Spec/Effect/TreasuryWithdrawal.hs  |  8 +++++++
 .../Spec/Sample/Effect/TreasuryWithdrawal.hs  | 11 ++++++++++
 agora/Agora/Effect/TreasuryWithdrawal.hs      | 21 ++++++++++++-------
 3 files changed, 32 insertions(+), 8 deletions(-)

diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs
index 67ae244..7deb7da 100644
--- a/agora-test/Spec/Effect/TreasuryWithdrawal.hs
+++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs
@@ -14,6 +14,7 @@ import Spec.Sample.Effect.TreasuryWithdrawal (
   inputGAT,
   inputTreasury,
   inputUser,
+  inputCollateral,
   outputTreasury,
   outputUser,
   treasuries,
@@ -40,6 +41,7 @@ tests =
           datum1
           ( buildScriptContext
               [ inputGAT
+              , inputCollateral 10
               , inputTreasury 1 (asset1 10)
               ]
               $ outputTreasury 1 (asset1 7) :
@@ -51,6 +53,7 @@ tests =
           datum1
           ( buildScriptContext
               [ inputGAT
+              , inputCollateral 10
               , inputTreasury 1 (asset1 10)
               , inputTreasury 2 (asset1 100)
               , inputTreasury 3 (asset1 500)
@@ -67,6 +70,7 @@ tests =
           datum2
           ( buildScriptContext
               [ inputGAT
+              , inputCollateral 10
               , inputTreasury 1 (asset1 20)
               , inputTreasury 2 (asset2 20)
               ]
@@ -81,6 +85,7 @@ tests =
           datum2
           ( buildScriptContext
               [ inputGAT
+              , inputCollateral 10
               , inputTreasury 1 (asset1 20)
               , inputTreasury 2 (asset2 20)
               ]
@@ -96,6 +101,7 @@ tests =
           datum2
           ( buildScriptContext
               [ inputGAT
+              , inputCollateral 10
               , inputTreasury 1 (asset1 20)
               , inputTreasury 2 (asset2 20)
               ]
@@ -110,6 +116,7 @@ tests =
           datum3
           ( buildScriptContext
               [ inputGAT
+              , inputCollateral 10
               , inputTreasury 999 (asset1 20)
               ]
               $ outputTreasury 999 (asset1 17) :
@@ -122,6 +129,7 @@ tests =
           ( buildScriptContext
               [ inputGAT
               , inputTreasury 1 (asset1 20)
+              , inputTreasury 999 (asset1 20)
               , inputUser 99 (asset2 100)
               ]
               $ [ outputTreasury 1 (asset1 17)
diff --git a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
index 37aa634..78e89e2 100644
--- a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
+++ b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
@@ -9,6 +9,7 @@ module Spec.Sample.Effect.TreasuryWithdrawal (
   inputTreasury,
   inputUser,
   inputGAT,
+  inputCollateral,
   outputTreasury,
   outputUser,
   buildReceiversOutputFromDatum,
@@ -106,6 +107,16 @@ inputUser indx val =
       , txOutDatumHash = Just (DatumHash "")
       }
 
+inputCollateral :: Int -> TxInInfo
+inputCollateral indx =
+  TxInInfo -- Initiator
+    (TxOutRef "" 1)
+    TxOut
+      { txOutAddress = Address (users !! indx) Nothing
+      , txOutValue = Value.singleton "" "" 2000000
+      , txOutDatumHash = Just (DatumHash "")
+      }  
+
 outputTreasury :: Int -> Value -> TxOut
 outputTreasury indx val =
   TxOut
diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 3f980c4..ff9d3ec 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -20,12 +20,12 @@ import Agora.Effect (makeEffect)
 import Agora.Utils (findTxOutByTxOutRef, paddValue, passert)
 import Plutarch (popaque)
 import Plutarch.Api.V1 (
-  PCredential,
-  PTuple,
-  PValidator,
-  PValue,
   ptuple,
- )
+  PValidator,
+  PTuple,
+  PValue,
+  PCredential(..)
+  )
 
 import Plutarch.DataRepr (
   DerivePConstantViaData (..),
@@ -34,7 +34,7 @@ import Plutarch.DataRepr (
  )
 import Plutarch.Lift (PUnsafeLiftDecl (..))
 import Plutarch.Monadic qualified as P
-import Plutus.V1.Ledger.Credential (Credential)
+import Plutus.V1.Ledger.Credential ( Credential )
 import Plutus.V1.Ledger.Value (CurrencySymbol, Value)
 import PlutusTx qualified
 
@@ -122,6 +122,10 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
         treasuryInputValuesSum = sumValues #$ ofTreasury # inputValues
         treasuryOutputValuesSum = sumValues #$ ofTreasury # outputValues
         receiverValuesSum = sumValues # datum.receivers
+        isCollateral = plam $ \cred -> P.do
+          pmatch cred $ \case
+            PPubKeyCredential _ -> pcon PTrue
+            PScriptCredential _ -> pcon PFalse     
 
         -- Constraints
         outputContentMatchesRecivers =
@@ -136,17 +140,18 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
                   effInput.address #== pfield @"address" # pfromData x
               )
             # pfromData txInfo.outputs
-        inputsAreOnlyTreasuries =
+        inputsAreOnlyTreasuriesOrCollateral =
           pall
             # plam
               ( \((pfield @"_0" #) . pfromData -> cred) ->
                   cred #== pfield @"credential" # effInput.address
                     #|| pelem # cred # datum.treasuries
+                    #|| isCollateral # pfromData cred
               )
             # inputValues
 
     passert "Transaction should not pay to effects" shouldNotPayToEffect
     passert "Transaction output does not match receivers" outputContentMatchesRecivers
     passert "Remainders should be returned to the treasury" excessShouldBePaidToInputs
-    passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuries
+    passert "Transaction should only have treasuries specified in the datum as input" inputsAreOnlyTreasuriesOrCollateral
     popaque $ pconstant ()

From 8315f410e8e9b2d7122ff116bda7f1df4701dee9 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Mon, 25 Apr 2022 08:48:22 -0400
Subject: [PATCH 45/78] format

---
 agora-test/Spec/Effect/TreasuryWithdrawal.hs        |  2 +-
 agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs |  2 +-
 agora/Agora/Effect/TreasuryWithdrawal.hs            | 12 ++++++------
 3 files changed, 8 insertions(+), 8 deletions(-)

diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs
index 7deb7da..db0aed6 100644
--- a/agora-test/Spec/Effect/TreasuryWithdrawal.hs
+++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs
@@ -11,10 +11,10 @@ import Spec.Sample.Effect.TreasuryWithdrawal (
   buildReceiversOutputFromDatum,
   buildScriptContext,
   currSymbol,
+  inputCollateral,
   inputGAT,
   inputTreasury,
   inputUser,
-  inputCollateral,
   outputTreasury,
   outputUser,
   treasuries,
diff --git a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
index 78e89e2..81709fe 100644
--- a/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
+++ b/agora-test/Spec/Sample/Effect/TreasuryWithdrawal.hs
@@ -115,7 +115,7 @@ inputCollateral indx =
       { txOutAddress = Address (users !! indx) Nothing
       , txOutValue = Value.singleton "" "" 2000000
       , txOutDatumHash = Just (DatumHash "")
-      }  
+      }
 
 outputTreasury :: Int -> Value -> TxOut
 outputTreasury indx val =
diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index ff9d3ec..0fbe118 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -20,12 +20,12 @@ import Agora.Effect (makeEffect)
 import Agora.Utils (findTxOutByTxOutRef, paddValue, passert)
 import Plutarch (popaque)
 import Plutarch.Api.V1 (
-  ptuple,
-  PValidator,
+  PCredential (..),
   PTuple,
+  PValidator,
   PValue,
-  PCredential(..)
-  )
+  ptuple,
+ )
 
 import Plutarch.DataRepr (
   DerivePConstantViaData (..),
@@ -34,7 +34,7 @@ import Plutarch.DataRepr (
  )
 import Plutarch.Lift (PUnsafeLiftDecl (..))
 import Plutarch.Monadic qualified as P
-import Plutus.V1.Ledger.Credential ( Credential )
+import Plutus.V1.Ledger.Credential (Credential)
 import Plutus.V1.Ledger.Value (CurrencySymbol, Value)
 import PlutusTx qualified
 
@@ -125,7 +125,7 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
         isCollateral = plam $ \cred -> P.do
           pmatch cred $ \case
             PPubKeyCredential _ -> pcon PTrue
-            PScriptCredential _ -> pcon PFalse     
+            PScriptCredential _ -> pcon PFalse
 
         -- Constraints
         outputContentMatchesRecivers =

From bb4b87eeb196000583ca924d6a0e99143a83cb8a Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Mon, 25 Apr 2022 09:01:40 -0400
Subject: [PATCH 46/78] More comments

---
 agora/Agora/Effect.hs | 7 +++++++
 1 file changed, 7 insertions(+)

diff --git a/agora/Agora/Effect.hs b/agora/Agora/Effect.hs
index db69492..3a3b1e9 100644
--- a/agora/Agora/Effect.hs
+++ b/agora/Agora/Effect.hs
@@ -33,17 +33,24 @@ makeEffect gatCs' f =
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
     txInfo' <- plet ctx.txInfo
 
+    -- 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', _) <- ptryFrom @datum datum
 
+    -- ensure purpose is Spending.
     PSpending txOutRef <- pmatch $ pfromData ctx.purpose
     txOutRef' <- plet (pfield @"_0" # txOutRef)
 
+    -- fetch minted values to ensure single GAT is burned
     txInfo <- pletFields @'["mint"] txInfo'
     let mint :: Term _ PValue
         mint = txInfo.mint
 
+    -- fetch script context
     gatCs <- plet $ pconstant gatCs'
 
     passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint
 
+    -- run effect function
     f gatCs datum' txOutRef' txInfo'

From 349b4454ab26f8f0b0c7ffd6b1c37dde0171eadd Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Mon, 25 Apr 2022 09:04:07 -0400
Subject: [PATCH 47/78] rename!

---
 agora/Agora/Effect/TreasuryWithdrawal.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 0fbe118..abf23bf 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -122,7 +122,7 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
         treasuryInputValuesSum = sumValues #$ ofTreasury # inputValues
         treasuryOutputValuesSum = sumValues #$ ofTreasury # outputValues
         receiverValuesSum = sumValues # datum.receivers
-        isCollateral = plam $ \cred -> P.do
+        isPubkey = plam $ \cred -> P.do
           pmatch cred $ \case
             PPubKeyCredential _ -> pcon PTrue
             PScriptCredential _ -> pcon PFalse
@@ -146,7 +146,7 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
               ( \((pfield @"_0" #) . pfromData -> cred) ->
                   cred #== pfield @"credential" # effInput.address
                     #|| pelem # cred # datum.treasuries
-                    #|| isCollateral # pfromData cred
+                    #|| isPubkey # pfromData cred
               )
             # inputValues
 

From cbff7324d8673b95aa79a6d97f69071d6d48df43 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Mon, 25 Apr 2022 11:16:17 -0400
Subject: [PATCH 48/78] PTryFrom for Treasury Withdrawal Effect!

---
 agora/Agora/Effect/TreasuryWithdrawal.hs | 10 ++++++++++
 1 file changed, 10 insertions(+)

diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index abf23bf..f39ad92 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -15,10 +15,12 @@ module Agora.Effect.TreasuryWithdrawal (
 
 import GHC.Generics qualified as GHC
 import Generics.SOP (Generic, I (I))
+import Control.Applicative (Const)
 
 import Agora.Effect (makeEffect)
 import Agora.Utils (findTxOutByTxOutRef, paddValue, passert)
 import Plutarch (popaque)
+import Plutarch.Internal (punsafeCoerce)
 import Plutarch.Api.V1 (
   PCredential (..),
   PTuple,
@@ -32,6 +34,7 @@ import Plutarch.DataRepr (
   PDataFields,
   PIsDataReprInstances (..),
  )
+import Plutarch.TryFrom ( PTryFrom(..) ) 
 import Plutarch.Lift (PUnsafeLiftDecl (..))
 import Plutarch.Monadic qualified as P
 import Plutus.V1.Ledger.Credential (Credential)
@@ -71,6 +74,13 @@ deriving via
   instance
     (PConstant TreasuryWithdrawalDatum)
 
+instance PTryFrom PData PTreasuryWithdrawalDatum where
+  type PTryFromExcess PData PTreasuryWithdrawalDatum = Const ()
+  ptryFrom' opq cont =
+    -- this will need to not use punsafeCoerce...
+    cont (punsafeCoerce opq, ())
+
+
 {- | Withdraws given list of values to specific target addresses.
      It can be evoked by burning GAT. The transaction should have correct
      outputs to the users and any left overs should be paid back to the treasury.

From e262395556b75a1878328308409b11fa1d844b70 Mon Sep 17 00:00:00 2001
From: Seungheon Oh <seungheon.ooh@gmail.com>
Date: Mon, 25 Apr 2022 11:17:15 -0400
Subject: [PATCH 49/78] format

---
 agora.cabal                              | 2 +-
 agora/Agora/Effect/TreasuryWithdrawal.hs | 7 +++----
 2 files changed, 4 insertions(+), 5 deletions(-)

diff --git a/agora.cabal b/agora.cabal
index e73243f..c1729d0 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -123,8 +123,8 @@ library
   exposed-modules:
     Agora.AuthorityToken
     Agora.Effect
-    Agora.Effect.TreasuryWithdrawal
     Agora.Effect.NoOp
+    Agora.Effect.TreasuryWithdrawal
     Agora.Governor
     Agora.MultiSig
     Agora.Proposal
diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index f39ad92..209877f 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -13,14 +13,13 @@ module Agora.Effect.TreasuryWithdrawal (
   treasuryWithdrawalValidator,
 ) where
 
+import Control.Applicative (Const)
 import GHC.Generics qualified as GHC
 import Generics.SOP (Generic, I (I))
-import Control.Applicative (Const)
 
 import Agora.Effect (makeEffect)
 import Agora.Utils (findTxOutByTxOutRef, paddValue, passert)
 import Plutarch (popaque)
-import Plutarch.Internal (punsafeCoerce)
 import Plutarch.Api.V1 (
   PCredential (..),
   PTuple,
@@ -28,15 +27,16 @@ import Plutarch.Api.V1 (
   PValue,
   ptuple,
  )
+import Plutarch.Internal (punsafeCoerce)
 
 import Plutarch.DataRepr (
   DerivePConstantViaData (..),
   PDataFields,
   PIsDataReprInstances (..),
  )
-import Plutarch.TryFrom ( PTryFrom(..) ) 
 import Plutarch.Lift (PUnsafeLiftDecl (..))
 import Plutarch.Monadic qualified as P
+import Plutarch.TryFrom (PTryFrom (..))
 import Plutus.V1.Ledger.Credential (Credential)
 import Plutus.V1.Ledger.Value (CurrencySymbol, Value)
 import PlutusTx qualified
@@ -80,7 +80,6 @@ instance PTryFrom PData PTreasuryWithdrawalDatum where
     -- this will need to not use punsafeCoerce...
     cont (punsafeCoerce opq, ())
 
-
 {- | Withdraws given list of values to specific target addresses.
      It can be evoked by burning GAT. The transaction should have correct
      outputs to the users and any left overs should be paid back to the treasury.

From 45afbf1d4ed3d8a46baa16ce3623896b898f2e42 Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Tue, 26 Apr 2022 10:22:26 +0100
Subject: [PATCH 50/78] Spelling error

---
 docs/README.md | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/docs/README.md b/docs/README.md
index 6829bb8..c645071 100644
--- a/docs/README.md
+++ b/docs/README.md
@@ -17,5 +17,5 @@ The following is a list of terms that are used frequently throughout the documen
 -   **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 grant's the effects of a proposal the authority to alter the system. More information can be read [here](./tech-design/authority-tokens.md).
+-   **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](./tech-design/authority-tokens.md).
 -   **Effect**: A script for implementing changes suggested by a proposal. An effect can make numerous changes and a proposal may have multiple effects.

From 801c9067e3492b09a32b17ece5418fc5fd2e993c Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Tue, 12 Apr 2022 14:25:30 +0200
Subject: [PATCH 51/78] add `proposalDatumValid`

---
 agora/Agora/Proposal.hs | 41 +++++++++++++++++++++++++++++++++++++++--
 hie.yaml                |  6 ------
 2 files changed, 39 insertions(+), 8 deletions(-)

diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index 7125da0..4b1062c 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-unused-matches #-}
 
 {- |
 Module     : Agora.Proposal
@@ -28,6 +29,7 @@ module Agora.Proposal (
   -- * Scripts
   proposalValidator,
   proposalPolicy,
+  proposalDatumValid,
 ) where
 
 import GHC.Generics qualified as GHC
@@ -52,9 +54,14 @@ import PlutusTx.AssocMap qualified as AssocMap
 --------------------------------------------------------------------------------
 
 import Agora.SafeMoney (GTTag)
+import Agora.Utils (pnotNull)
 import Plutarch (popaque)
+import Plutarch.Builtin (PBuiltinMap)
 import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..))
+import Plutarch.Monadic qualified as P
 import Plutarch.SafeMoney (PDiscrete, Tagged)
+import Plutarch.Unsafe (punsafeCoerce)
+import Plutus.V1.Ledger.Value (AssetClass)
 
 --------------------------------------------------------------------------------
 -- Haskell-land
@@ -169,6 +176,9 @@ newtype ProposalId = ProposalId {proposalTag :: Integer}
 
 -- | Parameters that identify the Proposal validator script.
 data Proposal = Proposal
+  { governorSTAssetClass :: AssetClass
+  }
+  deriving stock (Show, Eq)
 
 --------------------------------------------------------------------------------
 -- Plutarch-land
@@ -251,7 +261,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum
       ( PDataRecord
           '[ "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash)
            , "status" ':= PProposalStatus
-           , "cosigners" ':= PBuiltinList PPubKeyHash
+           , "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
            , "thresholds" ':= PProposalThresholds
            , "votes" ':= PProposalVotes
            ]
@@ -269,7 +279,11 @@ deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PCo
 
 --------------------------------------------------------------------------------
 
--- | Policy for Proposals.
+{- | Policy for Proposals.
+   This needs to perform two checks:
+     - Governor is happy with mint.
+     - Datum is valid
+-}
 proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
 proposalPolicy _ =
   plam $ \_redeemer _ctx' -> P.do
@@ -280,3 +294,26 @@ proposalValidator :: Proposal -> ClosedTerm PValidator
 proposalValidator _ =
   plam $ \_datum _redeemer _ctx' -> P.do
     popaque (pconstant ())
+
+{- | Check for various invariants a proposal must uphold.
+     This can be used to check both upopn creation and
+     upon any following state transitions in the proposal.
+-}
+proposalDatumValid :: Term s (PProposalDatum :--> PBool)
+proposalDatumValid =
+  phoistAcyclic $
+    plam $ \datum' -> P.do
+      datum <- pletFields @'["effects", "cosigners"] $ datum'
+
+      let effects :: Term _ (PBuiltinMap PResultTag (PBuiltinMap PValidatorHash PDatumHash))
+          effects = punsafeCoerce datum.effects
+
+          atLeastOneNegativeResult :: Term _ PBool
+          atLeastOneNegativeResult =
+            pany # plam (\pair -> pnull #$ pfromData $ psndBuiltin # pair) # effects
+
+      foldr1
+        (#&&)
+        [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult
+        , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
+        ]
diff --git a/hie.yaml b/hie.yaml
index 6020af6..04cd243 100644
--- a/hie.yaml
+++ b/hie.yaml
@@ -1,8 +1,2 @@
 cradle:
   cabal:
-    - path: "./agora"
-      component: "lib:agora"
-    - path: "./agora-bench"
-      component: "benchmark:agora-bench"
-    - path: "./agora-test"
-      component: "test:agora-test"

From 27263486650641828edec1b128e773b962ebec71 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Wed, 13 Apr 2022 16:39:08 +0200
Subject: [PATCH 52/78] refactor out ptokenSpent

---
 agora/Agora/AuthorityToken.hs | 31 +++++++++--------------
 agora/Agora/Proposal.hs       | 46 +++++++++++++++++++++++++++++------
 agora/Agora/Utils.hs          | 37 +++++++++++++++-------------
 3 files changed, 70 insertions(+), 44 deletions(-)

diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs
index 8239242..cd04507 100644
--- a/agora/Agora/AuthorityToken.hs
+++ b/agora/Agora/AuthorityToken.hs
@@ -18,16 +18,14 @@ import Plutarch.Api.V1 (
   PCurrencySymbol (..),
   PScriptContext (..),
   PScriptPurpose (..),
-  PTxInInfo (..),
   PTxInfo (..),
   PTxOut (..),
  )
 import Plutarch.Api.V1.AssocMap (PMap (PMap))
 import Plutarch.Api.V1.Value (PValue (PValue))
 import Plutarch.Builtin (pforgetData)
-import Plutarch.List (pfoldr')
 import Plutarch.Monadic qualified as P
-import Plutus.V1.Ledger.Value (AssetClass)
+import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
 
 import Prelude
 
@@ -36,11 +34,11 @@ import Prelude
 import Agora.Utils (
   allOutputs,
   passert,
-  passetClassValueOf,
-  passetClassValueOf',
   plookup,
   psymbolValueOf,
+  ptokenSpent,
  )
+import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
 
 --------------------------------------------------------------------------------
 
@@ -132,26 +130,19 @@ authorityTokenPolicy params =
       PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
       txInfo <- pletFields @'["inputs", "mint"] txInfo'
       let inputs = txInfo.inputs
-      let authorityTokenInputs =
-            pfoldr' @PBuiltinList
-              ( \txInInfo' acc -> P.do
-                  PTxInInfo txInInfo <- pmatch (pfromData txInInfo')
-                  PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo
-                  txOut <- pletFields @'["value"] txOut'
-                  let txOutValue = pfromData txOut.value
-                  passetClassValueOf' params.authority # txOutValue + acc
-              )
-              # 0
-              # inputs
-      let mintedValue = pfromData txInfo.mint
-      let tokenMoved = 0 #< authorityTokenInputs
+          mintedValue = pfromData txInfo.mint
+          AssetClass (govCs, govTn) = params.authority
+          govAc = passetClass # pconstant govCs # pconstant govTn
+          govTokenSpent = ptokenSpent # govAc # inputs
+
       PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
+
       let ownSymbol = pfromData $ pfield @"_0" # ownSymbol'
-      let mintedATs = passetClassValueOf # ownSymbol # pconstant "" # mintedValue
+          mintedATs = passetClassValueOf # mintedValue # (passetClass # ownSymbol # pconstant "")
       pif
         (0 #< mintedATs)
         ( P.do
-            passert "Parent token did not move in minting GATs" tokenMoved
+            passert "Parent token did not move in minting GATs" govTokenSpent
             passert "All outputs only emit valid GATs" $
               allOutputs @PUnit # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
                 authorityTokensValidIn
diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index 4b1062c..eea1c0c 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE TemplateHaskell #-}
-{-# OPTIONS_GHC -Wno-unused-matches #-}
 
 {- |
 Module     : Agora.Proposal
@@ -39,6 +38,9 @@ import Plutarch.Api.V1 (
   PMap,
   PMintingPolicy,
   PPubKeyHash,
+  PScriptContext (PScriptContext),
+  PScriptPurpose (PMinting, PSpending),
+  PTxInfo (PTxInfo),
   PValidator,
   PValidatorHash,
  )
@@ -54,14 +56,15 @@ import PlutusTx.AssocMap qualified as AssocMap
 --------------------------------------------------------------------------------
 
 import Agora.SafeMoney (GTTag)
-import Agora.Utils (pnotNull)
+import Agora.Utils (passert, pnotNull, ptokenSpent)
 import Plutarch (popaque)
+import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
 import Plutarch.Builtin (PBuiltinMap)
 import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..))
 import Plutarch.Monadic qualified as P
 import Plutarch.SafeMoney (PDiscrete, Tagged)
 import Plutarch.Unsafe (punsafeCoerce)
-import Plutus.V1.Ledger.Value (AssetClass)
+import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
 
 --------------------------------------------------------------------------------
 -- Haskell-land
@@ -282,17 +285,46 @@ deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PCo
 {- | Policy for Proposals.
    This needs to perform two checks:
      - Governor is happy with mint.
-     - Datum is valid
+     - Exactly 1 token is minted.
+
+   NOTE: The governor needs to check that the datum is correct
+         and sent to the right address.
 -}
 proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
-proposalPolicy _ =
-  plam $ \_redeemer _ctx' -> P.do
+proposalPolicy proposal =
+  plam $ \_redeemer ctx' -> P.do
+    PScriptContext ctx' <- pmatch ctx'
+    ctx <- pletFields @'["txInfo", "purpose"] ctx'
+    PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
+    txInfo <- pletFields @'["inputs", "mint"] txInfo'
+    PMinting _ownSymbol <- pmatch $ pfromData ctx.purpose
+
+    let inputs = txInfo.inputs
+        mintedValue = pfromData txInfo.mint
+        AssetClass (govCs, govTn) = proposal.governorSTAssetClass
+
+    PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
+    let mintedProposalST = passetClassValueOf # mintedValue # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "")
+
+    passert "Governance state-thread token must move" $
+      ptokenSpent
+        # (passetClass # pconstant govCs # pconstant govTn)
+        # inputs
+
+    passert "Minted exactly one proposal ST" $
+      mintedProposalST #== 1
+
     popaque (pconstant ())
 
 -- | Validator for Proposals.
 proposalValidator :: Proposal -> ClosedTerm PValidator
 proposalValidator _ =
-  plam $ \_datum _redeemer _ctx' -> P.do
+  plam $ \_datum _redeemer ctx' -> P.do
+    PScriptContext ctx' <- pmatch ctx'
+    ctx <- pletFields @'["txInfo", "purpose"] ctx'
+    PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
+    _txInfo <- pletFields @'["inputs", "mint"] txInfo'
+    PSpending _txOutRef <- pmatch $ pfromData ctx.purpose
     popaque (pconstant ())
 
 {- | Check for various invariants a proposal must uphold.
diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index 48e5af3..58c350a 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -17,8 +17,6 @@ module Agora.Utils (
   plookup,
   pfromMaybe,
   psymbolValueOf,
-  passetClassValueOf,
-  passetClassValueOf',
   pgeqByClass,
   pgeqBySymbol,
   pgeqByClass',
@@ -27,6 +25,7 @@ module Agora.Utils (
   pfindMap,
   pnotNull,
   pisJust,
+  ptokenSpent,
 
   -- * Functions which should (probably) not be upstreamed
   anyOutput,
@@ -63,6 +62,7 @@ import Plutarch.Api.V1 (
   PValue,
  )
 import Plutarch.Api.V1.AssocMap (PMap (PMap))
+import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf, pvalueOf)
 import Plutarch.Api.V1.Value (PValue (PValue))
 import Plutarch.Builtin (ppairDataBuiltin)
 import Plutarch.Internal (punsafeCoerce)
@@ -183,30 +183,17 @@ psymbolValueOf =
       PMap m <- pmatch (pfromData m')
       pfoldr # plam (\x v -> pfromData (psndBuiltin # x) + v) # 0 # m
 
--- | Extract amount from PValue belonging to a Plutarch-level asset class.
-passetClassValueOf ::
-  Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PInteger)
-passetClassValueOf =
-  phoistAcyclic $
-    plam $ \sym token value'' -> P.do
-      PValue value' <- pmatch value''
-      PMap value <- pmatch value'
-      m' <- pexpectJust 0 (plookup # pdata sym # value)
-      PMap m <- pmatch (pfromData m')
-      v <- pexpectJust 0 (plookup # pdata token # m)
-      pfromData v
-
 -- | Extract amount from PValue belonging to a Haskell-level AssetClass.
 passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger)
 passetClassValueOf' (AssetClass (sym, token)) =
-  passetClassValueOf # pconstant sym # pconstant token
+  phoistAcyclic $ plam $ \value -> pvalueOf # value # pconstant sym # pconstant token
 
 -- | Return '>=' on two values comparing by only a particular AssetClass.
 pgeqByClass :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PValue :--> PBool)
 pgeqByClass =
   phoistAcyclic $
     plam $ \cs tn a b ->
-      passetClassValueOf # cs # tn # b #<= passetClassValueOf # cs # tn # a
+      pvalueOf # b # cs # tn #<= pvalueOf # a # cs # tn
 
 -- | Return '>=' on two values comparing by only a particular CurrencySymbol.
 pgeqBySymbol :: Term s (PCurrencySymbol :--> PValue :--> PValue :--> PBool)
@@ -421,3 +408,19 @@ findTxOutDatum = phoistAcyclic $
     case datumHash' of
       PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # info
       _ -> pcon PNothing
+
+-- | Check if a particular asset class has been spent in the input list.
+ptokenSpent :: forall {s :: S}. Term s (PAssetClass :--> PBuiltinList (PAsData PTxInInfo) :--> PBool)
+ptokenSpent =
+  plam $ \tokenClass inputs ->
+    0
+      #< pfoldr @PBuiltinList
+        # ( plam $ \txInInfo' acc -> P.do
+              PTxInInfo txInInfo <- pmatch (pfromData txInInfo')
+              PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo
+              txOut <- pletFields @'["value"] txOut'
+              let txOutValue = pfromData txOut.value
+              acc + passetClassValueOf # txOutValue # tokenClass
+          )
+        # 0
+        # inputs

From 8f8416593f7ff960699af3e62d5b3d1543d493b4 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Fri, 15 Apr 2022 22:03:18 +0200
Subject: [PATCH 53/78] add `ProposalRedeemer`, bump plutarch-safemoney PR
 revision

---
 agora-test/Spec/Sample/Stake.hs |   3 +-
 agora/Agora/Proposal.hs         | 102 ++++++++++++++++++++++++++++++--
 agora/Agora/Stake.hs            |  25 +++++---
 flake.lock                      |   8 +--
 flake.nix                       |   2 +-
 5 files changed, 122 insertions(+), 18 deletions(-)

diff --git a/agora-test/Spec/Sample/Stake.hs b/agora-test/Spec/Sample/Stake.hs
index 08bd0e1..e62103e 100644
--- a/agora-test/Spec/Sample/Stake.hs
+++ b/agora-test/Spec/Sample/Stake.hs
@@ -177,8 +177,7 @@ stakeDepositWithdraw config =
                   [ TxOut
                       { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
                       , txOutValue =
-                          st
-                            <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
+                          st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
                       , txOutDatumHash = Just (toDatumHash stakeAfter)
                       }
                   ]
diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index eea1c0c..d4b6c4d 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -57,12 +57,14 @@ import PlutusTx.AssocMap qualified as AssocMap
 
 import Agora.SafeMoney (GTTag)
 import Agora.Utils (passert, pnotNull, ptokenSpent)
+import Control.Arrow (first)
 import Plutarch (popaque)
 import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
 import Plutarch.Builtin (PBuiltinMap)
 import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..))
 import Plutarch.Monadic qualified as P
 import Plutarch.SafeMoney (PDiscrete, Tagged)
+import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
 import Plutarch.Unsafe (punsafeCoerce)
 import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
 
@@ -102,26 +104,33 @@ data ProposalStatus
     --   This means that once the timing requirements align,
     --   proposal will be able to be voted on.
     VotingReady
+  | -- | The proposal has been voted on, and the votes have been locked
+    --   permanently. The proposal can now be executed.
+    Voted
   | -- | The proposal has finished.
     --
     --   This can mean it's been voted on and completed, but it can also mean
-    --   the proposal failed due to  time constraints or didn't
+    --   the proposal failed due to time constraints or didn't
     --   get to 'VotingReady' first.
     --
+    --   At this stage, the 'votes' field of 'ProposalState' is frozen.
+    --
+    --   See 'AdvanceProposal' for documentation on state transitions.
+    --
     --   TODO: The owner of the proposal may choose to reclaim their proposal.
     Finished
   deriving stock (Eq, Show, GHC.Generic)
 
-PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Finished, 2)]
+PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Voted, 2), ('Finished, 3)]
 
 {- | The threshold values for various state transitions to happen.
      This data is stored centrally (in the 'Agora.Governor.Governor') and copied over
      to 'Proposal's when they are created.
 -}
 data ProposalThresholds = ProposalThresholds
-  { execute :: Tagged GTTag Integer
+  { countVoting :: Tagged GTTag Integer
   -- ^ How much GT minimum must a particular 'ResultTag' accumulate for it to pass.
-  , draft :: Tagged GTTag Integer
+  , create :: Tagged GTTag Integer
   -- ^ How much GT required to "create" a proposal.
   , vote :: Tagged GTTag Integer
   -- ^ How much GT required to allow voting to happen.
@@ -168,6 +177,49 @@ data ProposalDatum = ProposalDatum
 
 PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)]
 
+-- | Haskell-level redeemer for Proposal scripts.
+data ProposalRedeemer
+  = -- | Cast one or more votes towards a particular 'ResultTag'.
+    Vote ResultTag
+  | -- | 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
+    --   'Stake's can be called to advance the proposal, provided enough GT is shared
+    --   among them.
+    Cosign [PubKeyHash]
+  | -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'.
+    Unlock ResultTag
+  | -- | Advance the proposal, performing the required checks for whether that is legal.
+    --
+    --   These are roughly the checks for each possible transition:
+    --
+    --   @'Draft' -> 'VotingReady'@:
+    --     1. The sum of all of the cosigner's GT is larger than the 'vote' field of 'ProposalThresholds'.
+    --     2. The proposal hasn't been alive for longer than the review time.
+    --
+    --   @'VotingReady' -> 'Voted'@:
+    --     1. The sum of all votes is larger than 'countVoting'.
+    --     2. The winning 'ResultTag' has more votes than all other 'ResultTag's.
+    --     3. The proposal hasn't been alive for longer than the voting time.
+    --
+    --   @'Voted' -> 'Finished'@:
+    --     Always valid provided the conditions for the transition are met.
+    --
+    --   @* -> 'Finished'@:
+    --     If the proposal has run out of time for the current 'ProposalStatus', it will always be possible
+    --     to transition into 'Finished' state, because it has expired (and failed).
+    AdvanceProposal
+  deriving stock (Eq, Show, GHC.Generic)
+
+PlutusTx.makeIsDataIndexed
+  ''ProposalRedeemer
+  [ ('Vote, 0)
+  , ('Cosign, 1)
+  , ('Unlock, 2)
+  , ('AdvanceProposal, 3)
+  ]
+
 {- | Identifies a Proposal, issued upon creation of a proposal.
      In practice, this number starts at zero, and increments by one
      for each proposal. The 100th proposal will be @'ProposalId' 99@.
@@ -196,10 +248,30 @@ deriving via
   instance
     (PConstant ResultTag)
 
+-- FIXME: This instance and the one below, for 'PProposalId', should be derived.
+-- Soon this will be possible through 'DerivePNewtype'.
+instance PTryFrom PData (PAsData PResultTag) where
+  type PTryFromExcess PData (PAsData PResultTag) = PTryFromExcess PData (PAsData PInteger)
+  ptryFrom' d k =
+    ptryFrom' @_ @(PAsData PInteger) d $
+      -- JUSTIFICATION:
+      -- We are coercing from @PAsData underlying@ to @PAsData (PTagged tag underlying)@.
+      -- Since 'PTagged' is a simple newtype, their shape is the same.
+      k . first punsafeCoerce
+
 -- | Plutarch-level version of 'PProposalId'.
 newtype PProposalId (s :: S) = PProposalId (Term s PInteger)
   deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalId PInteger)
 
+instance PTryFrom PData (PAsData PProposalId) where
+  type PTryFromExcess PData (PAsData PProposalId) = PTryFromExcess PData (PAsData PInteger)
+  ptryFrom' d k =
+    ptryFrom' @_ @(PAsData PInteger) d $
+      -- JUSTIFICATION:
+      -- We are coercing from @PAsData underlying@ to @PAsData (PTagged tag underlying)@.
+      -- Since 'PTagged' is a simple newtype, their shape is the same.
+      k . first punsafeCoerce
+
 instance PUnsafeLiftDecl PProposalId where type PLifted PProposalId = ProposalId
 deriving via
   (DerivePConstantViaNewtype ProposalId PProposalId PInteger)
@@ -280,6 +352,28 @@ newtype PProposalDatum (s :: S) = PProposalDatum
 instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
 deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstant ProposalDatum)
 
+-- | Haskell-level redeemer for Proposal scripts.
+data PProposalRedeemer (s :: S)
+  = PVote (Term s (PDataRecord '["resultTag" ':= PResultTag]))
+  | PCosign (Term s (PDataRecord '["newCosigners" ':= PBuiltinList (PAsData PPubKeyHash)]))
+  | PUnlock (Term s (PDataRecord '["resultTag" ':= PResultTag]))
+  | PAdvanceProposal (Term s (PDataRecord '[]))
+  deriving stock (GHC.Generic)
+  deriving anyclass (Generic)
+  deriving anyclass (PIsDataRepr)
+  deriving
+    (PlutusType, PIsData)
+    via PIsDataReprInstances PProposalRedeemer
+
+-- TODO: Waiting on PTryFrom for 'PPubKeyHash'
+-- deriving via
+--   PAsData (PIsDataReprInstances PProposalRedeemer)
+--   instance
+--     PTryFrom PData (PAsData PProposalRedeemer)
+
+instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer
+deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstant ProposalRedeemer)
+
 --------------------------------------------------------------------------------
 
 {- | Policy for Proposals.
diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs
index 8327d57..afaacb1 100644
--- a/agora/Agora/Stake.hs
+++ b/agora/Agora/Stake.hs
@@ -77,9 +77,10 @@ import Plutarch.Numeric
 import Plutarch.SafeMoney (
   PDiscrete,
   Tagged (..),
-  pdiscreteValue,
+  pdiscreteValue',
   untag,
  )
+import Plutarch.TryFrom (PTryFrom, ptryFrom)
 
 --------------------------------------------------------------------------------
 
@@ -205,7 +206,7 @@ data PStakeRedeemer (s :: S)
   | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
     PDestroy (Term s (PDataRecord '[]))
   | PPermitVote (Term s (PDataRecord '["lock" ':= PProposalLock]))
-  | PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList PProposalLock]))
+  | PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList (PAsData PProposalLock)]))
   deriving stock (GHC.Generic)
   deriving anyclass (Generic)
   deriving anyclass (PIsDataRepr)
@@ -213,6 +214,11 @@ data PStakeRedeemer (s :: S)
     (PlutusType, PIsData)
     via PIsDataReprInstances PStakeRedeemer
 
+deriving via
+  PAsData (PIsDataReprInstances PStakeRedeemer)
+  instance
+    PTryFrom PData (PAsData PStakeRedeemer)
+
 instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer
 deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstant StakeRedeemer)
 
@@ -233,6 +239,11 @@ newtype PProposalLock (s :: S) = PProposalLock
     (PlutusType, PIsData, PDataFields)
     via (PIsDataReprInstances PProposalLock)
 
+deriving via
+  PAsData (PIsDataReprInstances PProposalLock)
+  instance
+    PTryFrom PData (PAsData PProposalLock)
+
 instance PUnsafeLiftDecl PProposalLock where type PLifted PProposalLock = ProposalLock
 deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstant ProposalLock)
 
@@ -312,7 +323,7 @@ stakePolicy stake =
                             # 1
                     let expectedValue =
                           paddValue
-                            # (pdiscreteValue stake.gtClassRef # stakeDatum.stakedAmount)
+                            # (pdiscreteValue' stake.gtClassRef # stakeDatum.stakedAmount)
                             # stValue
                     let ownerSignsTransaction =
                           ptxSignedBy
@@ -352,10 +363,10 @@ stakeValidator stake =
     txInfo' <- plet ctx.txInfo
     txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo'
 
+    (pfromData -> stakeRedeemer, _) <- ptryFrom redeemer
+
     -- TODO: Use PTryFrom
-    let stakeRedeemer :: Term _ PStakeRedeemer
-        stakeRedeemer = pfromData $ punsafeCoerce redeemer
-        stakeDatum' :: Term _ PStakeDatum
+    let stakeDatum' :: Term _ PStakeDatum
         stakeDatum' = pfromData $ punsafeCoerce datum
     stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
 
@@ -425,7 +436,7 @@ stakeValidator stake =
                         -- do we need to check this, really?
                         zero #<= pfromData newStakeDatum.stakedAmount
                       ]
-              let expectedValue = paddValue # continuingValue # (pdiscreteValue stake.gtClassRef # delta)
+              let expectedValue = paddValue # continuingValue # (pdiscreteValue' stake.gtClassRef # delta)
 
               -- TODO: Same as above. This is quite inefficient now, as it does two lookups
               -- instead of a more efficient single pass,
diff --git a/flake.lock b/flake.lock
index 73e7d0d..0b23a54 100644
--- a/flake.lock
+++ b/flake.lock
@@ -1621,17 +1621,17 @@
         "validity": "validity"
       },
       "locked": {
-        "lastModified": 1648639396,
-        "narHash": "sha256-pAkEsIDXJckVYufVPUzD/4sq4/uE7iyV0IR2BuLhZjY=",
+        "lastModified": 1650025193,
+        "narHash": "sha256-SXfkWYse308SdnWO34cMVjKliDvyYYx++Y5uiuUmGXE=",
         "owner": "peter-mlabs",
         "repo": "plutarch",
-        "rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6",
+        "rev": "18e787d420912ed765fc5653c3558f20ab5e638a",
         "type": "github"
       },
       "original": {
         "owner": "peter-mlabs",
         "repo": "plutarch",
-        "rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6",
+        "rev": "18e787d420912ed765fc5653c3558f20ab5e638a",
         "type": "github"
       }
     },
diff --git a/flake.nix b/flake.nix
index 3b1756a..d51df25 100644
--- a/flake.nix
+++ b/flake.nix
@@ -9,7 +9,7 @@
 
   # Rev is this PR https://github.com/peter-mlabs/plutarch/pull/5.
   inputs.plutarch.url =
-    "github:peter-mlabs/plutarch?rev=a7a410da209b9c14c834a41e07b1c197c2a4dcd6";
+    "github:peter-mlabs/plutarch?rev=18e787d420912ed765fc5653c3558f20ab5e638a";
   inputs.plutarch.inputs.nixpkgs.follows =
     "plutarch/haskell-nix/nixpkgs-unstable";
 

From faf326f9c30c4cbae73e2c97040de69ba159b9c4 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Fri, 15 Apr 2022 22:22:22 +0200
Subject: [PATCH 54/78] implement Agora.Record, implement Agora.Proposal.Time

---
 agora.cabal                  |   3 +
 agora/Agora/Proposal.hs      |  11 +--
 agora/Agora/Proposal/Time.hs | 160 +++++++++++++++++++++++++++++++++++
 agora/Agora/Record.hs        |  67 +++++++++++++++
 4 files changed, 236 insertions(+), 5 deletions(-)
 create mode 100644 agora/Agora/Proposal/Time.hs
 create mode 100644 agora/Agora/Record.hs

diff --git a/agora.cabal b/agora.cabal
index c1729d0..bd07338 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -78,6 +78,7 @@ common lang
     UndecidableInstances
     ViewPatterns
     OverloadedRecordDot
+    OverloadedLabels
     QualifiedDo
 
   default-language:   Haskell2010
@@ -128,9 +129,11 @@ library
     Agora.Governor
     Agora.MultiSig
     Agora.Proposal
+    Agora.Proposal.Time
     Agora.SafeMoney
     Agora.Stake
     Agora.Treasury
+    Agora.Record
 
   other-modules:
     Agora.Utils
diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index d4b6c4d..5399e95 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -105,8 +105,9 @@ data ProposalStatus
     --   proposal will be able to be voted on.
     VotingReady
   | -- | The proposal has been voted on, and the votes have been locked
-    --   permanently. The proposal can now be executed.
-    Voted
+    --   permanently. The proposal now goes into a locking time after the
+    --   normal voting time. After this, it's possible to execute the proposal.
+    Locked
   | -- | The proposal has finished.
     --
     --   This can mean it's been voted on and completed, but it can also mean
@@ -121,7 +122,7 @@ data ProposalStatus
     Finished
   deriving stock (Eq, Show, GHC.Generic)
 
-PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Voted, 2), ('Finished, 3)]
+PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Locked, 2), ('Finished, 3)]
 
 {- | The threshold values for various state transitions to happen.
      This data is stored centrally (in the 'Agora.Governor.Governor') and copied over
@@ -198,12 +199,12 @@ data ProposalRedeemer
     --     1. The sum of all of the cosigner's GT is larger than the 'vote' field of 'ProposalThresholds'.
     --     2. The proposal hasn't been alive for longer than the review time.
     --
-    --   @'VotingReady' -> 'Voted'@:
+    --   @'VotingReady' -> 'Locked'@:
     --     1. The sum of all votes is larger than 'countVoting'.
     --     2. The winning 'ResultTag' has more votes than all other 'ResultTag's.
     --     3. The proposal hasn't been alive for longer than the voting time.
     --
-    --   @'Voted' -> 'Finished'@:
+    --   @'Locked' -> 'Finished'@:
     --     Always valid provided the conditions for the transition are met.
     --
     --   @* -> 'Finished'@:
diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs
new file mode 100644
index 0000000..7245dd0
--- /dev/null
+++ b/agora/Agora/Proposal/Time.hs
@@ -0,0 +1,160 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+{- |
+Module     : Agora.Proposal.Time
+Maintainer : emi@haskell.fyi
+Description: Time functions for proposal phases.
+
+Time functions for proposal phases.
+-}
+module Agora.Proposal.Time (
+  -- * Haskell-land
+  ProposalTime (..),
+  ProposalTimingConfig (..),
+  ProposalStartingTime (..),
+
+  -- * Plutarch-land
+  PProposalTime (..),
+  PProposalTimingConfig (..),
+  PProposalStartingTime (..),
+
+  -- * Compute ranges given config and starting time.
+  proposalDraftRange,
+
+  -- * Upstreamables
+  plowerBound,
+  pupperBound,
+  pstrictLowerBound,
+  pstrictUpperBound,
+) where
+
+import Agora.Record (build, (.&), (.=))
+import GHC.Generics qualified as GHC
+import Generics.SOP (Generic, I (I))
+import Plutarch.Api.V1 (PExtended (PFinite), PInterval (PInterval), PLowerBound (PLowerBound), PPOSIXTime, PPOSIXTimeRange, PUpperBound (PUpperBound))
+import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..))
+import Plutarch.Numeric (AdditiveSemigroup ((+)))
+import Plutarch.Unsafe (punsafeCoerce)
+import Plutus.V1.Ledger.Time (POSIXTime, POSIXTimeRange)
+import PlutusTx qualified
+import Prelude hiding ((+))
+
+--------------------------------------------------------------------------------
+
+-- | Represents the current time, as far as the proposal is concerned.
+newtype ProposalTime = ProposalTime
+  { getProposalTime :: POSIXTimeRange
+  }
+  deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
+  deriving stock (Eq, Show, GHC.Generic)
+
+-- | Represents the starting time of the proposal.
+newtype ProposalStartingTime = ProposalStartingTime
+  { getProposalStartingTime :: POSIXTime
+  }
+  deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
+  deriving stock (Eq, Show, GHC.Generic)
+
+-- | Configuration of proposal timings.
+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 (Eq, Show, GHC.Generic)
+
+PlutusTx.makeIsDataIndexed ''ProposalTimingConfig [('ProposalTimingConfig, 0)]
+
+--------------------------------------------------------------------------------
+
+-- | Plutarch-level version of 'ProposalTime'.
+newtype PProposalTime (s :: S) = PProposalTime (Term s PPOSIXTime)
+  deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalTime PPOSIXTime)
+
+-- | Plutarch-level version of 'ProposalStartingTime'.
+newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime)
+  deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalStartingTime PPOSIXTime)
+
+-- | Plutarch-level version of 'ProposalTimingConfig'.
+newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
+  { getProposalTimingConfig ::
+    Term
+      s
+      ( PDataRecord
+          '[ "draftTime" ':= PPOSIXTime
+           , "votingTime" ':= PPOSIXTime
+           , "lockingTime" ':= PPOSIXTime
+           , "executingTime" ':= PPOSIXTime
+           ]
+      )
+  }
+  deriving stock (GHC.Generic)
+  deriving anyclass (Generic)
+  deriving anyclass (PIsDataRepr)
+  deriving
+    (PlutusType, PIsData, PDataFields)
+    via (PIsDataReprInstances PProposalTimingConfig)
+
+--------------------------------------------------------------------------------
+
+-- -- Need to move these away from here
+pstrictLowerBound :: PIsData a => Term s (a :--> PLowerBound a)
+pstrictLowerBound = phoistAcyclic $
+  plam $ \a ->
+    pcon
+      ( PLowerBound $
+          build $
+            #_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a))
+              .& #_1 .= pdata (pcon PFalse)
+      )
+
+pstrictUpperBound :: PIsData a => Term s (a :--> PUpperBound a)
+pstrictUpperBound = phoistAcyclic $
+  plam $ \a ->
+    pcon
+      ( PUpperBound $
+          build $
+            #_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a))
+              .& #_1 .= pdata (pcon PFalse)
+      )
+
+plowerBound :: PIsData a => Term s (a :--> PLowerBound a)
+plowerBound = phoistAcyclic $
+  plam $ \a ->
+    pcon
+      ( PLowerBound $
+          build $
+            #_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a))
+              .& #_1 .= pdata (pcon PTrue)
+      )
+
+pupperBound :: PIsData a => Term s (a :--> PUpperBound a)
+pupperBound = phoistAcyclic $
+  plam $ \a ->
+    pcon
+      ( PUpperBound $
+          build $
+            #_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a))
+              .& #_1 .= pdata (pcon PTrue)
+      )
+
+-- Move this to plutarch-extra.
+instance AdditiveSemigroup (Term s PPOSIXTime) where
+  (punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y
+
+-- | Compute the range of time during which cosigning is legal.
+proposalDraftRange :: Term s (PPOSIXTime :--> PProposalTimingConfig :--> PPOSIXTimeRange)
+proposalDraftRange = phoistAcyclic $
+  plam $ \s config ->
+    pcon
+      ( PInterval $
+          build $
+            #from .= pdata (pstrictLowerBound # s)
+              .& #to .= pdata (pstrictUpperBound #$ s + pfield @"draftTime" # config)
+      )
diff --git a/agora/Agora/Record.hs b/agora/Agora/Record.hs
new file mode 100644
index 0000000..3cd0723
--- /dev/null
+++ b/agora/Agora/Record.hs
@@ -0,0 +1,67 @@
+{- |
+Module     : Agora.Record
+Maintainer : emi@haskell.fyi
+Description: PDataRecord helper functions.
+
+PDataRecord helper functions.
+-}
+module Agora.Record (build, (.=), (.&)) where
+
+import Control.Category (Category (..))
+import Data.Coerce (coerce)
+import GHC.OverloadedLabels (IsLabel (fromLabel))
+import GHC.TypeLits (Symbol)
+import Plutarch.DataRepr (PDataRecord (PDCons))
+import Prelude hiding (id, (.))
+
+-- | Like 'Data.Proxy.Proxy' but local to this module.
+data FieldName (sym :: Symbol) = FieldName
+
+{- | The use of two different 'Symbol's here allows unification to happen,
+     ensuring 'FieldName' has a fully inferred 'Symbol'.
+
+     For example, @'build' (#foo .= 'pconstantData' (42 :: 'Integer'))@ gets
+     the correct type. Namely, @'Term' s ('PDataRecord' '["foo" ':= 'PInteger'])@.
+-}
+instance forall (sym :: Symbol) (sym' :: Symbol). sym ~ sym' => IsLabel sym (FieldName sym') where
+  fromLabel = FieldName
+
+-- | Turn a builder into a fully built 'PDataRecord'.
+build :: forall (s :: S) (r :: [PLabeledType]). RecordMorphism s '[] r -> Term s (PDataRecord r)
+build f = coerce f pdnil
+
+-- | A morphism from one PDataRecord to another, representing some sort of consing of data.
+newtype RecordMorphism (s :: S) (as :: [PLabeledType]) (bs :: [PLabeledType]) = RecordMorphism
+  { runRecordMorphism ::
+    Term s (PDataRecord as) ->
+    Term s (PDataRecord bs)
+  }
+
+instance Category (RecordMorphism s) where
+  id = RecordMorphism id
+  f . g = coerce $ f.runRecordMorphism . g.runRecordMorphism
+
+infix 7 .=
+
+-- | Cons a labeled type as a 'RecordMorphism'.
+(.=) ::
+  forall (sym :: Symbol) (a :: PType) (as :: [PLabeledType]) (s :: S).
+  FieldName sym ->
+  Term s (PAsData a) ->
+  ( RecordMorphism s as ((sym ':= a) ': as)
+  )
+_ .= x = RecordMorphism $ pcon . PDCons x
+
+infixr 6 .&
+
+-- | Compose two morphisms between records.
+(.&) ::
+  forall
+    (s :: S)
+    (a :: [PLabeledType])
+    (b :: [PLabeledType])
+    (c :: [PLabeledType]).
+  (RecordMorphism s b c) ->
+  (RecordMorphism s a b) ->
+  (RecordMorphism s a c)
+(.&) = (.)

From 12fc16390b091fee5bae608c1f1d02d1768eab7b Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Mon, 18 Apr 2022 13:52:01 +0200
Subject: [PATCH 55/78] add 'isDraftRange' checking function.

---
 agora/Agora/Proposal.hs      |  32 ++++---
 agora/Agora/Proposal/Time.hs | 158 +++++++++++++++++++++--------------
 2 files changed, 113 insertions(+), 77 deletions(-)

diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index 5399e95..5252f0f 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -11,6 +11,7 @@ module Agora.Proposal (
   -- * Haskell-land
   Proposal (..),
   ProposalDatum (..),
+  ProposalRedeemer (..),
   ProposalStatus (..),
   ProposalThresholds (..),
   ProposalVotes (..),
@@ -19,6 +20,7 @@ module Agora.Proposal (
 
   -- * Plutarch-land
   PProposalDatum (..),
+  PProposalRedeemer (..),
   PProposalStatus (..),
   PProposalThresholds (..),
   PProposalVotes (..),
@@ -182,12 +184,12 @@ PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)]
 data ProposalRedeemer
   = -- | Cast one or more votes towards a particular 'ResultTag'.
     Vote ResultTag
-  | -- | Add one or more public keys to the cosignature list. Must be signed by
-    --   those cosigning.
+  | -- | 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
-    --   'Stake's can be called to advance the proposal, provided enough GT is shared
-    --   among them.
+    --   This is particularly used in the 'Draft' 'ProposalStatus',
+    --   where matching 'Stake's can be called to advance the proposal,
+    --   provided enough GT is shared  among them.
     Cosign [PubKeyHash]
   | -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'.
     Unlock ResultTag
@@ -195,19 +197,23 @@ data ProposalRedeemer
     --
     --   These are roughly the checks for each possible transition:
     --
-    --   @'Draft' -> 'VotingReady'@:
+    --   === @'Draft' -> 'VotingReady'@:
+    --
     --     1. The sum of all of the cosigner's GT is larger than the 'vote' field of 'ProposalThresholds'.
     --     2. The proposal hasn't been alive for longer than the review time.
     --
-    --   @'VotingReady' -> 'Locked'@:
+    --   === @'VotingReady' -> 'Locked'@:
+    --
     --     1. The sum of all votes is larger than 'countVoting'.
     --     2. The winning 'ResultTag' has more votes than all other 'ResultTag's.
     --     3. The proposal hasn't been alive for longer than the voting time.
     --
-    --   @'Locked' -> 'Finished'@:
+    --   === @'Locked' -> 'Finished'@:
+    --
     --     Always valid provided the conditions for the transition are met.
     --
-    --   @* -> 'Finished'@:
+    --   === @* -> 'Finished'@:
+    --
     --     If the proposal has run out of time for the current 'ProposalStatus', it will always be possible
     --     to transition into 'Finished' state, because it has expired (and failed).
     AdvanceProposal
@@ -221,10 +227,10 @@ PlutusTx.makeIsDataIndexed
   , ('AdvanceProposal, 3)
   ]
 
-{- | Identifies a Proposal, issued upon creation of a proposal.
-     In practice, this number starts at zero, and increments by one
-     for each proposal. The 100th proposal will be @'ProposalId' 99@.
-     This counter lives in the 'Governor', see 'nextProposalId'.
+{- | Identifies a Proposal, issued upon creation of a proposal. In practice,
+     this number starts at zero, and increments by one for each proposal.
+     The 100th proposal will be @'ProposalId' 99@. This counter lives
+     in the 'Agora.Governor.Governor', see 'Agora.Governor.nextProposalId'.
 -}
 newtype ProposalId = ProposalId {proposalTag :: Integer}
   deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs
index 7245dd0..952b8dd 100644
--- a/agora/Agora/Proposal/Time.hs
+++ b/agora/Agora/Proposal/Time.hs
@@ -20,35 +20,53 @@ module Agora.Proposal.Time (
   PProposalStartingTime (..),
 
   -- * Compute ranges given config and starting time.
-  proposalDraftRange,
-
-  -- * Upstreamables
-  plowerBound,
-  pupperBound,
-  pstrictLowerBound,
-  pstrictUpperBound,
+  currentProposalTime,
+  isDraftRange,
 ) where
 
 import Agora.Record (build, (.&), (.=))
 import GHC.Generics qualified as GHC
 import Generics.SOP (Generic, I (I))
-import Plutarch.Api.V1 (PExtended (PFinite), PInterval (PInterval), PLowerBound (PLowerBound), PPOSIXTime, PPOSIXTimeRange, PUpperBound (PUpperBound))
+import Plutarch.Api.V1 (PExtended (PFinite), PInterval (PInterval), PLowerBound (PLowerBound), PMaybeData (PDJust, PDNothing), PPOSIXTime, PPOSIXTimeRange, PUpperBound (PUpperBound))
 import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..))
+import Plutarch.Monadic qualified as P
 import Plutarch.Numeric (AdditiveSemigroup ((+)))
 import Plutarch.Unsafe (punsafeCoerce)
-import Plutus.V1.Ledger.Time (POSIXTime, POSIXTimeRange)
+import Plutus.V1.Ledger.Time (POSIXTime)
 import PlutusTx qualified
 import Prelude hiding ((+))
 
 --------------------------------------------------------------------------------
 
--- | Represents the current time, as far as the proposal is concerned.
-newtype ProposalTime = ProposalTime
-  { getProposalTime :: POSIXTimeRange
+{- | == Establishing timing in Proposal interactions.
+
+   In Plutus, it's impossible to determine time exactly. It's also impossible
+   to get a single point in time, yet often we need to check
+   various constraints on time.
+
+   For the purposes of proposals, there's a single most important feature:
+   The ability to determine if we can perform an action. In order to correctly
+   determine if we are able to perform certain actions, we need to know what
+   time it roughly is, compared to when the proposal got created.
+
+   'ProposalTime' represents "the time according to the proposal".
+   Its representation is opaque, and doesn't matter.
+
+   Various functions work simply on 'ProposalTime' and 'ProposalTimingConfig'.
+   In particular, 'currentProposalTime' is useful for extracting the time
+   from the 'Plutus.V1.Ledger.Api.txInfoValidRange' field
+   of 'Plutus.V1.Ledger.Api.TxInfo'.
+
+   We avoid 'PPOSIXTimeRange' where we can in order to save on operations.
+-}
+data ProposalTime = ProposalTime
+  { lowerBound :: Maybe POSIXTime
+  , upperBound :: Maybe POSIXTime
   }
-  deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
   deriving stock (Eq, Show, GHC.Generic)
 
+PlutusTx.makeIsDataIndexed ''ProposalTime [('ProposalTime, 0)]
+
 -- | Represents the starting time of the proposal.
 newtype ProposalStartingTime = ProposalStartingTime
   { getProposalStartingTime :: POSIXTime
@@ -74,8 +92,22 @@ PlutusTx.makeIsDataIndexed ''ProposalTimingConfig [('ProposalTimingConfig, 0)]
 --------------------------------------------------------------------------------
 
 -- | Plutarch-level version of 'ProposalTime'.
-newtype PProposalTime (s :: S) = PProposalTime (Term s PPOSIXTime)
-  deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalTime PPOSIXTime)
+newtype PProposalTime (s :: S)
+  = PProposalTime
+      ( Term
+          s
+          ( PDataRecord
+              '[ "lowerBound" ':= PMaybeData PPOSIXTime
+               , "upperBound" ':= PMaybeData PPOSIXTime
+               ]
+          )
+      )
+  deriving stock (GHC.Generic)
+  deriving anyclass (Generic)
+  deriving anyclass (PIsDataRepr)
+  deriving
+    (PlutusType, PIsData, PDataFields)
+    via (PIsDataReprInstances PProposalTime)
 
 -- | Plutarch-level version of 'ProposalStartingTime'.
 newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime)
@@ -103,58 +135,56 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
 
 --------------------------------------------------------------------------------
 
--- -- Need to move these away from here
-pstrictLowerBound :: PIsData a => Term s (a :--> PLowerBound a)
-pstrictLowerBound = phoistAcyclic $
-  plam $ \a ->
-    pcon
-      ( PLowerBound $
-          build $
-            #_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a))
-              .& #_1 .= pdata (pcon PFalse)
-      )
-
-pstrictUpperBound :: PIsData a => Term s (a :--> PUpperBound a)
-pstrictUpperBound = phoistAcyclic $
-  plam $ \a ->
-    pcon
-      ( PUpperBound $
-          build $
-            #_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a))
-              .& #_1 .= pdata (pcon PFalse)
-      )
-
-plowerBound :: PIsData a => Term s (a :--> PLowerBound a)
-plowerBound = phoistAcyclic $
-  plam $ \a ->
-    pcon
-      ( PLowerBound $
-          build $
-            #_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a))
-              .& #_1 .= pdata (pcon PTrue)
-      )
-
-pupperBound :: PIsData a => Term s (a :--> PUpperBound a)
-pupperBound = phoistAcyclic $
-  plam $ \a ->
-    pcon
-      ( PUpperBound $
-          build $
-            #_0 .= pdata (pcon (PFinite $ build $ #_0 .= pdata a))
-              .& #_1 .= pdata (pcon PTrue)
-      )
-
--- Move this to plutarch-extra.
+-- FIXME: Orphan instance, move this to plutarch-extra.
 instance AdditiveSemigroup (Term s PPOSIXTime) where
   (punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y
 
--- | Compute the range of time during which cosigning is legal.
-proposalDraftRange :: Term s (PPOSIXTime :--> PProposalTimingConfig :--> PPOSIXTimeRange)
-proposalDraftRange = phoistAcyclic $
-  plam $ \s config ->
+-- | Get the current proposal time, from the 'txInfoValidRange' field.
+currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime)
+currentProposalTime = phoistAcyclic $
+  plam $ \iv -> P.do
+    PInterval iv' <- pmatch iv
+    ivf <- pletFields @'["from", "to"] iv'
+    PLowerBound lb <- pmatch ivf.from
+    PUpperBound ub <- pmatch ivf.to
+    lbf <- pletFields @'["_0", "_1"] lb
+    ubf <- pletFields @'["_0", "_1"] ub
     pcon
-      ( PInterval $
+      ( PProposalTime $
           build $
-            #from .= pdata (pstrictLowerBound # s)
-              .& #to .= pdata (pstrictUpperBound #$ s + pfield @"draftTime" # config)
+            #lowerBound
+              .= pdata
+                ( pmatch lbf._0 $
+                    \case
+                      PFinite d -> pcon (PDJust d)
+                      _ -> pcon (PDNothing pdnil)
+                )
+              .& #upperBound
+              .= pdata
+                ( pmatch ubf._0 $ \case
+                    PFinite d -> pcon (PDJust d)
+                    _ -> pcon (PDNothing pdnil)
+                )
       )
+
+-- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
+proposalTimeWithin :: Term s (PPOSIXTime :--> PPOSIXTime :--> PProposalTime :--> PBool)
+proposalTimeWithin = phoistAcyclic $
+  plam $ \l h proposalTime' -> P.do
+    PProposalTime proposalTime <- pmatch proposalTime'
+    ptf <- pletFields @'["lowerBound", "upperBound"] proposalTime
+    foldr1
+      (#&&)
+      [ pmatch ptf.lowerBound $ \case
+          PDJust lb -> l #<= pfromData (pfield @"_0" # lb)
+          _ -> pcon PFalse
+      , pmatch ptf.upperBound $ \case
+          PDJust lb -> pfromData (pfield @"_0" # lb) #<= h
+          _ -> pcon PFalse
+      ]
+
+-- | True if the 'PProposalTime' is in the draft period.
+isDraftRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool)
+isDraftRange = phoistAcyclic $
+  plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
+    proposalTimeWithin # s # (s + pfield @"draftTime" # config)

From f79f85b2c0b6fb26221a0d1b3ef690ee9746b831 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Mon, 18 Apr 2022 16:26:34 +0200
Subject: [PATCH 56/78] add proposalCreation Sample test

---
 agora-test/Spec.hs                 |   4 +
 agora-test/Spec/Proposal.hs        |  38 ++++++
 agora-test/Spec/Sample/Proposal.hs | 198 +++++++++++++++++++++++++++++
 agora-test/Spec/Stake.hs           |   5 +-
 agora.cabal                        |   2 +
 agora/Agora/Governor.hs            |   7 +
 agora/Agora/Proposal.hs            |  25 ++--
 7 files changed, 267 insertions(+), 12 deletions(-)
 create mode 100644 agora-test/Spec/Proposal.hs
 create mode 100644 agora-test/Spec/Sample/Proposal.hs

diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs
index 40a7b7f..22c5b49 100644
--- a/agora-test/Spec.hs
+++ b/agora-test/Spec.hs
@@ -11,6 +11,7 @@ import Test.Tasty (defaultMain, testGroup)
 import Spec.AuthorityToken qualified as AuthorityToken
 import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal
 import Spec.Model.MultiSig qualified as MultiSig
+import Spec.Proposal qualified as Proposal
 import Spec.Stake qualified as Stake
 
 -- | The Agora test suite.
@@ -28,6 +29,9 @@ main =
       , testGroup
           "Stake tests"
           Stake.tests
+      , testGroup
+          "Proposal tests"
+          Proposal.tests
       , testGroup
           "Multisig tests"
           [ testGroup
diff --git a/agora-test/Spec/Proposal.hs b/agora-test/Spec/Proposal.hs
new file mode 100644
index 0000000..4d3c4e3
--- /dev/null
+++ b/agora-test/Spec/Proposal.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+{- |
+Module     : Spec.Proposal
+Maintainer : emi@haskell.fyi
+Description: Tests for Proposal policy and validator
+
+Tests for Proposal policy and validator
+-}
+module Spec.Proposal (tests) where
+
+--------------------------------------------------------------------------------
+
+--------------------------------------------------------------------------------
+
+import Agora.Proposal (proposalPolicy)
+import Spec.Sample.Proposal qualified as Proposal
+import Spec.Util (policySucceedsWith)
+import Test.Tasty (TestTree, testGroup)
+
+--------------------------------------------------------------------------------
+
+--------------------------------------------------------------------------------
+
+--------------------------------------------------------------------------------
+
+-- | Stake tests.
+tests :: [TestTree]
+tests =
+  [ testGroup
+      "policy"
+      [ policySucceedsWith
+          "stakeCreation"
+          (proposalPolicy Proposal.proposal)
+          ()
+          Proposal.proposalCreation
+      ]
+  ]
diff --git a/agora-test/Spec/Sample/Proposal.hs b/agora-test/Spec/Sample/Proposal.hs
new file mode 100644
index 0000000..ba4a3bb
--- /dev/null
+++ b/agora-test/Spec/Sample/Proposal.hs
@@ -0,0 +1,198 @@
+{- |
+Module     : Spec.Sample.Proposal
+Maintainer : emi@haskell.fyi
+Description: Sample based testing for Proposal utxos
+
+This module tests primarily the happy path for Proposal interactions
+-}
+module Spec.Sample.Proposal (
+  proposal,
+  policy,
+  policySymbol,
+  validatorHashTN,
+  signer,
+
+  -- * Script contexts
+  proposalCreation,
+) where
+
+--------------------------------------------------------------------------------
+import Plutarch.Api.V1 (
+  mintingPolicySymbol,
+  mkMintingPolicy,
+  mkValidator,
+  validatorHash,
+ )
+import Plutus.V1.Ledger.Api (
+  Address (Address),
+  Credential (ScriptCredential),
+  CurrencySymbol,
+  Datum (Datum),
+  MintingPolicy (..),
+  PubKeyHash,
+  ScriptContext (..),
+  ScriptPurpose (..),
+  ToData (toBuiltinData),
+  TxInInfo (TxInInfo),
+  TxInfo (..),
+  TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue),
+  TxOutRef (TxOutRef),
+  ValidatorHash (ValidatorHash),
+ )
+import Plutus.V1.Ledger.Interval qualified as Interval
+import Plutus.V1.Ledger.Scripts (Validator)
+import Plutus.V1.Ledger.Value (AssetClass (AssetClass), TokenName (TokenName))
+import Plutus.V1.Ledger.Value qualified as Value
+
+--------------------------------------------------------------------------------
+
+import Agora.Governor (
+  Governor (Governor),
+  GovernorDatum (GovernorDatum, nextProposalId, proposalThresholds),
+  governorPolicy,
+  governorValidator,
+ )
+import Agora.Proposal
+import Plutarch.SafeMoney
+import PlutusTx.AssocMap qualified as AssocMap
+import Spec.Util (datumPair, toDatumHash)
+
+--------------------------------------------------------------------------------
+
+governor :: Governor
+governor = Governor
+
+govPolicy :: MintingPolicy
+govPolicy = mkMintingPolicy (governorPolicy governor)
+
+govValidator :: Validator
+govValidator = mkValidator (governorValidator governor)
+
+govSymbol :: CurrencySymbol
+govSymbol = mintingPolicySymbol govPolicy
+
+proposal :: Proposal
+proposal =
+  Proposal
+    { governorSTAssetClass =
+        -- TODO: if we had a governor here
+        AssetClass
+          ( govSymbol
+          , ""
+          )
+    }
+
+-- | 'Proposal' policy instance.
+policy :: MintingPolicy
+policy = mkMintingPolicy (proposalPolicy proposal)
+
+policySymbol :: CurrencySymbol
+policySymbol = mintingPolicySymbol policy
+
+-- | A sample 'PubKeyHash'.
+signer :: PubKeyHash
+signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
+
+-- | 'Proposal' validator instance.
+validator :: Validator
+validator = mkValidator (proposalValidator proposal)
+
+-- | 'TokenName' that represents the hash of the 'Proposal' validator.
+validatorHashTN :: TokenName
+validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
+
+propThresholds :: ProposalThresholds
+propThresholds =
+  ProposalThresholds
+    { countVoting = Tagged 1000
+    , create = Tagged 1
+    , vote = Tagged 10
+    }
+
+-- | This script context should be a valid transaction.
+proposalCreation :: ScriptContext
+proposalCreation =
+  let st = Value.singleton policySymbol "" 1 -- Proposal ST
+      proposalDatum :: Datum
+      proposalDatum =
+        Datum
+          ( toBuiltinData $
+              ProposalDatum
+                { proposalId = ProposalId 0
+                , effects =
+                    AssocMap.fromList
+                      [ (ResultTag 0, [])
+                      , (ResultTag 1, [])
+                      ]
+                , status = Draft
+                , cosigners = [signer]
+                , thresholds = propThresholds
+                , votes = ProposalVotes $ AssocMap.empty
+                }
+          )
+
+      govBefore :: Datum
+      govBefore =
+        Datum
+          ( toBuiltinData $
+              GovernorDatum
+                { proposalThresholds = propThresholds
+                , nextProposalId = ProposalId 0
+                }
+          )
+      govAfter :: Datum
+      govAfter =
+        Datum
+          ( toBuiltinData $
+              GovernorDatum
+                { proposalThresholds = propThresholds
+                , nextProposalId = ProposalId 1
+                }
+          )
+   in ScriptContext
+        { scriptContextTxInfo =
+            TxInfo
+              { txInfoInputs =
+                  [ TxInInfo
+                      (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+                      TxOut
+                        { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                        , txOutValue = Value.assetClassValue proposal.governorSTAssetClass 1
+                        , txOutDatumHash = Just (toDatumHash govBefore)
+                        }
+                  ]
+              , txInfoOutputs =
+                  [ TxOut
+                      { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                      , txOutValue =
+                          mconcat
+                            [ st
+                            , Value.singleton "" "" 10_000_000
+                            ]
+                      , txOutDatumHash = Just (toDatumHash proposalDatum)
+                      }
+                  , TxOut
+                      { txOutAddress = Address (ScriptCredential $ validatorHash govValidator) Nothing
+                      , txOutValue =
+                          mconcat
+                            [ Value.assetClassValue proposal.governorSTAssetClass 1
+                            , Value.singleton "" "" 10_000_000
+                            ]
+                      , txOutDatumHash = Just (toDatumHash govAfter)
+                      }
+                  ]
+              , txInfoFee = Value.singleton "" "" 2
+              , txInfoMint = st
+              , txInfoDCert = []
+              , txInfoWdrl = []
+              , txInfoValidRange = Interval.always
+              , txInfoSignatories = [signer]
+              , txInfoData =
+                  [ datumPair proposalDatum
+                  , datumPair govBefore
+                  , datumPair govAfter
+                  ]
+              , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+              }
+        , scriptContextPurpose = Minting policySymbol
+        }
diff --git a/agora-test/Spec/Stake.hs b/agora-test/Spec/Stake.hs
index 8f2538d..2513bab 100644
--- a/agora-test/Spec/Stake.hs
+++ b/agora-test/Spec/Stake.hs
@@ -49,7 +49,10 @@ tests =
           (stakePolicy Stake.stake)
           ()
           Stake.stakeCreationUnsigned
-      , validatorSucceedsWith
+      ]
+  , testGroup
+      "validator"
+      [ validatorSucceedsWith
           "stakeDepositWithdraw deposit"
           (stakeValidator Stake.stake)
           (toDatum $ StakeDatum 100_000 signer [])
diff --git a/agora.cabal b/agora.cabal
index bd07338..df30ebb 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -162,6 +162,8 @@ test-suite agora-test
     Spec.Sample.Effect.TreasuryWithdrawal
     Spec.Sample.Stake
     Spec.Stake
+    Spec.Sample.Proposal
+    Spec.Proposal
     Spec.Util
 
   build-depends:  agora
diff --git a/agora/Agora/Governor.hs b/agora/Agora/Governor.hs
index 8f12181..7a47865 100644
--- a/agora/Agora/Governor.hs
+++ b/agora/Agora/Governor.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 {- |
 Module     : Agora.Governor
 Maintainer : emi@haskell.fyi
@@ -21,6 +23,7 @@ module Agora.Governor (
 import Agora.Proposal (ProposalId, ProposalThresholds)
 import Plutarch (popaque)
 import Plutarch.Api.V1 (PMintingPolicy, PValidator)
+import PlutusTx qualified
 
 -- | Datum for the Governor script.
 data GovernorDatum = GovernorDatum
@@ -30,6 +33,8 @@ data GovernorDatum = GovernorDatum
   -- ^ What tag the next proposal will get upon creating.
   }
 
+PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)]
+
 {- | Redeemer for Governor script. The governor has two primary
      responsibilities:
 
@@ -43,6 +48,8 @@ data GovernorRedeemer
     --   and allows minting GATs for each effect script.
     MintGATs
 
+PlutusTx.makeIsDataIndexed ''GovernorRedeemer [('CreateProposal, 0), ('MintGATs, 1)]
+
 -- | Parameters for creating Governor scripts.
 data Governor
   = Governor
diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index 5252f0f..a32b283 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -73,6 +73,15 @@ import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
 --------------------------------------------------------------------------------
 -- Haskell-land
 
+{- | Identifies a Proposal, issued upon creation of a proposal. In practice,
+     this number starts at zero, and increments by one for each proposal.
+     The 100th proposal will be @'ProposalId' 99@. This counter lives
+     in the 'Agora.Governor.Governor', see 'Agora.Governor.nextProposalId'.
+-}
+newtype ProposalId = ProposalId {proposalTag :: Integer}
+  deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
+  deriving stock (Eq, Show, GHC.Generic)
+
 {- | Encodes a result. Typically, for a Yes/No proposal, we encode it like this:
 
 @
@@ -162,7 +171,9 @@ newtype ProposalVotes = ProposalVotes
 
 -- | Haskell-level datum for Proposal scripts.
 data ProposalDatum = ProposalDatum
-  { -- TODO: could we encode this more efficiently?
+  { proposalId :: ProposalId
+  -- ^ 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 :: AssocMap.Map ResultTag [(ValidatorHash, DatumHash)]
@@ -227,15 +238,6 @@ PlutusTx.makeIsDataIndexed
   , ('AdvanceProposal, 3)
   ]
 
-{- | Identifies a Proposal, issued upon creation of a proposal. In practice,
-     this number starts at zero, and increments by one for each proposal.
-     The 100th proposal will be @'ProposalId' 99@. This counter lives
-     in the 'Agora.Governor.Governor', see 'Agora.Governor.nextProposalId'.
--}
-newtype ProposalId = ProposalId {proposalTag :: Integer}
-  deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
-  deriving stock (Eq, Show, GHC.Generic)
-
 -- | Parameters that identify the Proposal validator script.
 data Proposal = Proposal
   { governorSTAssetClass :: AssetClass
@@ -341,7 +343,8 @@ newtype PProposalDatum (s :: S) = PProposalDatum
     Term
       s
       ( PDataRecord
-          '[ "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash)
+          '[ "id" ':= PProposalId
+           , "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash)
            , "status" ':= PProposalStatus
            , "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
            , "thresholds" ':= PProposalThresholds

From eba9ce452e267c77607da9ff5e9696c4931c374d Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Tue, 19 Apr 2022 11:07:11 +0200
Subject: [PATCH 57/78] fix linter errors

---
 agora-test/Spec/Sample/Proposal.hs | 4 ++--
 agora.cabal                        | 8 ++++----
 agora/Agora/Proposal.hs            | 2 +-
 agora/Agora/Record.hs              | 6 +++---
 agora/Agora/Utils.hs               | 3 ++-
 5 files changed, 12 insertions(+), 11 deletions(-)

diff --git a/agora-test/Spec/Sample/Proposal.hs b/agora-test/Spec/Sample/Proposal.hs
index ba4a3bb..9b464cb 100644
--- a/agora-test/Spec/Sample/Proposal.hs
+++ b/agora-test/Spec/Sample/Proposal.hs
@@ -127,7 +127,7 @@ proposalCreation =
                 , status = Draft
                 , cosigners = [signer]
                 , thresholds = propThresholds
-                , votes = ProposalVotes $ AssocMap.empty
+                , votes = ProposalVotes AssocMap.empty
                 }
           )
 
@@ -156,7 +156,7 @@ proposalCreation =
                   [ TxInInfo
                       (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
                       TxOut
-                        { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                        { txOutAddress = Address (ScriptCredential $ validatorHash govValidator) Nothing
                         , txOutValue = Value.assetClassValue proposal.governorSTAssetClass 1
                         , txOutDatumHash = Just (toDatumHash govBefore)
                         }
diff --git a/agora.cabal b/agora.cabal
index df30ebb..6500ad6 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -60,6 +60,7 @@ common lang
     NamedFieldPuns
     NamedWildCards
     NumericUnderscores
+    OverloadedLabels
     OverloadedStrings
     PartialTypeSignatures
     PatternGuards
@@ -78,7 +79,6 @@ common lang
     UndecidableInstances
     ViewPatterns
     OverloadedRecordDot
-    OverloadedLabels
     QualifiedDo
 
   default-language:   Haskell2010
@@ -130,10 +130,10 @@ library
     Agora.MultiSig
     Agora.Proposal
     Agora.Proposal.Time
+    Agora.Record
     Agora.SafeMoney
     Agora.Stake
     Agora.Treasury
-    Agora.Record
 
   other-modules:
     Agora.Utils
@@ -159,11 +159,11 @@ test-suite agora-test
     Spec.AuthorityToken
     Spec.Effect.TreasuryWithdrawal
     Spec.Model.MultiSig
+    Spec.Proposal
     Spec.Sample.Effect.TreasuryWithdrawal
+    Spec.Sample.Proposal
     Spec.Sample.Stake
     Spec.Stake
-    Spec.Sample.Proposal
-    Spec.Proposal
     Spec.Util
 
   build-depends:  agora
diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index a32b283..bd73e76 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -239,7 +239,7 @@ PlutusTx.makeIsDataIndexed
   ]
 
 -- | Parameters that identify the Proposal validator script.
-data Proposal = Proposal
+newtype Proposal = Proposal
   { governorSTAssetClass :: AssetClass
   }
   deriving stock (Show, Eq)
diff --git a/agora/Agora/Record.hs b/agora/Agora/Record.hs
index 3cd0723..a5dfe35 100644
--- a/agora/Agora/Record.hs
+++ b/agora/Agora/Record.hs
@@ -61,7 +61,7 @@ infixr 6 .&
     (a :: [PLabeledType])
     (b :: [PLabeledType])
     (c :: [PLabeledType]).
-  (RecordMorphism s b c) ->
-  (RecordMorphism s a b) ->
-  (RecordMorphism s a c)
+  RecordMorphism s b c ->
+  RecordMorphism s a b ->
+  RecordMorphism s a c
 (.&) = (.)
diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index 58c350a..ed86334 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -415,7 +415,8 @@ ptokenSpent =
   plam $ \tokenClass inputs ->
     0
       #< pfoldr @PBuiltinList
-        # ( plam $ \txInInfo' acc -> P.do
+        # plam
+          ( \txInInfo' acc -> P.do
               PTxInInfo txInInfo <- pmatch (pfromData txInInfo')
               PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo
               txOut <- pletFields @'["value"] txOut'

From e77140e86333c4d473e6d68771853a7995dc408d Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Tue, 19 Apr 2022 14:16:31 +0200
Subject: [PATCH 58/78] stub redeemer matching

---
 agora/Agora/Proposal.hs | 42 +++++++++++++++++++++++++++++++++++++----
 1 file changed, 38 insertions(+), 4 deletions(-)

diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index bd73e76..aaca9a1 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -45,6 +45,8 @@ import Plutarch.Api.V1 (
   PTxInfo (PTxInfo),
   PValidator,
   PValidatorHash,
+  mintingPolicySymbol,
+  mkMintingPolicy,
  )
 import Plutarch.DataRepr (
   DerivePConstantViaData (..),
@@ -58,7 +60,7 @@ import PlutusTx.AssocMap qualified as AssocMap
 --------------------------------------------------------------------------------
 
 import Agora.SafeMoney (GTTag)
-import Agora.Utils (passert, pnotNull, ptokenSpent)
+import Agora.Utils (passert, pnotNull, psymbolValueOf, ptokenSpent, pvalueSpent)
 import Control.Arrow (first)
 import Plutarch (popaque)
 import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
@@ -422,14 +424,46 @@ proposalPolicy proposal =
 
 -- | Validator for Proposals.
 proposalValidator :: Proposal -> ClosedTerm PValidator
-proposalValidator _ =
-  plam $ \_datum _redeemer ctx' -> P.do
+proposalValidator proposal =
+  plam $ \datum redeemer ctx' -> P.do
     PScriptContext ctx' <- pmatch ctx'
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
     PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
     _txInfo <- pletFields @'["inputs", "mint"] txInfo'
     PSpending _txOutRef <- pmatch $ pfromData ctx.purpose
-    popaque (pconstant ())
+
+    let _proposalDatum' :: Term _ PProposalDatum
+        _proposalDatum' = pfromData $ punsafeCoerce datum
+        proposalRedeemer :: Term _ PProposalRedeemer
+        proposalRedeemer = pfromData $ punsafeCoerce redeemer
+
+    stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal)
+    spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # ctx.txInfo
+
+    pmatch proposalRedeemer $ \case
+      PVote _r -> P.do
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        popaque (pconstant ())
+      --------------------------------------------------------------------------
+      PCosign _r -> P.do
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        popaque (pconstant ())
+      --------------------------------------------------------------------------
+      PUnlock _r -> P.do
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        popaque (pconstant ())
+      --------------------------------------------------------------------------
+      PAdvanceProposal _r -> P.do
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        popaque (pconstant ())
 
 {- | Check for various invariants a proposal must uphold.
      This can be used to check both upopn creation and

From 8f7f543438c7ee72a52731d2173a555380e4a7ec Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Tue, 19 Apr 2022 17:42:39 +0200
Subject: [PATCH 59/78] flake: bump plutarch-extra fork

---
 agora/Agora/Governor.hs |   1 -
 agora/Agora/MultiSig.hs |   3 +-
 agora/Agora/Proposal.hs |  17 ++--
 agora/Agora/Stake.hs    |   9 +-
 agora/Agora/Treasury.hs |   1 -
 agora/Agora/Utils.hs    |   2 +-
 agora/PPrelude.hs       |   5 +-
 flake.lock              | 178 +++++++++++++++-------------------------
 flake.nix               |   5 +-
 9 files changed, 85 insertions(+), 136 deletions(-)

diff --git a/agora/Agora/Governor.hs b/agora/Agora/Governor.hs
index 7a47865..24f52ad 100644
--- a/agora/Agora/Governor.hs
+++ b/agora/Agora/Governor.hs
@@ -21,7 +21,6 @@ module Agora.Governor (
 ) where
 
 import Agora.Proposal (ProposalId, ProposalThresholds)
-import Plutarch (popaque)
 import Plutarch.Api.V1 (PMintingPolicy, PValidator)
 import PlutusTx qualified
 
diff --git a/agora/Agora/MultiSig.hs b/agora/Agora/MultiSig.hs
index 93cf3e6..a65d0f0 100644
--- a/agora/Agora/MultiSig.hs
+++ b/agora/Agora/MultiSig.hs
@@ -24,6 +24,7 @@ import Plutarch.DataRepr (
   PIsDataReprInstances (PIsDataReprInstances),
  )
 import Plutarch.Lift (
+  PConstantDecl,
   PLifted,
   PUnsafeLiftDecl,
  )
@@ -73,7 +74,7 @@ newtype PMultiSig (s :: S) = PMultiSig
     via (PIsDataReprInstances PMultiSig)
 
 instance PUnsafeLiftDecl PMultiSig where type PLifted PMultiSig = MultiSig
-deriving via (DerivePConstantViaData MultiSig PMultiSig) instance (PConstant MultiSig)
+deriving via (DerivePConstantViaData MultiSig PMultiSig) instance (PConstantDecl MultiSig)
 
 --------------------------------------------------------------------------------
 
diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index aaca9a1..126b384 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -62,10 +62,9 @@ import PlutusTx.AssocMap qualified as AssocMap
 import Agora.SafeMoney (GTTag)
 import Agora.Utils (passert, pnotNull, psymbolValueOf, ptokenSpent, pvalueSpent)
 import Control.Arrow (first)
-import Plutarch (popaque)
 import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
 import Plutarch.Builtin (PBuiltinMap)
-import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..))
+import Plutarch.Lift (DerivePConstantViaNewtype (..), PConstantDecl, PUnsafeLiftDecl (..))
 import Plutarch.Monadic qualified as P
 import Plutarch.SafeMoney (PDiscrete, Tagged)
 import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
@@ -257,7 +256,7 @@ instance PUnsafeLiftDecl PResultTag where type PLifted PResultTag = ResultTag
 deriving via
   (DerivePConstantViaNewtype ResultTag PResultTag PInteger)
   instance
-    (PConstant ResultTag)
+    (PConstantDecl ResultTag)
 
 -- FIXME: This instance and the one below, for 'PProposalId', should be derived.
 -- Soon this will be possible through 'DerivePNewtype'.
@@ -287,7 +286,7 @@ instance PUnsafeLiftDecl PProposalId where type PLifted PProposalId = ProposalId
 deriving via
   (DerivePConstantViaNewtype ProposalId PProposalId PInteger)
   instance
-    (PConstant ProposalId)
+    (PConstantDecl ProposalId)
 
 -- | Plutarch-level version of 'ProposalStatus'.
 data PProposalStatus (s :: S)
@@ -304,7 +303,7 @@ data PProposalStatus (s :: S)
     via PIsDataReprInstances PProposalStatus
 
 instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus
-deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (PConstant ProposalStatus)
+deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (PConstantDecl ProposalStatus)
 
 -- | Plutarch-level version of 'ProposalThresholds'.
 newtype PProposalThresholds (s :: S) = PProposalThresholds
@@ -326,7 +325,7 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds
     via (PIsDataReprInstances PProposalThresholds)
 
 instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds
-deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) instance (PConstant ProposalThresholds)
+deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) instance (PConstantDecl ProposalThresholds)
 
 -- | Plutarch-level version of 'ProposalVotes'.
 newtype PProposalVotes (s :: S)
@@ -337,7 +336,7 @@ instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = Prop
 deriving via
   (DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap PResultTag PInteger))
   instance
-    (PConstant ProposalVotes)
+    (PConstantDecl ProposalVotes)
 
 -- | Plutarch-level version of 'ProposalDatum'.
 newtype PProposalDatum (s :: S) = PProposalDatum
@@ -362,7 +361,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum
     via (PIsDataReprInstances PProposalDatum)
 
 instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
-deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstant ProposalDatum)
+deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum)
 
 -- | Haskell-level redeemer for Proposal scripts.
 data PProposalRedeemer (s :: S)
@@ -384,7 +383,7 @@ data PProposalRedeemer (s :: S)
 --     PTryFrom PData (PAsData PProposalRedeemer)
 
 instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer
-deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstant ProposalRedeemer)
+deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstantDecl ProposalRedeemer)
 
 --------------------------------------------------------------------------------
 
diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs
index afaacb1..9334d29 100644
--- a/agora/Agora/Stake.hs
+++ b/agora/Agora/Stake.hs
@@ -33,7 +33,6 @@ import PlutusTx qualified
 
 --------------------------------------------------------------------------------
 
-import Plutarch (popaque)
 import Plutarch.Api.V1 (
   PCredential (PPubKeyCredential, PScriptCredential),
   PMintingPolicy,
@@ -50,7 +49,7 @@ import Plutarch.DataRepr (
   PIsDataReprInstances (PIsDataReprInstances),
  )
 import Plutarch.Internal (punsafeCoerce)
-import Plutarch.Lift (PUnsafeLiftDecl (..))
+import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
 import Plutarch.Monadic qualified as P
 import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
 
@@ -197,7 +196,7 @@ newtype PStakeDatum (s :: S) = PStakeDatum
     via (PIsDataReprInstances PStakeDatum)
 
 instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum
-deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstant StakeDatum)
+deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstantDecl StakeDatum)
 
 -- | Plutarch-level redeemer for Stake scripts.
 data PStakeRedeemer (s :: S)
@@ -220,7 +219,7 @@ deriving via
     PTryFrom PData (PAsData PStakeRedeemer)
 
 instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer
-deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstant StakeRedeemer)
+deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstantDecl StakeRedeemer)
 
 newtype PProposalLock (s :: S) = PProposalLock
   { getProposalLock ::
@@ -245,7 +244,7 @@ deriving via
     PTryFrom PData (PAsData PProposalLock)
 
 instance PUnsafeLiftDecl PProposalLock where type PLifted PProposalLock = ProposalLock
-deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstant ProposalLock)
+deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstantDecl ProposalLock)
 
 --------------------------------------------------------------------------------
 {- What this Policy does
diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs
index 3f48a1f..9cda2b1 100644
--- a/agora/Agora/Treasury.hs
+++ b/agora/Agora/Treasury.hs
@@ -23,7 +23,6 @@ import Plutus.V1.Ledger.Value (CurrencySymbol)
 
 import Agora.AuthorityToken (singleAuthorityTokenBurned)
 import Agora.Utils (passert)
-import Plutarch (popaque)
 import Plutarch.Api.V1 (PValidator)
 import Plutarch.Unsafe (punsafeCoerce)
 
diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index ed86334..8eeb07a 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -80,7 +80,7 @@ pfindDatum :: Term s (PDatumHash :--> PTxInfo :--> PMaybe PDatum)
 pfindDatum = phoistAcyclic $
   plam $ \datumHash txInfo'' -> P.do
     PTxInfo txInfo' <- pmatch txInfo''
-    plookupTuple # datumHash #$ pfield @"data" # txInfo'
+    plookupTuple # datumHash #$ pfield @"datums" # txInfo'
 
 {- | Find a datum with the given hash.
 NOTE: this is unsafe in the sense that, if the data layout is wrong, this is UB.
diff --git a/agora/PPrelude.hs b/agora/PPrelude.hs
index 3232cf9..5878ff4 100644
--- a/agora/PPrelude.hs
+++ b/agora/PPrelude.hs
@@ -11,8 +11,7 @@ module PPrelude (
   module Plutarch,
 ) where
 
--- NOTE: These are not exported by Plutarch.Prelude, for some reason.
--- Maybe we can 'fix' this upstream?
-import Plutarch (ClosedTerm, POpaque, compile)
+-- 'compile' is not exported by Plutarch.Prelude.
+import Plutarch (compile)
 import Plutarch.Prelude
 import Prelude
diff --git a/flake.lock b/flake.lock
index 0b23a54..00c46fe 100644
--- a/flake.lock
+++ b/flake.lock
@@ -117,23 +117,6 @@
         "type": "github"
       }
     },
-    "autodocodec": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1644358110,
-        "narHash": "sha256-X1TNZlmO2qDFk3OL4Z1v/gzvd3ouoACAiMweutsYek4=",
-        "owner": "srid",
-        "repo": "autodocodec",
-        "rev": "42b42a7407f33c6c74fa4e8c84906aebfed28daf",
-        "type": "github"
-      },
-      "original": {
-        "owner": "srid",
-        "ref": "ghc921",
-        "repo": "autodocodec",
-        "type": "github"
-      }
-    },
     "cabal-32": {
       "flake": false,
       "locked": {
@@ -463,21 +446,6 @@
         "type": "github"
       }
     },
-    "flake-compat-ci_3": {
-      "locked": {
-        "lastModified": 1641672839,
-        "narHash": "sha256-Bdwv+DKeEMlRNPDpZxSz0sSrqQBvdKO5fZ8LmvrgCOU=",
-        "owner": "hercules-ci",
-        "repo": "flake-compat-ci",
-        "rev": "e832114bc18376c0f3fa13c19bf5ff253cc6570a",
-        "type": "github"
-      },
-      "original": {
-        "owner": "hercules-ci",
-        "repo": "flake-compat-ci",
-        "type": "github"
-      }
-    },
     "flake-compat_2": {
       "flake": false,
       "locked": {
@@ -495,22 +463,6 @@
       }
     },
     "flake-compat_3": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1641205782,
-        "narHash": "sha256-4jY7RCWUoZ9cKD8co0/4tFARpWB+57+r1bLLvXNJliY=",
-        "owner": "edolstra",
-        "repo": "flake-compat",
-        "rev": "b7547d3eed6f32d06102ead8991ec52ab0a4f1a7",
-        "type": "github"
-      },
-      "original": {
-        "owner": "edolstra",
-        "repo": "flake-compat",
-        "type": "github"
-      }
-    },
-    "flake-compat_4": {
       "flake": false,
       "locked": {
         "lastModified": 1606424373,
@@ -527,7 +479,7 @@
         "type": "github"
       }
     },
-    "flake-compat_5": {
+    "flake-compat_4": {
       "flake": false,
       "locked": {
         "lastModified": 1606424373,
@@ -981,7 +933,7 @@
     },
     "hercules-ci-agent": {
       "inputs": {
-        "flake-compat": "flake-compat_5",
+        "flake-compat": "flake-compat_4",
         "nix-darwin": "nix-darwin",
         "nixos-20_09": "nixos-20_09",
         "nixos-unstable": "nixos-unstable",
@@ -1004,7 +956,7 @@
     },
     "hercules-ci-effects": {
       "inputs": {
-        "flake-compat": "flake-compat_4",
+        "flake-compat": "flake-compat_3",
         "hercules-ci-agent": "hercules-ci-agent",
         "nixpkgs": "nixpkgs_3",
         "nixpkgs-nixops": "nixpkgs-nixops"
@@ -1088,6 +1040,55 @@
         "type": "github"
       }
     },
+    "hspec": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1649095108,
+        "narHash": "sha256-cPmt4hvmdh727VT6UAL8yFArmm4FAWeg3K5Qi3XtU4g=",
+        "owner": "srid",
+        "repo": "hspec",
+        "rev": "44f2a143e10c93df237af428457d0e4b74ae270a",
+        "type": "github"
+      },
+      "original": {
+        "owner": "srid",
+        "ref": "askAncestors",
+        "repo": "hspec",
+        "type": "github"
+      }
+    },
+    "hspec-golden": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1648755064,
+        "narHash": "sha256-5a6BksZx00o2iL0Ei/L1Kkou2BsnsIagN+tTmqYyKfs=",
+        "owner": "stackbuilders",
+        "repo": "hspec-golden",
+        "rev": "4b0ad56b2de0254a7b1e0feda917656f78a5bcda",
+        "type": "github"
+      },
+      "original": {
+        "owner": "stackbuilders",
+        "repo": "hspec-golden",
+        "type": "github"
+      }
+    },
+    "hspec-hedgehog": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1602603478,
+        "narHash": "sha256-XnS3zjQ7eh3iBOWq+Z/YcwrfWI55hV6k8LsZ8qm/qOc=",
+        "owner": "parsonsmatt",
+        "repo": "hspec-hedgehog",
+        "rev": "eb617d854542510f0129acdea4bf52e50b13042e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "parsonsmatt",
+        "repo": "hspec-hedgehog",
+        "type": "github"
+      }
+    },
     "iohk-nix": {
       "flake": false,
       "locked": {
@@ -1592,19 +1593,24 @@
     "plutarch": {
       "inputs": {
         "Shrinker": "Shrinker",
-        "autodocodec": "autodocodec",
         "cardano-base": "cardano-base",
         "cardano-crypto": "cardano-crypto",
         "cardano-prelude": "cardano-prelude",
         "cryptonite": "cryptonite",
-        "flake-compat": "flake-compat_3",
-        "flake-compat-ci": "flake-compat-ci_3",
+        "emanote": [
+          "plutarch",
+          "haskell-nix",
+          "nixpkgs-unstable"
+        ],
         "flat": "flat",
         "foundation": "foundation",
         "haskell-language-server": "haskell-language-server_2",
         "haskell-nix": "haskell-nix_4",
         "hercules-ci-effects": "hercules-ci-effects",
         "hs-memory": "hs-memory",
+        "hspec": "hspec",
+        "hspec-golden": "hspec-golden",
+        "hspec-hedgehog": "hspec-hedgehog",
         "iohk-nix": "iohk-nix_2",
         "nixpkgs": [
           "plutarch",
@@ -1614,24 +1620,21 @@
         "nixpkgs-2111": "nixpkgs-2111_5",
         "plutus": "plutus_2",
         "protolude": "protolude",
-        "safe-coloured-text": "safe-coloured-text",
         "sized-functors": "sized-functors",
-        "sydtest": "sydtest",
-        "th-extras": "th-extras",
-        "validity": "validity"
+        "th-extras": "th-extras"
       },
       "locked": {
-        "lastModified": 1650025193,
-        "narHash": "sha256-SXfkWYse308SdnWO34cMVjKliDvyYYx++Y5uiuUmGXE=",
+        "lastModified": 1650382454,
+        "narHash": "sha256-b31DK+E/0MtR45+Z+F5U1E8jjcewvZ42UmFLZlXDAYM=",
         "owner": "peter-mlabs",
         "repo": "plutarch",
-        "rev": "18e787d420912ed765fc5653c3558f20ab5e638a",
+        "rev": "6ef18aacd02050fc07398e399cff5e8734c1045e",
         "type": "github"
       },
       "original": {
         "owner": "peter-mlabs",
         "repo": "plutarch",
-        "rev": "18e787d420912ed765fc5653c3558f20ab5e638a",
+        "rev": "6ef18aacd02050fc07398e399cff5e8734c1045e",
         "type": "github"
       }
     },
@@ -1771,23 +1774,6 @@
         "plutarch": "plutarch"
       }
     },
-    "safe-coloured-text": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1644357337,
-        "narHash": "sha256-sXSKw8m6O9K/H2BBiYqO5e4sJIo+9UP+UvEukRn28d8=",
-        "owner": "srid",
-        "repo": "safe-coloured-text",
-        "rev": "034f3612525568b422e0c62b52417d77b7cf31c2",
-        "type": "github"
-      },
-      "original": {
-        "owner": "srid",
-        "ref": "ghc921",
-        "repo": "safe-coloured-text",
-        "type": "github"
-      }
-    },
     "sized-functors": {
       "flake": false,
       "locked": {
@@ -1917,23 +1903,6 @@
         "type": "github"
       }
     },
-    "sydtest": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1645114028,
-        "narHash": "sha256-P6ZwwfFeN8fpi3fziz9yERTn7BfxdE/j/OofUu+4GdA=",
-        "owner": "srid",
-        "repo": "sydtest",
-        "rev": "9c6c7678f7aabe22e075aab810a6a2e304591d24",
-        "type": "github"
-      },
-      "original": {
-        "owner": "srid",
-        "ref": "ghc921",
-        "repo": "sydtest",
-        "type": "github"
-      }
-    },
     "th-extras": {
       "flake": false,
       "locked": {
@@ -1950,23 +1919,6 @@
         "rev": "787ed752c1e5d41b5903b74e171ed087de38bffa",
         "type": "github"
       }
-    },
-    "validity": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1644358698,
-        "narHash": "sha256-dpMIu08qXMzy8Kilk/2VWpuwIsfqFtpg/3mkwt5pdjA=",
-        "owner": "srid",
-        "repo": "validity",
-        "rev": "f7982549b95d0ab727950dc876ca06b1862135ba",
-        "type": "github"
-      },
-      "original": {
-        "owner": "srid",
-        "ref": "ghc921",
-        "repo": "validity",
-        "type": "github"
-      }
     }
   },
   "root": "root",
diff --git a/flake.nix b/flake.nix
index d51df25..3da51ee 100644
--- a/flake.nix
+++ b/flake.nix
@@ -7,9 +7,10 @@
   # see https://github.com/NixOS/nix/issues/6013
   inputs.nixpkgs-2111 = { url = "github:NixOS/nixpkgs/nixpkgs-21.11-darwin"; };
 
-  # Rev is this PR https://github.com/peter-mlabs/plutarch/pull/5.
   inputs.plutarch.url =
-    "github:peter-mlabs/plutarch?rev=18e787d420912ed765fc5653c3558f20ab5e638a";
+    "github:peter-mlabs/plutarch?rev=6ef18aacd02050fc07398e399cff5e8734c1045e";
+  inputs.plutarch.inputs.emanote.follows =
+    "plutarch/haskell-nix/nixpkgs-unstable";
   inputs.plutarch.inputs.nixpkgs.follows =
     "plutarch/haskell-nix/nixpkgs-unstable";
 

From 7634460241c8a1c15448b570d5e5913446f06abd Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Tue, 19 Apr 2022 22:20:17 +0200
Subject: [PATCH 60/78] simplify some PTxInfo functions

---
 agora/Agora/Proposal.hs |  56 ++++++++++++++++++----
 agora/Agora/Record.hs   |   3 +-
 agora/Agora/Stake.hs    |  27 ++++++-----
 agora/Agora/Utils.hs    | 100 ++++++++++++++++++++--------------------
 4 files changed, 113 insertions(+), 73 deletions(-)

diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index 126b384..693b3bc 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -60,7 +60,16 @@ import PlutusTx.AssocMap qualified as AssocMap
 --------------------------------------------------------------------------------
 
 import Agora.SafeMoney (GTTag)
-import Agora.Utils (passert, pnotNull, psymbolValueOf, ptokenSpent, pvalueSpent)
+import Agora.Utils (
+  anyOutput,
+  findTxOutByTxOutRef,
+  passert,
+  pnotNull,
+  psymbolValueOf,
+  ptokenSpent,
+  ptxSignedBy,
+  pvalueSpent,
+ )
 import Control.Arrow (first)
 import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
 import Plutarch.Builtin (PBuiltinMap)
@@ -427,17 +436,25 @@ proposalValidator proposal =
   plam $ \datum redeemer ctx' -> P.do
     PScriptContext ctx' <- pmatch ctx'
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
-    PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
-    _txInfo <- pletFields @'["inputs", "mint"] txInfo'
-    PSpending _txOutRef <- pmatch $ pfromData ctx.purpose
+    txInfo <- plet $ pfromData ctx.txInfo
+    PTxInfo txInfo' <- pmatch $ txInfo
+    txInfoF <- pletFields @'["inputs", "mint"] txInfo'
+    PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose
 
-    let _proposalDatum' :: Term _ PProposalDatum
-        _proposalDatum' = pfromData $ punsafeCoerce datum
+    PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
+    txOutF <- pletFields @'["address"] $ txOut
+
+    let proposalDatum :: Term _ PProposalDatum
+        proposalDatum = pfromData $ punsafeCoerce datum
         proposalRedeemer :: Term _ PProposalRedeemer
         proposalRedeemer = pfromData $ punsafeCoerce redeemer
 
+    proposalF <- pletFields @'["cosigners"] proposalDatum
+
+    ownAddress <- plet $ txOutF.address
+
     stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal)
-    spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # ctx.txInfo
+    spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs
 
     pmatch proposalRedeemer $ \case
       PVote _r -> P.do
@@ -446,10 +463,33 @@ proposalValidator proposal =
 
         popaque (pconstant ())
       --------------------------------------------------------------------------
-      PCosign _r -> P.do
+      PCosign r -> P.do
+        newSigs <- plet $ pfield @"newCosigners" # r
+
         passert "ST at inputs must be 1" $
           spentST #== 1
 
+        passert "Signed by all new cosigners" $
+          pall # plam (\sig -> ptxSignedBy # ctx.txInfo # sig) # newSigs
+
+        passert "Signatures are correctly added to cosignature list" $
+          anyOutput @PProposalDatum # ctx.txInfo
+            #$ plam
+            $ \_value address newProposalDatum -> P.do
+              newProposalF <- pletFields @'["cosigners"] newProposalDatum
+
+              let correctDatum =
+                    foldr1
+                      (#&&)
+                      [ newProposalF.cosigners #== proposalF.cosigners
+                      ]
+
+              foldr1
+                (#&&)
+                [ ptraceIfFalse "Datum must be correct" $ correctDatum
+                , ptraceIfFalse "Must be sent to Proposal's address" $ ownAddress #== pdata address
+                ]
+
         popaque (pconstant ())
       --------------------------------------------------------------------------
       PUnlock _r -> P.do
diff --git a/agora/Agora/Record.hs b/agora/Agora/Record.hs
index a5dfe35..db293c7 100644
--- a/agora/Agora/Record.hs
+++ b/agora/Agora/Record.hs
@@ -48,8 +48,7 @@ infix 7 .=
   forall (sym :: Symbol) (a :: PType) (as :: [PLabeledType]) (s :: S).
   FieldName sym ->
   Term s (PAsData a) ->
-  ( RecordMorphism s as ((sym ':= a) ': as)
-  )
+  RecordMorphism s as ((sym ':= a) ': as)
 _ .= x = RecordMorphism $ pcon . PDCons x
 
 infixr 6 .&
diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs
index 9334d29..600af94 100644
--- a/agora/Agora/Stake.hs
+++ b/agora/Agora/Stake.hs
@@ -39,6 +39,7 @@ import Plutarch.Api.V1 (
   PPubKeyHash,
   PScriptPurpose (PMinting, PSpending),
   PTokenName,
+  PTxInfo,
   PValidator,
   mintingPolicySymbol,
   mkMintingPolicy,
@@ -266,13 +267,15 @@ stakePolicy :: Stake -> ClosedTerm PMintingPolicy
 stakePolicy stake =
   plam $ \_redeemer ctx' -> P.do
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
-    txInfo' <- plet ctx.txInfo
-    txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo'
+    txInfo <- plet $ ctx.txInfo
+    let _a :: Term _ PTxInfo
+        _a = txInfo
+    txInfoF <- pletFields @'["mint", "inputs", "outputs"] txInfo
 
     PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
     ownSymbol <- plet $ pfield @"_0" # ownSymbol'
-    spentST <- plet $ psymbolValueOf # ownSymbol #$ pvalueSpent # pfromData txInfo'
-    mintedST <- plet $ psymbolValueOf # ownSymbol # txInfo.mint
+    spentST <- plet $ psymbolValueOf # ownSymbol #$ pvalueSpent # txInfoF.inputs
+    mintedST <- plet $ psymbolValueOf # ownSymbol # txInfoF.mint
 
     let burning = P.do
           passert "ST at inputs must be 1" $
@@ -282,7 +285,7 @@ stakePolicy stake =
             mintedST #== -1
 
           passert "An unlocked input existed containing an ST" $
-            anyInput @PStakeDatum # pfromData txInfo'
+            anyInput @PStakeDatum # txInfo
               #$ plam
               $ \value _ stakeDatum' -> P.do
                 let hasST = psymbolValueOf # ownSymbol # value #== 1
@@ -299,7 +302,7 @@ stakePolicy stake =
             mintedST #== 1
 
           passert "A UTXO must exist with the correct output" $
-            anyOutput @PStakeDatum # pfromData txInfo'
+            anyOutput @PStakeDatum # txInfo
               #$ plam
               $ \value address stakeDatum' -> P.do
                 let cred = pfield @"credential" # address
@@ -359,8 +362,8 @@ stakeValidator :: Stake -> ClosedTerm PValidator
 stakeValidator stake =
   plam $ \datum redeemer ctx' -> P.do
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
-    txInfo' <- plet ctx.txInfo
-    txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo'
+    txInfo <- plet $ pfromData ctx.txInfo
+    txInfoF <- pletFields @'["mint", "inputs", "outputs"] txInfo
 
     (pfromData -> stakeRedeemer, _) <- ptryFrom redeemer
 
@@ -371,7 +374,7 @@ stakeValidator stake =
 
     PSpending txOutRef <- pmatch $ pfromData ctx.purpose
 
-    PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfo'
+    PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfoF.inputs
     ownAddress <- plet $ pfield @"address" #$ pfield @"resolved" # txInInfo
     let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo
 
@@ -379,8 +382,8 @@ stakeValidator stake =
     ownerSignsTransaction <- plet $ ptxSignedBy # ctx.txInfo # stakeDatum.owner
 
     stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake)
-    mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfo.mint
-    spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfo'
+    mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
+    spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs
 
     -- Is the stake currently locked?
     stakeIsLocked <- plet $ stakeLocked # stakeDatum'
@@ -420,7 +423,7 @@ stakeValidator stake =
           "Owner signs this transaction"
           ownerSignsTransaction
         passert "A UTXO must exist with the correct output" $
-          anyOutput @PStakeDatum # txInfo'
+          anyOutput @PStakeDatum # txInfo
             #$ plam
             $ \value address newStakeDatum' -> P.do
               newStakeDatum <- pletFields @'["owner", "stakedAmount"] newStakeDatum'
diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index 8eeb07a..ba9763c 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -249,46 +249,61 @@ paddValue = phoistAcyclic $
       )
 
 -- | Sum of all value at input.
-pvalueSpent :: Term s (PTxInfo :--> PValue)
+pvalueSpent :: Term s (PBuiltinList (PAsData PTxInInfo) :--> PValue)
 pvalueSpent = phoistAcyclic $
-  plam $ \txInfo' ->
-    pmatch txInfo' $ \(PTxInfo txInfo) ->
-      pfoldr
-        # plam
-          ( \txInInfo' v ->
-              pmatch
-                (pfromData txInInfo')
-                $ \(PTxInInfo txInInfo) ->
-                  paddValue
-                    # pmatch
-                      (pfield @"resolved" # txInInfo)
-                      (\(PTxOut o) -> pfromData $ pfield @"value" # o)
-                    # v
-          )
-        # pconstant mempty
-        # (pfield @"inputs" # txInfo)
+  plam $ \inputs ->
+    pfoldr
+      # plam
+        ( \txInInfo' v ->
+            pmatch
+              (pfromData txInInfo')
+              $ \(PTxInInfo txInInfo) ->
+                paddValue
+                  # pmatch
+                    (pfield @"resolved" # txInInfo)
+                    (\(PTxOut o) -> pfromData $ pfield @"value" # o)
+                  # v
+        )
+      # pconstant mempty
+      # inputs
 
 -- | Find the TxInInfo by a TxOutRef.
-pfindTxInByTxOutRef :: Term s (PTxOutRef :--> PTxInfo :--> PMaybe PTxInInfo)
+pfindTxInByTxOutRef :: Term s (PTxOutRef :--> PBuiltinList (PAsData PTxInInfo) :--> PMaybe PTxInInfo)
 pfindTxInByTxOutRef = phoistAcyclic $
-  plam $ \txOutRef txInfo' ->
-    pmatch txInfo' $ \(PTxInfo txInfo) ->
-      pfindMap
-        # plam
-          ( \txInInfo' ->
-              plet (pfromData txInInfo') $ \r ->
-                pmatch r $ \(PTxInInfo txInInfo) ->
-                  pif
-                    (pdata txOutRef #== pfield @"outRef" # txInInfo)
-                    (pcon (PJust r))
-                    (pcon PNothing)
-          )
-        #$ (pfield @"inputs" # txInfo)
+  plam $ \txOutRef inputs ->
+    pfindMap
+      # plam
+        ( \txInInfo' ->
+            plet (pfromData txInInfo') $ \r ->
+              pmatch r $ \(PTxInInfo txInInfo) ->
+                pif
+                  (pdata txOutRef #== pfield @"outRef" # txInInfo)
+                  (pcon (PJust r))
+                  (pcon PNothing)
+        )
+      #$ inputs
 
 -- | True if a list is not empty.
 pnotNull :: forall list a. PIsListLike list a => Term _ (list a :--> PBool)
 pnotNull = phoistAcyclic $ plam $ pelimList (\_ _ -> pcon PTrue) (pcon PFalse)
 
+-- | Check if a particular asset class has been spent in the input list.
+ptokenSpent :: forall {s :: S}. Term s (PAssetClass :--> PBuiltinList (PAsData PTxInInfo) :--> PBool)
+ptokenSpent =
+  plam $ \tokenClass inputs ->
+    0
+      #< pfoldr @PBuiltinList
+        # plam
+          ( \txInInfo' acc -> P.do
+              PTxInInfo txInInfo <- pmatch (pfromData txInInfo')
+              PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo
+              txOut <- pletFields @'["value"] txOut'
+              let txOutValue = pfromData txOut.value
+              acc + passetClassValueOf # txOutValue # tokenClass
+          )
+        # 0
+        # inputs
+
 --------------------------------------------------------------------------------
 {- Functions which should (probably) not be upstreamed
    All of these functions are quite inefficient.
@@ -372,10 +387,10 @@ psingletonValue = phoistAcyclic $
      in res
 
 -- | Finds the TxOut of an effect from TxInfo and TxOutRef
-findTxOutByTxOutRef :: Term s (PTxOutRef :--> PTxInfo :--> PMaybe PTxOut)
+findTxOutByTxOutRef :: Term s (PTxOutRef :--> PBuiltinList (PAsData PTxInInfo) :--> PMaybe PTxOut)
 findTxOutByTxOutRef = phoistAcyclic $
-  plam $ \txOutRef txInfo ->
-    pmatch (pfindTxInByTxOutRef # txOutRef # txInfo) $ \case
+  plam $ \txOutRef inputs ->
+    pmatch (pfindTxInByTxOutRef # txOutRef # inputs) $ \case
       PJust ((pfield @"resolved" #) -> txOut) -> pcon $ PJust txOut
       PNothing -> pcon PNothing
 
@@ -408,20 +423,3 @@ findTxOutDatum = phoistAcyclic $
     case datumHash' of
       PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # info
       _ -> pcon PNothing
-
--- | Check if a particular asset class has been spent in the input list.
-ptokenSpent :: forall {s :: S}. Term s (PAssetClass :--> PBuiltinList (PAsData PTxInInfo) :--> PBool)
-ptokenSpent =
-  plam $ \tokenClass inputs ->
-    0
-      #< pfoldr @PBuiltinList
-        # plam
-          ( \txInInfo' acc -> P.do
-              PTxInInfo txInInfo <- pmatch (pfromData txInInfo')
-              PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo
-              txOut <- pletFields @'["value"] txOut'
-              let txOutValue = pfromData txOut.value
-              acc + passetClassValueOf # txOutValue # tokenClass
-          )
-        # 0
-        # inputs

From 18df6ead55fcd992267becaa13086a3f884e7829 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Tue, 19 Apr 2022 22:31:38 +0200
Subject: [PATCH 61/78] add checks to cosign

---
 agora-test/Spec/Proposal.hs        |  42 ++++++++-
 agora-test/Spec/Sample/Proposal.hs | 138 ++++++++++++++++++++++++-----
 agora-test/Spec/Sample/Stake.hs    |   3 +-
 agora-test/Spec/Stake.hs           |   8 +-
 agora/Agora/Proposal.hs            |  39 ++++++--
 agora/Agora/Stake.hs               |  49 ++++++++--
 agora/Agora/Utils.hs               |   6 +-
 7 files changed, 241 insertions(+), 44 deletions(-)

diff --git a/agora-test/Spec/Proposal.hs b/agora-test/Spec/Proposal.hs
index 4d3c4e3..e59df7e 100644
--- a/agora-test/Spec/Proposal.hs
+++ b/agora-test/Spec/Proposal.hs
@@ -13,9 +13,26 @@ module Spec.Proposal (tests) where
 
 --------------------------------------------------------------------------------
 
-import Agora.Proposal (proposalPolicy)
+import Agora.Proposal (
+  ProposalDatum (ProposalDatum),
+  ProposalId (ProposalId),
+  ProposalRedeemer (Cosign),
+  ProposalStatus (Draft),
+  ProposalVotes (ProposalVotes),
+  ResultTag (ResultTag),
+  cosigners,
+  effects,
+  proposalId,
+  proposalPolicy,
+  proposalValidator,
+  status,
+  thresholds,
+  votes,
+ )
+import PlutusTx.AssocMap qualified as AssocMap
+import Spec.Sample.Proposal (propThresholds, signer, signer2)
 import Spec.Sample.Proposal qualified as Proposal
-import Spec.Util (policySucceedsWith)
+import Spec.Util (policySucceedsWith, validatorSucceedsWith)
 import Test.Tasty (TestTree, testGroup)
 
 --------------------------------------------------------------------------------
@@ -35,4 +52,25 @@ tests =
           ()
           Proposal.proposalCreation
       ]
+  , testGroup
+      "validator"
+      [ validatorSucceedsWith
+          "stakeCreation"
+          (proposalValidator Proposal.proposal)
+          ( ProposalDatum
+              { proposalId = ProposalId 0
+              , effects =
+                  AssocMap.fromList
+                    [ (ResultTag 0, [])
+                    , (ResultTag 1, [])
+                    ]
+              , status = Draft
+              , cosigners = [signer]
+              , thresholds = propThresholds
+              , votes = ProposalVotes AssocMap.empty
+              }
+          )
+          (Cosign [signer2])
+          (Proposal.cosignProposal [signer2])
+      ]
   ]
diff --git a/agora-test/Spec/Sample/Proposal.hs b/agora-test/Spec/Sample/Proposal.hs
index 9b464cb..cceb12e 100644
--- a/agora-test/Spec/Sample/Proposal.hs
+++ b/agora-test/Spec/Sample/Proposal.hs
@@ -7,13 +7,15 @@ This module tests primarily the happy path for Proposal interactions
 -}
 module Spec.Sample.Proposal (
   proposal,
-  policy,
-  policySymbol,
-  validatorHashTN,
+  propPolicy,
+  propPolicySymbol,
+  propThresholds,
   signer,
+  signer2,
 
   -- * Script contexts
   proposalCreation,
+  cosignProposal,
 ) where
 
 --------------------------------------------------------------------------------
@@ -37,11 +39,9 @@ import Plutus.V1.Ledger.Api (
   TxInfo (..),
   TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue),
   TxOutRef (TxOutRef),
-  ValidatorHash (ValidatorHash),
  )
 import Plutus.V1.Ledger.Interval qualified as Interval
-import Plutus.V1.Ledger.Scripts (Validator)
-import Plutus.V1.Ledger.Value (AssetClass (AssetClass), TokenName (TokenName))
+import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash)
 import Plutus.V1.Ledger.Value qualified as Value
 
 --------------------------------------------------------------------------------
@@ -52,13 +52,35 @@ import Agora.Governor (
   governorPolicy,
   governorValidator,
  )
-import Agora.Proposal
+import Agora.Proposal (
+  Proposal (..),
+  ProposalDatum (..),
+  ProposalId (..),
+  ProposalStatus (..),
+  ProposalThresholds (..),
+  ProposalVotes (..),
+  ResultTag (..),
+  proposalPolicy,
+  proposalValidator,
+ )
+import Agora.Stake (Stake (..), stakePolicy)
 import Plutarch.SafeMoney
+import Plutus.V1.Ledger.Address (scriptHashAddress)
 import PlutusTx.AssocMap qualified as AssocMap
 import Spec.Util (datumPair, toDatumHash)
 
 --------------------------------------------------------------------------------
 
+stake :: Stake
+stake =
+  Stake
+    { gtClassRef = Tagged $ Value.assetClass govSymbol ""
+    , proposalSTClass = Value.assetClass propPolicySymbol ""
+    }
+
+stakeSymbol :: CurrencySymbol
+stakeSymbol = mintingPolicySymbol $ mkMintingPolicy $ stakePolicy stake.gtClassRef
+
 governor :: Governor
 governor = Governor
 
@@ -76,30 +98,35 @@ proposal =
   Proposal
     { governorSTAssetClass =
         -- TODO: if we had a governor here
-        AssetClass
-          ( govSymbol
-          , ""
-          )
+        Value.assetClass govSymbol ""
+    , stakeSTAssetClass =
+        Value.assetClass stakeSymbol ""
     }
 
 -- | 'Proposal' policy instance.
-policy :: MintingPolicy
-policy = mkMintingPolicy (proposalPolicy proposal)
+propPolicy :: MintingPolicy
+propPolicy = mkMintingPolicy (proposalPolicy proposal)
 
-policySymbol :: CurrencySymbol
-policySymbol = mintingPolicySymbol policy
+propPolicySymbol :: CurrencySymbol
+propPolicySymbol = mintingPolicySymbol propPolicy
 
 -- | A sample 'PubKeyHash'.
 signer :: PubKeyHash
 signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
 
--- | 'Proposal' validator instance.
-validator :: Validator
-validator = mkValidator (proposalValidator proposal)
+-- | Another sample 'PubKeyHash'.
+signer2 :: PubKeyHash
+signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192"
 
--- | 'TokenName' that represents the hash of the 'Proposal' validator.
-validatorHashTN :: TokenName
-validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
+-- | 'Proposal' validator instance.
+propValidator :: Validator
+propValidator = mkValidator (proposalValidator proposal)
+
+propValidatorHash :: ValidatorHash
+propValidatorHash = validatorHash propValidator
+
+propValidatorAddress :: Address
+propValidatorAddress = scriptHashAddress propValidatorHash
 
 propThresholds :: ProposalThresholds
 propThresholds =
@@ -112,7 +139,7 @@ propThresholds =
 -- | This script context should be a valid transaction.
 proposalCreation :: ScriptContext
 proposalCreation =
-  let st = Value.singleton policySymbol "" 1 -- Proposal ST
+  let st = Value.singleton propPolicySymbol "" 1 -- Proposal ST
       proposalDatum :: Datum
       proposalDatum =
         Datum
@@ -163,7 +190,7 @@ proposalCreation =
                   ]
               , txInfoOutputs =
                   [ TxOut
-                      { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                      { txOutAddress = Address (ScriptCredential $ validatorHash propValidator) Nothing
                       , txOutValue =
                           mconcat
                             [ st
@@ -194,5 +221,68 @@ proposalCreation =
                   ]
               , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
               }
-        , scriptContextPurpose = Minting policySymbol
+        , scriptContextPurpose = Minting propPolicySymbol
+        }
+
+-- | This script context should be a valid transaction.
+cosignProposal :: [PubKeyHash] -> ScriptContext
+cosignProposal newSigners =
+  let st = Value.singleton propPolicySymbol "" 1 -- Proposal ST
+      proposalBefore :: ProposalDatum
+      proposalBefore =
+        ProposalDatum
+          { proposalId = ProposalId 0
+          , effects =
+              AssocMap.fromList
+                [ (ResultTag 0, [])
+                , (ResultTag 1, [])
+                ]
+          , status = Draft
+          , cosigners = [signer]
+          , thresholds = propThresholds
+          , votes = ProposalVotes AssocMap.empty
+          }
+      proposalAfter :: ProposalDatum
+      proposalAfter = proposalBefore {cosigners = newSigners <> proposalBefore.cosigners}
+      proposalRef = (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+   in ScriptContext
+        { scriptContextTxInfo =
+            TxInfo
+              { txInfoInputs =
+                  [ TxInInfo
+                      proposalRef
+                      TxOut
+                        { txOutAddress = propValidatorAddress
+                        , txOutValue =
+                            mconcat
+                              [ st
+                              , Value.singleton "" "" 10_000_000
+                              ]
+                        , txOutDatumHash = Just (toDatumHash proposalBefore)
+                        }
+                  ]
+              , txInfoOutputs =
+                  [ TxOut
+                      { txOutAddress = Address (ScriptCredential $ validatorHash propValidator) Nothing
+                      , txOutValue =
+                          mconcat
+                            [ st
+                            , Value.singleton "" "" 10_000_000
+                            ]
+                      , txOutDatumHash = Just (toDatumHash . Datum $ toBuiltinData proposalAfter)
+                      }
+                  ]
+              , txInfoFee = Value.singleton "" "" 2
+              , txInfoMint = st
+              , txInfoDCert = []
+              , txInfoWdrl = []
+              , txInfoValidRange = Interval.always
+              , txInfoSignatories = newSigners
+              , txInfoData =
+                  [ datumPair . Datum $ toBuiltinData proposalBefore
+                  , datumPair . Datum $ toBuiltinData proposalAfter
+                  ]
+              , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+              }
+        , scriptContextPurpose = Spending proposalRef
         }
diff --git a/agora-test/Spec/Sample/Stake.hs b/agora-test/Spec/Sample/Stake.hs
index e62103e..f100ab6 100644
--- a/agora-test/Spec/Sample/Stake.hs
+++ b/agora-test/Spec/Sample/Stake.hs
@@ -69,11 +69,12 @@ stake =
               , "LQ"
               )
           )
+    , proposalSTClass = AssetClass ("", "")
     }
 
 -- | 'Stake' policy instance.
 policy :: MintingPolicy
-policy = mkMintingPolicy (stakePolicy stake)
+policy = mkMintingPolicy (stakePolicy stake.gtClassRef)
 
 policySymbol :: CurrencySymbol
 policySymbol = mintingPolicySymbol policy
diff --git a/agora-test/Spec/Stake.hs b/agora-test/Spec/Stake.hs
index 2513bab..427f228 100644
--- a/agora-test/Spec/Stake.hs
+++ b/agora-test/Spec/Stake.hs
@@ -19,7 +19,7 @@ import Test.Tasty (TestTree, testGroup)
 
 --------------------------------------------------------------------------------
 
-import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw), stakePolicy, stakeValidator)
+import Agora.Stake (Stake (..), StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw), stakePolicy, stakeValidator)
 
 --------------------------------------------------------------------------------
 
@@ -36,17 +36,17 @@ tests =
       "policy"
       [ policySucceedsWith
           "stakeCreation"
-          (stakePolicy Stake.stake)
+          (stakePolicy Stake.stake.gtClassRef)
           ()
           Stake.stakeCreation
       , policyFailsWith
           "stakeCreationWrongDatum"
-          (stakePolicy Stake.stake)
+          (stakePolicy Stake.stake.gtClassRef)
           ()
           Stake.stakeCreationWrongDatum
       , policyFailsWith
           "stakeCreationUnsigned"
-          (stakePolicy Stake.stake)
+          (stakePolicy Stake.stake.gtClassRef)
           ()
           Stake.stakeCreationUnsigned
       ]
diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index 693b3bc..cc73294 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -249,8 +249,9 @@ PlutusTx.makeIsDataIndexed
   ]
 
 -- | Parameters that identify the Proposal validator script.
-newtype Proposal = Proposal
+data Proposal = Proposal
   { governorSTAssetClass :: AssetClass
+  , stakeSTAssetClass :: AssetClass
   }
   deriving stock (Show, Eq)
 
@@ -442,14 +443,23 @@ proposalValidator proposal =
     PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose
 
     PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
-    txOutF <- pletFields @'["address"] $ txOut
+    txOutF <- pletFields @'["address", "value"] $ txOut
 
     let proposalDatum :: Term _ PProposalDatum
         proposalDatum = pfromData $ punsafeCoerce datum
         proposalRedeemer :: Term _ PProposalRedeemer
         proposalRedeemer = pfromData $ punsafeCoerce redeemer
 
-    proposalF <- pletFields @'["cosigners"] proposalDatum
+    proposalF <-
+      pletFields
+        @'[ "id"
+          , "effects"
+          , "status"
+          , "cosigners"
+          , "thresholds"
+          , "votes"
+          ]
+        proposalDatum
 
     ownAddress <- plet $ txOutF.address
 
@@ -475,18 +485,35 @@ proposalValidator proposal =
         passert "Signatures are correctly added to cosignature list" $
           anyOutput @PProposalDatum # ctx.txInfo
             #$ plam
-            $ \_value address newProposalDatum -> P.do
-              newProposalF <- pletFields @'["cosigners"] newProposalDatum
+            $ \newValue address newProposalDatum -> P.do
+              newProposalF <-
+                pletFields
+                  @'[ "id"
+                    , "effects"
+                    , "status"
+                    , "cosigners"
+                    , "thresholds"
+                    , "votes"
+                    ]
+                  newProposalDatum
 
+              -- This is a little sad. Can we do better by
+              -- building a new ProposalDatum and then comparing?
               let correctDatum =
                     foldr1
                       (#&&)
-                      [ newProposalF.cosigners #== proposalF.cosigners
+                      [ newProposalF.cosigners #== pconcat # newSigs # proposalF.cosigners
+                      , newProposalF.id #== proposalF.id
+                      , newProposalF.effects #== proposalF.effects
+                      , newProposalF.status #== proposalF.status
+                      , newProposalF.thresholds #== proposalF.thresholds
+                      , newProposalF.votes #== proposalF.votes
                       ]
 
               foldr1
                 (#&&)
                 [ ptraceIfFalse "Datum must be correct" $ correctDatum
+                , ptraceIfFalse "Value should be correct" $ pdata txOutF.value #== pdata newValue
                 , ptraceIfFalse "Must be sent to Proposal's address" $ ownAddress #== pdata address
                 ]
 
diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs
index 600af94..98242c8 100644
--- a/agora/Agora/Stake.hs
+++ b/agora/Agora/Stake.hs
@@ -70,9 +70,11 @@ import Agora.Utils (
   pnotNull,
   psingletonValue,
   psymbolValueOf,
+  ptokenSpent,
   ptxSignedBy,
   pvalueSpent,
  )
+import Plutarch.Api.V1.Extra (passetClass)
 import Plutarch.Numeric
 import Plutarch.SafeMoney (
   PDiscrete,
@@ -85,9 +87,10 @@ import Plutarch.TryFrom (PTryFrom, ptryFrom)
 --------------------------------------------------------------------------------
 
 -- | Parameters for creating Stake scripts.
-newtype Stake = Stake
+data Stake = Stake
   { gtClassRef :: Tagged GTTag AssetClass
   -- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code.
+  , proposalSTClass :: AssetClass
   }
 
 {- | A lock placed on a Stake datum in order to prevent
@@ -147,6 +150,9 @@ data StakeRedeemer
     --   always allowed to have votes retracted and won't affect the Proposal datum,
     --   allowing 'Stake's to be unlocked.
     RetractVotes [ProposalLock]
+  | -- | 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
   deriving stock (Show, GHC.Generic)
 
 PlutusTx.makeIsDataIndexed
@@ -155,6 +161,7 @@ PlutusTx.makeIsDataIndexed
   , ('Destroy, 1)
   , ('PermitVote, 2)
   , ('RetractVotes, 3)
+  , ('WitnessStake, 4)
   ]
 
 -- | Haskell-level datum for Stake scripts.
@@ -207,6 +214,7 @@ data PStakeRedeemer (s :: S)
     PDestroy (Term s (PDataRecord '[]))
   | PPermitVote (Term s (PDataRecord '["lock" ':= PProposalLock]))
   | PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList (PAsData PProposalLock)]))
+  | PWitnessStake (Term s (PDataRecord '[]))
   deriving stock (GHC.Generic)
   deriving anyclass (Generic)
   deriving anyclass (PIsDataRepr)
@@ -263,8 +271,8 @@ deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PCons
 --------------------------------------------------------------------------------
 
 -- | Policy for Stake state threads.
-stakePolicy :: Stake -> ClosedTerm PMintingPolicy
-stakePolicy stake =
+stakePolicy :: Tagged GTTag AssetClass -> ClosedTerm PMintingPolicy
+stakePolicy gtClassRef =
   plam $ \_redeemer ctx' -> P.do
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
     txInfo <- plet $ ctx.txInfo
@@ -325,7 +333,7 @@ stakePolicy stake =
                             # 1
                     let expectedValue =
                           paddValue
-                            # (pdiscreteValue' stake.gtClassRef # stakeDatum.stakedAmount)
+                            # (pdiscreteValue' gtClassRef # stakeDatum.stakedAmount)
                             # stValue
                     let ownerSignsTransaction =
                           ptxSignedBy
@@ -339,7 +347,7 @@ stakePolicy stake =
                           foldr1
                             (#&&)
                             [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
-                            , pgeqByClass' (untag stake.gtClassRef)
+                            , pgeqByClass' (untag gtClassRef)
                                 # value
                                 # expectedValue
                             , pgeqByClass
@@ -381,7 +389,7 @@ stakeValidator stake =
     -- Whether the owner signs this transaction or not.
     ownerSignsTransaction <- plet $ ptxSignedBy # ctx.txInfo # stakeDatum.owner
 
-    stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake)
+    stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef)
     mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
     spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs
 
@@ -414,6 +422,35 @@ stakeValidator stake =
         -- TODO: check proposal constraints
         popaque (pconstant ())
       --------------------------------------------------------------------------
+      PWitnessStake _ -> P.do
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        let AssetClass (propCs, propTn) = stake.proposalSTClass
+            propAssetClass = passetClass # pconstant propCs # pconstant propTn
+            proposalTokenMoved =
+              ptokenSpent
+                # propAssetClass
+                # txInfoF.inputs
+
+        passert
+          "Owner signs this transaction OR proposal token is spent"
+          (ownerSignsTransaction #|| proposalTokenMoved)
+
+        passert "A UTXO must exist with the correct output" $
+          anyOutput @PStakeDatum # txInfo
+            #$ plam
+            $ \value address newStakeDatum' -> P.do
+              let isScriptAddress = pdata address #== ownAddress
+              let correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
+              let valueCorrect = pdata continuingValue #== pdata value
+              foldr1
+                (#&&)
+                [ ptraceIfFalse "isScriptAddress" isScriptAddress
+                , ptraceIfFalse "correctOutputDatum" correctOutputDatum
+                , ptraceIfFalse "valueCorrect" valueCorrect
+                ]
+        popaque (pconstant ())
       PDepositWithdraw r -> P.do
         passert "ST at inputs must be 1" $
           spentST #== 1
diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index ba9763c..bd0449d 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -287,7 +287,11 @@ pfindTxInByTxOutRef = phoistAcyclic $
 pnotNull :: forall list a. PIsListLike list a => Term _ (list a :--> PBool)
 pnotNull = phoistAcyclic $ plam $ pelimList (\_ _ -> pcon PTrue) (pcon PFalse)
 
--- | Check if a particular asset class has been spent in the input list.
+{- | Check if a particular asset class has been spent in the input list.
+
+     When using this as an authority check, you __MUST__ ensure the authority
+     knows how to ensure its end of the contract.
+-}
 ptokenSpent :: forall {s :: S}. Term s (PAssetClass :--> PBuiltinList (PAsData PTxInInfo) :--> PBool)
 ptokenSpent =
   plam $ \tokenClass inputs ->

From eb4dc2c6548c48fe1b7bd55b5e4f43acc000762b Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Wed, 20 Apr 2022 16:39:03 +0200
Subject: [PATCH 62/78] add shared Sample values module

- add Proposal validator testing
- add some Agora.Record improvements
---
 agora-test/Spec/Proposal.hs        |  57 +++++---
 agora-test/Spec/Sample/Proposal.hs | 218 +++++++++++------------------
 agora-test/Spec/Sample/Shared.hs   | 132 +++++++++++++++++
 agora-test/Spec/Sample/Stake.hs    |  59 ++------
 agora-test/Spec/Util.hs            |   9 +-
 agora.cabal                        |   1 +
 agora/Agora/AuthorityToken.hs      |   1 +
 agora/Agora/Proposal.hs            |  51 ++++---
 agora/Agora/Proposal/Time.hs       |  33 ++---
 agora/Agora/Record.hs              |  59 ++++++--
 agora/Agora/Stake.hs               |  17 ++-
 11 files changed, 367 insertions(+), 270 deletions(-)
 create mode 100644 agora-test/Spec/Sample/Shared.hs

diff --git a/agora-test/Spec/Proposal.hs b/agora-test/Spec/Proposal.hs
index e59df7e..2827d5d 100644
--- a/agora-test/Spec/Proposal.hs
+++ b/agora-test/Spec/Proposal.hs
@@ -11,8 +11,6 @@ module Spec.Proposal (tests) where
 
 --------------------------------------------------------------------------------
 
---------------------------------------------------------------------------------
-
 import Agora.Proposal (
   ProposalDatum (ProposalDatum),
   ProposalId (ProposalId),
@@ -29,9 +27,13 @@ import Agora.Proposal (
   thresholds,
   votes,
  )
+import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (WitnessStake), stakeValidator)
+import Plutarch.SafeMoney (Tagged (Tagged))
+import Plutus.V1.Ledger.Api (ScriptContext (..), ScriptPurpose (..))
 import PlutusTx.AssocMap qualified as AssocMap
-import Spec.Sample.Proposal (propThresholds, signer, signer2)
 import Spec.Sample.Proposal qualified as Proposal
+import Spec.Sample.Shared (signer, signer2)
+import Spec.Sample.Shared qualified as Shared
 import Spec.Util (policySucceedsWith, validatorSucceedsWith)
 import Test.Tasty (TestTree, testGroup)
 
@@ -47,30 +49,39 @@ tests =
   [ testGroup
       "policy"
       [ policySucceedsWith
-          "stakeCreation"
-          (proposalPolicy Proposal.proposal)
+          "proposalCreation"
+          (proposalPolicy Shared.proposal)
           ()
           Proposal.proposalCreation
       ]
   , testGroup
       "validator"
-      [ validatorSucceedsWith
-          "stakeCreation"
-          (proposalValidator Proposal.proposal)
-          ( ProposalDatum
-              { proposalId = ProposalId 0
-              , effects =
-                  AssocMap.fromList
-                    [ (ResultTag 0, [])
-                    , (ResultTag 1, [])
-                    ]
-              , status = Draft
-              , cosigners = [signer]
-              , thresholds = propThresholds
-              , votes = ProposalVotes AssocMap.empty
-              }
-          )
-          (Cosign [signer2])
-          (Proposal.cosignProposal [signer2])
+      [ testGroup
+          "cosignature"
+          [ validatorSucceedsWith
+              "proposal"
+              (proposalValidator Shared.proposal)
+              ( ProposalDatum
+                  { proposalId = ProposalId 0
+                  , effects =
+                      AssocMap.fromList
+                        [ (ResultTag 0, [])
+                        , (ResultTag 1, [])
+                        ]
+                  , status = Draft
+                  , cosigners = [signer]
+                  , thresholds = Shared.defaultProposalThresholds
+                  , votes = ProposalVotes AssocMap.empty
+                  }
+              )
+              (Cosign [signer2])
+              (ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.proposalRef))
+          , validatorSucceedsWith
+              "stake"
+              (stakeValidator Shared.stake)
+              (StakeDatum (Tagged 50_000_000) signer2 [])
+              WitnessStake
+              (ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.stakeRef))
+          ]
       ]
   ]
diff --git a/agora-test/Spec/Sample/Proposal.hs b/agora-test/Spec/Sample/Proposal.hs
index cceb12e..1b560f4 100644
--- a/agora-test/Spec/Sample/Proposal.hs
+++ b/agora-test/Spec/Sample/Proposal.hs
@@ -6,31 +6,21 @@ Description: Sample based testing for Proposal utxos
 This module tests primarily the happy path for Proposal interactions
 -}
 module Spec.Sample.Proposal (
-  proposal,
-  propPolicy,
-  propPolicySymbol,
-  propThresholds,
-  signer,
-  signer2,
-
   -- * Script contexts
   proposalCreation,
   cosignProposal,
+  proposalRef,
+  stakeRef,
 ) where
 
 --------------------------------------------------------------------------------
 import Plutarch.Api.V1 (
-  mintingPolicySymbol,
-  mkMintingPolicy,
-  mkValidator,
   validatorHash,
  )
 import Plutus.V1.Ledger.Api (
   Address (Address),
   Credential (ScriptCredential),
-  CurrencySymbol,
   Datum (Datum),
-  MintingPolicy (..),
   PubKeyHash,
   ScriptContext (..),
   ScriptPurpose (..),
@@ -41,105 +31,33 @@ import Plutus.V1.Ledger.Api (
   TxOutRef (TxOutRef),
  )
 import Plutus.V1.Ledger.Interval qualified as Interval
-import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash)
 import Plutus.V1.Ledger.Value qualified as Value
 
 --------------------------------------------------------------------------------
 
 import Agora.Governor (
-  Governor (Governor),
   GovernorDatum (GovernorDatum, nextProposalId, proposalThresholds),
-  governorPolicy,
-  governorValidator,
  )
 import Agora.Proposal (
   Proposal (..),
   ProposalDatum (..),
   ProposalId (..),
   ProposalStatus (..),
-  ProposalThresholds (..),
   ProposalVotes (..),
   ResultTag (..),
-  proposalPolicy,
-  proposalValidator,
  )
-import Agora.Stake (Stake (..), stakePolicy)
-import Plutarch.SafeMoney
-import Plutus.V1.Ledger.Address (scriptHashAddress)
+import Agora.Stake (Stake (..), StakeDatum (StakeDatum))
+import Plutarch.SafeMoney (Tagged (Tagged), untag)
 import PlutusTx.AssocMap qualified as AssocMap
+import Spec.Sample.Shared
 import Spec.Util (datumPair, toDatumHash)
 
 --------------------------------------------------------------------------------
 
-stake :: Stake
-stake =
-  Stake
-    { gtClassRef = Tagged $ Value.assetClass govSymbol ""
-    , proposalSTClass = Value.assetClass propPolicySymbol ""
-    }
-
-stakeSymbol :: CurrencySymbol
-stakeSymbol = mintingPolicySymbol $ mkMintingPolicy $ stakePolicy stake.gtClassRef
-
-governor :: Governor
-governor = Governor
-
-govPolicy :: MintingPolicy
-govPolicy = mkMintingPolicy (governorPolicy governor)
-
-govValidator :: Validator
-govValidator = mkValidator (governorValidator governor)
-
-govSymbol :: CurrencySymbol
-govSymbol = mintingPolicySymbol govPolicy
-
-proposal :: Proposal
-proposal =
-  Proposal
-    { governorSTAssetClass =
-        -- TODO: if we had a governor here
-        Value.assetClass govSymbol ""
-    , stakeSTAssetClass =
-        Value.assetClass stakeSymbol ""
-    }
-
--- | 'Proposal' policy instance.
-propPolicy :: MintingPolicy
-propPolicy = mkMintingPolicy (proposalPolicy proposal)
-
-propPolicySymbol :: CurrencySymbol
-propPolicySymbol = mintingPolicySymbol propPolicy
-
--- | A sample 'PubKeyHash'.
-signer :: PubKeyHash
-signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
-
--- | Another sample 'PubKeyHash'.
-signer2 :: PubKeyHash
-signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192"
-
--- | 'Proposal' validator instance.
-propValidator :: Validator
-propValidator = mkValidator (proposalValidator proposal)
-
-propValidatorHash :: ValidatorHash
-propValidatorHash = validatorHash propValidator
-
-propValidatorAddress :: Address
-propValidatorAddress = scriptHashAddress propValidatorHash
-
-propThresholds :: ProposalThresholds
-propThresholds =
-  ProposalThresholds
-    { countVoting = Tagged 1000
-    , create = Tagged 1
-    , vote = Tagged 10
-    }
-
 -- | This script context should be a valid transaction.
 proposalCreation :: ScriptContext
 proposalCreation =
-  let st = Value.singleton propPolicySymbol "" 1 -- Proposal ST
+  let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST
       proposalDatum :: Datum
       proposalDatum =
         Datum
@@ -153,7 +71,7 @@ proposalCreation =
                       ]
                 , status = Draft
                 , cosigners = [signer]
-                , thresholds = propThresholds
+                , thresholds = defaultProposalThresholds
                 , votes = ProposalVotes AssocMap.empty
                 }
           )
@@ -163,7 +81,7 @@ proposalCreation =
         Datum
           ( toBuiltinData $
               GovernorDatum
-                { proposalThresholds = propThresholds
+                { proposalThresholds = defaultProposalThresholds
                 , nextProposalId = ProposalId 0
                 }
           )
@@ -172,7 +90,7 @@ proposalCreation =
         Datum
           ( toBuiltinData $
               GovernorDatum
-                { proposalThresholds = propThresholds
+                { proposalThresholds = defaultProposalThresholds
                 , nextProposalId = ProposalId 1
                 }
           )
@@ -190,7 +108,7 @@ proposalCreation =
                   ]
               , txInfoOutputs =
                   [ TxOut
-                      { txOutAddress = Address (ScriptCredential $ validatorHash propValidator) Nothing
+                      { txOutAddress = Address (ScriptCredential proposalValidatorHash) Nothing
                       , txOutValue =
                           mconcat
                             [ st
@@ -221,13 +139,19 @@ proposalCreation =
                   ]
               , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
               }
-        , scriptContextPurpose = Minting propPolicySymbol
+        , scriptContextPurpose = Minting proposalPolicySymbol
         }
 
+proposalRef :: TxOutRef
+proposalRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1
+
+stakeRef :: TxOutRef
+stakeRef = TxOutRef "0ca36f3a357bc69579ab2531aecd1e7d3714d993c7820f40b864be15" 0
+
 -- | This script context should be a valid transaction.
-cosignProposal :: [PubKeyHash] -> ScriptContext
+cosignProposal :: [PubKeyHash] -> TxInfo
 cosignProposal newSigners =
-  let st = Value.singleton propPolicySymbol "" 1 -- Proposal ST
+  let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST
       proposalBefore :: ProposalDatum
       proposalBefore =
         ProposalDatum
@@ -239,50 +163,70 @@ cosignProposal newSigners =
                 ]
           , status = Draft
           , cosigners = [signer]
-          , thresholds = propThresholds
+          , thresholds = defaultProposalThresholds
           , votes = ProposalVotes AssocMap.empty
           }
+      stakeDatum :: StakeDatum
+      stakeDatum = StakeDatum (Tagged 50_000_000) signer2 []
       proposalAfter :: ProposalDatum
       proposalAfter = proposalBefore {cosigners = newSigners <> proposalBefore.cosigners}
-      proposalRef = (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
-   in ScriptContext
-        { scriptContextTxInfo =
-            TxInfo
-              { txInfoInputs =
-                  [ TxInInfo
-                      proposalRef
-                      TxOut
-                        { txOutAddress = propValidatorAddress
-                        , txOutValue =
-                            mconcat
-                              [ st
-                              , Value.singleton "" "" 10_000_000
-                              ]
-                        , txOutDatumHash = Just (toDatumHash proposalBefore)
-                        }
-                  ]
-              , txInfoOutputs =
-                  [ TxOut
-                      { txOutAddress = Address (ScriptCredential $ validatorHash propValidator) Nothing
-                      , txOutValue =
-                          mconcat
-                            [ st
-                            , Value.singleton "" "" 10_000_000
-                            ]
-                      , txOutDatumHash = Just (toDatumHash . Datum $ toBuiltinData proposalAfter)
-                      }
-                  ]
-              , txInfoFee = Value.singleton "" "" 2
-              , txInfoMint = st
-              , txInfoDCert = []
-              , txInfoWdrl = []
-              , txInfoValidRange = Interval.always
-              , txInfoSignatories = newSigners
-              , txInfoData =
-                  [ datumPair . Datum $ toBuiltinData proposalBefore
-                  , datumPair . Datum $ toBuiltinData proposalAfter
-                  ]
-              , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
-              }
-        , scriptContextPurpose = Spending proposalRef
+   in TxInfo
+        { txInfoInputs =
+            [ TxInInfo
+                proposalRef
+                TxOut
+                  { txOutAddress = proposalValidatorAddress
+                  , txOutValue =
+                      mconcat
+                        [ st
+                        , Value.singleton "" "" 10_000_000
+                        ]
+                  , txOutDatumHash = Just (toDatumHash proposalBefore)
+                  }
+            , TxInInfo
+                stakeRef
+                TxOut
+                  { txOutAddress = stakeAddress
+                  , txOutValue =
+                      mconcat
+                        [ Value.singleton "" "" 10_000_000
+                        , Value.assetClassValue (untag stake.gtClassRef) 50_000_000
+                        , Value.singleton stakeSymbol "" 1
+                        ]
+                  , txOutDatumHash = Just (toDatumHash stakeDatum)
+                  }
+            ]
+        , txInfoOutputs =
+            [ TxOut
+                { txOutAddress = Address (ScriptCredential proposalValidatorHash) Nothing
+                , txOutValue =
+                    mconcat
+                      [ st
+                      , Value.singleton "" "" 10_000_000
+                      ]
+                , txOutDatumHash = Just (toDatumHash . Datum $ toBuiltinData proposalAfter)
+                }
+            , TxOut
+                { txOutAddress = stakeAddress
+                , txOutValue =
+                    mconcat
+                      [ Value.singleton "" "" 10_000_000
+                      , Value.assetClassValue (untag stake.gtClassRef) 50_000_000
+                      , Value.singleton stakeSymbol "" 1
+                      ]
+                , txOutDatumHash = Just (toDatumHash stakeDatum)
+                }
+            ]
+        , txInfoFee = Value.singleton "" "" 2
+        , txInfoMint = st
+        , txInfoDCert = []
+        , txInfoWdrl = []
+        , txInfoValidRange = Interval.always
+        , txInfoSignatories = newSigners
+        , txInfoData =
+            [ datumPair . Datum $ toBuiltinData proposalBefore
+            , datumPair . Datum $ toBuiltinData proposalAfter
+            , datumPair . Datum $ toBuiltinData stakeDatum
+            ]
+        , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
         }
diff --git a/agora-test/Spec/Sample/Shared.hs b/agora-test/Spec/Sample/Shared.hs
new file mode 100644
index 0000000..1bb4636
--- /dev/null
+++ b/agora-test/Spec/Sample/Shared.hs
@@ -0,0 +1,132 @@
+{- |
+Module     : Spec.Sample.Shared
+Maintainer : emi@haskell.fyi
+Description: Shared useful values for creating Samples for testing.
+
+Shared useful values for creating Samples for testing.
+-}
+module Spec.Sample.Shared (
+  -- * Misc
+  signer,
+  signer2,
+
+  -- * Components
+
+  -- ** Stake
+  stake,
+  stakeSymbol,
+  stakeValidatorHash,
+  stakeAddress,
+
+  -- ** Governor
+  governor,
+  govPolicy,
+  govValidator,
+  govSymbol,
+
+  -- ** Proposal
+  defaultProposalThresholds,
+  proposal,
+  proposalPolicySymbol,
+  proposalValidatorHash,
+  proposalValidatorAddress,
+) where
+
+import Agora.Governor (
+  Governor (Governor),
+  governorPolicy,
+  governorValidator,
+ )
+import Agora.Proposal (
+  Proposal (..),
+  ProposalThresholds (..),
+  proposalPolicy,
+  proposalValidator,
+ )
+import Agora.Stake (Stake (..), stakePolicy, stakeValidator)
+import Plutarch.Api.V1 (
+  mintingPolicySymbol,
+  mkMintingPolicy,
+  mkValidator,
+  validatorHash,
+ )
+import Plutarch.SafeMoney
+import Plutus.V1.Ledger.Address (scriptHashAddress)
+import Plutus.V1.Ledger.Api (
+  Address (Address),
+  Credential (ScriptCredential),
+  CurrencySymbol,
+  MintingPolicy (..),
+  PubKeyHash,
+ )
+import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash)
+import Plutus.V1.Ledger.Value qualified as Value
+
+--------------------------------------------------------------------------------
+
+stake :: Stake
+stake =
+  Stake
+    { gtClassRef =
+        Tagged $
+          Value.assetClass
+            "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
+            "LQ"
+    , proposalSTClass = Value.assetClass proposalPolicySymbol ""
+    }
+
+stakeSymbol :: CurrencySymbol
+stakeSymbol = mintingPolicySymbol $ mkMintingPolicy $ stakePolicy stake.gtClassRef
+
+stakeValidatorHash :: ValidatorHash
+stakeValidatorHash = validatorHash $ mkValidator (stakeValidator stake)
+
+stakeAddress :: Address
+stakeAddress = Address (ScriptCredential stakeValidatorHash) Nothing
+
+governor :: Governor
+governor = Governor
+
+govPolicy :: MintingPolicy
+govPolicy = mkMintingPolicy (governorPolicy governor)
+
+govValidator :: Validator
+govValidator = mkValidator (governorValidator governor)
+
+govSymbol :: CurrencySymbol
+govSymbol = mintingPolicySymbol govPolicy
+
+proposal :: Proposal
+proposal =
+  Proposal
+    { governorSTAssetClass =
+        -- TODO: if we had a governor here
+        Value.assetClass govSymbol ""
+    , stakeSTAssetClass =
+        Value.assetClass stakeSymbol ""
+    }
+
+proposalPolicySymbol :: CurrencySymbol
+proposalPolicySymbol = mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal)
+
+-- | A sample 'PubKeyHash'.
+signer :: PubKeyHash
+signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
+
+-- | Another sample 'PubKeyHash'.
+signer2 :: PubKeyHash
+signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192"
+
+proposalValidatorHash :: ValidatorHash
+proposalValidatorHash = validatorHash (mkValidator $ proposalValidator proposal)
+
+proposalValidatorAddress :: Address
+proposalValidatorAddress = scriptHashAddress proposalValidatorHash
+
+defaultProposalThresholds :: ProposalThresholds
+defaultProposalThresholds =
+  ProposalThresholds
+    { countVoting = Tagged 1000
+    , create = Tagged 1
+    , vote = Tagged 10
+    }
diff --git a/agora-test/Spec/Sample/Stake.hs b/agora-test/Spec/Sample/Stake.hs
index f100ab6..e893eed 100644
--- a/agora-test/Spec/Sample/Stake.hs
+++ b/agora-test/Spec/Sample/Stake.hs
@@ -7,8 +7,7 @@ This module tests primarily the happy path for Stake creation
 -}
 module Spec.Sample.Stake (
   stake,
-  policy,
-  policySymbol,
+  stakeSymbol,
   validatorHashTN,
   signer,
 
@@ -22,19 +21,14 @@ module Spec.Sample.Stake (
 
 --------------------------------------------------------------------------------
 import Plutarch.Api.V1 (
-  mintingPolicySymbol,
-  mkMintingPolicy,
   mkValidator,
   validatorHash,
  )
 import Plutus.V1.Ledger.Api (
   Address (Address),
   Credential (ScriptCredential),
-  CurrencySymbol,
   Datum (Datum),
   DatumHash (DatumHash),
-  MintingPolicy (..),
-  PubKeyHash,
   ScriptContext (..),
   ScriptPurpose (..),
   ToData (toBuiltinData),
@@ -45,8 +39,7 @@ import Plutus.V1.Ledger.Api (
  )
 import Plutus.V1.Ledger.Contexts (TxOut (TxOut), TxOutRef (TxOutRef))
 import Plutus.V1.Ledger.Interval qualified as Interval
-import Plutus.V1.Ledger.Scripts (Validator)
-import Plutus.V1.Ledger.Value (AssetClass (AssetClass), TokenName (TokenName))
+import Plutus.V1.Ledger.Value (TokenName (TokenName))
 import Plutus.V1.Ledger.Value qualified as Value
 
 --------------------------------------------------------------------------------
@@ -54,47 +47,19 @@ import Plutus.V1.Ledger.Value qualified as Value
 import Agora.SafeMoney (GTTag)
 import Agora.Stake
 import Plutarch.SafeMoney
+import Spec.Sample.Shared
 import Spec.Util (datumPair, toDatumHash)
 
 --------------------------------------------------------------------------------
 
--- | 'Stake' parameters for 'LQ'.
-stake :: Stake
-stake =
-  Stake
-    { gtClassRef =
-        Tagged
-          ( AssetClass
-              ( "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
-              , "LQ"
-              )
-          )
-    , proposalSTClass = AssetClass ("", "")
-    }
-
--- | 'Stake' policy instance.
-policy :: MintingPolicy
-policy = mkMintingPolicy (stakePolicy stake.gtClassRef)
-
-policySymbol :: CurrencySymbol
-policySymbol = mintingPolicySymbol policy
-
--- | A sample 'PubKeyHash'.
-signer :: PubKeyHash
-signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
-
--- | 'Stake' validator instance.
-validator :: Validator
-validator = mkValidator (stakeValidator stake)
-
 -- | 'TokenName' that represents the hash of the 'Stake' validator.
 validatorHashTN :: TokenName
-validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
+validatorHashTN = let ValidatorHash vh = validatorHash (mkValidator $ stakeValidator stake) in TokenName vh
 
 -- | This script context should be a valid transaction.
 stakeCreation :: ScriptContext
 stakeCreation =
-  let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
+  let st = Value.singleton stakeSymbol validatorHashTN 1 -- Stake ST
       datum :: Datum
       datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer [])
    in ScriptContext
@@ -103,7 +68,7 @@ stakeCreation =
               { txInfoInputs = []
               , txInfoOutputs =
                   [ TxOut
-                      { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                      { txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
                       , txOutValue = st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242
                       , txOutDatumHash = Just (DatumHash "")
                       }
@@ -117,7 +82,7 @@ stakeCreation =
               , txInfoData = [("", datum)]
               , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
               }
-        , scriptContextPurpose = Minting policySymbol
+        , scriptContextPurpose = Minting stakeSymbol
         }
 
 -- | This ScriptContext should fail because the datum has too much GT.
@@ -127,7 +92,7 @@ stakeCreationWrongDatum =
       datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer []) -- Too much GT
    in ScriptContext
         { scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]}
-        , scriptContextPurpose = Minting policySymbol
+        , scriptContextPurpose = Minting stakeSymbol
         }
 
 -- | This ScriptContext should fail because the datum has too much GT.
@@ -138,7 +103,7 @@ stakeCreationUnsigned =
         stakeCreation.scriptContextTxInfo
           { txInfoSignatories = []
           }
-    , scriptContextPurpose = Minting policySymbol
+    , scriptContextPurpose = Minting stakeSymbol
     }
 
 --------------------------------------------------------------------------------
@@ -154,7 +119,7 @@ data DepositWithdrawExample = DepositWithdrawExample
 -- | Create a ScriptContext that deposits or withdraws, given the config for it.
 stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
 stakeDepositWithdraw config =
-  let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
+  let st = Value.singleton stakeSymbol validatorHashTN 1 -- Stake ST
       stakeBefore :: StakeDatum
       stakeBefore = StakeDatum config.startAmount signer []
 
@@ -167,7 +132,7 @@ stakeDepositWithdraw config =
                   [ TxInInfo
                       (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
                       TxOut
-                        { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                        { txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
                         , txOutValue =
                             st
                               <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount)
@@ -176,7 +141,7 @@ stakeDepositWithdraw config =
                   ]
               , txInfoOutputs =
                   [ TxOut
-                      { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+                      { txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
                       , txOutValue =
                           st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
                       , txOutDatumHash = Just (toDatumHash stakeAfter)
diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs
index f36b3ba..c9c3ce4 100644
--- a/agora-test/Spec/Util.hs
+++ b/agora-test/Spec/Util.hs
@@ -90,6 +90,7 @@ policyFailsWith tag policy redeemer scriptContext =
 -- | Check that a validator script succeeds, given a name and arguments.
 validatorSucceedsWith ::
   ( PLift datum
+  , Show (PLifted datum)
   , PlutusTx.ToData (PLifted datum)
   , PLift redeemer
   , PlutusTx.ToData (PLifted redeemer)
@@ -100,10 +101,10 @@ validatorSucceedsWith ::
   PLifted redeemer ->
   ScriptContext ->
   TestTree
-validatorSucceedsWith tag policy datum redeemer scriptContext =
+validatorSucceedsWith tag validator datum redeemer scriptContext =
   scriptSucceeds tag $
     compile
-      ( policy
+      ( validator
           # pforgetData (pconstantData datum)
           # pforgetData (pconstantData redeemer)
           # pconstant scriptContext
@@ -122,10 +123,10 @@ validatorFailsWith ::
   PLifted redeemer ->
   ScriptContext ->
   TestTree
-validatorFailsWith tag policy datum redeemer scriptContext =
+validatorFailsWith tag validator datum redeemer scriptContext =
   scriptFails tag $
     compile
-      ( policy
+      ( validator
           # pforgetData (pconstantData datum)
           # pforgetData (pconstantData redeemer)
           # pconstant scriptContext
diff --git a/agora.cabal b/agora.cabal
index 6500ad6..1740981 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -162,6 +162,7 @@ test-suite agora-test
     Spec.Proposal
     Spec.Sample.Effect.TreasuryWithdrawal
     Spec.Sample.Proposal
+    Spec.Sample.Shared
     Spec.Sample.Stake
     Spec.Stake
     Spec.Util
diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs
index cd04507..57baf46 100644
--- a/agora/Agora/AuthorityToken.hs
+++ b/agora/Agora/AuthorityToken.hs
@@ -18,6 +18,7 @@ import Plutarch.Api.V1 (
   PCurrencySymbol (..),
   PScriptContext (..),
   PScriptPurpose (..),
+  PTxInInfo (PTxInInfo),
   PTxInfo (..),
   PTxOut (..),
  )
diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index cc73294..5fa862d 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -58,7 +58,7 @@ import PlutusTx qualified
 import PlutusTx.AssocMap qualified as AssocMap
 
 --------------------------------------------------------------------------------
-
+import Agora.Record (mkRecordConstr, (.&), (.=))
 import Agora.SafeMoney (GTTag)
 import Agora.Utils (
   anyOutput,
@@ -354,7 +354,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum
     Term
       s
       ( PDataRecord
-          '[ "id" ':= PProposalId
+          '[ "proposalId" ':= PProposalId
            , "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash)
            , "status" ':= PProposalStatus
            , "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
@@ -438,7 +438,7 @@ proposalValidator proposal =
     PScriptContext ctx' <- pmatch ctx'
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
     txInfo <- plet $ pfromData ctx.txInfo
-    PTxInfo txInfo' <- pmatch $ txInfo
+    PTxInfo txInfo' <- pmatch txInfo
     txInfoF <- pletFields @'["inputs", "mint"] txInfo'
     PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose
 
@@ -452,7 +452,7 @@ proposalValidator proposal =
 
     proposalF <-
       pletFields
-        @'[ "id"
+        @'[ "proposalId"
           , "effects"
           , "status"
           , "cosigners"
@@ -464,7 +464,10 @@ proposalValidator proposal =
     ownAddress <- plet $ txOutF.address
 
     stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal)
-    spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs
+    valueSpent <- plet $ pvalueSpent # txInfoF.inputs
+    spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
+    let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass
+    spentStakeST <- plet $ passetClassValueOf # valueSpent # (passetClass # pconstant stakeSym # pconstant stakeTn)
 
     pmatch proposalRedeemer $ \case
       PVote _r -> P.do
@@ -482,37 +485,33 @@ proposalValidator proposal =
         passert "Signed by all new cosigners" $
           pall # plam (\sig -> ptxSignedBy # ctx.txInfo # sig) # newSigs
 
+        passert "As many new cosigners as Stake datums" $
+          spentStakeST #== plength # newSigs
+
         passert "Signatures are correctly added to cosignature list" $
           anyOutput @PProposalDatum # ctx.txInfo
             #$ plam
             $ \newValue address newProposalDatum -> P.do
-              newProposalF <-
-                pletFields
-                  @'[ "id"
-                    , "effects"
-                    , "status"
-                    , "cosigners"
-                    , "thresholds"
-                    , "votes"
-                    ]
-                  newProposalDatum
-
               -- This is a little sad. Can we do better by
               -- building a new ProposalDatum and then comparing?
               let correctDatum =
-                    foldr1
-                      (#&&)
-                      [ newProposalF.cosigners #== pconcat # newSigs # proposalF.cosigners
-                      , newProposalF.id #== proposalF.id
-                      , newProposalF.effects #== proposalF.effects
-                      , newProposalF.status #== proposalF.status
-                      , newProposalF.thresholds #== proposalF.thresholds
-                      , newProposalF.votes #== proposalF.votes
-                      ]
+                    pdata newProposalDatum
+                      #== pdata
+                        ( mkRecordConstr
+                            PProposalDatum
+                            ( #proposalId .= proposalF.proposalId
+                                .& #effects .= proposalF.effects
+                                .& #status .= proposalF.status
+                                .& #cosigners .= pdata (pconcat # newSigs # proposalF.cosigners)
+                                .& #thresholds .= proposalF.thresholds
+                                .& #votes .= proposalF.votes
+                            )
+                        )
 
               foldr1
                 (#&&)
-                [ ptraceIfFalse "Datum must be correct" $ correctDatum
+                [ pcon PTrue
+                , ptraceIfFalse "Datum must be correct" correctDatum
                 , ptraceIfFalse "Value should be correct" $ pdata txOutF.value #== pdata newValue
                 , ptraceIfFalse "Must be sent to Proposal's address" $ ownAddress #== pdata address
                 ]
diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs
index 952b8dd..311c3fb 100644
--- a/agora/Agora/Proposal/Time.hs
+++ b/agora/Agora/Proposal/Time.hs
@@ -24,7 +24,7 @@ module Agora.Proposal.Time (
   isDraftRange,
 ) where
 
-import Agora.Record (build, (.&), (.=))
+import Agora.Record (mkRecordConstr, (.&), (.=))
 import GHC.Generics qualified as GHC
 import Generics.SOP (Generic, I (I))
 import Plutarch.Api.V1 (PExtended (PFinite), PInterval (PInterval), PLowerBound (PLowerBound), PMaybeData (PDJust, PDNothing), PPOSIXTime, PPOSIXTimeRange, PUpperBound (PUpperBound))
@@ -149,23 +149,20 @@ currentProposalTime = phoistAcyclic $
     PUpperBound ub <- pmatch ivf.to
     lbf <- pletFields @'["_0", "_1"] lb
     ubf <- pletFields @'["_0", "_1"] ub
-    pcon
-      ( PProposalTime $
-          build $
-            #lowerBound
-              .= pdata
-                ( pmatch lbf._0 $
-                    \case
-                      PFinite d -> pcon (PDJust d)
-                      _ -> pcon (PDNothing pdnil)
-                )
-              .& #upperBound
-              .= pdata
-                ( pmatch ubf._0 $ \case
-                    PFinite d -> pcon (PDJust d)
-                    _ -> pcon (PDNothing pdnil)
-                )
-      )
+    mkRecordConstr PProposalTime $
+      #lowerBound
+        .= pdata
+          ( pmatch lbf._0 $
+              \case
+                PFinite d -> pcon (PDJust d)
+                _ -> pcon (PDNothing pdnil)
+          )
+        .& #upperBound
+        .= pdata
+          ( pmatch ubf._0 $ \case
+              PFinite d -> pcon (PDJust d)
+              _ -> pcon (PDNothing pdnil)
+          )
 
 -- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
 proposalTimeWithin :: Term s (PPOSIXTime :--> PPOSIXTime :--> PProposalTime :--> PBool)
diff --git a/agora/Agora/Record.hs b/agora/Agora/Record.hs
index db293c7..5ad5691 100644
--- a/agora/Agora/Record.hs
+++ b/agora/Agora/Record.hs
@@ -3,9 +3,16 @@ Module     : Agora.Record
 Maintainer : emi@haskell.fyi
 Description: PDataRecord helper functions.
 
-PDataRecord helper functions.
+'PDataRecord' helper functions.
 -}
-module Agora.Record (build, (.=), (.&)) where
+module Agora.Record (
+  mkRecord,
+  mkRecordConstr,
+  (.=),
+  (.&),
+  RecordMorphism,
+  FieldName,
+) where
 
 import Control.Category (Category (..))
 import Data.Coerce (coerce)
@@ -20,17 +27,47 @@ data FieldName (sym :: Symbol) = FieldName
 {- | The use of two different 'Symbol's here allows unification to happen,
      ensuring 'FieldName' has a fully inferred 'Symbol'.
 
-     For example, @'build' (#foo .= 'pconstantData' (42 :: 'Integer'))@ gets
+     For example, @'mkRecord' (#foo .= 'pconstantData' (42 :: 'Integer'))@ gets
      the correct type. Namely, @'Term' s ('PDataRecord' '["foo" ':= 'PInteger'])@.
 -}
-instance forall (sym :: Symbol) (sym' :: Symbol). sym ~ sym' => IsLabel sym (FieldName sym') where
+instance forall (sym :: Symbol) (sym' :: Symbol). sym ~ sym' => IsLabel sym (FieldName sym) where
   fromLabel = FieldName
 
--- | Turn a builder into a fully built 'PDataRecord'.
-build :: forall (s :: S) (r :: [PLabeledType]). RecordMorphism s '[] r -> Term s (PDataRecord r)
-build f = coerce f pdnil
+-- | Turn a constant 'RecordMorphism' into a fully built 'PDataRecord'.
+mkRecord :: forall (r :: [PLabeledType]) (s :: S). RecordMorphism s '[] r -> Term s (PDataRecord r)
+mkRecord f = f.runRecordMorphism pdnil
 
--- | A morphism from one PDataRecord to another, representing some sort of consing of data.
+{- | 'mkRecord' but for known data-types.
+
+This allows you to dynamically construct a record type constructor.
+
+=== Example:
+@
+'mkRecordConstr'
+  'Agora.Stake.PStakeDatum'
+  ( #stakedAmount '.=' 'pconstantData' ('Plutarch.SafeMoney.Tagged' @GTTag 42)
+      '.&' #owner '.=' 'pconstantData' "aabbcc"
+      '.&' #lockedBy '.=' 'pdata' pnil
+  )
+@
+Is the same as
+
+@
+'pconstant' ('Agora.Stake.StakeDatum' ('Plutarch.SafeMoney.Tagged' 42) "aabbcc" [])
+@
+-}
+mkRecordConstr ::
+  forall (r :: [PLabeledType]) (s :: S) (pt :: PType).
+  PlutusType pt =>
+  -- | The constructor. This is just the Haskell-level constructor for the type.
+  --   For 'PMaybeData', this could be 'PDJust', or 'PNothing'.
+  (forall s'. Term s' (PDataRecord r) -> pt s') ->
+  -- | The morphism that builds the record.
+  RecordMorphism s '[] r ->
+  Term s pt
+mkRecordConstr ctr = pcon . ctr . mkRecord
+
+-- | A morphism from one 'PDataRecord' to another, representing some sort of consing of data.
 newtype RecordMorphism (s :: S) (as :: [PLabeledType]) (bs :: [PLabeledType]) = RecordMorphism
   { runRecordMorphism ::
     Term s (PDataRecord as) ->
@@ -46,14 +83,18 @@ infix 7 .=
 -- | Cons a labeled type as a 'RecordMorphism'.
 (.=) ::
   forall (sym :: Symbol) (a :: PType) (as :: [PLabeledType]) (s :: S).
+  -- | The field name. You can use @-XOverloadedLabels@ to enable the syntax:
+  --   @#hello ~ 'FieldName' "hello"@
   FieldName sym ->
+  -- | The value at that field. This must be 'PAsData', because the underlying
+  --   type is @'Constr' 'Integer' ['Data']@.
   Term s (PAsData a) ->
   RecordMorphism s as ((sym ':= a) ': as)
 _ .= x = RecordMorphism $ pcon . PDCons x
 
 infixr 6 .&
 
--- | Compose two morphisms between records.
+-- | Compose two 'RecordMorphism's.
 (.&) ::
   forall
     (s :: S)
diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs
index 98242c8..05a4d23 100644
--- a/agora/Agora/Stake.hs
+++ b/agora/Agora/Stake.hs
@@ -441,15 +441,20 @@ stakeValidator stake =
           anyOutput @PStakeDatum # txInfo
             #$ plam
             $ \value address newStakeDatum' -> P.do
+              PStakeDatum newStakeDatum <- pmatch newStakeDatum'
+              newStakeDatumF <- pletFields @'["stakedAmount"] newStakeDatum
               let isScriptAddress = pdata address #== ownAddress
               let correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
               let valueCorrect = pdata continuingValue #== pdata value
-              foldr1
-                (#&&)
-                [ ptraceIfFalse "isScriptAddress" isScriptAddress
-                , ptraceIfFalse "correctOutputDatum" correctOutputDatum
-                , ptraceIfFalse "valueCorrect" valueCorrect
-                ]
+              pif
+                isScriptAddress
+                ( foldl1
+                    (#&&)
+                    [ ptraceIfFalse "valueCorrect" valueCorrect
+                    , ptraceIfFalse "correctOutputDatum" correctOutputDatum
+                    ]
+                )
+                (pcon PFalse)
         popaque (pconstant ())
       PDepositWithdraw r -> P.do
         passert "ST at inputs must be 1" $

From 53629f53c3e5326080311efa8b533db4e1c7f265 Mon Sep 17 00:00:00 2001
From: Hongrui Fang <chfanghr@gmail.com>
Date: Thu, 21 Apr 2022 18:21:20 +0800
Subject: [PATCH 63/78] add missing plutarch level proposal status `PLocked`

---
 agora/Agora/Proposal.hs | 1 +
 agora/Agora/Stake.hs    | 2 --
 2 files changed, 1 insertion(+), 2 deletions(-)

diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index 5fa862d..e6cdce0 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -304,6 +304,7 @@ data PProposalStatus (s :: S)
     -- e.g. like Tilde used 'pmatchEnum'.
     PDraft (Term s (PDataRecord '[]))
   | PVotingReady (Term s (PDataRecord '[]))
+  | PLocked (Term s (PDataRecord '[]))
   | PFinished (Term s (PDataRecord '[]))
   deriving stock (GHC.Generic)
   deriving anyclass (Generic)
diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs
index 05a4d23..f484f9d 100644
--- a/agora/Agora/Stake.hs
+++ b/agora/Agora/Stake.hs
@@ -441,8 +441,6 @@ stakeValidator stake =
           anyOutput @PStakeDatum # txInfo
             #$ plam
             $ \value address newStakeDatum' -> P.do
-              PStakeDatum newStakeDatum <- pmatch newStakeDatum'
-              newStakeDatumF <- pletFields @'["stakedAmount"] newStakeDatum
               let isScriptAddress = pdata address #== ownAddress
               let correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
               let valueCorrect = pdata continuingValue #== pdata value

From 4411dba71704c12b0d3a43aa06ca25f1ec127184 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Mon, 25 Apr 2022 22:32:26 +0200
Subject: [PATCH 64/78] move Proposal impl. to `Agora.Proposal.Scripts` to
 avoid cyclic deps

---
 agora.cabal                              |   1 +
 agora/Agora/Effect/NoOp.hs               |   1 -
 agora/Agora/Effect/TreasuryWithdrawal.hs |   8 +-
 agora/Agora/Proposal.hs                  | 200 +-------------------
 agora/Agora/Proposal/Scripts.hs          | 227 +++++++++++++++++++++++
 agora/Agora/Utils.hs                     |  13 ++
 6 files changed, 253 insertions(+), 197 deletions(-)
 create mode 100644 agora/Agora/Proposal/Scripts.hs

diff --git a/agora.cabal b/agora.cabal
index 1740981..1948966 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -129,6 +129,7 @@ library
     Agora.Governor
     Agora.MultiSig
     Agora.Proposal
+    Agora.Proposal.Scripts
     Agora.Proposal.Time
     Agora.Record
     Agora.SafeMoney
diff --git a/agora/Agora/Effect/NoOp.hs b/agora/Agora/Effect/NoOp.hs
index 90782e9..ccdae74 100644
--- a/agora/Agora/Effect/NoOp.hs
+++ b/agora/Agora/Effect/NoOp.hs
@@ -10,7 +10,6 @@ module Agora.Effect.NoOp (noOpValidator, PNoOp) where
 import Control.Applicative (Const)
 
 import Agora.Effect (makeEffect)
-import Plutarch (popaque)
 import Plutarch.Api.V1 (PValidator)
 import Plutarch.TryFrom (PTryFrom (..))
 import Plutus.V1.Ledger.Value (CurrencySymbol)
diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 209877f..312efbf 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -19,7 +19,6 @@ import Generics.SOP (Generic, I (I))
 
 import Agora.Effect (makeEffect)
 import Agora.Utils (findTxOutByTxOutRef, paddValue, passert)
-import Plutarch (popaque)
 import Plutarch.Api.V1 (
   PCredential (..),
   PTuple,
@@ -34,7 +33,7 @@ import Plutarch.DataRepr (
   PDataFields,
   PIsDataReprInstances (..),
  )
-import Plutarch.Lift (PUnsafeLiftDecl (..))
+import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
 import Plutarch.Monadic qualified as P
 import Plutarch.TryFrom (PTryFrom (..))
 import Plutus.V1.Ledger.Credential (Credential)
@@ -69,10 +68,11 @@ newtype PTreasuryWithdrawalDatum (s :: S)
 
 instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where
   type PLifted PTreasuryWithdrawalDatum = TreasuryWithdrawalDatum
+
 deriving via
   (DerivePConstantViaData TreasuryWithdrawalDatum PTreasuryWithdrawalDatum)
   instance
-    (PConstant TreasuryWithdrawalDatum)
+    (PConstantDecl TreasuryWithdrawalDatum)
 
 instance PTryFrom PData PTreasuryWithdrawalDatum where
   type PTryFromExcess PData PTreasuryWithdrawalDatum = Const ()
@@ -99,7 +99,7 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
   \_cs (datum' :: Term _ PTreasuryWithdrawalDatum) txOutRef' txInfo' -> P.do
     datum <- pletFields @'["receivers", "treasuries"] datum'
     txInfo <- pletFields @'["outputs", "inputs"] txInfo'
-    PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo'
+    PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef' # pfromData txInfo.inputs
     effInput <- pletFields @'["address", "value"] $ txOut
     outputValues <-
       plet $
diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index e6cdce0..6c26a3f 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -26,11 +26,6 @@ module Agora.Proposal (
   PProposalVotes (..),
   PProposalId (..),
   PResultTag (..),
-
-  -- * Scripts
-  proposalValidator,
-  proposalPolicy,
-  proposalDatumValid,
 ) where
 
 import GHC.Generics qualified as GHC
@@ -38,47 +33,26 @@ import Generics.SOP (Generic, I (I))
 import Plutarch.Api.V1 (
   PDatumHash,
   PMap,
-  PMintingPolicy,
   PPubKeyHash,
-  PScriptContext (PScriptContext),
-  PScriptPurpose (PMinting, PSpending),
-  PTxInfo (PTxInfo),
-  PValidator,
   PValidatorHash,
-  mintingPolicySymbol,
-  mkMintingPolicy,
  )
-import Plutarch.DataRepr (
-  DerivePConstantViaData (..),
-  PDataFields,
-  PIsDataReprInstances (PIsDataReprInstances),
- )
-import Plutus.V1.Ledger.Api (DatumHash, PubKeyHash, ValidatorHash)
 import PlutusTx qualified
 import PlutusTx.AssocMap qualified as AssocMap
 
 --------------------------------------------------------------------------------
-import Agora.Record (mkRecordConstr, (.&), (.=))
 import Agora.SafeMoney (GTTag)
-import Agora.Utils (
-  anyOutput,
-  findTxOutByTxOutRef,
-  passert,
-  pnotNull,
-  psymbolValueOf,
-  ptokenSpent,
-  ptxSignedBy,
-  pvalueSpent,
- )
 import Control.Arrow (first)
-import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
-import Plutarch.Builtin (PBuiltinMap)
-import Plutarch.Lift (DerivePConstantViaNewtype (..), PConstantDecl, PUnsafeLiftDecl (..))
-import Plutarch.Monadic qualified as P
+import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..))
+import Plutarch.Lift (
+  DerivePConstantViaNewtype (..),
+  PConstantDecl,
+  PUnsafeLiftDecl (..),
+ )
 import Plutarch.SafeMoney (PDiscrete, Tagged)
 import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
 import Plutarch.Unsafe (punsafeCoerce)
-import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
+import Plutus.V1.Ledger.Api (DatumHash, PubKeyHash, ValidatorHash)
+import Plutus.V1.Ledger.Value (AssetClass)
 
 --------------------------------------------------------------------------------
 -- Haskell-land
@@ -395,161 +369,3 @@ data PProposalRedeemer (s :: S)
 
 instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer
 deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstantDecl ProposalRedeemer)
-
---------------------------------------------------------------------------------
-
-{- | Policy for Proposals.
-   This needs to perform two checks:
-     - Governor is happy with mint.
-     - Exactly 1 token is minted.
-
-   NOTE: The governor needs to check that the datum is correct
-         and sent to the right address.
--}
-proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
-proposalPolicy proposal =
-  plam $ \_redeemer ctx' -> P.do
-    PScriptContext ctx' <- pmatch ctx'
-    ctx <- pletFields @'["txInfo", "purpose"] ctx'
-    PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
-    txInfo <- pletFields @'["inputs", "mint"] txInfo'
-    PMinting _ownSymbol <- pmatch $ pfromData ctx.purpose
-
-    let inputs = txInfo.inputs
-        mintedValue = pfromData txInfo.mint
-        AssetClass (govCs, govTn) = proposal.governorSTAssetClass
-
-    PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
-    let mintedProposalST = passetClassValueOf # mintedValue # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "")
-
-    passert "Governance state-thread token must move" $
-      ptokenSpent
-        # (passetClass # pconstant govCs # pconstant govTn)
-        # inputs
-
-    passert "Minted exactly one proposal ST" $
-      mintedProposalST #== 1
-
-    popaque (pconstant ())
-
--- | Validator for Proposals.
-proposalValidator :: Proposal -> ClosedTerm PValidator
-proposalValidator proposal =
-  plam $ \datum redeemer ctx' -> P.do
-    PScriptContext ctx' <- pmatch ctx'
-    ctx <- pletFields @'["txInfo", "purpose"] ctx'
-    txInfo <- plet $ pfromData ctx.txInfo
-    PTxInfo txInfo' <- pmatch txInfo
-    txInfoF <- pletFields @'["inputs", "mint"] txInfo'
-    PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose
-
-    PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
-    txOutF <- pletFields @'["address", "value"] $ txOut
-
-    let proposalDatum :: Term _ PProposalDatum
-        proposalDatum = pfromData $ punsafeCoerce datum
-        proposalRedeemer :: Term _ PProposalRedeemer
-        proposalRedeemer = pfromData $ punsafeCoerce redeemer
-
-    proposalF <-
-      pletFields
-        @'[ "proposalId"
-          , "effects"
-          , "status"
-          , "cosigners"
-          , "thresholds"
-          , "votes"
-          ]
-        proposalDatum
-
-    ownAddress <- plet $ txOutF.address
-
-    stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal)
-    valueSpent <- plet $ pvalueSpent # txInfoF.inputs
-    spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
-    let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass
-    spentStakeST <- plet $ passetClassValueOf # valueSpent # (passetClass # pconstant stakeSym # pconstant stakeTn)
-
-    pmatch proposalRedeemer $ \case
-      PVote _r -> P.do
-        passert "ST at inputs must be 1" $
-          spentST #== 1
-
-        popaque (pconstant ())
-      --------------------------------------------------------------------------
-      PCosign r -> P.do
-        newSigs <- plet $ pfield @"newCosigners" # r
-
-        passert "ST at inputs must be 1" $
-          spentST #== 1
-
-        passert "Signed by all new cosigners" $
-          pall # plam (\sig -> ptxSignedBy # ctx.txInfo # sig) # newSigs
-
-        passert "As many new cosigners as Stake datums" $
-          spentStakeST #== plength # newSigs
-
-        passert "Signatures are correctly added to cosignature list" $
-          anyOutput @PProposalDatum # ctx.txInfo
-            #$ plam
-            $ \newValue address newProposalDatum -> P.do
-              -- This is a little sad. Can we do better by
-              -- building a new ProposalDatum and then comparing?
-              let correctDatum =
-                    pdata newProposalDatum
-                      #== pdata
-                        ( mkRecordConstr
-                            PProposalDatum
-                            ( #proposalId .= proposalF.proposalId
-                                .& #effects .= proposalF.effects
-                                .& #status .= proposalF.status
-                                .& #cosigners .= pdata (pconcat # newSigs # proposalF.cosigners)
-                                .& #thresholds .= proposalF.thresholds
-                                .& #votes .= proposalF.votes
-                            )
-                        )
-
-              foldr1
-                (#&&)
-                [ pcon PTrue
-                , ptraceIfFalse "Datum must be correct" correctDatum
-                , ptraceIfFalse "Value should be correct" $ pdata txOutF.value #== pdata newValue
-                , ptraceIfFalse "Must be sent to Proposal's address" $ ownAddress #== pdata address
-                ]
-
-        popaque (pconstant ())
-      --------------------------------------------------------------------------
-      PUnlock _r -> P.do
-        passert "ST at inputs must be 1" $
-          spentST #== 1
-
-        popaque (pconstant ())
-      --------------------------------------------------------------------------
-      PAdvanceProposal _r -> P.do
-        passert "ST at inputs must be 1" $
-          spentST #== 1
-
-        popaque (pconstant ())
-
-{- | Check for various invariants a proposal must uphold.
-     This can be used to check both upopn creation and
-     upon any following state transitions in the proposal.
--}
-proposalDatumValid :: Term s (PProposalDatum :--> PBool)
-proposalDatumValid =
-  phoistAcyclic $
-    plam $ \datum' -> P.do
-      datum <- pletFields @'["effects", "cosigners"] $ datum'
-
-      let effects :: Term _ (PBuiltinMap PResultTag (PBuiltinMap PValidatorHash PDatumHash))
-          effects = punsafeCoerce datum.effects
-
-          atLeastOneNegativeResult :: Term _ PBool
-          atLeastOneNegativeResult =
-            pany # plam (\pair -> pnull #$ pfromData $ psndBuiltin # pair) # effects
-
-      foldr1
-        (#&&)
-        [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult
-        , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
-        ]
diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs
new file mode 100644
index 0000000..ce21cea
--- /dev/null
+++ b/agora/Agora/Proposal/Scripts.hs
@@ -0,0 +1,227 @@
+module Agora.Proposal.Scripts (
+  proposalValidator,
+  proposalPolicy,
+  proposalDatumValid,
+) where
+
+import Agora.Proposal
+import Agora.Record (mkRecordConstr, (.&), (.=))
+import Agora.Stake (PStakeDatum)
+import Agora.Utils (
+  anyOutput,
+  findTxOutByTxOutRef,
+  passert,
+  pfindDatum',
+  pnotNull,
+  psymbolValueOf,
+  ptokenSpent,
+  ptxSignedBy,
+  pvalueSpent,
+ )
+import Plutarch.Api.V1 (
+  PDatumHash,
+  PMaybeData (PDJust, PDNothing),
+  PMintingPolicy,
+  PPubKeyHash,
+  PScriptContext (PScriptContext),
+  PScriptPurpose (PMinting, PSpending),
+  PTxInInfo (PTxInInfo),
+  PTxInfo (PTxInfo),
+  PTxOut (PTxOut),
+  PValidator,
+  PValidatorHash,
+  mintingPolicySymbol,
+  mkMintingPolicy,
+ )
+import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
+import Plutarch.Builtin (PBuiltinMap)
+import Plutarch.Monadic qualified as P
+import Plutarch.Unsafe (punsafeCoerce)
+import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
+
+{- | Policy for Proposals.
+   This needs to perform two checks:
+     - Governor is happy with mint.
+     - Exactly 1 token is minted.
+
+   NOTE: The governor needs to check that the datum is correct
+         and sent to the right address.
+-}
+proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
+proposalPolicy proposal =
+  plam $ \_redeemer ctx' -> P.do
+    PScriptContext ctx' <- pmatch ctx'
+    ctx <- pletFields @'["txInfo", "purpose"] ctx'
+    PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
+    txInfo <- pletFields @'["inputs", "mint"] txInfo'
+    PMinting _ownSymbol <- pmatch $ pfromData ctx.purpose
+
+    let inputs = txInfo.inputs
+        mintedValue = pfromData txInfo.mint
+        AssetClass (govCs, govTn) = proposal.governorSTAssetClass
+
+    PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
+    let mintedProposalST = passetClassValueOf # mintedValue # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "")
+
+    passert "Governance state-thread token must move" $
+      ptokenSpent
+        # (passetClass # pconstant govCs # pconstant govTn)
+        # inputs
+
+    passert "Minted exactly one proposal ST" $
+      mintedProposalST #== 1
+
+    popaque (pconstant ())
+
+-- | Validator for Proposals.
+proposalValidator :: Proposal -> ClosedTerm PValidator
+proposalValidator proposal =
+  plam $ \datum redeemer ctx' -> P.do
+    PScriptContext ctx' <- pmatch ctx'
+    ctx <- pletFields @'["txInfo", "purpose"] ctx'
+    txInfo <- plet $ pfromData ctx.txInfo
+    PTxInfo txInfo' <- pmatch txInfo
+    txInfoF <- pletFields @'["inputs", "mint"] txInfo'
+    PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose
+
+    PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
+    txOutF <- pletFields @'["address", "value"] $ txOut
+
+    let proposalDatum :: Term _ PProposalDatum
+        proposalDatum = pfromData $ punsafeCoerce datum
+        proposalRedeemer :: Term _ PProposalRedeemer
+        proposalRedeemer = pfromData $ punsafeCoerce redeemer
+
+    proposalF <-
+      pletFields
+        @'[ "proposalId"
+          , "effects"
+          , "status"
+          , "cosigners"
+          , "thresholds"
+          , "votes"
+          ]
+        proposalDatum
+
+    ownAddress <- plet $ txOutF.address
+
+    stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal)
+    valueSpent <- plet $ pvalueSpent # txInfoF.inputs
+    spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
+    let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass
+    stakeSTAssetClass <- plet $ passetClass # pconstant stakeSym # pconstant stakeTn
+    spentStakeST <- plet $ passetClassValueOf # valueSpent # stakeSTAssetClass
+
+    pmatch proposalRedeemer $ \case
+      PVote _r -> P.do
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        popaque (pconstant ())
+      --------------------------------------------------------------------------
+      PCosign r -> P.do
+        newSigs <- plet $ pfield @"newCosigners" # r
+
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        passert "Signed by all new cosigners" $
+          pall # plam (\sig -> ptxSignedBy # ctx.txInfo # sig) # newSigs
+
+        passert "As many new cosigners as Stake datums" $
+          spentStakeST #== plength # newSigs
+
+        let stakeDatumOwnedBy :: Term _ (PPubKeyHash :--> PStakeDatum :--> PBool)
+            stakeDatumOwnedBy =
+              phoistAcyclic $
+                plam $ \pk stakeDatum -> P.do
+                  stakeDatumF <- pletFields @'["owner"] $ pto stakeDatum
+                  stakeDatumF.owner #== pdata pk
+
+        -- Does the input have a `Stake` owned by a particular PK?
+        let isInputStakeOwnedBy :: Term _ (PAsData PPubKeyHash :--> PAsData PTxInInfo :--> PBool)
+            isInputStakeOwnedBy =
+              plam $ \ss txInInfo' -> P.do
+                PTxInInfo ((pfield @"resolved" #) -> txOut) <- pmatch $ pfromData txInInfo'
+                PTxOut txOut' <- pmatch txOut
+                txOutF <- pletFields @'["value", "datumHash"] txOut'
+                outStakeST <- plet $ passetClassValueOf # txOutF.value # stakeSTAssetClass
+                pmatch txOutF.datumHash $ \case
+                  PDNothing _ -> pcon PFalse
+                  PDJust ((pfield @"_0" #) -> datumHash) ->
+                    pif
+                      (outStakeST #== 1)
+                      -- TODO: use 'ptryFindDatum' instead in the future
+                      ( pmatch (pfindDatum' # datumHash # txInfo) $ \case
+                          PNothing -> pcon PFalse
+                          PJust v -> stakeDatumOwnedBy # pfromData ss # pfromData v
+                      )
+                      (pcon PFalse)
+
+        passert "All new cosigners are witnessed by their Stake datums" $
+          pall
+            # plam (\sig -> pany # (isInputStakeOwnedBy # sig) # txInfoF.inputs)
+            # newSigs
+
+        passert "Signatures are correctly added to cosignature list" $
+          anyOutput @PProposalDatum # ctx.txInfo
+            #$ plam
+            $ \newValue address newProposalDatum -> P.do
+              let correctDatum =
+                    pdata newProposalDatum
+                      #== pdata
+                        ( mkRecordConstr
+                            PProposalDatum
+                            ( #proposalId .= proposalF.proposalId
+                                .& #effects .= proposalF.effects
+                                .& #status .= proposalF.status
+                                .& #cosigners .= pdata (pconcat # newSigs # proposalF.cosigners)
+                                .& #thresholds .= proposalF.thresholds
+                                .& #votes .= proposalF.votes
+                            )
+                        )
+
+              foldr1
+                (#&&)
+                [ pcon PTrue
+                , ptraceIfFalse "Datum must be correct" correctDatum
+                , ptraceIfFalse "Value should be correct" $ pdata txOutF.value #== pdata newValue
+                , ptraceIfFalse "Must be sent to Proposal's address" $ ownAddress #== pdata address
+                ]
+
+        popaque (pconstant ())
+      --------------------------------------------------------------------------
+      PUnlock _r -> P.do
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        popaque (pconstant ())
+      --------------------------------------------------------------------------
+      PAdvanceProposal _r -> P.do
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        popaque (pconstant ())
+
+{- | Check for various invariants a proposal must uphold.
+     This can be used to check both upopn creation and
+     upon any following state transitions in the proposal.
+-}
+proposalDatumValid :: Term s (PProposalDatum :--> PBool)
+proposalDatumValid =
+  phoistAcyclic $
+    plam $ \datum' -> P.do
+      datum <- pletFields @'["effects", "cosigners"] $ datum'
+
+      let effects :: Term _ (PBuiltinMap PResultTag (PBuiltinMap PValidatorHash PDatumHash))
+          effects = punsafeCoerce datum.effects
+
+          atLeastOneNegativeResult :: Term _ PBool
+          atLeastOneNegativeResult =
+            pany # plam (\pair -> pnull #$ pfromData $ psndBuiltin # pair) # effects
+
+      foldr1
+        (#&&)
+        [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult
+        , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
+        ]
diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index bd0449d..7a2ee01 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -11,6 +11,7 @@ module Agora.Utils (
   pfind',
   pfindDatum,
   pfindDatum',
+  ptryFindDatum,
   pvalueSpent,
   ptxSignedBy,
   paddValue,
@@ -67,6 +68,7 @@ import Plutarch.Api.V1.Value (PValue (PValue))
 import Plutarch.Builtin (ppairDataBuiltin)
 import Plutarch.Internal (punsafeCoerce)
 import Plutarch.Monadic qualified as P
+import Plutarch.TryFrom (PTryFrom, ptryFrom)
 
 --------------------------------------------------------------------------------
 -- Validator-level utility functions
@@ -82,6 +84,17 @@ pfindDatum = phoistAcyclic $
     PTxInfo txInfo' <- pmatch txInfo''
     plookupTuple # datumHash #$ pfield @"datums" # txInfo'
 
+-- | Find a datum with the given hash, and `ptryFrom` it.
+ptryFindDatum :: PTryFrom PData a => Term s (PDatumHash :--> PTxInfo :--> PMaybe a)
+ptryFindDatum = phoistAcyclic $
+  plam $ \datumHash txInfo'' -> P.do
+    PTxInfo txInfo' <- pmatch txInfo''
+    pmatch (plookupTuple # datumHash #$ pfield @"datums" # txInfo') $ \case
+      PNothing -> pcon PNothing
+      PJust datum -> P.do
+        (datum', _) <- ptryFrom $ pto datum
+        pcon (PJust datum')
+
 {- | Find a datum with the given hash.
 NOTE: this is unsafe in the sense that, if the data layout is wrong, this is UB.
 -}

From 189973f30fef0c18d373a2e5eb765f4b4ddbb1b9 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Tue, 26 Apr 2022 15:37:54 +0200
Subject: [PATCH 65/78] reduce 'PTxInfo' passing to functions

---
 agora/Agora/Effect/TreasuryWithdrawal.hs |  8 +-
 agora/Agora/Proposal.hs                  |  3 +
 agora/Agora/Proposal/Scripts.hs          | 95 ++++++++++--------------
 agora/Agora/Stake.hs                     | 75 +++++++++++++++++--
 agora/Agora/Utils.hs                     | 56 ++++++--------
 5 files changed, 140 insertions(+), 97 deletions(-)

diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 312efbf..8693cdf 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -40,9 +40,12 @@ import Plutus.V1.Ledger.Credential (Credential)
 import Plutus.V1.Ledger.Value (CurrencySymbol, Value)
 import PlutusTx qualified
 
+-- | Datum that encodes behavior of Treasury Withdrawal effect.
 data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum
   { receivers :: [(Credential, Value)]
+  -- ^ AssocMap for Value sent to each receiver from the treasury.
   , treasuries :: [Credential]
+  -- ^ What Credentials is spending from legal.
   }
   deriving stock (Show, GHC.Generic)
   deriving anyclass (Generic)
@@ -77,7 +80,8 @@ deriving via
 instance PTryFrom PData PTreasuryWithdrawalDatum where
   type PTryFromExcess PData PTreasuryWithdrawalDatum = Const ()
   ptryFrom' opq cont =
-    -- this will need to not use punsafeCoerce...
+    -- TODO: This should not use 'punsafeCoerce'.
+    -- Blocked by 'PCredential', and 'PTuple'.
     cont (punsafeCoerce opq, ())
 
 {- | Withdraws given list of values to specific target addresses.
@@ -90,7 +94,7 @@ instance PTryFrom PData PTreasuryWithdrawalDatum where
      Note:
      It should check...
      1. Transaction outputs should contain all of what Datum specified
-     2. Left over assests should be redirected back to Treasury
+     2. Left over assets should be redirected back to Treasury
      It can be more flexiable over...
      - The number of outputs themselves
 -}
diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index 6c26a3f..bf88bf8 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -128,6 +128,9 @@ data ProposalThresholds = ProposalThresholds
   -- ^ How much GT minimum must a particular 'ResultTag' accumulate for it to pass.
   , create :: Tagged GTTag Integer
   -- ^ How much GT required to "create" a proposal.
+  --
+  -- It is recommended this be a high enough amount, in order to prevent DOS from bad
+  -- actors.
   , vote :: Tagged GTTag Integer
   -- ^ How much GT required to allow voting to happen.
   -- (i.e. to move into 'VotingReady')
diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs
index ce21cea..09ae5c4 100644
--- a/agora/Agora/Proposal/Scripts.hs
+++ b/agora/Agora/Proposal/Scripts.hs
@@ -4,14 +4,18 @@ module Agora.Proposal.Scripts (
   proposalDatumValid,
 ) where
 
-import Agora.Proposal
+import Agora.Proposal (
+  PProposalDatum (PProposalDatum),
+  PProposalRedeemer (..),
+  PResultTag,
+  Proposal (governorSTAssetClass, stakeSTAssetClass),
+ )
 import Agora.Record (mkRecordConstr, (.&), (.=))
-import Agora.Stake (PStakeDatum)
+import Agora.Stake (findStakeOwnedBy)
 import Agora.Utils (
   anyOutput,
   findTxOutByTxOutRef,
   passert,
-  pfindDatum',
   pnotNull,
   psymbolValueOf,
   ptokenSpent,
@@ -20,14 +24,10 @@ import Agora.Utils (
  )
 import Plutarch.Api.V1 (
   PDatumHash,
-  PMaybeData (PDJust, PDNothing),
   PMintingPolicy,
-  PPubKeyHash,
   PScriptContext (PScriptContext),
   PScriptPurpose (PMinting, PSpending),
-  PTxInInfo (PTxInInfo),
   PTxInfo (PTxInfo),
-  PTxOut (PTxOut),
   PValidator,
   PValidatorHash,
   mintingPolicySymbol,
@@ -47,20 +47,20 @@ import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
    NOTE: The governor needs to check that the datum is correct
          and sent to the right address.
 -}
-proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
+proposalPolicy :: Agora.Proposal.Proposal -> ClosedTerm Plutarch.Api.V1.PMintingPolicy
 proposalPolicy proposal =
   plam $ \_redeemer ctx' -> P.do
-    PScriptContext ctx' <- pmatch ctx'
+    Plutarch.Api.V1.PScriptContext ctx' <- pmatch ctx'
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
-    PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
+    Plutarch.Api.V1.PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
     txInfo <- pletFields @'["inputs", "mint"] txInfo'
-    PMinting _ownSymbol <- pmatch $ pfromData ctx.purpose
+    Plutarch.Api.V1.PMinting _ownSymbol <- pmatch $ pfromData ctx.purpose
 
     let inputs = txInfo.inputs
         mintedValue = pfromData txInfo.mint
         AssetClass (govCs, govTn) = proposal.governorSTAssetClass
 
-    PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
+    Plutarch.Api.V1.PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
     let mintedProposalST = passetClassValueOf # mintedValue # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "")
 
     passert "Governance state-thread token must move" $
@@ -74,22 +74,22 @@ proposalPolicy proposal =
     popaque (pconstant ())
 
 -- | Validator for Proposals.
-proposalValidator :: Proposal -> ClosedTerm PValidator
+proposalValidator :: Agora.Proposal.Proposal -> ClosedTerm Plutarch.Api.V1.PValidator
 proposalValidator proposal =
   plam $ \datum redeemer ctx' -> P.do
-    PScriptContext ctx' <- pmatch ctx'
+    Plutarch.Api.V1.PScriptContext ctx' <- pmatch ctx'
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
     txInfo <- plet $ pfromData ctx.txInfo
-    PTxInfo txInfo' <- pmatch txInfo
-    txInfoF <- pletFields @'["inputs", "mint"] txInfo'
-    PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose
+    Plutarch.Api.V1.PTxInfo txInfo' <- pmatch txInfo
+    txInfoF <- pletFields @'["inputs", "mint", "datums", "signatories"] txInfo'
+    Plutarch.Api.V1.PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose
 
     PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
     txOutF <- pletFields @'["address", "value"] $ txOut
 
-    let proposalDatum :: Term _ PProposalDatum
+    let proposalDatum :: Term _ Agora.Proposal.PProposalDatum
         proposalDatum = pfromData $ punsafeCoerce datum
-        proposalRedeemer :: Term _ PProposalRedeemer
+        proposalRedeemer :: Term _ Agora.Proposal.PProposalRedeemer
         proposalRedeemer = pfromData $ punsafeCoerce redeemer
 
     proposalF <-
@@ -105,73 +105,53 @@ proposalValidator proposal =
 
     ownAddress <- plet $ txOutF.address
 
-    stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (proposalPolicy proposal)
+    stCurrencySymbol <- plet $ pconstant $ Plutarch.Api.V1.mintingPolicySymbol $ Plutarch.Api.V1.mkMintingPolicy (proposalPolicy proposal)
     valueSpent <- plet $ pvalueSpent # txInfoF.inputs
     spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
     let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass
     stakeSTAssetClass <- plet $ passetClass # pconstant stakeSym # pconstant stakeTn
     spentStakeST <- plet $ passetClassValueOf # valueSpent # stakeSTAssetClass
 
+    signedBy <- plet $ ptxSignedBy # txInfoF.signatories
+
     pmatch proposalRedeemer $ \case
-      PVote _r -> P.do
+      Agora.Proposal.PVote _r -> P.do
         passert "ST at inputs must be 1" $
           spentST #== 1
 
         popaque (pconstant ())
       --------------------------------------------------------------------------
-      PCosign r -> P.do
+      Agora.Proposal.PCosign r -> P.do
         newSigs <- plet $ pfield @"newCosigners" # r
 
         passert "ST at inputs must be 1" $
           spentST #== 1
 
         passert "Signed by all new cosigners" $
-          pall # plam (\sig -> ptxSignedBy # ctx.txInfo # sig) # newSigs
+          pall # signedBy # newSigs
 
         passert "As many new cosigners as Stake datums" $
           spentStakeST #== plength # newSigs
 
-        let stakeDatumOwnedBy :: Term _ (PPubKeyHash :--> PStakeDatum :--> PBool)
-            stakeDatumOwnedBy =
-              phoistAcyclic $
-                plam $ \pk stakeDatum -> P.do
-                  stakeDatumF <- pletFields @'["owner"] $ pto stakeDatum
-                  stakeDatumF.owner #== pdata pk
-
-        -- Does the input have a `Stake` owned by a particular PK?
-        let isInputStakeOwnedBy :: Term _ (PAsData PPubKeyHash :--> PAsData PTxInInfo :--> PBool)
-            isInputStakeOwnedBy =
-              plam $ \ss txInInfo' -> P.do
-                PTxInInfo ((pfield @"resolved" #) -> txOut) <- pmatch $ pfromData txInInfo'
-                PTxOut txOut' <- pmatch txOut
-                txOutF <- pletFields @'["value", "datumHash"] txOut'
-                outStakeST <- plet $ passetClassValueOf # txOutF.value # stakeSTAssetClass
-                pmatch txOutF.datumHash $ \case
-                  PDNothing _ -> pcon PFalse
-                  PDJust ((pfield @"_0" #) -> datumHash) ->
-                    pif
-                      (outStakeST #== 1)
-                      -- TODO: use 'ptryFindDatum' instead in the future
-                      ( pmatch (pfindDatum' # datumHash # txInfo) $ \case
-                          PNothing -> pcon PFalse
-                          PJust v -> stakeDatumOwnedBy # pfromData ss # pfromData v
-                      )
-                      (pcon PFalse)
-
         passert "All new cosigners are witnessed by their Stake datums" $
           pall
-            # plam (\sig -> pany # (isInputStakeOwnedBy # sig) # txInfoF.inputs)
+            # plam
+              ( \sig ->
+                  pmatch (findStakeOwnedBy # stakeSTAssetClass # pfromData sig # txInfoF.datums # txInfoF.inputs) $ \case
+                    PNothing -> pcon PFalse
+                    PJust _ -> pcon PTrue
+              )
             # newSigs
 
         passert "Signatures are correctly added to cosignature list" $
-          anyOutput @PProposalDatum # ctx.txInfo
+          anyOutput @Agora.Proposal.PProposalDatum # ctx.txInfo
             #$ plam
             $ \newValue address newProposalDatum -> P.do
               let correctDatum =
                     pdata newProposalDatum
                       #== pdata
                         ( mkRecordConstr
-                            PProposalDatum
+                            Agora.Proposal.PProposalDatum
                             ( #proposalId .= proposalF.proposalId
                                 .& #effects .= proposalF.effects
                                 .& #status .= proposalF.status
@@ -191,13 +171,13 @@ proposalValidator proposal =
 
         popaque (pconstant ())
       --------------------------------------------------------------------------
-      PUnlock _r -> P.do
+      Agora.Proposal.PUnlock _r -> P.do
         passert "ST at inputs must be 1" $
           spentST #== 1
 
         popaque (pconstant ())
       --------------------------------------------------------------------------
-      PAdvanceProposal _r -> P.do
+      Agora.Proposal.PAdvanceProposal _r -> P.do
         passert "ST at inputs must be 1" $
           spentST #== 1
 
@@ -207,13 +187,13 @@ proposalValidator proposal =
      This can be used to check both upopn creation and
      upon any following state transitions in the proposal.
 -}
-proposalDatumValid :: Term s (PProposalDatum :--> PBool)
+proposalDatumValid :: Term s (Agora.Proposal.PProposalDatum :--> PBool)
 proposalDatumValid =
   phoistAcyclic $
     plam $ \datum' -> P.do
       datum <- pletFields @'["effects", "cosigners"] $ datum'
 
-      let effects :: Term _ (PBuiltinMap PResultTag (PBuiltinMap PValidatorHash PDatumHash))
+      let effects :: Term _ (PBuiltinMap Agora.Proposal.PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash))
           effects = punsafeCoerce datum.effects
 
           atLeastOneNegativeResult :: Term _ PBool
@@ -224,4 +204,5 @@ proposalDatumValid =
         (#&&)
         [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult
         , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
+        , ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #< 6
         ]
diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs
index f484f9d..d5d872f 100644
--- a/agora/Agora/Stake.hs
+++ b/agora/Agora/Stake.hs
@@ -18,6 +18,7 @@ module Agora.Stake (
   stakePolicy,
   stakeValidator,
   stakeLocked,
+  findStakeOwnedBy,
 ) where
 
 --------------------------------------------------------------------------------
@@ -35,11 +36,17 @@ import PlutusTx qualified
 
 import Plutarch.Api.V1 (
   PCredential (PPubKeyCredential, PScriptCredential),
+  PDatum,
+  PDatumHash,
+  PMaybeData (PDJust, PDNothing),
   PMintingPolicy,
   PPubKeyHash,
   PScriptPurpose (PMinting, PSpending),
   PTokenName,
+  PTuple,
+  PTxInInfo (PTxInInfo),
   PTxInfo,
+  PTxOut (PTxOut),
   PValidator,
   mintingPolicySymbol,
   mkMintingPolicy,
@@ -63,6 +70,7 @@ import Agora.Utils (
   anyOutput,
   paddValue,
   passert,
+  pfindDatum,
   pfindTxInByTxOutRef,
   pgeqByClass,
   pgeqByClass',
@@ -74,7 +82,7 @@ import Agora.Utils (
   ptxSignedBy,
   pvalueSpent,
  )
-import Plutarch.Api.V1.Extra (passetClass)
+import Plutarch.Api.V1.Extra (PAssetClass, passetClass, passetClassValueOf)
 import Plutarch.Numeric
 import Plutarch.SafeMoney (
   PDiscrete,
@@ -278,7 +286,7 @@ stakePolicy gtClassRef =
     txInfo <- plet $ ctx.txInfo
     let _a :: Term _ PTxInfo
         _a = txInfo
-    txInfoF <- pletFields @'["mint", "inputs", "outputs"] txInfo
+    txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo
 
     PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
     ownSymbol <- plet $ pfield @"_0" # ownSymbol'
@@ -337,7 +345,7 @@ stakePolicy gtClassRef =
                             # stValue
                     let ownerSignsTransaction =
                           ptxSignedBy
-                            # ctx.txInfo
+                            # txInfoF.signatories
                             # stakeDatum.owner
 
                     -- TODO: This is quite inefficient now, as it does two lookups
@@ -371,7 +379,7 @@ stakeValidator stake =
   plam $ \datum redeemer ctx' -> P.do
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
     txInfo <- plet $ pfromData ctx.txInfo
-    txInfoF <- pletFields @'["mint", "inputs", "outputs"] txInfo
+    txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo
 
     (pfromData -> stakeRedeemer, _) <- ptryFrom redeemer
 
@@ -387,7 +395,7 @@ stakeValidator stake =
     let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo
 
     -- Whether the owner signs this transaction or not.
-    ownerSignsTransaction <- plet $ ptxSignedBy # ctx.txInfo # stakeDatum.owner
+    ownerSignsTransaction <- plet $ ptxSignedBy # txInfoF.signatories # stakeDatum.owner
 
     stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef)
     mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
@@ -514,3 +522,60 @@ stakeLocked = phoistAcyclic $
     let locks :: Term _ (PBuiltinList (PAsData PProposalLock))
         locks = pfield @"lockedBy" # stakeDatum
      in pnotNull # locks
+
+-- | Find a stake owned by a particular PK.
+findStakeOwnedBy ::
+  Term
+    s
+    ( PAssetClass
+        :--> PPubKeyHash
+        :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum))
+        :--> PBuiltinList (PAsData PTxInInfo)
+        :--> PMaybe PTxOut
+    )
+findStakeOwnedBy = phoistAcyclic $
+  plam $ \ac pk datums inputs ->
+    pmatch (pfind # (isInputStakeOwnedBy # ac # pk # datums) # inputs) $ \case
+      PNothing -> pcon PNothing
+      PJust (pfromData -> v) -> P.do
+        let txOut = pfield @"resolved" # pto v
+        txOutF <- pletFields @'["datumHash"] $ txOut
+        pmatch txOutF.datumHash $ \case
+          PDNothing _ -> pcon PNothing
+          PDJust ((pfield @"_0" #) -> dh) ->
+            -- TODO: PTryFrom here
+            punsafeCoerce $ pfindDatum # dh # datums
+
+stakeDatumOwnedBy :: Term _ (PPubKeyHash :--> PStakeDatum :--> PBool)
+stakeDatumOwnedBy =
+  phoistAcyclic $
+    plam $ \pk stakeDatum -> P.do
+      stakeDatumF <- pletFields @'["owner"] $ pto stakeDatum
+      stakeDatumF.owner #== pdata pk
+
+-- Does the input have a `Stake` owned by a particular PK?
+isInputStakeOwnedBy ::
+  Term
+    _
+    ( PAssetClass :--> PPubKeyHash
+        :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum))
+        :--> PAsData PTxInInfo
+        :--> PBool
+    )
+isInputStakeOwnedBy =
+  plam $ \ac ss datums txInInfo' -> P.do
+    PTxInInfo ((pfield @"resolved" #) -> txOut) <- pmatch $ pfromData txInInfo'
+    PTxOut txOut' <- pmatch txOut
+    txOutF <- pletFields @'["value", "datumHash"] txOut'
+    outStakeST <- plet $ passetClassValueOf # txOutF.value # ac
+    pmatch txOutF.datumHash $ \case
+      PDNothing _ -> pcon PFalse
+      PDJust ((pfield @"_0" #) -> datumHash) ->
+        pif
+          (outStakeST #== 1)
+          -- TODO: use 'ptryFindDatum' instead in the future
+          ( pmatch (pfindDatum # datumHash # datums) $ \case
+              PNothing -> pcon PFalse
+              PJust v -> stakeDatumOwnedBy # ss # pfromData (punsafeCoerce v)
+          )
+          (pcon PFalse)
diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index 7a2ee01..e1b80e1 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -56,7 +56,7 @@ import Plutarch.Api.V1 (
   PTokenName,
   PTuple,
   PTxInInfo (PTxInInfo),
-  PTxInfo (PTxInfo),
+  PTxInfo,
   PTxOut (PTxOut),
   PTxOutRef,
   PValidatorHash,
@@ -78,35 +78,30 @@ passert :: Term s PString -> Term s PBool -> Term s k -> Term s k
 passert errorMessage check k = pif check k (ptraceError errorMessage)
 
 -- | Find a datum with the given hash.
-pfindDatum :: Term s (PDatumHash :--> PTxInfo :--> PMaybe PDatum)
+pfindDatum :: Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe PDatum)
 pfindDatum = phoistAcyclic $
-  plam $ \datumHash txInfo'' -> P.do
-    PTxInfo txInfo' <- pmatch txInfo''
-    plookupTuple # datumHash #$ pfield @"datums" # txInfo'
+  plam $ \datumHash datums -> plookupTuple # datumHash # datums
 
 -- | Find a datum with the given hash, and `ptryFrom` it.
-ptryFindDatum :: PTryFrom PData a => Term s (PDatumHash :--> PTxInfo :--> PMaybe a)
+ptryFindDatum :: PTryFrom PData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe a)
 ptryFindDatum = phoistAcyclic $
-  plam $ \datumHash txInfo'' -> P.do
-    PTxInfo txInfo' <- pmatch txInfo''
-    pmatch (plookupTuple # datumHash #$ pfield @"datums" # txInfo') $ \case
+  plam $ \datumHash inputs -> P.do
+    pmatch (pfindDatum # datumHash # inputs) $ \case
       PNothing -> pcon PNothing
       PJust datum -> P.do
-        (datum', _) <- ptryFrom $ pto datum
+        (datum', _) <- ptryFrom (pto datum)
         pcon (PJust datum')
 
 {- | Find a datum with the given hash.
 NOTE: this is unsafe in the sense that, if the data layout is wrong, this is UB.
 -}
-pfindDatum' :: PIsData a => Term s (PDatumHash :--> PTxInfo :--> PMaybe (PAsData a))
+pfindDatum' :: PIsData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe (PAsData a))
 pfindDatum' = phoistAcyclic $ plam $ \dh x -> punsafeCoerce $ pfindDatum # dh # x
 
 -- | Check if a PubKeyHash signs this transaction.
-ptxSignedBy :: Term s (PTxInfo :--> PAsData PPubKeyHash :--> PBool)
+ptxSignedBy :: Term s (PBuiltinList (PAsData PPubKeyHash) :--> PAsData PPubKeyHash :--> PBool)
 ptxSignedBy = phoistAcyclic $
-  plam $ \txInfo' pkh -> P.do
-    txInfo <- pletFields @'["signatories"] txInfo'
-    pelem @PBuiltinList # pkh # txInfo.signatories
+  plam $ \sigs sig -> pelem # sig # sigs
 
 -- | Get the first element that matches a predicate or return Nothing.
 pfind' ::
@@ -334,14 +329,14 @@ anyOutput ::
   Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
 anyOutput = phoistAcyclic $
   plam $ \txInfo' predicate -> P.do
-    txInfo <- pletFields @'["outputs"] txInfo'
+    txInfo <- pletFields @'["outputs", "datums"] txInfo'
     pany
       # plam
         ( \txOut'' -> P.do
             PTxOut txOut' <- pmatch (pfromData txOut'')
             txOut <- pletFields @'["value", "datumHash", "address"] txOut'
             PDJust dh <- pmatch txOut.datumHash
-            pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case
+            pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo.datums) $ \case
               PJust datum -> P.do
                 predicate # txOut.value # txOut.address # pfromData datum
               PNothing -> pcon PFalse
@@ -356,14 +351,14 @@ allOutputs ::
   Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
 allOutputs = phoistAcyclic $
   plam $ \txInfo' predicate -> P.do
-    txInfo <- pletFields @'["outputs"] txInfo'
+    txInfo <- pletFields @'["outputs", "datums"] txInfo'
     pall
       # plam
         ( \txOut'' -> P.do
             PTxOut txOut' <- pmatch (pfromData txOut'')
             txOut <- pletFields @'["value", "datumHash", "address"] txOut'
             PDJust dh <- pmatch txOut.datumHash
-            pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case
+            pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo.datums) $ \case
               PJust datum -> P.do
                 predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum
               PNothing -> pcon PFalse
@@ -378,7 +373,7 @@ anyInput ::
   Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
 anyInput = phoistAcyclic $
   plam $ \txInfo' predicate -> P.do
-    txInfo <- pletFields @'["inputs"] txInfo'
+    txInfo <- pletFields @'["inputs", "datums"] txInfo'
     pany
       # plam
         ( \txInInfo'' -> P.do
@@ -387,7 +382,7 @@ anyInput = phoistAcyclic $
             PTxOut txOut' <- pmatch (pfromData txOut'')
             txOut <- pletFields @'["value", "datumHash", "address"] txOut'
             PDJust dh <- pmatch txOut.datumHash
-            pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case
+            pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo.datums) $ \case
               PJust datum -> P.do
                 predicate # txOut.value # txOut.address # pfromData datum
               PNothing -> pcon PFalse
@@ -420,23 +415,18 @@ scriptHashFromAddress = phoistAcyclic $
       _ -> pcon PNothing
 
 -- | Find all TxOuts sent to an Address
-findOutputsToAddress :: Term s (PTxInfo :--> PAddress :--> PBuiltinList (PAsData PTxOut))
+findOutputsToAddress :: Term s (PBuiltinList (PAsData PTxOut) :--> PAddress :--> PBuiltinList (PAsData PTxOut))
 findOutputsToAddress = phoistAcyclic $
-  plam $ \info address' -> P.do
+  plam $ \outputs address' -> P.do
     address <- plet $ pdata address'
-    let outputs = pfromData $ pfield @"outputs" # info
-        filteredOutputs =
-          pfilter
-            # plam
-              (\(pfromData -> txOut) -> pfield @"address" # txOut #== address)
-            # outputs
-    filteredOutputs
+    pfilter # plam (\(pfromData -> txOut) -> pfield @"address" # txOut #== address)
+      # outputs
 
 -- | Find the data corresponding to a TxOut, if there is one
-findTxOutDatum :: Term s (PTxInfo :--> PTxOut :--> PMaybe PDatum)
+findTxOutDatum :: Term s (PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PTxOut :--> PMaybe PDatum)
 findTxOutDatum = phoistAcyclic $
-  plam $ \info out -> P.do
+  plam $ \datums out -> P.do
     datumHash' <- pmatch $ pfromData $ pfield @"datumHash" # out
     case datumHash' of
-      PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # info
+      PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # datums
       _ -> pcon PNothing

From f2a9749d95b60d55c59d14f9e22cb15f42b53239 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Tue, 26 Apr 2022 17:34:00 +0200
Subject: [PATCH 66/78] remove `TreasuryDatum`, `PTryFrom` for
 `PTreasuryRedeemer`

---
 agora/Agora/Treasury.hs | 93 ++++++++++++++++++++---------------------
 1 file changed, 46 insertions(+), 47 deletions(-)

diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs
index 9cda2b1..db9172f 100644
--- a/agora/Agora/Treasury.hs
+++ b/agora/Agora/Treasury.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 {- |
 Module: Agora.Treasury
 Maintainer: jack@mlabs.city
@@ -8,23 +10,58 @@ treasury.
 -}
 module Agora.Treasury (module Agora.Treasury) where
 
+import Agora.AuthorityToken (singleAuthorityTokenBurned)
+import Agora.Utils (passert)
 import GHC.Generics qualified as GHC
 import Generics.SOP
+import Plutarch.Api.V1 (PValidator)
 import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting))
-import Plutarch.Api.V1.Value (PCurrencySymbol, PValue)
+import Plutarch.Api.V1.Value (PValue)
 import Plutarch.DataRepr (
-  PDataFields,
+  DerivePConstantViaData (..),
   PIsDataReprInstances (PIsDataReprInstances),
  )
+import Plutarch.Lift (PConstantDecl (..), PLifted (..), PUnsafeLiftDecl)
 import Plutarch.Monadic qualified as P
+import Plutarch.TryFrom (PTryFrom, ptryFrom)
 import Plutus.V1.Ledger.Value (CurrencySymbol)
+import PlutusTx qualified
 
 --------------------------------------------------------------------------------
 
-import Agora.AuthorityToken (singleAuthorityTokenBurned)
-import Agora.Utils (passert)
-import Plutarch.Api.V1 (PValidator)
-import Plutarch.Unsafe (punsafeCoerce)
+data TreasuryRedeemer
+  = SpendTreasuryGAT
+  deriving stock (Eq, Show, GHC.Generic)
+
+PlutusTx.makeIsDataIndexed
+  ''TreasuryRedeemer
+  [ ('SpendTreasuryGAT, 0)
+  ]
+
+--------------------------------------------------------------------------------
+
+{- | Plutarch level type representing valid redeemers of the
+     treasury.
+-}
+newtype PTreasuryRedeemer (s :: S)
+  = -- | Alters treasury parameters, subject to the burning of a
+    --   governance authority token.
+    PSpendTreasuryGAT (Term s (PDataRecord '[]))
+  deriving stock (GHC.Generic)
+  deriving anyclass (Generic, PIsDataRepr)
+  deriving
+    (PlutusType, PIsData)
+    via PIsDataReprInstances PTreasuryRedeemer
+
+deriving via
+  PAsData (PIsDataReprInstances PTreasuryRedeemer)
+  instance
+    PTryFrom PData (PAsData PTreasuryRedeemer)
+
+instance PUnsafeLiftDecl PTreasuryRedeemer where type PLifted PTreasuryRedeemer = TreasuryRedeemer
+deriving via (DerivePConstantViaData TreasuryRedeemer PTreasuryRedeemer) instance (PConstantDecl TreasuryRedeemer)
+
+--------------------------------------------------------------------------------
 
 {- | Validator ensuring that transactions consuming the treasury
      do so in a valid manner.
@@ -32,12 +69,8 @@ import Plutarch.Unsafe (punsafeCoerce)
 treasuryValidator ::
   CurrencySymbol ->
   ClosedTerm PValidator
-treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do
-  -- TODO: Use PTryFrom
-  let treasuryRedeemer :: Term _ (PAsData PTreasuryRedeemer)
-      treasuryRedeemer = punsafeCoerce redeemer
-      _treasuryDatum' :: Term _ (PAsData PTreasuryDatum)
-      _treasuryDatum' = punsafeCoerce datum
+treasuryValidator gatCs' = plam $ \_datum redeemer ctx' -> P.do
+  (treasuryRedeemer, _) <- ptryFrom redeemer
 
   -- plet required fields from script context.
   ctx <- pletFields @["txInfo", "purpose"] ctx'
@@ -46,7 +79,7 @@ treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do
   PMinting _ <- pmatch ctx.purpose
 
   -- Ensure redeemer type is valid.
-  PAlterTreasuryParams _ <- pmatch $ pfromData treasuryRedeemer
+  PSpendTreasuryGAT _ <- pmatch $ pfromData treasuryRedeemer
 
   -- Get the minted value from txInfo.
   txInfo' <- plet ctx.txInfo
@@ -59,37 +92,3 @@ treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do
   passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint
 
   popaque $ pconstant ()
-
-{- | Plutarch level type representing datum of the treasury.
-     Contains:
-
-       - @stateThread@ representing the asset class of the
-         treasury's state thread token.
--}
-newtype PTreasuryDatum (s :: S)
-  = PTreasuryDatum
-      ( Term
-          s
-          ( PDataRecord
-              '[ "stateThread" ':= PCurrencySymbol
-               ]
-          )
-      )
-  deriving stock (GHC.Generic)
-  deriving anyclass (Generic, PIsDataRepr)
-  deriving
-    (PlutusType, PIsData, PDataFields)
-    via PIsDataReprInstances PTreasuryDatum
-
-{- | Plutarch level type representing valid redeemers of the
-     treasury.
--}
-newtype PTreasuryRedeemer (s :: S)
-  = -- | Alters treasury parameters, subject to the burning of a
-    --   governance authority token.
-    PAlterTreasuryParams (Term s (PDataRecord '[]))
-  deriving stock (GHC.Generic)
-  deriving anyclass (Generic, PIsDataRepr)
-  deriving
-    (PlutusType, PIsData)
-    via PIsDataReprInstances PTreasuryRedeemer

From 438ed872e3524c6b9843778c4e16596c4fef5c20 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Tue, 26 Apr 2022 19:26:26 +0200
Subject: [PATCH 67/78] move Stake to Scripts, fix tests

---
 agora-test/Spec/Effect/TreasuryWithdrawal.hs |  13 +-
 agora-test/Spec/Proposal.hs                  |  13 +-
 agora-test/Spec/Sample/Shared.hs             |   5 +-
 agora-test/Spec/Sample/Stake.hs              |   1 +
 agora-test/Spec/Stake.hs                     |   3 +-
 agora-test/Spec/Util.hs                      |   1 -
 agora.cabal                                  |   1 +
 agora/Agora/Proposal/Scripts.hs              |   7 +
 agora/Agora/Stake.hs                         | 296 +-----------------
 agora/Agora/Stake/Scripts.hs                 | 297 +++++++++++++++++++
 agora/Agora/Utils.hs                         |   6 +-
 11 files changed, 341 insertions(+), 302 deletions(-)
 create mode 100644 agora/Agora/Stake/Scripts.hs

diff --git a/agora-test/Spec/Effect/TreasuryWithdrawal.hs b/agora-test/Spec/Effect/TreasuryWithdrawal.hs
index db0aed6..27310d9 100644
--- a/agora-test/Spec/Effect/TreasuryWithdrawal.hs
+++ b/agora-test/Spec/Effect/TreasuryWithdrawal.hs
@@ -7,6 +7,11 @@ This module tests the Treasury Withdrawal Effect.
 -}
 module Spec.Effect.TreasuryWithdrawal (tests) where
 
+import Agora.Effect.TreasuryWithdrawal (
+  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
+  treasuryWithdrawalValidator,
+ )
+import Plutus.V1.Ledger.Value qualified as Value
 import Spec.Sample.Effect.TreasuryWithdrawal (
   buildReceiversOutputFromDatum,
   buildScriptContext,
@@ -20,15 +25,7 @@ import Spec.Sample.Effect.TreasuryWithdrawal (
   treasuries,
   users,
  )
-
-import Agora.Effect.TreasuryWithdrawal (
-  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
-  treasuryWithdrawalValidator,
- )
-
-import Plutus.V1.Ledger.Value qualified as Value
 import Spec.Util (effectFailsWith, effectSucceedsWith)
-
 import Test.Tasty (TestTree, testGroup)
 
 tests :: [TestTree]
diff --git a/agora-test/Spec/Proposal.hs b/agora-test/Spec/Proposal.hs
index 2827d5d..b80d144 100644
--- a/agora-test/Spec/Proposal.hs
+++ b/agora-test/Spec/Proposal.hs
@@ -21,13 +21,16 @@ import Agora.Proposal (
   cosigners,
   effects,
   proposalId,
-  proposalPolicy,
-  proposalValidator,
   status,
   thresholds,
   votes,
  )
-import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (WitnessStake), stakeValidator)
+import Agora.Proposal.Scripts (
+  proposalPolicy,
+  proposalValidator,
+ )
+import Agora.Stake (StakeDatum (StakeDatum), StakeRedeemer (WitnessStake))
+import Agora.Stake.Scripts (stakeValidator)
 import Plutarch.SafeMoney (Tagged (Tagged))
 import Plutus.V1.Ledger.Api (ScriptContext (..), ScriptPurpose (..))
 import PlutusTx.AssocMap qualified as AssocMap
@@ -39,10 +42,6 @@ import Test.Tasty (TestTree, testGroup)
 
 --------------------------------------------------------------------------------
 
---------------------------------------------------------------------------------
-
---------------------------------------------------------------------------------
-
 -- | Stake tests.
 tests :: [TestTree]
 tests =
diff --git a/agora-test/Spec/Sample/Shared.hs b/agora-test/Spec/Sample/Shared.hs
index 1bb4636..37b1afc 100644
--- a/agora-test/Spec/Sample/Shared.hs
+++ b/agora-test/Spec/Sample/Shared.hs
@@ -40,10 +40,13 @@ import Agora.Governor (
 import Agora.Proposal (
   Proposal (..),
   ProposalThresholds (..),
+ )
+import Agora.Proposal.Scripts (
   proposalPolicy,
   proposalValidator,
  )
-import Agora.Stake (Stake (..), stakePolicy, stakeValidator)
+import Agora.Stake (Stake (..))
+import Agora.Stake.Scripts (stakePolicy, stakeValidator)
 import Plutarch.Api.V1 (
   mintingPolicySymbol,
   mkMintingPolicy,
diff --git a/agora-test/Spec/Sample/Stake.hs b/agora-test/Spec/Sample/Stake.hs
index e893eed..07af063 100644
--- a/agora-test/Spec/Sample/Stake.hs
+++ b/agora-test/Spec/Sample/Stake.hs
@@ -46,6 +46,7 @@ import Plutus.V1.Ledger.Value qualified as Value
 
 import Agora.SafeMoney (GTTag)
 import Agora.Stake
+import Agora.Stake.Scripts (stakeValidator)
 import Plutarch.SafeMoney
 import Spec.Sample.Shared
 import Spec.Util (datumPair, toDatumHash)
diff --git a/agora-test/Spec/Stake.hs b/agora-test/Spec/Stake.hs
index 427f228..6824b80 100644
--- a/agora-test/Spec/Stake.hs
+++ b/agora-test/Spec/Stake.hs
@@ -19,7 +19,8 @@ import Test.Tasty (TestTree, testGroup)
 
 --------------------------------------------------------------------------------
 
-import Agora.Stake (Stake (..), StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw), stakePolicy, stakeValidator)
+import Agora.Stake (Stake (..), StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw))
+import Agora.Stake.Scripts (stakePolicy, stakeValidator)
 
 --------------------------------------------------------------------------------
 
diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs
index c9c3ce4..365ad50 100644
--- a/agora-test/Spec/Util.hs
+++ b/agora-test/Spec/Util.hs
@@ -90,7 +90,6 @@ policyFailsWith tag policy redeemer scriptContext =
 -- | Check that a validator script succeeds, given a name and arguments.
 validatorSucceedsWith ::
   ( PLift datum
-  , Show (PLifted datum)
   , PlutusTx.ToData (PLifted datum)
   , PLift redeemer
   , PlutusTx.ToData (PLifted redeemer)
diff --git a/agora.cabal b/agora.cabal
index 1948966..b55630b 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -134,6 +134,7 @@ library
     Agora.Record
     Agora.SafeMoney
     Agora.Stake
+    Agora.Stake.Scripts
     Agora.Treasury
 
   other-modules:
diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs
index 09ae5c4..417f577 100644
--- a/agora/Agora/Proposal/Scripts.hs
+++ b/agora/Agora/Proposal/Scripts.hs
@@ -1,3 +1,10 @@
+{- |
+Module     : Agora.Proposal.Scripts
+Maintainer : emi@haskell.fyi
+Description: Plutus Scripts for Proposals.
+
+Plutus Scripts for Proposals.
+-}
 module Agora.Proposal.Scripts (
   proposalValidator,
   proposalPolicy,
diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs
index d5d872f..efdc91b 100644
--- a/agora/Agora/Stake.hs
+++ b/agora/Agora/Stake.hs
@@ -8,15 +8,18 @@ Description: Vote-lockable stake UTXOs holding GT.
 Vote-lockable stake UTXOs holding GT.
 -}
 module Agora.Stake (
-  PStakeDatum (..),
-  PStakeRedeemer (..),
+  -- * Haskell-land
   StakeDatum (..),
   StakeRedeemer (..),
-  ProposalLock (..),
-  PProposalLock (..),
   Stake (..),
-  stakePolicy,
-  stakeValidator,
+  ProposalLock (..),
+
+  -- * Plutarch-land
+  PStakeDatum (..),
+  PStakeRedeemer (..),
+  PProposalLock (..),
+
+  -- * Utility functions
   stakeLocked,
   findStakeOwnedBy,
 ) where
@@ -35,21 +38,13 @@ import PlutusTx qualified
 --------------------------------------------------------------------------------
 
 import Plutarch.Api.V1 (
-  PCredential (PPubKeyCredential, PScriptCredential),
   PDatum,
   PDatumHash,
   PMaybeData (PDJust, PDNothing),
-  PMintingPolicy,
   PPubKeyHash,
-  PScriptPurpose (PMinting, PSpending),
-  PTokenName,
   PTuple,
   PTxInInfo (PTxInInfo),
-  PTxInfo,
   PTxOut (PTxOut),
-  PValidator,
-  mintingPolicySymbol,
-  mkMintingPolicy,
  )
 import Plutarch.DataRepr (
   DerivePConstantViaData (..),
@@ -59,38 +54,23 @@ import Plutarch.DataRepr (
 import Plutarch.Internal (punsafeCoerce)
 import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
 import Plutarch.Monadic qualified as P
-import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
+import Plutus.V1.Ledger.Value (AssetClass)
 
 --------------------------------------------------------------------------------
 
 import Agora.Proposal (PProposalId, PResultTag, ProposalId (..), ResultTag (..))
 import Agora.SafeMoney (GTTag)
 import Agora.Utils (
-  anyInput,
-  anyOutput,
-  paddValue,
-  passert,
   pfindDatum,
-  pfindTxInByTxOutRef,
-  pgeqByClass,
-  pgeqByClass',
-  pgeqBySymbol,
   pnotNull,
-  psingletonValue,
-  psymbolValueOf,
-  ptokenSpent,
-  ptxSignedBy,
-  pvalueSpent,
  )
-import Plutarch.Api.V1.Extra (PAssetClass, passetClass, passetClassValueOf)
-import Plutarch.Numeric
+import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf)
+import Plutarch.Numeric ()
 import Plutarch.SafeMoney (
   PDiscrete,
   Tagged (..),
-  pdiscreteValue',
-  untag,
  )
-import Plutarch.TryFrom (PTryFrom, ptryFrom)
+import Plutarch.TryFrom (PTryFrom)
 
 --------------------------------------------------------------------------------
 
@@ -263,256 +243,6 @@ deriving via
 instance PUnsafeLiftDecl PProposalLock where type PLifted PProposalLock = ProposalLock
 deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstantDecl ProposalLock)
 
---------------------------------------------------------------------------------
-{- What this Policy does
-
-   For minting:
-     Check that exactly one state thread is minted
-     Check that an output exists with a state thread and a valid datum
-     Check that no state thread is an input
-     assert TokenName == ValidatorHash of the script that we pay to
-
-   For burning:
-     Check that exactly one state thread is burned
-     Check that datum at state thread is valid and not locked
--}
---------------------------------------------------------------------------------
-
--- | Policy for Stake state threads.
-stakePolicy :: Tagged GTTag AssetClass -> ClosedTerm PMintingPolicy
-stakePolicy gtClassRef =
-  plam $ \_redeemer ctx' -> P.do
-    ctx <- pletFields @'["txInfo", "purpose"] ctx'
-    txInfo <- plet $ ctx.txInfo
-    let _a :: Term _ PTxInfo
-        _a = txInfo
-    txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo
-
-    PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
-    ownSymbol <- plet $ pfield @"_0" # ownSymbol'
-    spentST <- plet $ psymbolValueOf # ownSymbol #$ pvalueSpent # txInfoF.inputs
-    mintedST <- plet $ psymbolValueOf # ownSymbol # txInfoF.mint
-
-    let burning = P.do
-          passert "ST at inputs must be 1" $
-            spentST #== 1
-
-          passert "ST burned" $
-            mintedST #== -1
-
-          passert "An unlocked input existed containing an ST" $
-            anyInput @PStakeDatum # txInfo
-              #$ plam
-              $ \value _ stakeDatum' -> P.do
-                let hasST = psymbolValueOf # ownSymbol # value #== 1
-                let unlocked = pnot # (stakeLocked # stakeDatum')
-                hasST #&& unlocked
-
-          popaque (pconstant ())
-
-    let minting = P.do
-          passert "ST at inputs must be 0" $
-            spentST #== 0
-
-          passert "Minted ST must be exactly 1" $
-            mintedST #== 1
-
-          passert "A UTXO must exist with the correct output" $
-            anyOutput @PStakeDatum # txInfo
-              #$ plam
-              $ \value address stakeDatum' -> P.do
-                let cred = pfield @"credential" # address
-                pmatch cred $ \case
-                  -- Should pay to a script address
-                  PPubKeyCredential _ -> pcon PFalse
-                  PScriptCredential validatorHash' -> P.do
-                    validatorHash <- pletFields @'["_0"] validatorHash'
-                    stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
-
-                    -- TODO: figure out why this is required :/ (specifically, why `validatorHash._0` is `PData`)
-                    tn <- plet (pfromData (punsafeCoerce validatorHash._0 :: Term _ (PAsData PTokenName)))
-
-                    let stValue =
-                          psingletonValue
-                            # ownSymbol
-                            -- This coerce is safe because the structure
-                            -- of PValidatorHash is the same as PTokenName.
-                            # tn
-                            # 1
-                    let expectedValue =
-                          paddValue
-                            # (pdiscreteValue' gtClassRef # stakeDatum.stakedAmount)
-                            # stValue
-                    let ownerSignsTransaction =
-                          ptxSignedBy
-                            # txInfoF.signatories
-                            # stakeDatum.owner
-
-                    -- TODO: This is quite inefficient now, as it does two lookups
-                    -- instead of a more efficient single pass,
-                    -- but it doesn't really matter for this. At least it's correct.
-                    let valueCorrect =
-                          foldr1
-                            (#&&)
-                            [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
-                            , pgeqByClass' (untag gtClassRef)
-                                # value
-                                # expectedValue
-                            , pgeqByClass
-                                # ownSymbol
-                                # tn
-                                # value
-                                # expectedValue
-                            ]
-
-                    ownerSignsTransaction
-                      #&& valueCorrect
-          popaque (pconstant ())
-
-    pif (0 #< mintedST) minting burning
-
---------------------------------------------------------------------------------
-
--- | Validator intended for Stake UTXOs to live in.
-stakeValidator :: Stake -> ClosedTerm PValidator
-stakeValidator stake =
-  plam $ \datum redeemer ctx' -> P.do
-    ctx <- pletFields @'["txInfo", "purpose"] ctx'
-    txInfo <- plet $ pfromData ctx.txInfo
-    txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo
-
-    (pfromData -> stakeRedeemer, _) <- ptryFrom redeemer
-
-    -- TODO: Use PTryFrom
-    let stakeDatum' :: Term _ PStakeDatum
-        stakeDatum' = pfromData $ punsafeCoerce datum
-    stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
-
-    PSpending txOutRef <- pmatch $ pfromData ctx.purpose
-
-    PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfoF.inputs
-    ownAddress <- plet $ pfield @"address" #$ pfield @"resolved" # txInInfo
-    let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo
-
-    -- Whether the owner signs this transaction or not.
-    ownerSignsTransaction <- plet $ ptxSignedBy # txInfoF.signatories # stakeDatum.owner
-
-    stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef)
-    mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
-    spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs
-
-    -- Is the stake currently locked?
-    stakeIsLocked <- plet $ stakeLocked # stakeDatum'
-
-    pmatch stakeRedeemer $ \case
-      PDestroy _ -> P.do
-        passert "ST at inputs must be 1" $
-          spentST #== 1
-        passert "Should burn ST" $
-          mintedST #== -1
-        passert "Stake unlocked" $ pnot # stakeIsLocked
-        passert
-          "Owner signs this transaction"
-          ownerSignsTransaction
-        popaque (pconstant ())
-      --------------------------------------------------------------------------
-      PRetractVotes _ -> P.do
-        passert
-          "Owner signs this transaction"
-          ownerSignsTransaction
-        -- TODO: check proposal constraints
-        popaque (pconstant ())
-      --------------------------------------------------------------------------
-      PPermitVote _ -> P.do
-        passert
-          "Owner signs this transaction"
-          ownerSignsTransaction
-        -- TODO: check proposal constraints
-        popaque (pconstant ())
-      --------------------------------------------------------------------------
-      PWitnessStake _ -> P.do
-        passert "ST at inputs must be 1" $
-          spentST #== 1
-
-        let AssetClass (propCs, propTn) = stake.proposalSTClass
-            propAssetClass = passetClass # pconstant propCs # pconstant propTn
-            proposalTokenMoved =
-              ptokenSpent
-                # propAssetClass
-                # txInfoF.inputs
-
-        passert
-          "Owner signs this transaction OR proposal token is spent"
-          (ownerSignsTransaction #|| proposalTokenMoved)
-
-        passert "A UTXO must exist with the correct output" $
-          anyOutput @PStakeDatum # txInfo
-            #$ plam
-            $ \value address newStakeDatum' -> P.do
-              let isScriptAddress = pdata address #== ownAddress
-              let correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
-              let valueCorrect = pdata continuingValue #== pdata value
-              pif
-                isScriptAddress
-                ( foldl1
-                    (#&&)
-                    [ ptraceIfFalse "valueCorrect" valueCorrect
-                    , ptraceIfFalse "correctOutputDatum" correctOutputDatum
-                    ]
-                )
-                (pcon PFalse)
-        popaque (pconstant ())
-      PDepositWithdraw r -> P.do
-        passert "ST at inputs must be 1" $
-          spentST #== 1
-        passert "Stake unlocked" $
-          pnot #$ stakeIsLocked
-        passert
-          "Owner signs this transaction"
-          ownerSignsTransaction
-        passert "A UTXO must exist with the correct output" $
-          anyOutput @PStakeDatum # txInfo
-            #$ plam
-            $ \value address newStakeDatum' -> P.do
-              newStakeDatum <- pletFields @'["owner", "stakedAmount"] newStakeDatum'
-              delta <- plet $ pfield @"delta" # r
-              let isScriptAddress = pdata address #== ownAddress
-              let correctOutputDatum =
-                    foldr1
-                      (#&&)
-                      [ stakeDatum.owner #== newStakeDatum.owner
-                      , (stakeDatum.stakedAmount + delta) #== newStakeDatum.stakedAmount
-                      , -- We can't magically conjure GT anyway (no input to spend!)
-                        -- do we need to check this, really?
-                        zero #<= pfromData newStakeDatum.stakedAmount
-                      ]
-              let expectedValue = paddValue # continuingValue # (pdiscreteValue' stake.gtClassRef # delta)
-
-              -- TODO: Same as above. This is quite inefficient now, as it does two lookups
-              -- instead of a more efficient single pass,
-              -- but it doesn't really matter for this. At least it's correct.
-              let valueCorrect =
-                    foldr1
-                      (#&&)
-                      [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
-                      , pgeqByClass' (untag stake.gtClassRef)
-                          # value
-                          # expectedValue
-                      , pgeqBySymbol
-                          # stCurrencySymbol
-                          # value
-                          # expectedValue
-                      ]
-
-              foldr1
-                (#&&)
-                [ ptraceIfFalse "isScriptAddress" isScriptAddress
-                , ptraceIfFalse "correctOutputDatum" correctOutputDatum
-                , ptraceIfFalse "valueCorrect" valueCorrect
-                ]
-
-        popaque (pconstant ())
-
 --------------------------------------------------------------------------------
 
 -- | Check whether a Stake is locked. If it is locked, various actions are unavailable.
diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs
new file mode 100644
index 0000000..f07ace3
--- /dev/null
+++ b/agora/Agora/Stake/Scripts.hs
@@ -0,0 +1,297 @@
+{- |
+Module     : Agora.Stake.Scripts
+Maintainer : emi@haskell.fyi
+Description: Plutus Scripts for Stakes.
+
+Plutus Scripts for Stakes.
+-}
+module Agora.Stake.Scripts (stakePolicy, stakeValidator) where
+
+import Agora.SafeMoney (GTTag)
+import Agora.Stake
+import Agora.Utils (
+  anyInput,
+  anyOutput,
+  paddValue,
+  passert,
+  pfindTxInByTxOutRef,
+  pgeqByClass,
+  pgeqByClass',
+  pgeqBySymbol,
+  psingletonValue,
+  psymbolValueOf,
+  ptokenSpent,
+  ptxSignedBy,
+  pvalueSpent,
+  validatorHashToTokenName,
+ )
+import Plutarch.Api.V1 (
+  PCredential (PPubKeyCredential, PScriptCredential),
+  PMintingPolicy,
+  PScriptPurpose (PMinting, PSpending),
+  PTokenName,
+  PTxInfo,
+  PValidator,
+  mintingPolicySymbol,
+  mkMintingPolicy,
+ )
+import Plutarch.Api.V1.Extra (passetClass)
+import Plutarch.Internal (punsafeCoerce)
+import Plutarch.Monadic qualified as P
+import Plutarch.Numeric
+import Plutarch.SafeMoney (
+  Tagged (..),
+  pdiscreteValue',
+  untag,
+ )
+import Plutarch.TryFrom (ptryFrom)
+import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
+import Prelude hiding (Num (..))
+
+{- | Policy for Stake state threads.
+
+   == What this Policy does
+
+   === For minting:
+
+   - Check that exactly one state thread is minted
+   - Check that an output exists with a state thread and a valid datum
+   - Check that no state thread is an input
+   - assert @'TokenName' == 'ValidatorHash'@ of the script that we pay to
+
+   === For burning:
+
+   - Check that exactly one state thread is burned
+   - Check that datum at state thread is valid and not locked
+-}
+stakePolicy :: Tagged GTTag AssetClass -> ClosedTerm PMintingPolicy
+stakePolicy gtClassRef =
+  plam $ \_redeemer ctx' -> P.do
+    ctx <- pletFields @'["txInfo", "purpose"] ctx'
+    txInfo <- plet $ ctx.txInfo
+    let _a :: Term _ PTxInfo
+        _a = txInfo
+    txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo
+
+    PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
+    ownSymbol <- plet $ pfield @"_0" # ownSymbol'
+    spentST <- plet $ psymbolValueOf # ownSymbol #$ pvalueSpent # txInfoF.inputs
+    mintedST <- plet $ psymbolValueOf # ownSymbol # txInfoF.mint
+
+    let burning = P.do
+          passert "ST at inputs must be 1" $
+            spentST #== 1
+
+          passert "ST burned" $
+            mintedST #== -1
+
+          passert "An unlocked input existed containing an ST" $
+            anyInput @PStakeDatum # txInfo
+              #$ plam
+              $ \value _ stakeDatum' -> P.do
+                let hasST = psymbolValueOf # ownSymbol # value #== 1
+                let unlocked = pnot # (stakeLocked # stakeDatum')
+                hasST #&& unlocked
+
+          popaque (pconstant ())
+
+    let minting = P.do
+          passert "ST at inputs must be 0" $
+            spentST #== 0
+
+          passert "Minted ST must be exactly 1" $
+            mintedST #== 1
+
+          passert "A UTXO must exist with the correct output" $
+            anyOutput @PStakeDatum # txInfo
+              #$ plam
+              $ \value address stakeDatum' -> P.do
+                let cred = pfield @"credential" # address
+                pmatch cred $ \case
+                  -- Should pay to a script address
+                  PPubKeyCredential _ -> pcon PFalse
+                  PScriptCredential validatorHash -> P.do
+                    stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
+
+                    tn :: Term _ PTokenName <- plet (validatorHashToTokenName $ pfromData $ pfield @"_0" # validatorHash)
+
+                    let stValue =
+                          psingletonValue
+                            # ownSymbol
+                            -- This coerce is safe because the structure
+                            -- of PValidatorHash is the same as PTokenName.
+                            # tn
+                            # 1
+                    let expectedValue =
+                          paddValue
+                            # (pdiscreteValue' gtClassRef # stakeDatum.stakedAmount)
+                            # stValue
+                    let ownerSignsTransaction =
+                          ptxSignedBy
+                            # txInfoF.signatories
+                            # stakeDatum.owner
+
+                    -- TODO: This is quite inefficient now, as it does two lookups
+                    -- instead of a more efficient single pass,
+                    -- but it doesn't really matter for this. At least it's correct.
+                    let valueCorrect =
+                          foldr1
+                            (#&&)
+                            [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
+                            , pgeqByClass' (untag gtClassRef)
+                                # value
+                                # expectedValue
+                            , pgeqByClass
+                                # ownSymbol
+                                # tn
+                                # value
+                                # expectedValue
+                            ]
+
+                    ownerSignsTransaction
+                      #&& valueCorrect
+          popaque (pconstant ())
+
+    pif (0 #< mintedST) minting burning
+
+--------------------------------------------------------------------------------
+
+-- | Validator intended for Stake UTXOs to live in.
+stakeValidator :: Stake -> ClosedTerm PValidator
+stakeValidator stake =
+  plam $ \datum redeemer ctx' -> P.do
+    ctx <- pletFields @'["txInfo", "purpose"] ctx'
+    txInfo <- plet $ pfromData ctx.txInfo
+    txInfoF <- pletFields @'["mint", "inputs", "outputs", "signatories"] txInfo
+
+    (pfromData -> stakeRedeemer, _) <- ptryFrom redeemer
+
+    -- TODO: Use PTryFrom
+    let stakeDatum' :: Term _ PStakeDatum
+        stakeDatum' = pfromData $ punsafeCoerce datum
+    stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
+
+    PSpending txOutRef <- pmatch $ pfromData ctx.purpose
+
+    PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfoF.inputs
+    ownAddress <- plet $ pfield @"address" #$ pfield @"resolved" # txInInfo
+    let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo
+
+    -- Whether the owner signs this transaction or not.
+    ownerSignsTransaction <- plet $ ptxSignedBy # txInfoF.signatories # stakeDatum.owner
+
+    stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef)
+    mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
+    spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs
+
+    -- Is the stake currently locked?
+    stakeIsLocked <- plet $ stakeLocked # stakeDatum'
+
+    pmatch stakeRedeemer $ \case
+      PDestroy _ -> P.do
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+        passert "Should burn ST" $
+          mintedST #== -1
+        passert "Stake unlocked" $ pnot # stakeIsLocked
+        passert
+          "Owner signs this transaction"
+          ownerSignsTransaction
+        popaque (pconstant ())
+      --------------------------------------------------------------------------
+      PRetractVotes _ -> P.do
+        passert
+          "Owner signs this transaction"
+          ownerSignsTransaction
+        -- TODO: check proposal constraints
+        popaque (pconstant ())
+      --------------------------------------------------------------------------
+      PPermitVote _ -> P.do
+        passert
+          "Owner signs this transaction"
+          ownerSignsTransaction
+        -- TODO: check proposal constraints
+        popaque (pconstant ())
+      --------------------------------------------------------------------------
+      PWitnessStake _ -> P.do
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        let AssetClass (propCs, propTn) = stake.proposalSTClass
+            propAssetClass = passetClass # pconstant propCs # pconstant propTn
+            proposalTokenMoved =
+              ptokenSpent
+                # propAssetClass
+                # txInfoF.inputs
+
+        passert
+          "Owner signs this transaction OR proposal token is spent"
+          (ownerSignsTransaction #|| proposalTokenMoved)
+
+        passert "A UTXO must exist with the correct output" $
+          anyOutput @PStakeDatum # txInfo
+            #$ plam
+            $ \value address newStakeDatum' -> P.do
+              let isScriptAddress = pdata address #== ownAddress
+              let correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
+              let valueCorrect = pdata continuingValue #== pdata value
+              pif
+                isScriptAddress
+                ( foldl1
+                    (#&&)
+                    [ ptraceIfFalse "valueCorrect" valueCorrect
+                    , ptraceIfFalse "correctOutputDatum" correctOutputDatum
+                    ]
+                )
+                (pcon PFalse)
+        popaque (pconstant ())
+      PDepositWithdraw r -> P.do
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+        passert "Stake unlocked" $
+          pnot #$ stakeIsLocked
+        passert
+          "Owner signs this transaction"
+          ownerSignsTransaction
+        passert "A UTXO must exist with the correct output" $
+          anyOutput @PStakeDatum # txInfo
+            #$ plam
+            $ \value address newStakeDatum' -> P.do
+              newStakeDatum <- pletFields @'["owner", "stakedAmount"] newStakeDatum'
+              delta <- plet $ pfield @"delta" # r
+              let isScriptAddress = pdata address #== ownAddress
+              let correctOutputDatum =
+                    foldr1
+                      (#&&)
+                      [ stakeDatum.owner #== newStakeDatum.owner
+                      , (stakeDatum.stakedAmount + delta) #== newStakeDatum.stakedAmount
+                      , -- We can't magically conjure GT anyway (no input to spend!)
+                        -- do we need to check this, really?
+                        zero #<= pfromData newStakeDatum.stakedAmount
+                      ]
+              let expectedValue = paddValue # continuingValue # (pdiscreteValue' stake.gtClassRef # delta)
+
+              -- TODO: Same as above. This is quite inefficient now, as it does two lookups
+              -- instead of a more efficient single pass,
+              -- but it doesn't really matter for this. At least it's correct.
+              let valueCorrect =
+                    foldr1
+                      (#&&)
+                      [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
+                      , pgeqByClass' (untag stake.gtClassRef)
+                          # value
+                          # expectedValue
+                      , pgeqBySymbol
+                          # stCurrencySymbol
+                          # value
+                          # expectedValue
+                      ]
+
+              foldr1
+                (#&&)
+                [ ptraceIfFalse "isScriptAddress" isScriptAddress
+                , ptraceIfFalse "correctOutputDatum" correctOutputDatum
+                , ptraceIfFalse "valueCorrect" valueCorrect
+                ]
+
+        popaque (pconstant ())
diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index e1b80e1..f60c853 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -36,6 +36,7 @@ module Agora.Utils (
   scriptHashFromAddress,
   findOutputsToAddress,
   findTxOutDatum,
+  validatorHashToTokenName,
 ) where
 
 --------------------------------------------------------------------------------
@@ -53,7 +54,7 @@ import Plutarch.Api.V1 (
   PMap,
   PMaybeData (PDJust),
   PPubKeyHash,
-  PTokenName,
+  PTokenName (PTokenName),
   PTuple,
   PTxInInfo (PTxInInfo),
   PTxInfo,
@@ -430,3 +431,6 @@ findTxOutDatum = phoistAcyclic $
     case datumHash' of
       PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # datums
       _ -> pcon PNothing
+
+validatorHashToTokenName :: forall (s :: S). Term s PValidatorHash -> Term s PTokenName
+validatorHashToTokenName vh = pcon (PTokenName (pto vh))

From 8cbdbeb2fe195874dc7185bfc7773fe3a009ba29 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Tue, 26 Apr 2022 21:07:02 +0200
Subject: [PATCH 68/78] fix haddock errors

---
 agora/Agora/Effect/NoOp.hs               |  1 +
 agora/Agora/Effect/TreasuryWithdrawal.hs | 10 ++++++++--
 agora/Agora/Proposal.hs                  |  6 +++---
 agora/Agora/Proposal/Time.hs             | 25 +++++++++++++++++-------
 agora/Agora/Record.hs                    |  5 +++--
 agora/Agora/Stake.hs                     |  7 ++++---
 agora/Agora/Stake/Scripts.hs             | 13 ++++++------
 agora/Agora/Treasury.hs                  |  4 +++-
 8 files changed, 47 insertions(+), 24 deletions(-)

diff --git a/agora/Agora/Effect/NoOp.hs b/agora/Agora/Effect/NoOp.hs
index ccdae74..82069b9 100644
--- a/agora/Agora/Effect/NoOp.hs
+++ b/agora/Agora/Effect/NoOp.hs
@@ -14,6 +14,7 @@ import Plutarch.Api.V1 (PValidator)
 import Plutarch.TryFrom (PTryFrom (..))
 import Plutus.V1.Ledger.Value (CurrencySymbol)
 
+-- | Dummy datum for NoOp effect.
 newtype PNoOp (s :: S) = PNoOp (Term s PUnit)
   deriving (PlutusType, PIsData) via (DerivePNewtype PNoOp PUnit)
 
diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs
index 8693cdf..e9957a4 100644
--- a/agora/Agora/Effect/TreasuryWithdrawal.hs
+++ b/agora/Agora/Effect/TreasuryWithdrawal.hs
@@ -40,7 +40,12 @@ import Plutus.V1.Ledger.Credential (Credential)
 import Plutus.V1.Ledger.Value (CurrencySymbol, Value)
 import PlutusTx qualified
 
--- | Datum that encodes behavior of Treasury Withdrawal effect.
+{- | Datum that encodes behavior of Treasury Withdrawal effect.
+
+Note: This Datum acts like a "predefined redeemer". Which is to say that
+it encodes the properties a redeemer would, but is locked in-place until
+spend.
+-}
 data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum
   { receivers :: [(Credential, Value)]
   -- ^ AssocMap for Value sent to each receiver from the treasury.
@@ -51,8 +56,9 @@ data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum
   deriving anyclass (Generic)
 
 PlutusTx.makeLift ''TreasuryWithdrawalDatum
-PlutusTx.unstableMakeIsData ''TreasuryWithdrawalDatum
+PlutusTx.makeIsDataIndexed ''TreasuryWithdrawalDatum [('TreasuryWithdrawalDatum, 0)]
 
+-- | Haskell-level version of 'TreasuryWithdrawalDatum'.
 newtype PTreasuryWithdrawalDatum (s :: S)
   = PTreasuryWithdrawalDatum
       ( Term
diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index bf88bf8..05a9f91 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -109,7 +109,7 @@ data ProposalStatus
     --   the proposal failed due to time constraints or didn't
     --   get to 'VotingReady' first.
     --
-    --   At this stage, the 'votes' field of 'ProposalState' is frozen.
+    --   At this stage, the 'votes' field of 'ProposalDatum' is frozen.
     --
     --   See 'AdvanceProposal' for documentation on state transitions.
     --
@@ -186,7 +186,7 @@ data ProposalRedeemer
     --   Must be signed by those cosigning.
     --
     --   This is particularly used in the 'Draft' 'ProposalStatus',
-    --   where matching 'Stake's can be called to advance the proposal,
+    --   where matching 'Agora.Stake.Stake's can be called to advance the proposal,
     --   provided enough GT is shared  among them.
     Cosign [PubKeyHash]
   | -- | Allow unlocking one or more stakes with votes towards particular 'ResultTag'.
@@ -351,7 +351,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum
 instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
 deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum)
 
--- | Haskell-level redeemer for Proposal scripts.
+-- | Plutarch-level version of 'ProposalRedeemer'.
 data PProposalRedeemer (s :: S)
   = PVote (Term s (PDataRecord '["resultTag" ':= PResultTag]))
   | PCosign (Term s (PDataRecord '["newCosigners" ':= PBuiltinList (PAsData PPubKeyHash)]))
diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs
index 311c3fb..fd5063a 100644
--- a/agora/Agora/Proposal/Time.hs
+++ b/agora/Agora/Proposal/Time.hs
@@ -27,7 +27,15 @@ module Agora.Proposal.Time (
 import Agora.Record (mkRecordConstr, (.&), (.=))
 import GHC.Generics qualified as GHC
 import Generics.SOP (Generic, I (I))
-import Plutarch.Api.V1 (PExtended (PFinite), PInterval (PInterval), PLowerBound (PLowerBound), PMaybeData (PDJust, PDNothing), PPOSIXTime, PPOSIXTimeRange, PUpperBound (PUpperBound))
+import Plutarch.Api.V1 (
+  PExtended (PFinite),
+  PInterval (PInterval),
+  PLowerBound (PLowerBound),
+  PMaybeData (PDJust, PDNothing),
+  PPOSIXTime,
+  PPOSIXTimeRange,
+  PUpperBound (PUpperBound),
+ )
 import Plutarch.DataRepr (PDataFields, PIsDataReprInstances (..))
 import Plutarch.Monadic qualified as P
 import Plutarch.Numeric (AdditiveSemigroup ((+)))
@@ -74,16 +82,19 @@ newtype ProposalStartingTime = ProposalStartingTime
   deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
   deriving stock (Eq, Show, GHC.Generic)
 
--- | Configuration of proposal timings.
+{- | Configuration of proposal timings.
+
+ See: https://github.com/Liqwid-Labs/agora/blob/master/docs/tech-design/proposals.md#when-may-interactions-occur
+-}
 data ProposalTimingConfig = ProposalTimingConfig
   { draftTime :: POSIXTime
-  -- ^ `D`: the length of the draft period.
+  -- ^ "D": the length of the draft period.
   , votingTime :: POSIXTime
-  -- ^ `V`: the length of the voting period.
+  -- ^ "V": the length of the voting period.
   , lockingTime :: POSIXTime
-  -- ^ `L`: the length of the locking period.
+  -- ^ "L": the length of the locking period.
   , executingTime :: POSIXTime
-  -- ^ `E`: the length of the execution period.
+  -- ^ "E": the length of the execution period.
   }
   deriving stock (Eq, Show, GHC.Generic)
 
@@ -139,7 +150,7 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
 instance AdditiveSemigroup (Term s PPOSIXTime) where
   (punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y
 
--- | Get the current proposal time, from the 'txInfoValidRange' field.
+-- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidRange' field.
 currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime)
 currentProposalTime = phoistAcyclic $
   plam $ \iv -> P.do
diff --git a/agora/Agora/Record.hs b/agora/Agora/Record.hs
index 5ad5691..30d7490 100644
--- a/agora/Agora/Record.hs
+++ b/agora/Agora/Record.hs
@@ -60,7 +60,8 @@ mkRecordConstr ::
   forall (r :: [PLabeledType]) (s :: S) (pt :: PType).
   PlutusType pt =>
   -- | The constructor. This is just the Haskell-level constructor for the type.
-  --   For 'PMaybeData', this could be 'PDJust', or 'PNothing'.
+  --   For 'Plutarch.Api.V1.Maybe.PMaybeData', this would
+  --   be 'Plutarch.Api.V1.Maybe.PDJust', or 'Plutarch.Api.V1.Maybe.PNothing'.
   (forall s'. Term s' (PDataRecord r) -> pt s') ->
   -- | The morphism that builds the record.
   RecordMorphism s '[] r ->
@@ -87,7 +88,7 @@ infix 7 .=
   --   @#hello ~ 'FieldName' "hello"@
   FieldName sym ->
   -- | The value at that field. This must be 'PAsData', because the underlying
-  --   type is @'Constr' 'Integer' ['Data']@.
+  --   type is @'PlutusCore.Data.Constr' 'Integer' ['PlutusCore.Data.Data']@.
   Term s (PAsData a) ->
   RecordMorphism s as ((sym ':= a) ': as)
 _ .= x = RecordMorphism $ pcon . PDCons x
diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs
index efdc91b..6788f91 100644
--- a/agora/Agora/Stake.hs
+++ b/agora/Agora/Stake.hs
@@ -127,14 +127,14 @@ data StakeRedeemer
   | -- | 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 'Proposal'.
+  | -- | Permit a Vote to be added onto a 'Agora.Proposal.Proposal'.
     --   This also adds a lock to the 'lockedBy' field. See 'ProposalLock'.
     --   This needs to be done in sync with casting a vote, otherwise
     --   it's possible for a lock to be permanently placed on the stake,
     --   and then the funds are lost.
     PermitVote ProposalLock
   | -- | Retract a vote, removing it from the 'lockedBy' field. See 'ProposalLock'.
-    --   This action checks for permission of the 'Proposal'. Finished proposals are
+    --   This action checks for permission of the 'Agora.Proposal.Proposal'. Finished proposals are
     --   always allowed to have votes retracted and won't affect the Proposal datum,
     --   allowing 'Stake's to be unlocked.
     RetractVotes [ProposalLock]
@@ -156,7 +156,7 @@ PlutusTx.makeIsDataIndexed
 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 'Proposal's.
+  -- This also acts as the voting weight for 'Agora.Proposal.Proposal's.
   , owner :: PubKeyHash
   -- ^ The hash of the public key this stake belongs to.
   --
@@ -218,6 +218,7 @@ deriving via
 instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer
 deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstantDecl StakeRedeemer)
 
+-- | Plutarch-level version of 'ProposalLock'.
 newtype PProposalLock (s :: S) = PProposalLock
   { getProposalLock ::
     Term
diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs
index f07ace3..44cefac 100644
--- a/agora/Agora/Stake/Scripts.hs
+++ b/agora/Agora/Stake/Scripts.hs
@@ -54,15 +54,16 @@ import Prelude hiding (Num (..))
 
    === For minting:
 
-   - Check that exactly one state thread is minted
-   - Check that an output exists with a state thread and a valid datum
-   - Check that no state thread is an input
-   - assert @'TokenName' == 'ValidatorHash'@ of the script that we pay to
+   - Check that exactly one state thread is minted.
+   - Check that an output exists with a state thread and a valid datum.
+   - Check that no state thread is an input.
+   - assert @'Plutus.V1.Ledger.Api.TokenName' == 'Plutus.V1.Ledger.Api.ValidatorHash'@
+     of the script that we pay to.
 
    === For burning:
 
-   - Check that exactly one state thread is burned
-   - Check that datum at state thread is valid and not locked
+   - Check that exactly one state thread is burned.
+   - Check that datum at state thread is valid and not locked.
 -}
 stakePolicy :: Tagged GTTag AssetClass -> ClosedTerm PMintingPolicy
 stakePolicy gtClassRef =
diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs
index db9172f..f3ff441 100644
--- a/agora/Agora/Treasury.hs
+++ b/agora/Agora/Treasury.hs
@@ -29,8 +29,10 @@ import PlutusTx qualified
 
 --------------------------------------------------------------------------------
 
+-- | Redeemer for Treasury actions.
 data TreasuryRedeemer
-  = SpendTreasuryGAT
+  = -- | Allow transaction to pass by delegating to GAT burn.
+    SpendTreasuryGAT
   deriving stock (Eq, Show, GHC.Generic)
 
 PlutusTx.makeIsDataIndexed

From 34827aeca668db9aa9cb7cc897c011c307d15c18 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Tue, 26 Apr 2022 22:08:31 +0200
Subject: [PATCH 69/78] add missing range checks

---
 agora/Agora/Proposal.hs      |  8 ++++----
 agora/Agora/Proposal/Time.hs | 24 ++++++++++++++++++++++++
 2 files changed, 28 insertions(+), 4 deletions(-)

diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index 05a9f91..8fcaa43 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -252,8 +252,8 @@ instance PTryFrom PData (PAsData PResultTag) where
   ptryFrom' d k =
     ptryFrom' @_ @(PAsData PInteger) d $
       -- JUSTIFICATION:
-      -- We are coercing from @PAsData underlying@ to @PAsData (PTagged tag underlying)@.
-      -- Since 'PTagged' is a simple newtype, their shape is the same.
+      -- We are coercing from @PAsData PInteger@ to @PAsData PResultTag@.
+      -- Since 'PResultTag' is a simple newtype, their shape is the same.
       k . first punsafeCoerce
 
 -- | Plutarch-level version of 'PProposalId'.
@@ -265,8 +265,8 @@ instance PTryFrom PData (PAsData PProposalId) where
   ptryFrom' d k =
     ptryFrom' @_ @(PAsData PInteger) d $
       -- JUSTIFICATION:
-      -- We are coercing from @PAsData underlying@ to @PAsData (PTagged tag underlying)@.
-      -- Since 'PTagged' is a simple newtype, their shape is the same.
+      -- We are coercing from @PAsData PInteger@ to @PAsData PProposalId@.
+      -- Since 'PProposalId' is a simple newtype, their shape is the same.
       k . first punsafeCoerce
 
 instance PUnsafeLiftDecl PProposalId where type PLifted PProposalId = ProposalId
diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs
index fd5063a..54e3d3d 100644
--- a/agora/Agora/Proposal/Time.hs
+++ b/agora/Agora/Proposal/Time.hs
@@ -22,6 +22,9 @@ module Agora.Proposal.Time (
   -- * Compute ranges given config and starting time.
   currentProposalTime,
   isDraftRange,
+  isVotingRange,
+  isLockingRange,
+  isExecutionRange,
 ) where
 
 import Agora.Record (mkRecordConstr, (.&), (.=))
@@ -196,3 +199,24 @@ isDraftRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalSta
 isDraftRange = phoistAcyclic $
   plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
     proposalTimeWithin # s # (s + pfield @"draftTime" # config)
+
+-- | True if the 'PProposalTime' is in the voting period.
+isVotingRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool)
+isVotingRange = 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.
+isLockingRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool)
+isLockingRange = 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.
+isExecutionRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool)
+isExecutionRange = 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)

From 9dd5bed05ea4077a9399299246f6392cbf5a3ecd Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Wed, 27 Apr 2022 12:42:19 +0200
Subject: [PATCH 70/78] reduce use of unjustified `punsafeCoerce`

---
 agora/Agora/AuthorityToken.hs   |  2 +-
 agora/Agora/Proposal.hs         | 50 +++++++++++++++++++++++
 agora/Agora/Proposal/Scripts.hs | 38 ++---------------
 agora/Agora/Stake.hs            | 20 +++++----
 agora/Agora/Stake/Scripts.hs    | 72 +++++++++++++++++++++++++++++----
 agora/Agora/Utils.hs            |  8 ++--
 docs/tech-design/proposals.md   |  9 ++++-
 7 files changed, 143 insertions(+), 56 deletions(-)

diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs
index 57baf46..241ad13 100644
--- a/agora/Agora/AuthorityToken.hs
+++ b/agora/Agora/AuthorityToken.hs
@@ -145,7 +145,7 @@ authorityTokenPolicy params =
         ( P.do
             passert "Parent token did not move in minting GATs" govTokenSpent
             passert "All outputs only emit valid GATs" $
-              allOutputs @PUnit # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
+              allOutputs @PData # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
                 authorityTokensValidIn
                   # ownSymbol
                   # txOut
diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index 8fcaa43..a383b00 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -26,6 +26,9 @@ module Agora.Proposal (
   PProposalVotes (..),
   PProposalId (..),
   PResultTag (..),
+
+  -- * Plutarch helpers
+  proposalDatumValid,
 ) where
 
 import GHC.Generics qualified as GHC
@@ -41,13 +44,17 @@ import PlutusTx.AssocMap qualified as AssocMap
 
 --------------------------------------------------------------------------------
 import Agora.SafeMoney (GTTag)
+import Agora.Utils (pnotNull)
+import Control.Applicative (Const)
 import Control.Arrow (first)
+import Plutarch.Builtin (PBuiltinMap)
 import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..))
 import Plutarch.Lift (
   DerivePConstantViaNewtype (..),
   PConstantDecl,
   PUnsafeLiftDecl (..),
  )
+import Plutarch.Monadic qualified as P
 import Plutarch.SafeMoney (PDiscrete, Tagged)
 import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
 import Plutarch.Unsafe (punsafeCoerce)
@@ -348,6 +355,12 @@ newtype PProposalDatum (s :: S) = PProposalDatum
     (PlutusType, PIsData, PDataFields)
     via (PIsDataReprInstances PProposalDatum)
 
+-- TODO: Derive this.
+instance PTryFrom PData (PAsData PProposalDatum) where
+  type PTryFromExcess PData (PAsData PProposalDatum) = Const ()
+  ptryFrom' d k =
+    k (punsafeCoerce d, ())
+
 instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
 deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum)
 
@@ -364,6 +377,12 @@ data PProposalRedeemer (s :: S)
     (PlutusType, PIsData)
     via PIsDataReprInstances PProposalRedeemer
 
+-- See below.
+instance PTryFrom PData (PAsData PProposalRedeemer) where
+  type PTryFromExcess PData (PAsData PProposalRedeemer) = Const ()
+  ptryFrom' d k =
+    k (punsafeCoerce d, ())
+
 -- TODO: Waiting on PTryFrom for 'PPubKeyHash'
 -- deriving via
 --   PAsData (PIsDataReprInstances PProposalRedeemer)
@@ -372,3 +391,34 @@ data PProposalRedeemer (s :: S)
 
 instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer
 deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstantDecl ProposalRedeemer)
+
+--------------------------------------------------------------------------------
+
+{- | Check for various invariants a proposal must uphold.
+     This can be used to check both upopn creation and
+     upon any following state transitions in the proposal.
+-}
+proposalDatumValid :: Term s (Agora.Proposal.PProposalDatum :--> PBool)
+proposalDatumValid =
+  phoistAcyclic $
+    plam $ \datum' -> P.do
+      datum <- pletFields @'["effects", "cosigners"] $ datum'
+
+      let effects :: Term _ (PBuiltinMap Agora.Proposal.PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash))
+          effects =
+            -- JUSTIFICATION:
+            -- @datum.effects : PMap PResultTag (PMap PValidatorHash PDatumHash)@
+            -- @PMap PResultTag (PMap PValidatorHash PDatumHash)@ is equivalent to
+            -- @PBuiltinMap PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash)@
+            punsafeCoerce datum.effects
+
+          atLeastOneNegativeResult :: Term _ PBool
+          atLeastOneNegativeResult =
+            pany # plam (\pair -> pnull #$ pfromData $ psndBuiltin # pair) # effects
+
+      foldr1
+        (#&&)
+        [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult
+        , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
+        , ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #< 6
+        ]
diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs
index 417f577..44612be 100644
--- a/agora/Agora/Proposal/Scripts.hs
+++ b/agora/Agora/Proposal/Scripts.hs
@@ -8,13 +8,11 @@ Plutus Scripts for Proposals.
 module Agora.Proposal.Scripts (
   proposalValidator,
   proposalPolicy,
-  proposalDatumValid,
 ) where
 
 import Agora.Proposal (
   PProposalDatum (PProposalDatum),
   PProposalRedeemer (..),
-  PResultTag,
   Proposal (governorSTAssetClass, stakeSTAssetClass),
  )
 import Agora.Record (mkRecordConstr, (.&), (.=))
@@ -23,27 +21,23 @@ import Agora.Utils (
   anyOutput,
   findTxOutByTxOutRef,
   passert,
-  pnotNull,
   psymbolValueOf,
   ptokenSpent,
   ptxSignedBy,
   pvalueSpent,
  )
 import Plutarch.Api.V1 (
-  PDatumHash,
   PMintingPolicy,
   PScriptContext (PScriptContext),
   PScriptPurpose (PMinting, PSpending),
   PTxInfo (PTxInfo),
   PValidator,
-  PValidatorHash,
   mintingPolicySymbol,
   mkMintingPolicy,
  )
 import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
-import Plutarch.Builtin (PBuiltinMap)
 import Plutarch.Monadic qualified as P
-import Plutarch.Unsafe (punsafeCoerce)
+import Plutarch.TryFrom (ptryFrom)
 import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
 
 {- | Policy for Proposals.
@@ -94,10 +88,8 @@ proposalValidator proposal =
     PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
     txOutF <- pletFields @'["address", "value"] $ txOut
 
-    let proposalDatum :: Term _ Agora.Proposal.PProposalDatum
-        proposalDatum = pfromData $ punsafeCoerce datum
-        proposalRedeemer :: Term _ Agora.Proposal.PProposalRedeemer
-        proposalRedeemer = pfromData $ punsafeCoerce redeemer
+    (pfromData -> proposalDatum, _) <- ptryFrom @(PAsData PProposalDatum) datum
+    (pfromData -> proposalRedeemer, _) <- ptryFrom @(PAsData PProposalRedeemer) redeemer
 
     proposalF <-
       pletFields
@@ -189,27 +181,3 @@ proposalValidator proposal =
           spentST #== 1
 
         popaque (pconstant ())
-
-{- | Check for various invariants a proposal must uphold.
-     This can be used to check both upopn creation and
-     upon any following state transitions in the proposal.
--}
-proposalDatumValid :: Term s (Agora.Proposal.PProposalDatum :--> PBool)
-proposalDatumValid =
-  phoistAcyclic $
-    plam $ \datum' -> P.do
-      datum <- pletFields @'["effects", "cosigners"] $ datum'
-
-      let effects :: Term _ (PBuiltinMap Agora.Proposal.PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash))
-          effects = punsafeCoerce datum.effects
-
-          atLeastOneNegativeResult :: Term _ PBool
-          atLeastOneNegativeResult =
-            pany # plam (\pair -> pnull #$ pfromData $ psndBuiltin # pair) # effects
-
-      foldr1
-        (#&&)
-        [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult
-        , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
-        , ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #< 6
-        ]
diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs
index 6788f91..b25a7ef 100644
--- a/agora/Agora/Stake.hs
+++ b/agora/Agora/Stake.hs
@@ -61,16 +61,17 @@ import Plutus.V1.Ledger.Value (AssetClass)
 import Agora.Proposal (PProposalId, PResultTag, ProposalId (..), ResultTag (..))
 import Agora.SafeMoney (GTTag)
 import Agora.Utils (
-  pfindDatum,
   pnotNull,
+  ptryFindDatum,
  )
+import Control.Applicative (Const)
 import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf)
 import Plutarch.Numeric ()
 import Plutarch.SafeMoney (
   PDiscrete,
   Tagged (..),
  )
-import Plutarch.TryFrom (PTryFrom)
+import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
 
 --------------------------------------------------------------------------------
 
@@ -191,6 +192,11 @@ newtype PStakeDatum (s :: S) = PStakeDatum
     (PlutusType, PIsData, PDataFields)
     via (PIsDataReprInstances PStakeDatum)
 
+instance PTryFrom PData (PAsData PStakeDatum) where
+  type PTryFromExcess PData (PAsData PStakeDatum) = Const ()
+  ptryFrom' d k =
+    k (punsafeCoerce d, ())
+
 instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum
 deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstantDecl StakeDatum)
 
@@ -262,7 +268,7 @@ findStakeOwnedBy ::
         :--> PPubKeyHash
         :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum))
         :--> PBuiltinList (PAsData PTxInInfo)
-        :--> PMaybe PTxOut
+        :--> PMaybe (PAsData PStakeDatum)
     )
 findStakeOwnedBy = phoistAcyclic $
   plam $ \ac pk datums inputs ->
@@ -273,9 +279,8 @@ findStakeOwnedBy = phoistAcyclic $
         txOutF <- pletFields @'["datumHash"] $ txOut
         pmatch txOutF.datumHash $ \case
           PDNothing _ -> pcon PNothing
-          PDJust ((pfield @"_0" #) -> dh) ->
-            -- TODO: PTryFrom here
-            punsafeCoerce $ pfindDatum # dh # datums
+          PDJust ((pfield @"_0" #) -> dh) -> P.do
+            ptryFindDatum @(PAsData PStakeDatum) # dh # datums
 
 stakeDatumOwnedBy :: Term _ (PPubKeyHash :--> PStakeDatum :--> PBool)
 stakeDatumOwnedBy =
@@ -304,8 +309,7 @@ isInputStakeOwnedBy =
       PDJust ((pfield @"_0" #) -> datumHash) ->
         pif
           (outStakeST #== 1)
-          -- TODO: use 'ptryFindDatum' instead in the future
-          ( pmatch (pfindDatum # datumHash # datums) $ \case
+          ( pmatch (ptryFindDatum @(PAsData PStakeDatum) # datumHash # datums) $ \case
               PNothing -> pcon PFalse
               PJust v -> stakeDatumOwnedBy # ss # pfromData (punsafeCoerce v)
           )
diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs
index 44cefac..2f80d66 100644
--- a/agora/Agora/Stake/Scripts.hs
+++ b/agora/Agora/Stake/Scripts.hs
@@ -35,7 +35,7 @@ import Plutarch.Api.V1 (
   mintingPolicySymbol,
   mkMintingPolicy,
  )
-import Plutarch.Api.V1.Extra (passetClass)
+import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
 import Plutarch.Internal (punsafeCoerce)
 import Plutarch.Monadic qualified as P
 import Plutarch.Numeric
@@ -183,7 +183,12 @@ stakeValidator stake =
 
     stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake.gtClassRef)
     mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
-    spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfoF.inputs
+    valueSpent <- plet $ pvalueSpent # txInfoF.inputs
+    spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
+
+    let AssetClass (propCs, propTn) = stake.proposalSTClass
+        proposalSTClass = passetClass # pconstant propCs # pconstant propTn
+    spentProposalST <- plet $ passetClassValueOf # valueSpent # proposalSTClass
 
     -- Is the stake currently locked?
     stakeIsLocked <- plet $ stakeLocked # stakeDatum'
@@ -192,26 +197,76 @@ stakeValidator stake =
       PDestroy _ -> P.do
         passert "ST at inputs must be 1" $
           spentST #== 1
+
         passert "Should burn ST" $
           mintedST #== -1
+
         passert "Stake unlocked" $ pnot # stakeIsLocked
-        passert
-          "Owner signs this transaction"
-          ownerSignsTransaction
+
+        passert "Owner signs this transaction" ownerSignsTransaction
+
         popaque (pconstant ())
       --------------------------------------------------------------------------
       PRetractVotes _ -> P.do
         passert
           "Owner signs this transaction"
           ownerSignsTransaction
-        -- TODO: check proposal constraints
+
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        -- This puts trust into the Proposal. The Proposal must necessarily check
+        -- that this is not abused.
+        passert "Proposal ST spent" $
+          spentProposalST #== 1
+
+        passert "A UTXO must exist with the correct output" $
+          anyOutput @PStakeDatum # txInfo
+            #$ plam
+            $ \value address newStakeDatum' -> P.do
+              let isScriptAddress = pdata address #== ownAddress
+              let _correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
+              let valueCorrect = pdata continuingValue #== pdata value
+              pif
+                isScriptAddress
+                ( foldl1
+                    (#&&)
+                    [ ptraceIfFalse "valueCorrect" valueCorrect
+                    ]
+                )
+                (pcon PFalse)
+
         popaque (pconstant ())
       --------------------------------------------------------------------------
       PPermitVote _ -> P.do
         passert
           "Owner signs this transaction"
           ownerSignsTransaction
-        -- TODO: check proposal constraints
+
+        passert "ST at inputs must be 1" $
+          spentST #== 1
+
+        -- This puts trust into the Proposal. The Proposal must necessarily check
+        -- that this is not abused.
+        passert "Proposal ST spent" $
+          spentProposalST #== 1
+
+        passert "A UTXO must exist with the correct output" $
+          anyOutput @PStakeDatum # txInfo
+            #$ plam
+            $ \value address newStakeDatum' -> P.do
+              let isScriptAddress = pdata address #== ownAddress
+              let _correctOutputDatum = pdata newStakeDatum' #== pdata stakeDatum'
+              let valueCorrect = pdata continuingValue #== pdata value
+              pif
+                isScriptAddress
+                ( foldl1
+                    (#&&)
+                    [ ptraceIfFalse "valueCorrect" valueCorrect
+                    ]
+                )
+                (pcon PFalse)
+
         popaque (pconstant ())
       --------------------------------------------------------------------------
       PWitnessStake _ -> P.do
@@ -225,6 +280,9 @@ stakeValidator stake =
                 # propAssetClass
                 # txInfoF.inputs
 
+        -- In order for cosignature to be witnessed, it must be possible for a
+        -- proposal to allow this transaction to happen. This puts trust into the Proposal.
+        -- The Proposal must necessarily check that this is not abused.
         passert
           "Owner signs this transaction OR proposal token is spent"
           (ownerSignsTransaction #|| proposalTokenMoved)
diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index f60c853..0f60dde 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -84,7 +84,7 @@ pfindDatum = phoistAcyclic $
   plam $ \datumHash datums -> plookupTuple # datumHash # datums
 
 -- | Find a datum with the given hash, and `ptryFrom` it.
-ptryFindDatum :: PTryFrom PData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe a)
+ptryFindDatum :: forall (a :: PType) (s :: S). PTryFrom PData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe a)
 ptryFindDatum = phoistAcyclic $
   plam $ \datumHash inputs -> P.do
     pmatch (pfindDatum # datumHash # inputs) $ \case
@@ -326,6 +326,7 @@ ptokenSpent =
 anyOutput ::
   forall (datum :: PType) s.
   ( PIsData datum
+  , PTryFrom PData (PAsData datum)
   ) =>
   Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
 anyOutput = phoistAcyclic $
@@ -337,7 +338,7 @@ anyOutput = phoistAcyclic $
             PTxOut txOut' <- pmatch (pfromData txOut'')
             txOut <- pletFields @'["value", "datumHash", "address"] txOut'
             PDJust dh <- pmatch txOut.datumHash
-            pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo.datums) $ \case
+            pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
               PJust datum -> P.do
                 predicate # txOut.value # txOut.address # pfromData datum
               PNothing -> pcon PFalse
@@ -348,6 +349,7 @@ anyOutput = phoistAcyclic $
 allOutputs ::
   forall (datum :: PType) s.
   ( PIsData datum
+  , PTryFrom PData (PAsData datum)
   ) =>
   Term s (PTxInfo :--> (PTxOut :--> PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
 allOutputs = phoistAcyclic $
@@ -359,7 +361,7 @@ allOutputs = phoistAcyclic $
             PTxOut txOut' <- pmatch (pfromData txOut'')
             txOut <- pletFields @'["value", "datumHash", "address"] txOut'
             PDJust dh <- pmatch txOut.datumHash
-            pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo.datums) $ \case
+            pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
               PJust datum -> P.do
                 predicate # pfromData txOut'' # txOut.value # txOut.address # pfromData datum
               PNothing -> pcon PFalse
diff --git a/docs/tech-design/proposals.md b/docs/tech-design/proposals.md
index a3a3fb1..6098795 100644
--- a/docs/tech-design/proposals.md
+++ b/docs/tech-design/proposals.md
@@ -4,7 +4,7 @@ This document gives an overview of the technical design of the proposals system
 
 | Specification | Implementation | Last revision |
 |:-----------:|:-----------:|:-------------:|
-| WIP         |  WIP        | v0.1 2022-04-11    |
+| WIP         |  WIP        | v0.1 2022-04-27    |
 
 ---
 
@@ -35,7 +35,12 @@ Initiating a proposal requires the proposer to have more than a certain amount o
 
 ### Voting stages
 
-The life-cycle of a proposal is neatly represented by a state machine, with the 'draft' phase being the initial state, and 'executed' and 'failed' being the terminating states. Please note that this state-machine representation is purely conceptual and should not be expected to reflect technical implementation.
+The life-cycle of a proposal is neatly represented by a state machine, with the 'draft' phase being the initial state, and 'executed' and 'failed' being the terminating states.
+
+**Please note that this state-machine representation is purely conceptual and should not be expected to reflect technical implementation.** This is because some state transitions in the state machine representation don't need to happen in the actual implementation as a transaction. A key example is going from the "lock" phase to the "execution" phase. The only thing that needs to happen is that time goes by. So under the hood, they are represented the same in the Proposal's datum.
+
+> Emily 2022-04-27: This is quite confusing still, I feel. @Jack, could you try to reword this and make it more clear?
+
 
 ![](../diagrams/ProposalStateMachine.svg)
 

From 2865f2f093a6e10df38033d016de942e4030d260 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Wed, 27 Apr 2022 14:43:55 +0200
Subject: [PATCH 71/78] be more consistent in use of "period", "state", etc
 wrt. proposals

- specify maximum cosigners requirement in spec.
- remove silly qualified names in Proposal impl.
---
 agora-test/Spec/Sample/Shared.hs |  1 +
 agora/Agora/Proposal.hs          | 18 +++++++++++-------
 agora/Agora/Proposal/Scripts.hs  | 30 +++++++++++++++---------------
 docs/tech-design/proposals.md    | 24 ++++++++++++------------
 4 files changed, 39 insertions(+), 34 deletions(-)

diff --git a/agora-test/Spec/Sample/Shared.hs b/agora-test/Spec/Sample/Shared.hs
index 37b1afc..516435b 100644
--- a/agora-test/Spec/Sample/Shared.hs
+++ b/agora-test/Spec/Sample/Shared.hs
@@ -107,6 +107,7 @@ proposal =
         Value.assetClass govSymbol ""
     , stakeSTAssetClass =
         Value.assetClass stakeSymbol ""
+    , maximumCosigners = 6
     }
 
 proposalPolicySymbol :: CurrencySymbol
diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index a383b00..d7c6e35 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -84,8 +84,10 @@ newtype ResultTag = ResultTag {getResultTag :: Integer}
   deriving stock (Eq, Show, Ord)
   deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
 
-{- | The "status" of the proposal. This is only useful for state transitions,
-     as opposed to time-based "phases".
+{- | The "status" of the proposal. This is only useful for state transitions that
+     need to happen as a result of a transaction as opposed to time-based "periods".
+
+     See the note on wording & the state machine in the tech-design.
 
      If the proposal is 'VotingReady', for instance, that doesn't necessarily
      mean that voting is possible, as this also requires the timing to be right.
@@ -220,7 +222,7 @@ data ProposalRedeemer
     --   === @* -> 'Finished'@:
     --
     --     If the proposal has run out of time for the current 'ProposalStatus', it will always be possible
-    --     to transition into 'Finished' state, because it has expired (and failed).
+    --     to transition into 'Finished' status, because it has expired (and failed).
     AdvanceProposal
   deriving stock (Eq, Show, GHC.Generic)
 
@@ -236,6 +238,8 @@ PlutusTx.makeIsDataIndexed
 data Proposal = Proposal
   { governorSTAssetClass :: AssetClass
   , stakeSTAssetClass :: AssetClass
+  , maximumCosigners :: Integer
+  -- ^ Arbitrary limit for maximum amount of cosigners on a proposal.
   }
   deriving stock (Show, Eq)
 
@@ -395,11 +399,11 @@ deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instanc
 --------------------------------------------------------------------------------
 
 {- | Check for various invariants a proposal must uphold.
-     This can be used to check both upopn creation and
+     This can be used to check both upon creation and
      upon any following state transitions in the proposal.
 -}
-proposalDatumValid :: Term s (Agora.Proposal.PProposalDatum :--> PBool)
-proposalDatumValid =
+proposalDatumValid :: Proposal -> Term s (Agora.Proposal.PProposalDatum :--> PBool)
+proposalDatumValid proposal =
   phoistAcyclic $
     plam $ \datum' -> P.do
       datum <- pletFields @'["effects", "cosigners"] $ datum'
@@ -420,5 +424,5 @@ proposalDatumValid =
         (#&&)
         [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult
         , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
-        , ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #< 6
+        , ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #<= pconstant proposal.maximumCosigners
         ]
diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs
index 44612be..3535260 100644
--- a/agora/Agora/Proposal/Scripts.hs
+++ b/agora/Agora/Proposal/Scripts.hs
@@ -48,20 +48,20 @@ import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
    NOTE: The governor needs to check that the datum is correct
          and sent to the right address.
 -}
-proposalPolicy :: Agora.Proposal.Proposal -> ClosedTerm Plutarch.Api.V1.PMintingPolicy
+proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
 proposalPolicy proposal =
   plam $ \_redeemer ctx' -> P.do
-    Plutarch.Api.V1.PScriptContext ctx' <- pmatch ctx'
+    PScriptContext ctx' <- pmatch ctx'
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
-    Plutarch.Api.V1.PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
+    PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
     txInfo <- pletFields @'["inputs", "mint"] txInfo'
-    Plutarch.Api.V1.PMinting _ownSymbol <- pmatch $ pfromData ctx.purpose
+    PMinting _ownSymbol <- pmatch $ pfromData ctx.purpose
 
     let inputs = txInfo.inputs
         mintedValue = pfromData txInfo.mint
         AssetClass (govCs, govTn) = proposal.governorSTAssetClass
 
-    Plutarch.Api.V1.PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
+    PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
     let mintedProposalST = passetClassValueOf # mintedValue # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "")
 
     passert "Governance state-thread token must move" $
@@ -75,15 +75,15 @@ proposalPolicy proposal =
     popaque (pconstant ())
 
 -- | Validator for Proposals.
-proposalValidator :: Agora.Proposal.Proposal -> ClosedTerm Plutarch.Api.V1.PValidator
+proposalValidator :: Proposal -> ClosedTerm PValidator
 proposalValidator proposal =
   plam $ \datum redeemer ctx' -> P.do
-    Plutarch.Api.V1.PScriptContext ctx' <- pmatch ctx'
+    PScriptContext ctx' <- pmatch ctx'
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
     txInfo <- plet $ pfromData ctx.txInfo
-    Plutarch.Api.V1.PTxInfo txInfo' <- pmatch txInfo
+    PTxInfo txInfo' <- pmatch txInfo
     txInfoF <- pletFields @'["inputs", "mint", "datums", "signatories"] txInfo'
-    Plutarch.Api.V1.PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose
+    PSpending ((pfield @"_0" #) -> txOutRef) <- pmatch $ pfromData ctx.purpose
 
     PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
     txOutF <- pletFields @'["address", "value"] $ txOut
@@ -114,13 +114,13 @@ proposalValidator proposal =
     signedBy <- plet $ ptxSignedBy # txInfoF.signatories
 
     pmatch proposalRedeemer $ \case
-      Agora.Proposal.PVote _r -> P.do
+      PVote _r -> P.do
         passert "ST at inputs must be 1" $
           spentST #== 1
 
         popaque (pconstant ())
       --------------------------------------------------------------------------
-      Agora.Proposal.PCosign r -> P.do
+      PCosign r -> P.do
         newSigs <- plet $ pfield @"newCosigners" # r
 
         passert "ST at inputs must be 1" $
@@ -143,14 +143,14 @@ proposalValidator proposal =
             # newSigs
 
         passert "Signatures are correctly added to cosignature list" $
-          anyOutput @Agora.Proposal.PProposalDatum # ctx.txInfo
+          anyOutput @PProposalDatum # ctx.txInfo
             #$ plam
             $ \newValue address newProposalDatum -> P.do
               let correctDatum =
                     pdata newProposalDatum
                       #== pdata
                         ( mkRecordConstr
-                            Agora.Proposal.PProposalDatum
+                            PProposalDatum
                             ( #proposalId .= proposalF.proposalId
                                 .& #effects .= proposalF.effects
                                 .& #status .= proposalF.status
@@ -170,13 +170,13 @@ proposalValidator proposal =
 
         popaque (pconstant ())
       --------------------------------------------------------------------------
-      Agora.Proposal.PUnlock _r -> P.do
+      PUnlock _r -> P.do
         passert "ST at inputs must be 1" $
           spentST #== 1
 
         popaque (pconstant ())
       --------------------------------------------------------------------------
-      Agora.Proposal.PAdvanceProposal _r -> P.do
+      PAdvanceProposal _r -> P.do
         passert "ST at inputs must be 1" $
           spentST #== 1
 
diff --git a/docs/tech-design/proposals.md b/docs/tech-design/proposals.md
index 6098795..2be2a23 100644
--- a/docs/tech-design/proposals.md
+++ b/docs/tech-design/proposals.md
@@ -35,9 +35,9 @@ Initiating a proposal requires the proposer to have more than a certain amount o
 
 ### Voting stages
 
-The life-cycle of a proposal is neatly represented by a state machine, with the 'draft' phase being the initial state, and 'executed' and 'failed' being the terminating states.
+The life-cycle of a proposal is neatly represented by a state machine, with the 'draft' state being the initial state, and 'executed' and 'failed' being the terminating states.
 
-**Please note that this state-machine representation is purely conceptual and should not be expected to reflect technical implementation.** This is because some state transitions in the state machine representation don't need to happen in the actual implementation as a transaction. A key example is going from the "lock" phase to the "execution" phase. The only thing that needs to happen is that time goes by. So under the hood, they are represented the same in the Proposal's datum.
+**Please note that this state-machine representation is purely conceptual and should not be expected to reflect technical implementation.** This is because some state transitions in the state machine representation don't need to happen in the actual implementation as a transaction. A key example is going from the "lock" phase to the "execution" phase. The only thing that needs to happen is that time goes by. So under the hood, they are represented the same in the Proposal's datum. Furthermore, in order to make our wording consistent, we use _"period"_ to mean a time-based, and _"status"_ to mean what is encoded in the datum. "State", then, refers to the more vague notion of what the state machine would look like.
 
 > Emily 2022-04-27: This is quite confusing still, I feel. @Jack, could you try to reword this and make it more clear?
 
@@ -54,21 +54,21 @@ Consider the following 'stages' of a proposal:
 -   `L`: the length of the locking period.
 -   `E`: the length of the execution period.
 
-| Action                              | Valid POSIXTimeRange                | Valid _stored_ state(s) |
-|-------------------------------------|-------------------------------------|-------------------------|
-| Witness                             | \[S, ∞)                             | \*                      |
-| Cosign                              | \[S, S + D)                         | Draft                   |
-| AdvanceProposal                     | \[S, S + D)                         | Draft                   |
-| Vote                                | \[S + D, S + D + V)                 | Voting                  |
-| Unlock                              | \[S + D, ∞)                         | \*                      |
-| CountVotes                          | \[S + D + V, S + D + V + L)         | Voting                  |
-| ExecuteProposal (if quorum reached) | \[S + D + V + L, S + D + V + L + E) | Voting                  |
+| Action                              | Valid POSIXTimeRange                | Valid _stored_ status(es) |
+|-------------------------------------|-------------------------------------|---------------------------|
+| Witness                             | \[S, ∞)                             | \*                        |
+| Cosign                              | \[S, S + D)                         | Draft                     |
+| AdvanceProposal                     | \[S, S + D)                         | Draft                     |
+| Vote                                | \[S + D, S + D + V)                 | Voting                    |
+| Unlock                              | \[S + D, ∞)                         | \*                        |
+| CountVotes                          | \[S + D + V, S + D + V + L)         | Voting                    |
+| ExecuteProposal (if quorum reached) | \[S + D + V + L, S + D + V + L + E) | Voting                    |
 
 > Jack 2022-02-02: I will consider revising this table further at a later time.
 
 #### Draft phase
 
-During the draft phase, a new UTXO at the proposal script  has been created. At this stage, only votes in favor of co-signing the draft are counted. For the proposal to transition to the voting phase, a threshold of GT will have to be staked backing the proposal. This threshold will be determined on a per-system basis and could itself be a 'governable' parameter. It's important to note that cosignatures are not locking votes. Cosignatures are more like a delegated approval to a proposal. The sum of all cosignatures must tally to the threshold, and all cosigner stake datums must fit into a single transaction to witness their size.
+During the draft phase, a new UTXO at the proposal script  has been created. At this stage, only votes in favor of co-signing the draft are counted. For the proposal to transition to the voting phase, a threshold of GT will have to be staked backing the proposal. This threshold will be determined on a per-system basis and could itself be a 'governable' parameter. It's important to note that cosignatures are not locking votes. Cosignatures are more like a delegated approval to a proposal. The sum of all cosignatures must tally to the threshold, and all cosigner stake datums must fit into a single transaction to witness their size. A limit on the maximum amount of cosigners is placed in order to prevent a situation where the stake datums no longer fit in the transaction. The number doesn't matter and may be expressed in a parametrized way.
 
 #### Voting phase
 

From 0ce867686074846c7bbef80e39e7a49f042ab519 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Wed, 27 Apr 2022 15:18:07 +0200
Subject: [PATCH 72/78] add effect and votes shape check on
 `proposalDatumValid`

---
 agora/Agora/Proposal.hs |  5 +++--
 agora/Agora/Utils.hs    | 13 +++++++++++++
 2 files changed, 16 insertions(+), 2 deletions(-)

diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index d7c6e35..fef4c71 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -44,7 +44,7 @@ import PlutusTx.AssocMap qualified as AssocMap
 
 --------------------------------------------------------------------------------
 import Agora.SafeMoney (GTTag)
-import Agora.Utils (pnotNull)
+import Agora.Utils (pkeysEqual, pnotNull)
 import Control.Applicative (Const)
 import Control.Arrow (first)
 import Plutarch.Builtin (PBuiltinMap)
@@ -406,7 +406,7 @@ proposalDatumValid :: Proposal -> Term s (Agora.Proposal.PProposalDatum :--> PBo
 proposalDatumValid proposal =
   phoistAcyclic $
     plam $ \datum' -> P.do
-      datum <- pletFields @'["effects", "cosigners"] $ datum'
+      datum <- pletFields @'["effects", "cosigners", "votes"] $ datum'
 
       let effects :: Term _ (PBuiltinMap Agora.Proposal.PResultTag (PBuiltinMap Plutarch.Api.V1.PValidatorHash Plutarch.Api.V1.PDatumHash))
           effects =
@@ -425,4 +425,5 @@ proposalDatumValid proposal =
         [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult
         , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
         , ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #<= pconstant proposal.maximumCosigners
+        , ptraceIfFalse "Proposal votes and effects are compatible with eachother" $ pkeysEqual # datum.effects # pto (pfromData datum.votes)
         ]
diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index 0f60dde..0affea1 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -27,6 +27,7 @@ module Agora.Utils (
   pnotNull,
   pisJust,
   ptokenSpent,
+  pkeysEqual,
 
   -- * Functions which should (probably) not be upstreamed
   anyOutput,
@@ -68,6 +69,7 @@ import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf, pvalueOf)
 import Plutarch.Api.V1.Value (PValue (PValue))
 import Plutarch.Builtin (ppairDataBuiltin)
 import Plutarch.Internal (punsafeCoerce)
+import Plutarch.Map.Extra (pkeys)
 import Plutarch.Monadic qualified as P
 import Plutarch.TryFrom (PTryFrom, ptryFrom)
 
@@ -317,6 +319,17 @@ ptokenSpent =
         # 0
         # inputs
 
+{- | True if both maps have exactly the same keys.
+     Using @'#=='@ is not sufficient, because keys returned are not ordered.
+-}
+pkeysEqual :: forall (s :: S) k a b. Term s (PMap k a :--> PMap k b :--> PBool)
+pkeysEqual = phoistAcyclic $
+  plam $ \p q -> P.do
+    pks <- plet $ pkeys # p
+    qks <- plet $ pkeys # q
+    pall # plam (\pk -> pelem # pk # qks) # pks
+      #&& pall # plam (\qk -> pelem # qk # pks) # qks
+
 --------------------------------------------------------------------------------
 {- Functions which should (probably) not be upstreamed
    All of these functions are quite inefficient.

From a313b2680a8625152446e9a78ec81ed2da193796 Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Thu, 28 Apr 2022 09:27:03 +0100
Subject: [PATCH 73/78] add hasktags function to Makefile

---
 Makefile | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/Makefile b/Makefile
index da13647..15de684 100644
--- a/Makefile
+++ b/Makefile
@@ -35,3 +35,7 @@ format_check:
 
 haddock:
 	cabal haddock --haddock-html --haddock-hoogle --builddir=haddock
+
+tag:
+	hasktags -x agora agora-bench agora-test
+

From 45e52619896919223307e2054272f962dce55614 Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Thu, 28 Apr 2022 09:28:58 +0100
Subject: [PATCH 74/78] Added doc to new Makefile function

---
 Makefile | 1 +
 1 file changed, 1 insertion(+)

diff --git a/Makefile b/Makefile
index 15de684..6a3164c 100644
--- a/Makefile
+++ b/Makefile
@@ -10,6 +10,7 @@ usage:
 	@echo "  hoogle -- Start local hoogle"
 	@echo "  format -- Format the project"
 	@echo "  haddock -- Generate Haddock docs for project"
+	@echo "  tag -- Generate CTAGS and ETAGS files for project"
 
 hoogle:
 	pkill hoogle || true

From 5ec74e86b80e98f50ef12fde4c99b5ee41049920 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Thu, 28 Apr 2022 16:18:07 +0200
Subject: [PATCH 75/78] apply suggestions

---
 agora-test/Spec/Sample/Proposal.hs |  14 ++--
 agora-test/Spec/Sample/Shared.hs   |   7 +-
 agora/Agora/Proposal.hs            |  23 +++---
 agora/Agora/Proposal/Scripts.hs    | 110 ++++++++++++++++++++---------
 agora/Agora/Proposal/Time.hs       |  76 +++++++++++++++-----
 agora/Agora/Stake/Scripts.hs       |  61 ++++++++++++++--
 agora/Agora/Utils.hs               |  40 ++++++++++-
 docs/tech-design/proposals.md      |  41 +++++------
 8 files changed, 273 insertions(+), 99 deletions(-)

diff --git a/agora-test/Spec/Sample/Proposal.hs b/agora-test/Spec/Sample/Proposal.hs
index 1b560f4..7ca6514 100644
--- a/agora-test/Spec/Sample/Proposal.hs
+++ b/agora-test/Spec/Sample/Proposal.hs
@@ -45,6 +45,7 @@ import Agora.Proposal (
   ProposalStatus (..),
   ProposalVotes (..),
   ResultTag (..),
+  emptyVotesFor,
  )
 import Agora.Stake (Stake (..), StakeDatum (StakeDatum))
 import Plutarch.SafeMoney (Tagged (Tagged), untag)
@@ -58,21 +59,22 @@ import Spec.Util (datumPair, toDatumHash)
 proposalCreation :: ScriptContext
 proposalCreation =
   let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST
+      effects =
+        AssocMap.fromList
+          [ (ResultTag 0, [])
+          , (ResultTag 1, [])
+          ]
       proposalDatum :: Datum
       proposalDatum =
         Datum
           ( toBuiltinData $
               ProposalDatum
                 { proposalId = ProposalId 0
-                , effects =
-                    AssocMap.fromList
-                      [ (ResultTag 0, [])
-                      , (ResultTag 1, [])
-                      ]
+                , effects = effects
                 , status = Draft
                 , cosigners = [signer]
                 , thresholds = defaultProposalThresholds
-                , votes = ProposalVotes AssocMap.empty
+                , votes = emptyVotesFor effects
                 }
           )
 
diff --git a/agora-test/Spec/Sample/Shared.hs b/agora-test/Spec/Sample/Shared.hs
index 516435b..56b136a 100644
--- a/agora-test/Spec/Sample/Shared.hs
+++ b/agora-test/Spec/Sample/Shared.hs
@@ -102,11 +102,8 @@ govSymbol = mintingPolicySymbol govPolicy
 proposal :: Proposal
 proposal =
   Proposal
-    { governorSTAssetClass =
-        -- TODO: if we had a governor here
-        Value.assetClass govSymbol ""
-    , stakeSTAssetClass =
-        Value.assetClass stakeSymbol ""
+    { governorSTAssetClass = Value.assetClass govSymbol ""
+    , stakeSTAssetClass = Value.assetClass stakeSymbol ""
     , maximumCosigners = 6
     }
 
diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs
index fef4c71..c5e0068 100644
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@@ -17,6 +17,7 @@ module Agora.Proposal (
   ProposalVotes (..),
   ProposalId (..),
   ResultTag (..),
+  emptyVotesFor,
 
   -- * Plutarch-land
   PProposalDatum (..),
@@ -67,7 +68,8 @@ import Plutus.V1.Ledger.Value (AssetClass)
 {- | Identifies a Proposal, issued upon creation of a proposal. In practice,
      this number starts at zero, and increments by one for each proposal.
      The 100th proposal will be @'ProposalId' 99@. This counter lives
-     in the 'Agora.Governor.Governor', see 'Agora.Governor.nextProposalId'.
+     in the 'Agora.Governor.Governor'. See 'Agora.Governor.nextProposalId', and
+     'Agora.Governor.pgetNextProposalId'.
 -}
 newtype ProposalId = ProposalId {proposalTag :: Integer}
   deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
@@ -140,7 +142,7 @@ data ProposalThresholds = ProposalThresholds
   --
   -- It is recommended this be a high enough amount, in order to prevent DOS from bad
   -- actors.
-  , vote :: Tagged GTTag Integer
+  , startVoting :: Tagged GTTag Integer
   -- ^ How much GT required to allow voting to happen.
   -- (i.e. to move into 'VotingReady')
   }
@@ -165,6 +167,10 @@ newtype ProposalVotes = ProposalVotes
   deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
   deriving stock (Eq, Show, GHC.Generic)
 
+-- | Create a 'ProposalVotes' that has the same shape as the 'effects' field.
+emptyVotesFor :: forall a. AssocMap.Map ResultTag a -> ProposalVotes
+emptyVotesFor = ProposalVotes . AssocMap.mapWithKey (const . const 0)
+
 -- | Haskell-level datum for Proposal scripts.
 data ProposalDatum = ProposalDatum
   { proposalId :: ProposalId
@@ -206,18 +212,19 @@ data ProposalRedeemer
     --
     --   === @'Draft' -> 'VotingReady'@:
     --
-    --     1. The sum of all of the cosigner's GT is larger than the 'vote' field of 'ProposalThresholds'.
-    --     2. The proposal hasn't been alive for longer than the review time.
+    --     1. The sum of all of the cosigner's GT is larger than the 'startVoting' field of 'ProposalThresholds'.
+    --     2. The proposal's current time ensures 'isDraftPeriod'.
     --
     --   === @'VotingReady' -> 'Locked'@:
     --
     --     1. The sum of all votes is larger than 'countVoting'.
     --     2. The winning 'ResultTag' has more votes than all other 'ResultTag's.
-    --     3. The proposal hasn't been alive for longer than the voting time.
+    --     3. The proposal's current time ensures 'isVotingPeriod'.
     --
     --   === @'Locked' -> 'Finished'@:
     --
-    --     Always valid provided the conditions for the transition are met.
+    --     1. The proposal's current time ensures 'isExecutionPeriod'.
+    --     2. The transaction mints the GATs to the receiving effects.
     --
     --   === @* -> 'Finished'@:
     --
@@ -424,6 +431,6 @@ proposalDatumValid proposal =
         (#&&)
         [ ptraceIfFalse "Proposal has at least one ResultTag has no effects" atLeastOneNegativeResult
         , ptraceIfFalse "Proposal has at least one cosigner" $ pnotNull # pfromData datum.cosigners
-        , ptraceIfFalse "Proposal has at most five cosigners" $ plength # (pfromData datum.cosigners) #<= pconstant proposal.maximumCosigners
-        , ptraceIfFalse "Proposal votes and effects are compatible with eachother" $ pkeysEqual # datum.effects # pto (pfromData datum.votes)
+        , ptraceIfFalse "Proposal has fewer cosigners than the limit" $ plength # (pfromData datum.cosigners) #<= pconstant proposal.maximumCosigners
+        , ptraceIfFalse "Proposal votes and effects are compatible with each other" $ pkeysEqual # datum.effects # pto (pfromData datum.votes)
         ]
diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs
index 3535260..1d06853 100644
--- a/agora/Agora/Proposal/Scripts.hs
+++ b/agora/Agora/Proposal/Scripts.hs
@@ -20,7 +20,9 @@ import Agora.Stake (findStakeOwnedBy)
 import Agora.Utils (
   anyOutput,
   findTxOutByTxOutRef,
+  getMintingPolicySymbol,
   passert,
+  pisUniq,
   psymbolValueOf,
   ptokenSpent,
   ptxSignedBy,
@@ -32,8 +34,6 @@ import Plutarch.Api.V1 (
   PScriptPurpose (PMinting, PSpending),
   PTxInfo (PTxInfo),
   PValidator,
-  mintingPolicySymbol,
-  mkMintingPolicy,
  )
 import Plutarch.Api.V1.Extra (passetClass, passetClassValueOf)
 import Plutarch.Monadic qualified as P
@@ -41,12 +41,22 @@ import Plutarch.TryFrom (ptryFrom)
 import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
 
 {- | Policy for Proposals.
-   This needs to perform two checks:
-     - Governor is happy with mint.
-     - Exactly 1 token is minted.
 
-   NOTE: The governor needs to check that the datum is correct
-         and sent to the right address.
+   == What this policy does
+
+   === For minting:
+
+   - Governor is happy with mint.
+
+     * The governor must do most of the checking for the validity of the
+       transaction. For example, the governor must check that the datum
+       is correct, and that the ST is correctly paid to the right validator.
+
+   - Exactly 1 token is minted.
+
+   === For burning:
+
+   - This policy cannot be burned.
 -}
 proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
 proposalPolicy proposal =
@@ -62,7 +72,10 @@ proposalPolicy proposal =
         AssetClass (govCs, govTn) = proposal.governorSTAssetClass
 
     PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose
-    let mintedProposalST = passetClassValueOf # mintedValue # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "")
+    let mintedProposalST =
+          passetClassValueOf
+            # mintedValue
+            # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "")
 
     passert "Governance state-thread token must move" $
       ptokenSpent
@@ -74,7 +87,32 @@ proposalPolicy proposal =
 
     popaque (pconstant ())
 
--- | Validator for Proposals.
+{- | The validator for Proposals.
+
+The documentation for various of the redeemers lives at 'Agora.Proposal.ProposalRedeemer'.
+
+== What this validator does
+
+=== Voting/unlocking
+
+When voting and unlocking, the proposal must witness a state transition
+occuring in the relevant Stake. This transition must place a lock on
+the stake that is tagged with the right 'Agora.Proposal.ResultTag', and 'Agora.Proposal.ProposalId'.
+
+=== Periods
+
+Most redeemers are time-sensitive.
+
+A list of all time-sensitive redeemers and their requirements:
+
+- 'Agora.Proposal.Vote' can only be used when both the status is in 'Agora.Proposal.VotingReady',
+  and 'Agora.Proposal.Time.isVotingPeriod' is true.
+- 'Agora.Proposal.Cosign' can only be used when both the status is in 'Agora.Proposal.Draft',
+  and 'Agora.Proposal.Time.isDraftPeriod' is true.
+- 'Agora.Proposal.AdvanceProposal' can only be used when the status can be advanced
+  (see 'Agora.Proposal.AdvanceProposal' docs).
+- 'Agora.Proposal.Unlock' is always valid.
+-}
 proposalValidator :: Proposal -> ClosedTerm PValidator
 proposalValidator proposal =
   plam $ \datum redeemer ctx' -> P.do
@@ -88,8 +126,10 @@ proposalValidator proposal =
     PJust txOut <- pmatch $ findTxOutByTxOutRef # txOutRef # txInfoF.inputs
     txOutF <- pletFields @'["address", "value"] $ txOut
 
-    (pfromData -> proposalDatum, _) <- ptryFrom @(PAsData PProposalDatum) datum
-    (pfromData -> proposalRedeemer, _) <- ptryFrom @(PAsData PProposalRedeemer) redeemer
+    (pfromData -> proposalDatum, _) <-
+      ptryFrom @(PAsData PProposalDatum) datum
+    (pfromData -> proposalRedeemer, _) <-
+      ptryFrom @(PAsData PProposalRedeemer) redeemer
 
     proposalF <-
       pletFields
@@ -104,27 +144,30 @@ proposalValidator proposal =
 
     ownAddress <- plet $ txOutF.address
 
-    stCurrencySymbol <- plet $ pconstant $ Plutarch.Api.V1.mintingPolicySymbol $ Plutarch.Api.V1.mkMintingPolicy (proposalPolicy proposal)
+    let stCurrencySymbol =
+          pconstant $ getMintingPolicySymbol (proposalPolicy proposal)
     valueSpent <- plet $ pvalueSpent # txInfoF.inputs
     spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ valueSpent
     let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass
-    stakeSTAssetClass <- plet $ passetClass # pconstant stakeSym # pconstant stakeTn
-    spentStakeST <- plet $ passetClassValueOf # valueSpent # stakeSTAssetClass
+    stakeSTAssetClass <-
+      plet $ passetClass # pconstant stakeSym # pconstant stakeTn
+    spentStakeST <-
+      plet $ passetClassValueOf # valueSpent # stakeSTAssetClass
 
     signedBy <- plet $ ptxSignedBy # txInfoF.signatories
 
+    passert "ST at inputs must be 1" $
+      spentST #== 1
+
     pmatch proposalRedeemer $ \case
       PVote _r -> P.do
-        passert "ST at inputs must be 1" $
-          spentST #== 1
-
         popaque (pconstant ())
       --------------------------------------------------------------------------
       PCosign r -> P.do
         newSigs <- plet $ pfield @"newCosigners" # r
 
-        passert "ST at inputs must be 1" $
-          spentST #== 1
+        passert "Cosigners are unique" $
+          pisUniq # newSigs
 
         passert "Signed by all new cosigners" $
           pall # signedBy # newSigs
@@ -136,9 +179,15 @@ proposalValidator proposal =
           pall
             # plam
               ( \sig ->
-                  pmatch (findStakeOwnedBy # stakeSTAssetClass # pfromData sig # txInfoF.datums # txInfoF.inputs) $ \case
-                    PNothing -> pcon PFalse
-                    PJust _ -> pcon PTrue
+                  pmatch
+                    ( findStakeOwnedBy # stakeSTAssetClass
+                        # pfromData sig
+                        # txInfoF.datums
+                        # txInfoF.inputs
+                    )
+                    $ \case
+                      PNothing -> pcon PFalse
+                      PJust _ -> pcon PTrue
               )
             # newSigs
 
@@ -146,7 +195,8 @@ proposalValidator proposal =
           anyOutput @PProposalDatum # ctx.txInfo
             #$ plam
             $ \newValue address newProposalDatum -> P.do
-              let correctDatum =
+              let updatedSigs = pconcat # newSigs # proposalF.cosigners
+                  correctDatum =
                     pdata newProposalDatum
                       #== pdata
                         ( mkRecordConstr
@@ -154,7 +204,7 @@ proposalValidator proposal =
                             ( #proposalId .= proposalF.proposalId
                                 .& #effects .= proposalF.effects
                                 .& #status .= proposalF.status
-                                .& #cosigners .= pdata (pconcat # newSigs # proposalF.cosigners)
+                                .& #cosigners .= pdata updatedSigs
                                 .& #thresholds .= proposalF.thresholds
                                 .& #votes .= proposalF.votes
                             )
@@ -164,20 +214,16 @@ proposalValidator proposal =
                 (#&&)
                 [ pcon PTrue
                 , ptraceIfFalse "Datum must be correct" correctDatum
-                , ptraceIfFalse "Value should be correct" $ pdata txOutF.value #== pdata newValue
-                , ptraceIfFalse "Must be sent to Proposal's address" $ ownAddress #== pdata address
+                , ptraceIfFalse "Value should be correct" $
+                    pdata txOutF.value #== pdata newValue
+                , ptraceIfFalse "Must be sent to Proposal's address" $
+                    ownAddress #== pdata address
                 ]
 
         popaque (pconstant ())
       --------------------------------------------------------------------------
       PUnlock _r -> P.do
-        passert "ST at inputs must be 1" $
-          spentST #== 1
-
         popaque (pconstant ())
       --------------------------------------------------------------------------
       PAdvanceProposal _r -> P.do
-        passert "ST at inputs must be 1" $
-          spentST #== 1
-
         popaque (pconstant ())
diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs
index 54e3d3d..560bc73 100644
--- a/agora/Agora/Proposal/Time.hs
+++ b/agora/Agora/Proposal/Time.hs
@@ -19,12 +19,12 @@ module Agora.Proposal.Time (
   PProposalTimingConfig (..),
   PProposalStartingTime (..),
 
-  -- * Compute ranges given config and starting time.
+  -- * Compute periods given config and starting time.
   currentProposalTime,
-  isDraftRange,
-  isVotingRange,
-  isLockingRange,
-  isExecutionRange,
+  isDraftPeriod,
+  isVotingPeriod,
+  isLockingPeriod,
+  isExecutionPeriod,
 ) where
 
 import Agora.Record (mkRecordConstr, (.&), (.=))
@@ -58,14 +58,14 @@ import Prelude hiding ((+))
    For the purposes of proposals, there's a single most important feature:
    The ability to determine if we can perform an action. In order to correctly
    determine if we are able to perform certain actions, we need to know what
-   time it roughly is, compared to when the proposal got created.
+   time it roughly is, compared to when the proposal was created.
 
    'ProposalTime' represents "the time according to the proposal".
    Its representation is opaque, and doesn't matter.
 
    Various functions work simply on 'ProposalTime' and 'ProposalTimingConfig'.
    In particular, 'currentProposalTime' is useful for extracting the time
-   from the 'Plutus.V1.Ledger.Api.txInfoValidRange' field
+   from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field
    of 'Plutus.V1.Ledger.Api.TxInfo'.
 
    We avoid 'PPOSIXTimeRange' where we can in order to save on operations.
@@ -153,7 +153,7 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
 instance AdditiveSemigroup (Term s PPOSIXTime) where
   (punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y
 
--- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidRange' field.
+-- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field.
 currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime)
 currentProposalTime = phoistAcyclic $
   plam $ \iv -> P.do
@@ -179,7 +179,14 @@ currentProposalTime = phoistAcyclic $
           )
 
 -- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
-proposalTimeWithin :: Term s (PPOSIXTime :--> PPOSIXTime :--> PProposalTime :--> PBool)
+proposalTimeWithin ::
+  Term
+    s
+    ( PPOSIXTime
+        :--> PPOSIXTime
+        :--> PProposalTime
+        :--> PBool
+    )
 proposalTimeWithin = phoistAcyclic $
   plam $ \l h proposalTime' -> P.do
     PProposalTime proposalTime <- pmatch proposalTime'
@@ -195,28 +202,61 @@ proposalTimeWithin = phoistAcyclic $
       ]
 
 -- | True if the 'PProposalTime' is in the draft period.
-isDraftRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool)
-isDraftRange = phoistAcyclic $
+isDraftPeriod ::
+  forall (s :: S).
+  Term
+    s
+    ( PProposalTimingConfig
+        :--> PProposalStartingTime
+        :--> PProposalTime
+        :--> PBool
+    )
+isDraftPeriod = phoistAcyclic $
   plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
     proposalTimeWithin # s # (s + pfield @"draftTime" # config)
 
 -- | True if the 'PProposalTime' is in the voting period.
-isVotingRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool)
-isVotingRange = phoistAcyclic $
+isVotingPeriod ::
+  forall (s :: S).
+  Term
+    s
+    ( PProposalTimingConfig
+        :--> PProposalStartingTime
+        :--> PProposalTime
+        :--> PBool
+    )
+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.
-isLockingRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool)
-isLockingRange = phoistAcyclic $
+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.
-isExecutionRange :: forall (s :: S). Term s (PProposalTimingConfig :--> PProposalStartingTime :--> PProposalTime :--> PBool)
-isExecutionRange = phoistAcyclic $
+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)
+      proposalTimeWithin # s
+        # (s + f.draftTime + f.votingTime + f.lockingTime + f.executingTime)
diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs
index 2f80d66..48483d3 100644
--- a/agora/Agora/Stake/Scripts.hs
+++ b/agora/Agora/Stake/Scripts.hs
@@ -65,7 +65,10 @@ import Prelude hiding (Num (..))
    - Check that exactly one state thread is burned.
    - Check that datum at state thread is valid and not locked.
 -}
-stakePolicy :: Tagged GTTag AssetClass -> ClosedTerm PMintingPolicy
+stakePolicy ::
+  -- | The (governance) token that a Stake can store.
+  Tagged GTTag AssetClass ->
+  ClosedTerm PMintingPolicy
 stakePolicy gtClassRef =
   plam $ \_redeemer ctx' -> P.do
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
@@ -157,7 +160,59 @@ stakePolicy gtClassRef =
 
 --------------------------------------------------------------------------------
 
--- | Validator intended for Stake UTXOs to live in.
+-- | Validator intended for Stake UTXOs to be locked by.
+--
+--
+-- == What this Validator does:
+--
+-- === 'DepositWithdraw'
+--
+-- Deposit or withdraw some GT to the stake.
+--
+-- - Tx must be signed by the owner.
+-- - The 'stakedAmount' field must be updated.
+-- - The stake must not be locked.
+-- - The new UTXO must have the previous value plus the difference
+--   as stated by the redeemer.
+--
+-- === 'PermitVote'
+--
+-- Allow a 'ProposalLock' to be put on the stake in order to vote
+-- on a proposal.
+--
+-- - A proposal token must be spent alongside the stake.
+--
+--   * Its total votes must be correctly updated to include this stake's
+--     contribution.
+--
+-- - Tx must be signed by the owner.
+--
+--
+-- === 'RetractVotes'
+--
+-- Remove a 'ProposalLock' set when voting on a proposal.
+--
+-- - A proposal token must be spent alongside the stake.
+-- - Tx must be signed by the owner.
+--
+--
+-- === 'Destroy'
+--
+-- Destroy the stake in order to reclaim the min ADA.
+--
+-- - The stake must not be locked.
+-- - Tx must be signed by the owner.
+--
+--
+-- === 'WitnessStake'
+--
+-- Allow this Stake to be included in a transaction without making
+-- any changes to it. In the future,
+-- this could use [CIP-31](https://cips.cardano.org/cips/cip31/) instead.
+--
+-- - Tx must be signed by the owner __or__ a proposal ST token must be spent
+--   alongside the stake.
+-- - The datum and value must remain unchanged.
 stakeValidator :: Stake -> ClosedTerm PValidator
 stakeValidator stake =
   plam $ \datum redeemer ctx' -> P.do
@@ -243,8 +298,6 @@ stakeValidator stake =
           "Owner signs this transaction"
           ownerSignsTransaction
 
-        passert "ST at inputs must be 1" $
-          spentST #== 1
 
         -- This puts trust into the Proposal. The Proposal must necessarily check
         -- that this is not abused.
diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index 0affea1..bb852c4 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -28,6 +28,8 @@ module Agora.Utils (
   pisJust,
   ptokenSpent,
   pkeysEqual,
+  pnub,
+  pisUniq,
 
   -- * Functions which should (probably) not be upstreamed
   anyOutput,
@@ -38,6 +40,7 @@ module Agora.Utils (
   findOutputsToAddress,
   findTxOutDatum,
   validatorHashToTokenName,
+  getMintingPolicySymbol,
 ) where
 
 --------------------------------------------------------------------------------
@@ -54,6 +57,7 @@ import Plutarch.Api.V1 (
   PDatumHash,
   PMap,
   PMaybeData (PDJust),
+  PMintingPolicy,
   PPubKeyHash,
   PTokenName (PTokenName),
   PTuple,
@@ -63,6 +67,8 @@ import Plutarch.Api.V1 (
   PTxOutRef,
   PValidatorHash,
   PValue,
+  mintingPolicySymbol,
+  mkMintingPolicy,
  )
 import Plutarch.Api.V1.AssocMap (PMap (PMap))
 import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf, pvalueOf)
@@ -72,6 +78,7 @@ import Plutarch.Internal (punsafeCoerce)
 import Plutarch.Map.Extra (pkeys)
 import Plutarch.Monadic qualified as P
 import Plutarch.TryFrom (PTryFrom, ptryFrom)
+import Plutus.V1.Ledger.Api (CurrencySymbol)
 
 --------------------------------------------------------------------------------
 -- Validator-level utility functions
@@ -88,7 +95,7 @@ pfindDatum = phoistAcyclic $
 -- | Find a datum with the given hash, and `ptryFrom` it.
 ptryFindDatum :: forall (a :: PType) (s :: S). PTryFrom PData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe a)
 ptryFindDatum = phoistAcyclic $
-  plam $ \datumHash inputs -> P.do
+  plam $ \datumHash inputs ->
     pmatch (pfindDatum # datumHash # inputs) $ \case
       PNothing -> pcon PNothing
       PJust datum -> P.do
@@ -330,6 +337,30 @@ pkeysEqual = phoistAcyclic $
     pall # plam (\pk -> pelem # pk # qks) # pks
       #&& pall # plam (\qk -> pelem # qk # pks) # qks
 
+-- | / O(n^2) /. Clear out duplicates in a list. The order is not preserved.
+pnub :: forall list a (s :: S). (PEq a, PIsListLike list a) => Term s (list a :--> list a)
+pnub =
+  phoistAcyclic $
+    precList
+      ( \self x xs ->
+          pif
+            (pnot #$ pelem # x # xs)
+            (pcons # x # (self # xs))
+            (self # xs)
+      )
+      (const pnil)
+
+-- | / O(n^2) /. Check if a list contains no duplicates.
+pisUniq :: forall list a (s :: S). (PEq a, PIsListLike list a) => Term s (list a :--> PBool)
+pisUniq =
+  phoistAcyclic $
+    precList
+      ( \self x xs ->
+          (pnot #$ pelem # x # xs)
+            #&& (self # xs)
+      )
+      (const $ pcon PTrue)
+
 --------------------------------------------------------------------------------
 {- Functions which should (probably) not be upstreamed
    All of these functions are quite inefficient.
@@ -447,5 +478,12 @@ findTxOutDatum = phoistAcyclic $
       PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # datums
       _ -> pcon PNothing
 
+{- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging
+     tokens for extra safety.
+-}
 validatorHashToTokenName :: forall (s :: S). Term s PValidatorHash -> Term s PTokenName
 validatorHashToTokenName vh = pcon (PTokenName (pto vh))
+
+-- | Get the CurrencySymbol of a PMintingPolicy.
+getMintingPolicySymbol :: ClosedTerm PMintingPolicy -> CurrencySymbol
+getMintingPolicySymbol v = mintingPolicySymbol $ mkMintingPolicy v
diff --git a/docs/tech-design/proposals.md b/docs/tech-design/proposals.md
index 2be2a23..3a4a82d 100644
--- a/docs/tech-design/proposals.md
+++ b/docs/tech-design/proposals.md
@@ -37,38 +37,29 @@ Initiating a proposal requires the proposer to have more than a certain amount o
 
 The life-cycle of a proposal is neatly represented by a state machine, with the 'draft' state being the initial state, and 'executed' and 'failed' being the terminating states.
 
-**Please note that this state-machine representation is purely conceptual and should not be expected to reflect technical implementation.** This is because some state transitions in the state machine representation don't need to happen in the actual implementation as a transaction. A key example is going from the "lock" phase to the "execution" phase. The only thing that needs to happen is that time goes by. So under the hood, they are represented the same in the Proposal's datum. Furthermore, in order to make our wording consistent, we use _"period"_ to mean a time-based, and _"status"_ to mean what is encoded in the datum. "State", then, refers to the more vague notion of what the state machine would look like.
+Note: this state-machine representation is purely conceptual and should not be expected to reflect technical implementation.
+**Please note that this state-machine representation is purely conceptual and should not be expected to reflect technical implementation.** This is because some transitions in the state machine representation don't need to happen on-chain, as a transaction. A key example of this is a proposal going from the "lock" phase to the "execution" phase. No on-chain transition takes place: it is simply that we have reached the time in the real-world, when the proposal is allowed to be executed.
 
-> Emily 2022-04-27: This is quite confusing still, I feel. @Jack, could you try to reword this and make it more clear?
+To make the following diagram clear, we employ the following terminology:
+
+
+> state
+> A 'state' in our conceptual FSM representation above. Useful for thinking about proposals. Does not necessarily reflect a change occurring on-chain.
+
+
+> period
+> A segment of real-world, POSIX time. As we transition from one period to another, a proposal's status (see below) will not be updated.
+
+
+> status
+> The 'status' of a proposal is stored in the proposal's datum and is thus always represented on-chain. Changing this requires a transaction to take place.
 
 
 ![](../diagrams/ProposalStateMachine.svg)
 
-#### When may interactions occur?
-
-Consider the following 'stages' of a proposal:
-
--   `S`: when the proposal was created.
--   `D`: the length of the draft period.
--   `V`: the length of the voting period.
--   `L`: the length of the locking period.
--   `E`: the length of the execution period.
-
-| Action                              | Valid POSIXTimeRange                | Valid _stored_ status(es) |
-|-------------------------------------|-------------------------------------|---------------------------|
-| Witness                             | \[S, ∞)                             | \*                        |
-| Cosign                              | \[S, S + D)                         | Draft                     |
-| AdvanceProposal                     | \[S, S + D)                         | Draft                     |
-| Vote                                | \[S + D, S + D + V)                 | Voting                    |
-| Unlock                              | \[S + D, ∞)                         | \*                        |
-| CountVotes                          | \[S + D + V, S + D + V + L)         | Voting                    |
-| ExecuteProposal (if quorum reached) | \[S + D + V + L, S + D + V + L + E) | Voting                    |
-
-> Jack 2022-02-02: I will consider revising this table further at a later time.
-
 #### Draft phase
 
-During the draft phase, a new UTXO at the proposal script  has been created. At this stage, only votes in favor of co-signing the draft are counted. For the proposal to transition to the voting phase, a threshold of GT will have to be staked backing the proposal. This threshold will be determined on a per-system basis and could itself be a 'governable' parameter. It's important to note that cosignatures are not locking votes. Cosignatures are more like a delegated approval to a proposal. The sum of all cosignatures must tally to the threshold, and all cosigner stake datums must fit into a single transaction to witness their size. A limit on the maximum amount of cosigners is placed in order to prevent a situation where the stake datums no longer fit in the transaction. The number doesn't matter and may be expressed in a parametrized way.
+During the draft phase, a new UTXO at the proposal script  has been created. At this stage, only votes in favor of co-signing the draft are counted. For the proposal to transition to the voting phase, a threshold of GT will have to be staked backing the proposal. This threshold will be determined on a per-system basis and could itself be a 'governable' parameter. It's important to note that cosignatures are not locking votes. Cosignatures are more like a delegated approval to a proposal. The sum of all cosignatures must tally to the threshold, and all cosigner stake datums must fit into a single transaction to witness their size. A limit on the maximum amount of cosigners is placed in order to prevent a situation where the stake datums no longer fit in the transaction. The number doesn't matter and may be expressed in a parameterized way.
 
 #### Voting phase
 

From c8f5c6af8fbb5abbe9ca21df2e8165675543717d Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Thu, 28 Apr 2022 16:20:05 +0200
Subject: [PATCH 76/78] remove `pfindDatum'`, in favour of `ptryFindDatum`

---
 agora-test/Spec/Sample/Proposal.hs | 13 +++++++------
 agora/Agora/Utils.hs               | 11 ++---------
 2 files changed, 9 insertions(+), 15 deletions(-)

diff --git a/agora-test/Spec/Sample/Proposal.hs b/agora-test/Spec/Sample/Proposal.hs
index 7ca6514..91aa9a4 100644
--- a/agora-test/Spec/Sample/Proposal.hs
+++ b/agora-test/Spec/Sample/Proposal.hs
@@ -154,19 +154,20 @@ stakeRef = TxOutRef "0ca36f3a357bc69579ab2531aecd1e7d3714d993c7820f40b864be15" 0
 cosignProposal :: [PubKeyHash] -> TxInfo
 cosignProposal newSigners =
   let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST
+      effects =
+        AssocMap.fromList
+          [ (ResultTag 0, [])
+          , (ResultTag 1, [])
+          ]
       proposalBefore :: ProposalDatum
       proposalBefore =
         ProposalDatum
           { proposalId = ProposalId 0
-          , effects =
-              AssocMap.fromList
-                [ (ResultTag 0, [])
-                , (ResultTag 1, [])
-                ]
+          , effects = effects
           , status = Draft
           , cosigners = [signer]
           , thresholds = defaultProposalThresholds
-          , votes = ProposalVotes AssocMap.empty
+          , votes = emptyVotesFor effects
           }
       stakeDatum :: StakeDatum
       stakeDatum = StakeDatum (Tagged 50_000_000) signer2 []
diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs
index bb852c4..874ecfe 100644
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@@ -10,7 +10,6 @@ module Agora.Utils (
   passert,
   pfind',
   pfindDatum,
-  pfindDatum',
   ptryFindDatum,
   pvalueSpent,
   ptxSignedBy,
@@ -74,7 +73,6 @@ import Plutarch.Api.V1.AssocMap (PMap (PMap))
 import Plutarch.Api.V1.Extra (PAssetClass, passetClassValueOf, pvalueOf)
 import Plutarch.Api.V1.Value (PValue (PValue))
 import Plutarch.Builtin (ppairDataBuiltin)
-import Plutarch.Internal (punsafeCoerce)
 import Plutarch.Map.Extra (pkeys)
 import Plutarch.Monadic qualified as P
 import Plutarch.TryFrom (PTryFrom, ptryFrom)
@@ -102,12 +100,6 @@ ptryFindDatum = phoistAcyclic $
         (datum', _) <- ptryFrom (pto datum)
         pcon (PJust datum')
 
-{- | Find a datum with the given hash.
-NOTE: this is unsafe in the sense that, if the data layout is wrong, this is UB.
--}
-pfindDatum' :: PIsData a => Term s (PDatumHash :--> PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PMaybe (PAsData a))
-pfindDatum' = phoistAcyclic $ plam $ \dh x -> punsafeCoerce $ pfindDatum # dh # x
-
 -- | Check if a PubKeyHash signs this transaction.
 ptxSignedBy :: Term s (PBuiltinList (PAsData PPubKeyHash) :--> PAsData PPubKeyHash :--> PBool)
 ptxSignedBy = phoistAcyclic $
@@ -416,6 +408,7 @@ allOutputs = phoistAcyclic $
 anyInput ::
   forall (datum :: PType) s.
   ( PIsData datum
+  , PTryFrom PData (PAsData datum)
   ) =>
   Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool)
 anyInput = phoistAcyclic $
@@ -429,7 +422,7 @@ anyInput = phoistAcyclic $
             PTxOut txOut' <- pmatch (pfromData txOut'')
             txOut <- pletFields @'["value", "datumHash", "address"] txOut'
             PDJust dh <- pmatch txOut.datumHash
-            pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo.datums) $ \case
+            pmatch (ptryFindDatum @(PAsData datum) # (pfield @"_0" # dh) # txInfo.datums) $ \case
               PJust datum -> P.do
                 predicate # txOut.value # txOut.address # pfromData datum
               PNothing -> pcon PFalse

From cf14d9edd830dadf42e5b97944b5a67ef228d6ce Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Thu, 28 Apr 2022 17:00:19 +0200
Subject: [PATCH 77/78] remove infinities in ProposalTime, fix test build

---
 agora-test/Spec/Proposal.hs        |  9 +++++--
 agora-test/Spec/Sample/Proposal.hs |  1 -
 agora-test/Spec/Sample/Shared.hs   |  2 +-
 agora/Agora/Proposal/Scripts.hs    |  3 +--
 agora/Agora/Proposal/Time.hs       | 42 +++++++++++++++---------------
 5 files changed, 30 insertions(+), 27 deletions(-)

diff --git a/agora-test/Spec/Proposal.hs b/agora-test/Spec/Proposal.hs
index b80d144..bd79762 100644
--- a/agora-test/Spec/Proposal.hs
+++ b/agora-test/Spec/Proposal.hs
@@ -16,10 +16,10 @@ import Agora.Proposal (
   ProposalId (ProposalId),
   ProposalRedeemer (Cosign),
   ProposalStatus (Draft),
-  ProposalVotes (ProposalVotes),
   ResultTag (ResultTag),
   cosigners,
   effects,
+  emptyVotesFor,
   proposalId,
   status,
   thresholds,
@@ -70,7 +70,12 @@ tests =
                   , status = Draft
                   , cosigners = [signer]
                   , thresholds = Shared.defaultProposalThresholds
-                  , votes = ProposalVotes AssocMap.empty
+                  , votes =
+                      emptyVotesFor $
+                        AssocMap.fromList
+                          [ (ResultTag 0, [])
+                          , (ResultTag 1, [])
+                          ]
                   }
               )
               (Cosign [signer2])
diff --git a/agora-test/Spec/Sample/Proposal.hs b/agora-test/Spec/Sample/Proposal.hs
index 91aa9a4..6112ec0 100644
--- a/agora-test/Spec/Sample/Proposal.hs
+++ b/agora-test/Spec/Sample/Proposal.hs
@@ -43,7 +43,6 @@ import Agora.Proposal (
   ProposalDatum (..),
   ProposalId (..),
   ProposalStatus (..),
-  ProposalVotes (..),
   ResultTag (..),
   emptyVotesFor,
  )
diff --git a/agora-test/Spec/Sample/Shared.hs b/agora-test/Spec/Sample/Shared.hs
index 56b136a..bd4957f 100644
--- a/agora-test/Spec/Sample/Shared.hs
+++ b/agora-test/Spec/Sample/Shared.hs
@@ -129,5 +129,5 @@ defaultProposalThresholds =
   ProposalThresholds
     { countVoting = Tagged 1000
     , create = Tagged 1
-    , vote = Tagged 10
+    , startVoting = Tagged 10
     }
diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs
index 1d06853..2e7a52d 100644
--- a/agora/Agora/Proposal/Scripts.hs
+++ b/agora/Agora/Proposal/Scripts.hs
@@ -212,8 +212,7 @@ proposalValidator proposal =
 
               foldr1
                 (#&&)
-                [ pcon PTrue
-                , ptraceIfFalse "Datum must be correct" correctDatum
+                [ ptraceIfFalse "Datum must be correct" correctDatum
                 , ptraceIfFalse "Value should be correct" $
                     pdata txOutF.value #== pdata newValue
                 , ptraceIfFalse "Must be sent to Proposal's address" $
diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs
index 560bc73..ec20f53 100644
--- a/agora/Agora/Proposal/Time.hs
+++ b/agora/Agora/Proposal/Time.hs
@@ -34,7 +34,6 @@ import Plutarch.Api.V1 (
   PExtended (PFinite),
   PInterval (PInterval),
   PLowerBound (PLowerBound),
-  PMaybeData (PDJust, PDNothing),
   PPOSIXTime,
   PPOSIXTimeRange,
   PUpperBound (PUpperBound),
@@ -71,8 +70,8 @@ import Prelude hiding ((+))
    We avoid 'PPOSIXTimeRange' where we can in order to save on operations.
 -}
 data ProposalTime = ProposalTime
-  { lowerBound :: Maybe POSIXTime
-  , upperBound :: Maybe POSIXTime
+  { lowerBound :: POSIXTime
+  , upperBound :: POSIXTime
   }
   deriving stock (Eq, Show, GHC.Generic)
 
@@ -111,8 +110,8 @@ newtype PProposalTime (s :: S)
       ( Term
           s
           ( PDataRecord
-              '[ "lowerBound" ':= PMaybeData PPOSIXTime
-               , "upperBound" ':= PMaybeData PPOSIXTime
+              '[ "lowerBound" ':= PPOSIXTime
+               , "upperBound" ':= PPOSIXTime
                ]
           )
       )
@@ -153,7 +152,11 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
 instance AdditiveSemigroup (Term s PPOSIXTime) where
   (punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y
 
--- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field.
+{- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field.
+
+ If it's impossible to get a fully-bounded time, (e.g. either end of the 'PPOSIXTimeRange' is
+ an infinity) then we error out.
+-}
 currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime)
 currentProposalTime = phoistAcyclic $
   plam $ \iv -> P.do
@@ -165,17 +168,18 @@ currentProposalTime = phoistAcyclic $
     ubf <- pletFields @'["_0", "_1"] ub
     mkRecordConstr PProposalTime $
       #lowerBound
-        .= pdata
-          ( pmatch lbf._0 $
-              \case
-                PFinite d -> pcon (PDJust d)
-                _ -> pcon (PDNothing pdnil)
+        .= pmatch
+          lbf._0
+          ( \case
+              PFinite ((pfield @"_0" #) -> d) -> d
+              _ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time."
           )
         .& #upperBound
-        .= pdata
-          ( pmatch ubf._0 $ \case
-              PFinite d -> pcon (PDJust d)
-              _ -> pcon (PDNothing pdnil)
+        .= pmatch
+          ubf._0
+          ( \case
+              PFinite ((pfield @"_0" #) -> d) -> d
+              _ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time."
           )
 
 -- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
@@ -193,12 +197,8 @@ proposalTimeWithin = phoistAcyclic $
     ptf <- pletFields @'["lowerBound", "upperBound"] proposalTime
     foldr1
       (#&&)
-      [ pmatch ptf.lowerBound $ \case
-          PDJust lb -> l #<= pfromData (pfield @"_0" # lb)
-          _ -> pcon PFalse
-      , pmatch ptf.upperBound $ \case
-          PDJust lb -> pfromData (pfield @"_0" # lb) #<= h
-          _ -> pcon PFalse
+      [ l #<= pfromData ptf.lowerBound
+      , pfromData ptf.upperBound #<= h
       ]
 
 -- | True if the 'PProposalTime' is in the draft period.

From be3b8ea5af7baa4a2f924a8109c6e2f8b3699fb2 Mon Sep 17 00:00:00 2001
From: Emily Martins <emi@haskell.fyi>
Date: Thu, 28 Apr 2022 17:22:40 +0200
Subject: [PATCH 78/78] fix formatting

fourmolu breaks weirdly on some spacing
---
 agora/Agora/Stake/Scripts.hs | 104 +++++++++++++++++------------------
 1 file changed, 50 insertions(+), 54 deletions(-)

diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs
index 48483d3..10e0df9 100644
--- a/agora/Agora/Stake/Scripts.hs
+++ b/agora/Agora/Stake/Scripts.hs
@@ -160,59 +160,56 @@ stakePolicy gtClassRef =
 
 --------------------------------------------------------------------------------
 
--- | Validator intended for Stake UTXOs to be locked by.
---
---
--- == What this Validator does:
---
--- === 'DepositWithdraw'
---
--- Deposit or withdraw some GT to the stake.
---
--- - Tx must be signed by the owner.
--- - The 'stakedAmount' field must be updated.
--- - The stake must not be locked.
--- - The new UTXO must have the previous value plus the difference
---   as stated by the redeemer.
---
--- === 'PermitVote'
---
--- Allow a 'ProposalLock' to be put on the stake in order to vote
--- on a proposal.
---
--- - A proposal token must be spent alongside the stake.
---
---   * Its total votes must be correctly updated to include this stake's
---     contribution.
---
--- - Tx must be signed by the owner.
---
---
--- === 'RetractVotes'
---
--- Remove a 'ProposalLock' set when voting on a proposal.
---
--- - A proposal token must be spent alongside the stake.
--- - Tx must be signed by the owner.
---
---
--- === 'Destroy'
---
--- Destroy the stake in order to reclaim the min ADA.
---
--- - The stake must not be locked.
--- - Tx must be signed by the owner.
---
---
--- === 'WitnessStake'
---
--- Allow this Stake to be included in a transaction without making
--- any changes to it. In the future,
--- this could use [CIP-31](https://cips.cardano.org/cips/cip31/) instead.
---
--- - Tx must be signed by the owner __or__ a proposal ST token must be spent
---   alongside the stake.
--- - The datum and value must remain unchanged.
+{- | Validator intended for Stake UTXOs to be locked by.
+
+== What this Validator does:
+
+=== 'DepositWithdraw'
+
+Deposit or withdraw some GT to the stake.
+
+- Tx must be signed by the owner.
+- The 'stakedAmount' field must be updated.
+- The stake must not be locked.
+- The new UTXO must have the previous value plus the difference
+  as stated by the redeemer.
+
+=== 'PermitVote'
+
+Allow a 'ProposalLock' to be put on the stake in order to vote
+on a proposal.
+
+- A proposal token must be spent alongside the stake.
+
+  * Its total votes must be correctly updated to include this stake's
+    contribution.
+
+- Tx must be signed by the owner.
+
+=== 'RetractVotes'
+
+Remove a 'ProposalLock' set when voting on a proposal.
+
+- A proposal token must be spent alongside the stake.
+- Tx must be signed by the owner.
+
+=== 'Destroy'
+
+Destroy the stake in order to reclaim the min ADA.
+
+- The stake must not be locked.
+- Tx must be signed by the owner.
+
+=== 'WitnessStake'
+
+Allow this Stake to be included in a transaction without making
+any changes to it. In the future,
+this could use [CIP-31](https://cips.cardano.org/cips/cip31/) instead.
+
+- Tx must be signed by the owner __or__ a proposal ST token must be spent
+  alongside the stake.
+- The datum and value must remain unchanged.
+-}
 stakeValidator :: Stake -> ClosedTerm PValidator
 stakeValidator stake =
   plam $ \datum redeemer ctx' -> P.do
@@ -298,7 +295,6 @@ stakeValidator stake =
           "Owner signs this transaction"
           ownerSignsTransaction
 
-
         -- This puts trust into the Proposal. The Proposal must necessarily check
         -- that this is not abused.
         passert "Proposal ST spent" $