From 47deeff5be364ca2efa7154089e30ce711d892d9 Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Thu, 17 Mar 2022 10:06:14 +0000
Subject: [PATCH 01/24] inited branch

---
 agora-test/Spec/Sample/Treasury.hs |  1 +
 agora-test/Spec/Treasury.hs        |  3 +++
 agora.cabal                        | 11 +++++------
 3 files changed, 9 insertions(+), 6 deletions(-)
 create mode 100644 agora-test/Spec/Sample/Treasury.hs
 create mode 100644 agora-test/Spec/Treasury.hs

diff --git a/agora-test/Spec/Sample/Treasury.hs b/agora-test/Spec/Sample/Treasury.hs
new file mode 100644
index 0000000..c3ffbd6
--- /dev/null
+++ b/agora-test/Spec/Sample/Treasury.hs
@@ -0,0 +1 @@
+module Spec.Sample.Treasury () where
diff --git a/agora-test/Spec/Treasury.hs b/agora-test/Spec/Treasury.hs
new file mode 100644
index 0000000..39f5bf5
--- /dev/null
+++ b/agora-test/Spec/Treasury.hs
@@ -0,0 +1,3 @@
+module Spec.Treasury () where 
+
+
diff --git a/agora.cabal b/agora.cabal
index 8d17d47..e6d6ea8 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -107,12 +107,12 @@ common deps
 
 common test-deps
   build-depends:
+    , apropos-tx
     , QuickCheck
     , quickcheck-instances
     , tasty
     , tasty-hedgehog
     , tasty-hunit
-    , apropos-tx
 
 library
   import:          lang, deps
@@ -150,17 +150,16 @@ test-suite agora-test
   other-modules:
     Spec.Int
     Spec.Sample.Stake
+    Spec.Sample.Treasury
     Spec.Stake
-
+    Spec.Treasury
     Spec.Util
 
-  build-depends:
-    , agora
+  build-depends:  agora
 
 benchmark agora-bench
   import:         lang, deps
   hs-source-dirs: agora-bench
   main-is:        Main.hs
   type:           exitcode-stdio-1.0
-  build-depends:
-    , agora
+  build-depends:  agora

From 998a2af674263ed2dc8e15137174025718422d91 Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Thu, 17 Mar 2022 10:45:01 +0000
Subject: [PATCH 02/24] formatting fix

---
 agora-test/Spec/Treasury.hs | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

diff --git a/agora-test/Spec/Treasury.hs b/agora-test/Spec/Treasury.hs
index 39f5bf5..b6fbdda 100644
--- a/agora-test/Spec/Treasury.hs
+++ b/agora-test/Spec/Treasury.hs
@@ -1,3 +1 @@
-module Spec.Treasury () where 
-
-
+module Spec.Treasury () where

From ec2a119f81f0e7c47ea6039c9660346b23a42402 Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Fri, 18 Mar 2022 10:59:46 +0000
Subject: [PATCH 03/24] inited tr tests

---
 agora-test/Spec/Int.hs      | 8 +++++++-
 agora-test/Spec/Treasury.hs | 9 +++++++++
 agora-test/Spec/Util.hs     | 7 ++++++-
 3 files changed, 22 insertions(+), 2 deletions(-)

diff --git a/agora-test/Spec/Int.hs b/agora-test/Spec/Int.hs
index 8063784..33d211d 100644
--- a/agora-test/Spec/Int.hs
+++ b/agora-test/Spec/Int.hs
@@ -1,4 +1,10 @@
-module Spec.Int (HasLogicalModel (..), IntProp (..), intGenTests, intPureTests, intPlutarchTests) where
+module Spec.Int (
+  HasLogicalModel (..),
+  IntProp (..),
+  intGenTests,
+  intPureTests,
+  intPlutarchTests,
+) where
 
 import Apropos
 import Apropos.Script
diff --git a/agora-test/Spec/Treasury.hs b/agora-test/Spec/Treasury.hs
index b6fbdda..c0d814f 100644
--- a/agora-test/Spec/Treasury.hs
+++ b/agora-test/Spec/Treasury.hs
@@ -1 +1,10 @@
 module Spec.Treasury () where
+
+import Test.Tasty (TestTree, testGroup)
+
+tests :: [TestTree]
+tests =
+  [ testGroup
+      "treasury"
+      []
+  ]
diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs
index 3db7f53..ce8861f 100644
--- a/agora-test/Spec/Util.hs
+++ b/agora-test/Spec/Util.hs
@@ -24,7 +24,12 @@ import Plutus.V1.Ledger.Scripts (Script)
 
 --------------------------------------------------------------------------------
 
-policySucceedsWith :: String -> ClosedTerm PMintingPolicy -> ClosedTerm PData -> _ -> TestTree
+policySucceedsWith ::
+  String ->
+  ClosedTerm PMintingPolicy ->
+  ClosedTerm PData ->
+  _ ->
+  TestTree
 policySucceedsWith tag policy redeemer scriptContext =
   scriptSucceeds tag $ compile (policy # redeemer # pconstant scriptContext)
 

From 2a940eb47783747becbde719a7a826791ae524c6 Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Thu, 24 Mar 2022 15:59:51 +0000
Subject: [PATCH 04/24] Began carving out apropos treasury tests

---
 agora-test/Spec/Model/Treasury.hs | 97 +++++++++++++++++++++++++++++++
 agora.cabal                       |  1 +
 hie.yaml                          |  2 +-
 3 files changed, 99 insertions(+), 1 deletion(-)
 create mode 100644 agora-test/Spec/Model/Treasury.hs

diff --git a/agora-test/Spec/Model/Treasury.hs b/agora-test/Spec/Model/Treasury.hs
new file mode 100644
index 0000000..c9f0956
--- /dev/null
+++ b/agora-test/Spec/Model/Treasury.hs
@@ -0,0 +1,97 @@
+{-# OPTIONS_GHC -Wwarn #-}
+
+module Spec.Model.Treasury (
+  ) where
+
+import Apropos (
+  Apropos (Apropos),
+  Enumerable (enumerated),
+  Formula (
+    ExactlyOne,
+    Not,
+    Var,
+    Yes,
+    (:&&:),
+    (:->:)
+  ),
+  Gen,
+  HasLogicalModel (satisfiesProperty),
+  HasParameterisedGenerator (parameterisedGenerator),
+  LogicalModel (logic),
+  runGeneratorTestsWhere,
+  (:+),
+ )
+import Apropos.Script (HasScriptRunner (expect, runScriptTestsWhere, script))
+import Data.Set (Set)
+import Plutus.V1.Ledger.Api (CurrencySymbol, ScriptContext)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Hedgehog (fromGroup)
+
+{-
+
+A Treasury transaction should pass if:
+
+1. A GAT is burned.
+2. All GATs are valid.
+
+If either of these things do _not_ hold, then the transaction
+should fail.
+
+-}
+
+data TreasuryTxProp
+  = GATIsBurned
+  | GATIsNotBurned
+  | AllGATsValid
+  | SomeGATsInvalid
+  deriving stock (Show, Eq, Ord, Enum, Bounded)
+
+data TreasuryTxModel = TreasuryTxModel
+  { gatCs :: CurrencySymbol
+  , ctx :: ScriptContext
+  }
+
+instance Enumerable TreasuryTxProp where
+  enumerated :: [TreasuryTxProp]
+  enumerated = [minBound .. maxBound]
+
+instance LogicalModel TreasuryTxProp where
+  logic :: Formula TreasuryTxProp
+  logic =
+    ExactlyOne [Var GATIsBurned, Var GATIsNotBurned]
+      :&&: Var SomeGATsInvalid :->: Not (Var AllGATsValid)
+
+instance HasLogicalModel TreasuryTxProp TreasuryTxModel where
+  satisfiesProperty :: TreasuryTxProp -> TreasuryTxModel -> Bool
+  satisfiesProperty GATIsBurned trModel = undefined
+  satisfiesProperty GATIsNotBurned trModel = undefined
+  satisfiesProperty AllGATsValid trModel = undefined
+  satisfiesProperty SomeGATsInvalid trModel = undefined
+
+-- instance HasParameterisedGenerator TreasuryTxProp Int where
+--   parameterisedGenerator :: Set TreasuryTxProp -> Gen Int
+--   parameterisedGenerator = undefined
+
+-- instance HasScriptRunner TreasuryTxProp Int where
+--   expect = undefined
+--   script = undefined
+
+-- genTests :: TestTree
+-- genTests =
+--   testGroup "genTests" $
+--     fromGroup
+--       <$> [ runGeneratorTestsWhere
+--               (Apropos :: Int :+ TreasuryTxProp)
+--               "Generator"
+--               Yes
+--           ]
+
+-- plutarchTests :: TestTree
+-- plutarchTests =
+--   testGroup "plutarchTests" $
+--     fromGroup
+--       <$> [ runScriptTestsWhere
+--               (Apropos :: Int :+ TreasuryTxProp)
+--               "ScriptValid"
+--               Yes
+--           ]
diff --git a/agora.cabal b/agora.cabal
index 403e259..7c1f98d 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -148,6 +148,7 @@ test-suite agora-test
   main-is:        Spec.hs
   hs-source-dirs: agora-test
   other-modules:
+    Spec.Model.Treasury
     Spec.Model.MultiSig
     Spec.Sample.Stake
     Spec.Sample.Treasury
diff --git a/hie.yaml b/hie.yaml
index e1be10a..6020af6 100644
--- a/hie.yaml
+++ b/hie.yaml
@@ -1,6 +1,6 @@
 cradle:
   cabal:
-    - path: "./agora-src"
+    - path: "./agora"
       component: "lib:agora"
     - path: "./agora-bench"
       component: "benchmark:agora-bench"

From dd62b2e517bc94e1442d9c5202f00b8a7611b7e4 Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Fri, 25 Mar 2022 11:28:17 +0000
Subject: [PATCH 05/24] Remove redundant Spec Int test

---
 agora-test/Spec/Int.hs | 94 ------------------------------------------
 1 file changed, 94 deletions(-)
 delete mode 100644 agora-test/Spec/Int.hs

diff --git a/agora-test/Spec/Int.hs b/agora-test/Spec/Int.hs
deleted file mode 100644
index 33d211d..0000000
--- a/agora-test/Spec/Int.hs
+++ /dev/null
@@ -1,94 +0,0 @@
-module Spec.Int (
-  HasLogicalModel (..),
-  IntProp (..),
-  intGenTests,
-  intPureTests,
-  intPlutarchTests,
-) where
-
-import Apropos
-import Apropos.Script
-import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.Hedgehog (fromGroup)
-
-import Plutarch (compile)
-
-data IntProp
-  = IsNegative
-  | IsPositive
-  | IsZero
-  | IsLarge
-  | IsSmall
-  | IsMaxBound
-  | IsMinBound
-  deriving stock (Eq, Ord, Enum, Show, Bounded)
-
-instance Enumerable IntProp where
-  enumerated = [minBound .. maxBound]
-
-instance LogicalModel IntProp where
-  logic =
-    ExactlyOne [Var IsNegative, Var IsPositive, Var IsZero]
-      :&&: ExactlyOne [Var IsLarge, Var IsSmall]
-      :&&: (Var IsZero :->: Var IsSmall)
-      :&&: (Var IsMaxBound :->: (Var IsLarge :&&: Var IsPositive))
-      :&&: (Var IsMinBound :->: (Var IsLarge :&&: Var IsNegative))
-
-instance HasLogicalModel IntProp Int where
-  satisfiesProperty IsNegative i = i < 0
-  satisfiesProperty IsPositive i = i > 0
-  satisfiesProperty IsMaxBound i = i == maxBound
-  satisfiesProperty IsMinBound i = i == minBound
-  satisfiesProperty IsZero i = i == 0
-  satisfiesProperty IsLarge i = i > 10 || i < -10
-  satisfiesProperty IsSmall i = i <= 10 && i >= -10
-
-instance HasParameterisedGenerator IntProp Int where
-  parameterisedGenerator s = do
-    i <-
-      if IsZero `elem` s
-        then pure 0
-        else
-          if IsSmall `elem` s
-            then int (linear 1 10)
-            else
-              if IsMaxBound `elem` s
-                then pure maxBound
-                else int (linear 11 (maxBound - 1))
-    if IsNegative `elem` s
-      then
-        if IsMinBound `elem` s
-          then pure minBound
-          else pure (-i)
-      else pure i
-
-intGenTests :: TestTree
-intGenTests =
-  testGroup "intGenTests" $
-    fromGroup
-      <$> [ runGeneratorTestsWhere (Apropos :: Int :+ IntProp) "Int Generator" Yes
-          ]
-
-instance HasPureRunner IntProp Int where
-  expect _ = Var IsSmall :&&: Var IsNegative
-  script _ i = i < 0 && i >= -10
-
-intPureTests :: TestTree
-intPureTests =
-  testGroup "intPureTests" $
-    fromGroup
-      <$> [ runPureTestsWhere (Apropos :: Int :+ IntProp) "AcceptsSmallNegativeInts" Yes
-          ]
-
-instance HasScriptRunner IntProp Int where
-  expect _ = Var IsSmall :&&: Var IsNegative
-  script _ i =
-    let ii = fromIntegral i :: Integer
-     in compile (pif ((fromInteger ii #< (0 :: Term s PInteger)) #&& ((fromInteger (-10) :: Term s PInteger) #<= fromInteger ii)) (pcon PUnit) perror)
-
-intPlutarchTests :: TestTree
-intPlutarchTests =
-  testGroup "intPlutarchTests" $
-    fromGroup
-      <$> [ runScriptTestsWhere (Apropos :: Int :+ IntProp) "AcceptsSmallNegativeInts" Yes
-          ]

From 1a1b978b288d1396bfe80283c2bb1cd65cc82c2e Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Fri, 25 Mar 2022 13:54:22 +0000
Subject: [PATCH 06/24] Work on treasury validator tests

---
 agora-test/Spec/Model/Treasury.hs | 22 +++++++++++++++++-----
 1 file changed, 17 insertions(+), 5 deletions(-)

diff --git a/agora-test/Spec/Model/Treasury.hs b/agora-test/Spec/Model/Treasury.hs
index c9f0956..3b0ecff 100644
--- a/agora-test/Spec/Model/Treasury.hs
+++ b/agora-test/Spec/Model/Treasury.hs
@@ -23,7 +23,13 @@ import Apropos (
  )
 import Apropos.Script (HasScriptRunner (expect, runScriptTestsWhere, script))
 import Data.Set (Set)
-import Plutus.V1.Ledger.Api (CurrencySymbol, ScriptContext)
+import Plutus.V1.Ledger.Api (
+  CurrencySymbol,
+  ScriptContext (scriptContextPurpose, scriptContextTxInfo),
+  ScriptPurpose (Minting),
+  TxInfo (txInfoMint),
+  Value,
+ )
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Hedgehog (fromGroup)
 
@@ -44,6 +50,7 @@ data TreasuryTxProp
   | GATIsNotBurned
   | AllGATsValid
   | SomeGATsInvalid
+  | ScriptPurposeIsNotMinting
   deriving stock (Show, Eq, Ord, Enum, Bounded)
 
 data TreasuryTxModel = TreasuryTxModel
@@ -63,10 +70,15 @@ instance LogicalModel TreasuryTxProp where
 
 instance HasLogicalModel TreasuryTxProp TreasuryTxModel where
   satisfiesProperty :: TreasuryTxProp -> TreasuryTxModel -> Bool
-  satisfiesProperty GATIsBurned trModel = undefined
-  satisfiesProperty GATIsNotBurned trModel = undefined
-  satisfiesProperty AllGATsValid trModel = undefined
-  satisfiesProperty SomeGATsInvalid trModel = undefined
+  satisfiesProperty prop model =
+    let purpose = model.ctx.scriptContextPurpose :: ScriptPurpose
+        txInfo = model.ctx.scriptContextTxInfo :: TxInfo
+        amountMinted = txInfo.txInfoMint :: Value
+     in case prop of
+          ScriptPurposeIsNotMinting -> case purpose of
+            Minting _ -> False
+            _ -> True
+          _ -> undefined
 
 -- instance HasParameterisedGenerator TreasuryTxProp Int where
 --   parameterisedGenerator :: Set TreasuryTxProp -> Gen Int

From 8633ff15b5d0e5bc4a343dce5cf0761c6c426cef Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Mon, 28 Mar 2022 12:43:09 +0100
Subject: [PATCH 07/24] Expanded logicalmodel of treasury tests

---
 agora-test/Spec/Model/Treasury.hs | 109 +++++++++++++++++++++---------
 1 file changed, 77 insertions(+), 32 deletions(-)

diff --git a/agora-test/Spec/Model/Treasury.hs b/agora-test/Spec/Model/Treasury.hs
index 3b0ecff..aad096e 100644
--- a/agora-test/Spec/Model/Treasury.hs
+++ b/agora-test/Spec/Model/Treasury.hs
@@ -22,14 +22,20 @@ import Apropos (
   (:+),
  )
 import Apropos.Script (HasScriptRunner (expect, runScriptTestsWhere, script))
+import Data.Maybe (fromMaybe)
 import Data.Set (Set)
-import Plutus.V1.Ledger.Api (
-  CurrencySymbol,
+import Plutus.V1.Ledger.Address (Address (addressCredential))
+import Plutus.V1.Ledger.Contexts (
   ScriptContext (scriptContextPurpose, scriptContextTxInfo),
   ScriptPurpose (Minting),
-  TxInfo (txInfoMint),
-  Value,
+  TxInfo (txInfoMint, txInfoOutputs),
+  TxOut (txOutAddress, txOutValue),
  )
+import Plutus.V1.Ledger.Credential (Credential (PubKeyCredential, ScriptCredential))
+import Plutus.V1.Ledger.Scripts (ValidatorHash (ValidatorHash))
+import Plutus.V1.Ledger.Value (CurrencySymbol, TokenName (unTokenName), Value (getValue))
+import PlutusTx.AssocMap (Map, elems, keys)
+import PlutusTx.AssocMap qualified as AssocMap (all, lookup)
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Hedgehog (fromGroup)
 
@@ -57,6 +63,7 @@ data TreasuryTxModel = TreasuryTxModel
   { gatCs :: CurrencySymbol
   , ctx :: ScriptContext
   }
+  deriving stock (Show)
 
 instance Enumerable TreasuryTxProp where
   enumerated :: [TreasuryTxProp]
@@ -68,42 +75,80 @@ instance LogicalModel TreasuryTxProp where
     ExactlyOne [Var GATIsBurned, Var GATIsNotBurned]
       :&&: Var SomeGATsInvalid :->: Not (Var AllGATsValid)
 
+isMinting :: ScriptPurpose -> Bool
+isMinting (Minting _) = True
+isMinting _ = False
+
+authorityTokensValidIn :: CurrencySymbol -> TxOut -> Bool
+authorityTokensValidIn cs out =
+  let add = out.txOutAddress :: Address
+      outValue = out.txOutValue :: Value
+
+      tokenMap :: Maybe (Map TokenName Integer)
+      tokenMap = AssocMap.lookup cs $ getValue outValue
+
+      cred = add.addressCredential :: Credential
+
+      validCred :: Map TokenName Integer -> Bool
+      validCred m = case cred of
+        PubKeyCredential _ -> False
+        ScriptCredential (ValidatorHash vh) ->
+          all (\tn -> vh == unTokenName tn) $ keys m
+   in case tokenMap of
+        Nothing -> True
+        Just m -> validCred m
+
 instance HasLogicalModel TreasuryTxProp TreasuryTxModel where
   satisfiesProperty :: TreasuryTxProp -> TreasuryTxModel -> Bool
   satisfiesProperty prop model =
     let purpose = model.ctx.scriptContextPurpose :: ScriptPurpose
         txInfo = model.ctx.scriptContextTxInfo :: TxInfo
         amountMinted = txInfo.txInfoMint :: Value
+
+        csValue :: Maybe (Map TokenName Integer)
+        csValue = AssocMap.lookup model.gatCs (getValue amountMinted)
+
+        csValueSum :: Integer
+        csValueSum = case csValue of
+          Nothing -> 0
+          Just m -> sum $ elems m
      in case prop of
-          ScriptPurposeIsNotMinting -> case purpose of
-            Minting _ -> False
-            _ -> True
-          _ -> undefined
+          GATIsBurned -> csValueSum <= -1
+          GATIsNotBurned -> csValueSum >= 0
+          AllGATsValid ->
+            all
+              (authorityTokensValidIn model.gatCs)
+              txInfo.txInfoOutputs
+          SomeGATsInvalid ->
+            any
+              (not . authorityTokensValidIn model.gatCs)
+              txInfo.txInfoOutputs
+          ScriptPurposeIsNotMinting -> not $ isMinting purpose
 
--- instance HasParameterisedGenerator TreasuryTxProp Int where
---   parameterisedGenerator :: Set TreasuryTxProp -> Gen Int
---   parameterisedGenerator = undefined
+instance HasParameterisedGenerator TreasuryTxProp TreasuryTxModel where
+  parameterisedGenerator :: Set TreasuryTxProp -> Gen TreasuryTxModel
+  parameterisedGenerator = undefined
 
--- instance HasScriptRunner TreasuryTxProp Int where
---   expect = undefined
---   script = undefined
+instance HasScriptRunner TreasuryTxProp TreasuryTxModel where
+  expect = undefined
+  script = undefined
 
--- genTests :: TestTree
--- genTests =
---   testGroup "genTests" $
---     fromGroup
---       <$> [ runGeneratorTestsWhere
---               (Apropos :: Int :+ TreasuryTxProp)
---               "Generator"
---               Yes
---           ]
+genTests :: TestTree
+genTests =
+  testGroup "genTests" $
+    fromGroup
+      <$> [ runGeneratorTestsWhere
+              (Apropos :: TreasuryTxModel :+ TreasuryTxProp)
+              "Generator"
+              Yes
+          ]
 
--- plutarchTests :: TestTree
--- plutarchTests =
---   testGroup "plutarchTests" $
---     fromGroup
---       <$> [ runScriptTestsWhere
---               (Apropos :: Int :+ TreasuryTxProp)
---               "ScriptValid"
---               Yes
---           ]
+plutarchTests :: TestTree
+plutarchTests =
+  testGroup "plutarchTests" $
+    fromGroup
+      <$> [ runScriptTestsWhere
+              (Apropos :: TreasuryTxModel :+ TreasuryTxProp)
+              "ScriptValid"
+              Yes
+          ]

From 56a1b4672f0de8d887d93cccb8f95c6758627cef Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Fri, 1 Apr 2022 10:41:18 +0100
Subject: [PATCH 08/24] lightly expanded prop generator

---
 agora-test/Spec/Model/Treasury.hs | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/agora-test/Spec/Model/Treasury.hs b/agora-test/Spec/Model/Treasury.hs
index aad096e..0ed634f 100644
--- a/agora-test/Spec/Model/Treasury.hs
+++ b/agora-test/Spec/Model/Treasury.hs
@@ -127,7 +127,12 @@ instance HasLogicalModel TreasuryTxProp TreasuryTxModel where
 
 instance HasParameterisedGenerator TreasuryTxProp TreasuryTxModel where
   parameterisedGenerator :: Set TreasuryTxProp -> Gen TreasuryTxModel
-  parameterisedGenerator = undefined
+  parameterisedGenerator propSet = do
+    purpose <-
+      if ScriptPurposeIsNotMinting `elem` propSet
+        then undefined
+        else undefined
+    undefined
 
 instance HasScriptRunner TreasuryTxProp TreasuryTxModel where
   expect = undefined

From 04118541ffe10e47c2191ab64facb2a7d539d897 Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Fri, 8 Apr 2022 13:50:24 +0100
Subject: [PATCH 09/24] Pointing towards treasury branch

---
 flake.lock | 12 ++++++------
 flake.nix  |  2 +-
 2 files changed, 7 insertions(+), 7 deletions(-)

diff --git a/flake.lock b/flake.lock
index 73e7d0d..de979be 100644
--- a/flake.lock
+++ b/flake.lock
@@ -103,17 +103,17 @@
         "plutus": "plutus"
       },
       "locked": {
-        "lastModified": 1648805998,
-        "narHash": "sha256-TWEiUifHkhgCHqe70aNn9j6LdFFWv2nMbSWV8hR59oE=",
-        "owner": "jhodgdev",
+        "lastModified": 1649421738,
+        "narHash": "sha256-07LdyHykRDObI984W04lIXgvh6sWKDEW8enAGhIijQU=",
+        "owner": "mlabs-haskell",
         "repo": "apropos-tx",
-        "rev": "4eca3fac23c339caee04ea6176e641a4b3857a25",
+        "rev": "5257325e3dd2603d09c0ebe468eec676eeb233b8",
         "type": "github"
       },
       "original": {
-        "owner": "jhodgdev",
+        "owner": "mlabs-haskell",
         "repo": "apropos-tx",
-        "rev": "4eca3fac23c339caee04ea6176e641a4b3857a25",
+        "rev": "5257325e3dd2603d09c0ebe468eec676eeb233b8",
         "type": "github"
       }
     },
diff --git a/flake.nix b/flake.nix
index 9f5a7a7..eae71ab 100644
--- a/flake.nix
+++ b/flake.nix
@@ -19,7 +19,7 @@
   # inputs to follow a commit on those master branches. For more
   # info, see: https://github.com/mlabs-haskell/apropos-tx/pull/37
   inputs.apropos-tx.url =
-    "github:jhodgdev/apropos-tx?rev=4eca3fac23c339caee04ea6176e641a4b3857a25";
+    "github:mlabs-haskell/apropos-tx?rev=5257325e3dd2603d09c0ebe468eec676eeb233b8";
   inputs.apropos-tx.inputs.nixpkgs.follows =
     "plutarch/haskell-nix/nixpkgs-unstable";
   inputs.apropos.url =

From c1188b6b9649384f169a322ee13a817a8e6e9102 Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Fri, 8 Apr 2022 14:33:51 +0100
Subject: [PATCH 10/24] fixed import issue

---
 agora-test/Spec/Model/Treasury.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/agora-test/Spec/Model/Treasury.hs b/agora-test/Spec/Model/Treasury.hs
index 0ed634f..d09a456 100644
--- a/agora-test/Spec/Model/Treasury.hs
+++ b/agora-test/Spec/Model/Treasury.hs
@@ -21,7 +21,7 @@ import Apropos (
   runGeneratorTestsWhere,
   (:+),
  )
-import Apropos.Script (HasScriptRunner (expect, runScriptTestsWhere, script))
+import Apropos.Script (ScriptModel (expect, runScriptTestsWhere, script))
 import Data.Maybe (fromMaybe)
 import Data.Set (Set)
 import Plutus.V1.Ledger.Address (Address (addressCredential))
@@ -134,7 +134,7 @@ instance HasParameterisedGenerator TreasuryTxProp TreasuryTxModel where
         else undefined
     undefined
 
-instance HasScriptRunner TreasuryTxProp TreasuryTxModel where
+instance ScriptModel TreasuryTxProp TreasuryTxModel where
   expect = undefined
   script = undefined
 

From 8020d12b42431f15f617c04ec67fc2a960a8019f Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Tue, 12 Apr 2022 13:44:05 +0100
Subject: [PATCH 11/24] more work on treasury testing!

---
 agora-test/Spec.hs                |  10 ++
 agora-test/Spec/Model/Treasury.hs | 253 ++++++++++++++++++++++++------
 agora/Agora/AuthorityToken.hs     |  36 +++--
 agora/Agora/Treasury.hs           |   3 +-
 flake.lock                        |   8 +-
 flake.nix                         |   2 +-
 6 files changed, 248 insertions(+), 64 deletions(-)

diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs
index 6442ae8..37a6267 100644
--- a/agora-test/Spec.hs
+++ b/agora-test/Spec.hs
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wwarn #-}
+
 --------------------------------------------------------------------------------
 
 import Prelude
@@ -9,6 +11,7 @@ import Test.Tasty (defaultMain, testGroup)
 --------------------------------------------------------------------------------
 
 import Spec.Model.MultiSig qualified as MultiSig
+import Spec.Model.Treasury qualified as Treasury
 import Spec.Stake qualified as Stake
 
 -- | The Agora test suite.
@@ -28,4 +31,11 @@ main =
               , MultiSig.genTests
               ]
           ]
+      , testGroup
+          "Treasury tests"
+          [ testGroup
+              "Treasury"
+              [ Treasury.genTests
+              ]
+          ]
       ]
diff --git a/agora-test/Spec/Model/Treasury.hs b/agora-test/Spec/Model/Treasury.hs
index d09a456..b9d81a5 100644
--- a/agora-test/Spec/Model/Treasury.hs
+++ b/agora-test/Spec/Model/Treasury.hs
@@ -1,64 +1,97 @@
 {-# OPTIONS_GHC -Wwarn #-}
 
-module Spec.Model.Treasury (
-  ) where
+{- |
+Module: Spec.Model.Treasury
+Description: `apropos-tx` tests for Treasury validator.
+Maintainer: jack@mlabs.city
 
+This module contains `apropos-tx` tests for ensuring that
+the `Agora.Treasury` validator acts as desired. Notes on desired
+behaviour and invluded in this description.
+
+A Treasury transaction should pass if:
+
+  1. A GAT is burned.
+
+  2. All GATs are valid.
+
+  3. The script purpose is Minting.
+
+If either of these things do /not/ hold, then the transaction
+should fail.
+-}
+module Spec.Model.Treasury (
+  plutarchTests,
+  genTests,
+) where
+
+import Agora.Treasury (
+  PTreasuryDatum (PTreasuryDatum),
+  PTreasuryRedeemer (PAlterTreasuryParams),
+  treasuryValidator,
+ )
 import Apropos (
   Apropos (Apropos),
+  Contract,
   Enumerable (enumerated),
   Formula (
-    ExactlyOne,
     Not,
+    Some,
     Var,
     Yes,
-    (:&&:),
-    (:->:)
+    (:&&:)
   ),
   Gen,
   HasLogicalModel (satisfiesProperty),
   HasParameterisedGenerator (parameterisedGenerator),
+  HasPermutationGenerator (buildGen, generators),
   LogicalModel (logic),
+  Morphism (Morphism, contract, match, morphism, name),
+  add,
   runGeneratorTestsWhere,
   (:+),
  )
+import Apropos.Gen.Contexts (scriptContext, txInInfo)
+import Apropos.Gen.Value (currencySymbol)
 import Apropos.Script (ScriptModel (expect, runScriptTestsWhere, script))
-import Data.Maybe (fromMaybe)
 import Data.Set (Set)
+import Plutarch.Api.V1 (PCurrencySymbol, PScriptContext)
+import Plutarch.Builtin (pforgetData)
 import Plutus.V1.Ledger.Address (Address (addressCredential))
 import Plutus.V1.Ledger.Contexts (
   ScriptContext (scriptContextPurpose, scriptContextTxInfo),
   ScriptPurpose (Minting),
-  TxInfo (txInfoMint, txInfoOutputs),
+  TxInInfo (txInInfoResolved),
+  TxInfo (txInfoInputs, txInfoMint, txInfoOutputs),
   TxOut (txOutAddress, txOutValue),
  )
 import Plutus.V1.Ledger.Credential (Credential (PubKeyCredential, ScriptCredential))
-import Plutus.V1.Ledger.Scripts (ValidatorHash (ValidatorHash))
-import Plutus.V1.Ledger.Value (CurrencySymbol, TokenName (unTokenName), Value (getValue))
-import PlutusTx.AssocMap (Map, elems, keys)
-import PlutusTx.AssocMap qualified as AssocMap (all, lookup)
+import Plutus.V1.Ledger.Scripts (Script, ValidatorHash (ValidatorHash))
+import Plutus.V1.Ledger.Value (
+  CurrencySymbol (CurrencySymbol),
+  TokenName (unTokenName),
+  Value (Value, getValue),
+ )
+import PlutusTx.AssocMap (Map, elems, fromList, keys, singleton, toList, unionWith)
+import PlutusTx.AssocMap qualified as AssocMap (lookup)
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Hedgehog (fromGroup)
 
-{-
-
-A Treasury transaction should pass if:
-
-1. A GAT is burned.
-2. All GATs are valid.
-
-If either of these things do _not_ hold, then the transaction
-should fail.
-
--}
-
 data TreasuryTxProp
   = GATIsBurned
-  | GATIsNotBurned
   | AllGATsValid
-  | SomeGATsInvalid
-  | ScriptPurposeIsNotMinting
+  | ScriptPurposeIsMinting
   deriving stock (Show, Eq, Ord, Enum, Bounded)
 
+instance LogicalModel TreasuryTxProp where
+  logic :: Formula TreasuryTxProp
+  logic =
+    Some
+      [ Var GATIsBurned
+      , Var AllGATsValid
+      , Var ScriptPurposeIsMinting
+      ]
+
 data TreasuryTxModel = TreasuryTxModel
   { gatCs :: CurrencySymbol
   , ctx :: ScriptContext
@@ -69,12 +102,6 @@ instance Enumerable TreasuryTxProp where
   enumerated :: [TreasuryTxProp]
   enumerated = [minBound .. maxBound]
 
-instance LogicalModel TreasuryTxProp where
-  logic :: Formula TreasuryTxProp
-  logic =
-    ExactlyOne [Var GATIsBurned, Var GATIsNotBurned]
-      :&&: Var SomeGATsInvalid :->: Not (Var AllGATsValid)
-
 isMinting :: ScriptPurpose -> Bool
 isMinting (Minting _) = True
 isMinting _ = False
@@ -113,30 +140,158 @@ instance HasLogicalModel TreasuryTxProp TreasuryTxModel where
           Nothing -> 0
           Just m -> sum $ elems m
      in case prop of
-          GATIsBurned -> csValueSum <= -1
-          GATIsNotBurned -> csValueSum >= 0
+          GATIsBurned -> csValueSum == -1
           AllGATsValid ->
             all
-              (authorityTokensValidIn model.gatCs)
-              txInfo.txInfoOutputs
-          SomeGATsInvalid ->
-            any
-              (not . authorityTokensValidIn model.gatCs)
-              txInfo.txInfoOutputs
-          ScriptPurposeIsNotMinting -> not $ isMinting purpose
+              (authorityTokensValidIn model.gatCs . txInInfoResolved)
+              txInfo.txInfoInputs
+          ScriptPurposeIsMinting -> isMinting purpose
 
 instance HasParameterisedGenerator TreasuryTxProp TreasuryTxModel where
   parameterisedGenerator :: Set TreasuryTxProp -> Gen TreasuryTxModel
-  parameterisedGenerator propSet = do
-    purpose <-
-      if ScriptPurposeIsNotMinting `elem` propSet
-        then undefined
-        else undefined
-    undefined
+  parameterisedGenerator = buildGen baseGen
+    where
+      baseGen :: Gen TreasuryTxModel
+      baseGen = do
+        cs <- currencySymbol
+        ctx <- scriptContext
+        return $ TreasuryTxModel cs ctx
+
+{- | Updates the `Integer` and `TokenName` for a given
+     `CurrencySymbol` for a given value.
+-}
+replaceValue ::
+  -- | The value whose entry to update.
+  Value ->
+  -- | The currency symbol of the entry to update.
+  CurrencySymbol ->
+  -- | The token name of the entry to place in the new value.
+  TokenName ->
+  -- | The number of tokens to place in the new value.
+  Integer ->
+  -- | The updated value.
+  Value
+replaceValue (Value v) cs tn n = Value $ unionWith (\_ x -> x) v v'
+  where
+    v' :: Map CurrencySymbol (Map TokenName Integer)
+    v' = singleton cs $ singleton tn n
+
+kmap :: (k -> k') -> Map k v -> Map k' v
+kmap g = fromList . fmap (\(x, y) -> (g x, y)) . toList
+
+fixTokenNames :: TxInInfo -> TxInInfo
+fixTokenNames inf =
+  let cred = inf.txInInfoResolved.txOutAddress.addressCredential
+      val = inf.txInInfoResolved.txOutValue
+   in case cred of
+        PubKeyCredential _ -> inf
+        ScriptCredential (ValidatorHash bs) -> undefined
+
+-- | TODO: Define.
+instance HasPermutationGenerator TreasuryTxProp TreasuryTxModel where
+  generators :: [Morphism TreasuryTxProp TreasuryTxModel]
+  generators =
+    [ Morphism
+        { name = "Ensure GAT is burned"
+        , match = Not $ Var GATIsBurned
+        , contract = add GATIsBurned
+        , morphism = \m ->
+            let ctx' = m.ctx
+                txInfo = ctx'.scriptContextTxInfo
+                mint = txInfo.txInfoMint
+                newMint = replaceValue mint m.gatCs "gat" (-1)
+             in return
+                  m
+                    { ctx =
+                        ctx'
+                          { scriptContextTxInfo =
+                              txInfo
+                                { txInfoMint = newMint
+                                }
+                          }
+                    }
+        }
+    , Morphism
+        { name = "Ensure all GATs are valid"
+        , match = Not $ Var AllGATsValid
+        , contract = add AllGATsValid
+        , {- For every GAT to be considered "valid", their
+             `TokenName`s have to be equal to the address
+             of their script. To represent this as a `Morphism`:
+
+             - FOR every UTXO input in the transaction:
+               - FOR every value in the input:
+                 - IF the currency symbol matches the recognised
+                   GAT currency symbol:
+                     - THEN: set the `TokenName` to be equal to
+                       the UTXO's address.
+                 - ELSE: ignore it.
+          -}
+          morphism = \m ->
+            let ctx' = m.ctx
+                txInfo = ctx'.scriptContextTxInfo
+                infoInputs :: [TxInInfo] = txInfo.txInfoInputs
+             in return $
+                  m
+                    { ctx =
+                        ctx'
+                          { scriptContextTxInfo =
+                              txInfo
+                                { txInfoInputs =
+                                    fixTokenNames <$> infoInputs
+                                }
+                          }
+                    }
+        }
+    , Morphism
+        { name = "Ensure script purpose is minting"
+        , match = Not $ Var ScriptPurposeIsMinting
+        , contract = add ScriptPurposeIsMinting
+        , morphism = \m ->
+            return
+              m
+                { ctx =
+                    m.ctx
+                      { scriptContextPurpose = Minting m.gatCs
+                      }
+                }
+        }
+    ]
 
 instance ScriptModel TreasuryTxProp TreasuryTxModel where
-  expect = undefined
-  script = undefined
+  expect :: (TreasuryTxModel :+ TreasuryTxProp) -> Formula TreasuryTxProp
+  expect _ =
+    Var GATIsBurned
+      :&&: Var AllGATsValid
+      :&&: Var ScriptPurposeIsMinting
+
+  script :: (TreasuryTxModel :+ TreasuryTxProp) -> TreasuryTxModel -> Script
+  script _ m = compile result
+    where
+      result :: Term s POpaque
+      result =
+        treasuryValidator cs
+          # (pforgetData $ pdata d)
+          # (pforgetData $ pdata r)
+          # ctx
+
+      cs :: CurrencySymbol
+      cs = m.gatCs
+
+      d :: Term s PTreasuryDatum
+      d = pcon $ PTreasuryDatum fields
+        where
+          adaStateThread :: Term _ PCurrencySymbol
+          adaStateThread = pconstant $ CurrencySymbol ""
+
+          fields :: Term _ (PDataRecord '["stateThread" ':= PCurrencySymbol])
+          fields = pdcons # (pdata adaStateThread) # pdnil
+
+      r :: Term s PTreasuryRedeemer
+      r = pcon $ PAlterTreasuryParams pdnil
+
+      ctx :: Term s PScriptContext
+      ctx = pconstant m.ctx
 
 genTests :: TestTree
 genTests =
diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs
index dadabe4..70bbe3b 100644
--- a/agora/Agora/AuthorityToken.hs
+++ b/agora/Agora/AuthorityToken.hs
@@ -69,30 +69,48 @@ newtype AuthorityToken = AuthorityToken
      are tagged with a TokenName that matches where they live.
 -}
 authorityTokensValidIn :: Term s (PCurrencySymbol :--> PTxOut :--> PBool)
-authorityTokensValidIn = phoistAcyclic $
+authorityTokensValidIn = phoistAcyclic $ -- /Lift/ the `Term`.
   plam $ \authorityTokenSym txOut'' -> P.do
+    -- Extract the desired fields: address and value, from the
+    -- transaction output info.
     PTxOut txOut' <- pmatch txOut''
     txOut <- pletFields @'["address", "value"] $ txOut'
     PAddress address <- pmatch txOut.address
     PValue value' <- pmatch txOut.value
     PMap value <- pmatch value'
+
+    -- Search the transaction output info's value for the
+    -- provided currency symbol for the authority token.
     pmatch (plookup # pdata authorityTokenSym # value) $ \case
+      -- In the case of `PNothing`, no GATs exist at this output
+      -- and ipso facto they are all valid.
+      PNothing -> pconstant True
+      -- This is the case wherein a TokenName/Integer map /has/
+      -- been found for the given currency symbol.
       PJust (pfromData -> tokenMap') ->
+        -- Now we need to look at the transaction output's
+        -- address.
         pmatch (pfield @"credential" # address) $ \case
-          PPubKeyCredential _ ->
-            -- GATs should only be sent to Effect validators
-            pconstant False
+          -- GATs should only be sent to Effect validators,
+          -- therefore we consider this invalid and return False.
+          PPubKeyCredential _ -> pconstant False
+          -- This is a script address. We need to ensure that
+          -- the the `TokenName`s associated with the given
+          -- currency symbol are all equal to this script
+          -- address.
           PScriptCredential ((pfromData . (pfield @"_0" #)) -> cred) -> P.do
+            -- Unwrap the `TokenName`/`Integer` map.
             PMap tokenMap <- pmatch tokenMap'
+
+            -- Check that the `TokenName` is equal to the validator
+            -- hash for all of the `TokenName` keys in the map.
             pall
               # plam
-                ( \pair ->
-                    pforgetData (pfstBuiltin # pair) #== pforgetData (pdata cred)
+                ( \tnMap ->
+                    pforgetData (pfstBuiltin # tnMap)
+                      #== pforgetData (pdata cred)
                 )
               # tokenMap
-      PNothing ->
-        -- No GATs exist at this output!
-        pconstant True
 
 -- | Assert that a single authority token has been burned.
 singleAuthorityTokenBurned ::
diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs
index 3f48a1f..8e12a07 100644
--- a/agora/Agora/Treasury.hs
+++ b/agora/Agora/Treasury.hs
@@ -57,7 +57,8 @@ treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do
 
   gatCs <- plet $ pconstant gatCs'
 
-  passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint
+  passert "A single authority token has been burned" $
+    singleAuthorityTokenBurned gatCs txInfo' mint
 
   popaque $ pconstant ()
 
diff --git a/flake.lock b/flake.lock
index de979be..bfdf259 100644
--- a/flake.lock
+++ b/flake.lock
@@ -103,17 +103,17 @@
         "plutus": "plutus"
       },
       "locked": {
-        "lastModified": 1649421738,
-        "narHash": "sha256-07LdyHykRDObI984W04lIXgvh6sWKDEW8enAGhIijQU=",
+        "lastModified": 1649673880,
+        "narHash": "sha256-LpR+F+fHB6Mh1NHI2O+3zeeSE+ZzyVBwuP9T12X3rek=",
         "owner": "mlabs-haskell",
         "repo": "apropos-tx",
-        "rev": "5257325e3dd2603d09c0ebe468eec676eeb233b8",
+        "rev": "dd292b49a29f8a259bdc3e35cf4ab1dbbc73582f",
         "type": "github"
       },
       "original": {
         "owner": "mlabs-haskell",
         "repo": "apropos-tx",
-        "rev": "5257325e3dd2603d09c0ebe468eec676eeb233b8",
+        "rev": "dd292b49a29f8a259bdc3e35cf4ab1dbbc73582f",
         "type": "github"
       }
     },
diff --git a/flake.nix b/flake.nix
index eae71ab..f3dacca 100644
--- a/flake.nix
+++ b/flake.nix
@@ -19,7 +19,7 @@
   # inputs to follow a commit on those master branches. For more
   # info, see: https://github.com/mlabs-haskell/apropos-tx/pull/37
   inputs.apropos-tx.url =
-    "github:mlabs-haskell/apropos-tx?rev=5257325e3dd2603d09c0ebe468eec676eeb233b8";
+    "github:mlabs-haskell/apropos-tx?rev=dd292b49a29f8a259bdc3e35cf4ab1dbbc73582f";
   inputs.apropos-tx.inputs.nixpkgs.follows =
     "plutarch/haskell-nix/nixpkgs-unstable";
   inputs.apropos.url =

From 3c818f436f2075788b50904977ab228f0529bc3f Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Tue, 12 Apr 2022 13:46:40 +0100
Subject: [PATCH 12/24] Formatting

---
 agora.cabal |  8 ++++----
 flake.nix   | 40 +++++++++++++++++++++++-----------------
 2 files changed, 27 insertions(+), 21 deletions(-)

diff --git a/agora.cabal b/agora.cabal
index 2e4129f..5ff2a48 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
@@ -151,8 +151,8 @@ test-suite agora-test
   main-is:        Spec.hs
   hs-source-dirs: agora-test
   other-modules:
-    Spec.Model.Treasury
     Spec.Model.MultiSig
+    Spec.Model.Treasury
     Spec.Sample.Stake
     Spec.Sample.Treasury
     Spec.Stake
diff --git a/flake.nix b/flake.nix
index f3dacca..ed58b04 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;
@@ -115,17 +117,19 @@
         let
           pkgs = nixpkgsFor system;
           pkgs' = nixpkgsFor' system;
-        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
-          ];
-        } ''
+        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
+            ];
+          } ''
           export LC_CTYPE=C.UTF-8
           export LC_ALL=C.UTF-8
           export LANG=C.UTF-8
@@ -133,7 +137,8 @@
           make format_check || (echo "    Please run 'make format'" ; exit 1)
           mkdir $out
         '';
-    in {
+    in
+    {
       project = perSystem projectFor;
       flake = perSystem (system: (projectFor system).flake { });
 
@@ -147,9 +152,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 fcd76c3dae798fe473ed86ccdc3cbfcf1a331207 Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Tue, 12 Apr 2022 13:55:27 +0100
Subject: [PATCH 13/24] apply hlint suggestions

---
 agora-test/Spec/Model/Treasury.hs | 13 ++++++-------
 1 file changed, 6 insertions(+), 7 deletions(-)

diff --git a/agora-test/Spec/Model/Treasury.hs b/agora-test/Spec/Model/Treasury.hs
index b9d81a5..b28fad3 100644
--- a/agora-test/Spec/Model/Treasury.hs
+++ b/agora-test/Spec/Model/Treasury.hs
@@ -54,6 +54,7 @@ import Apropos (
 import Apropos.Gen.Contexts (scriptContext, txInInfo)
 import Apropos.Gen.Value (currencySymbol)
 import Apropos.Script (ScriptModel (expect, runScriptTestsWhere, script))
+import Data.Bifunctor (Bifunctor (first))
 import Data.Set (Set)
 import Plutarch.Api.V1 (PCurrencySymbol, PScriptContext)
 import Plutarch.Builtin (pforgetData)
@@ -121,9 +122,7 @@ authorityTokensValidIn cs out =
         PubKeyCredential _ -> False
         ScriptCredential (ValidatorHash vh) ->
           all (\tn -> vh == unTokenName tn) $ keys m
-   in case tokenMap of
-        Nothing -> True
-        Just m -> validCred m
+   in maybe True validCred tokenMap
 
 instance HasLogicalModel TreasuryTxProp TreasuryTxModel where
   satisfiesProperty :: TreasuryTxProp -> TreasuryTxModel -> Bool
@@ -177,7 +176,7 @@ replaceValue (Value v) cs tn n = Value $ unionWith (\_ x -> x) v v'
     v' = singleton cs $ singleton tn n
 
 kmap :: (k -> k') -> Map k v -> Map k' v
-kmap g = fromList . fmap (\(x, y) -> (g x, y)) . toList
+kmap g = fromList . fmap (first g) . toList
 
 fixTokenNames :: TxInInfo -> TxInInfo
 fixTokenNames inf =
@@ -271,8 +270,8 @@ instance ScriptModel TreasuryTxProp TreasuryTxModel where
       result :: Term s POpaque
       result =
         treasuryValidator cs
-          # (pforgetData $ pdata d)
-          # (pforgetData $ pdata r)
+          # pforgetData (pdata d)
+          # pforgetData (pdata r)
           # ctx
 
       cs :: CurrencySymbol
@@ -285,7 +284,7 @@ instance ScriptModel TreasuryTxProp TreasuryTxModel where
           adaStateThread = pconstant $ CurrencySymbol ""
 
           fields :: Term _ (PDataRecord '["stateThread" ':= PCurrencySymbol])
-          fields = pdcons # (pdata adaStateThread) # pdnil
+          fields = pdcons # pdata adaStateThread # pdnil
 
       r :: Term s PTreasuryRedeemer
       r = pcon $ PAlterTreasuryParams pdnil

From 53ae45eaafe0c1bb845783a92b44f9a6f27443ce Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Thu, 28 Apr 2022 16:14:35 +0100
Subject: [PATCH 14/24] finished morphisms

---
 agora-test/Spec/Model/Treasury.hs | 27 +++++++++++++++++++--------
 1 file changed, 19 insertions(+), 8 deletions(-)

diff --git a/agora-test/Spec/Model/Treasury.hs b/agora-test/Spec/Model/Treasury.hs
index b28fad3..2671e14 100644
--- a/agora-test/Spec/Model/Treasury.hs
+++ b/agora-test/Spec/Model/Treasury.hs
@@ -70,11 +70,11 @@ import Plutus.V1.Ledger.Credential (Credential (PubKeyCredential, ScriptCredenti
 import Plutus.V1.Ledger.Scripts (Script, ValidatorHash (ValidatorHash))
 import Plutus.V1.Ledger.Value (
   CurrencySymbol (CurrencySymbol),
-  TokenName (unTokenName),
+  TokenName (TokenName, unTokenName),
   Value (Value, getValue),
  )
 import PlutusTx.AssocMap (Map, elems, fromList, keys, singleton, toList, unionWith)
-import PlutusTx.AssocMap qualified as AssocMap (lookup)
+import PlutusTx.AssocMap qualified as AssocMap (insert, lookup)
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Hedgehog (fromGroup)
 
@@ -178,15 +178,26 @@ replaceValue (Value v) cs tn n = Value $ unionWith (\_ x -> x) v v'
 kmap :: (k -> k') -> Map k v -> Map k' v
 kmap g = fromList . fmap (first g) . toList
 
-fixTokenNames :: TxInInfo -> TxInInfo
-fixTokenNames inf =
+fixTokenNames :: CurrencySymbol -> TxInInfo -> TxInInfo
+fixTokenNames cs inf =
   let cred = inf.txInInfoResolved.txOutAddress.addressCredential
-      val = inf.txInInfoResolved.txOutValue
+      Value val = inf.txInInfoResolved.txOutValue
    in case cred of
         PubKeyCredential _ -> inf
-        ScriptCredential (ValidatorHash bs) -> undefined
+        ScriptCredential (ValidatorHash bs) ->
+          case AssocMap.lookup cs val of
+            Nothing -> inf
+            Just m ->
+              let tn :: TokenName = TokenName bs
+                  m' = kmap (\_ -> tn) m
+                  v' = Value $ AssocMap.insert cs m' val
+               in inf
+                    { txInInfoResolved =
+                        inf.txInInfoResolved
+                          { txOutValue = v'
+                          }
+                    }
 
--- | TODO: Define.
 instance HasPermutationGenerator TreasuryTxProp TreasuryTxModel where
   generators :: [Morphism TreasuryTxProp TreasuryTxModel]
   generators =
@@ -237,7 +248,7 @@ instance HasPermutationGenerator TreasuryTxProp TreasuryTxModel where
                           { scriptContextTxInfo =
                               txInfo
                                 { txInfoInputs =
-                                    fixTokenNames <$> infoInputs
+                                    fixTokenNames m.gatCs <$> infoInputs
                                 }
                           }
                     }

From 9490701dbb1981e63ed8e2807b9ef1fae161363d Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Fri, 29 Apr 2022 14:00:44 +0100
Subject: [PATCH 15/24] CekEvaluationError

---
 agora-test/Spec.hs                |  1 +
 agora-test/Spec/Model/Treasury.hs | 99 +++++++++++++++++++++++++++----
 2 files changed, 88 insertions(+), 12 deletions(-)

diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs
index 37a6267..a61e7ee 100644
--- a/agora-test/Spec.hs
+++ b/agora-test/Spec.hs
@@ -36,6 +36,7 @@ main =
           [ testGroup
               "Treasury"
               [ Treasury.genTests
+              , Treasury.plutarchTests
               ]
           ]
       ]
diff --git a/agora-test/Spec/Model/Treasury.hs b/agora-test/Spec/Model/Treasury.hs
index 2671e14..db54d5e 100644
--- a/agora-test/Spec/Model/Treasury.hs
+++ b/agora-test/Spec/Model/Treasury.hs
@@ -35,11 +35,13 @@ import Apropos (
   Contract,
   Enumerable (enumerated),
   Formula (
+    All,
     Not,
     Some,
     Var,
     Yes,
-    (:&&:)
+    (:&&:),
+    (:||:)
   ),
   Gen,
   HasLogicalModel (satisfiesProperty),
@@ -48,20 +50,25 @@ import Apropos (
   LogicalModel (logic),
   Morphism (Morphism, contract, match, morphism, name),
   add,
+  choice,
+  remove,
   runGeneratorTestsWhere,
   (:+),
  )
-import Apropos.Gen.Contexts (scriptContext, txInInfo)
+import Apropos.Gen.Contexts (scriptContext, txInInfo, txOutRef)
+import Apropos.Gen.Credential (stakingCredential)
+import Apropos.Gen.DCert (dCert)
 import Apropos.Gen.Value (currencySymbol)
 import Apropos.Script (ScriptModel (expect, runScriptTestsWhere, script))
 import Data.Bifunctor (Bifunctor (first))
+import Data.Maybe (listToMaybe)
 import Data.Set (Set)
 import Plutarch.Api.V1 (PCurrencySymbol, PScriptContext)
 import Plutarch.Builtin (pforgetData)
 import Plutus.V1.Ledger.Address (Address (addressCredential))
 import Plutus.V1.Ledger.Contexts (
   ScriptContext (scriptContextPurpose, scriptContextTxInfo),
-  ScriptPurpose (Minting),
+  ScriptPurpose (Certifying, Minting, Rewarding, Spending),
   TxInInfo (txInInfoResolved),
   TxInfo (txInfoInputs, txInfoMint, txInfoOutputs),
   TxOut (txOutAddress, txOutValue),
@@ -73,8 +80,9 @@ import Plutus.V1.Ledger.Value (
   TokenName (TokenName, unTokenName),
   Value (Value, getValue),
  )
+import Plutus.V1.Ledger.Value qualified as Value (unionWith)
 import PlutusTx.AssocMap (Map, elems, fromList, keys, singleton, toList, unionWith)
-import PlutusTx.AssocMap qualified as AssocMap (insert, lookup)
+import PlutusTx.AssocMap qualified as AssocMap (delete, insert, lookup)
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Hedgehog (fromGroup)
 
@@ -86,12 +94,7 @@ data TreasuryTxProp
 
 instance LogicalModel TreasuryTxProp where
   logic :: Formula TreasuryTxProp
-  logic =
-    Some
-      [ Var GATIsBurned
-      , Var AllGATsValid
-      , Var ScriptPurposeIsMinting
-      ]
+  logic = Yes
 
 data TreasuryTxModel = TreasuryTxModel
   { gatCs :: CurrencySymbol
@@ -183,7 +186,9 @@ fixTokenNames cs inf =
   let cred = inf.txInInfoResolved.txOutAddress.addressCredential
       Value val = inf.txInInfoResolved.txOutValue
    in case cred of
-        PubKeyCredential _ -> inf
+        PubKeyCredential _ ->
+          let newVal = Value $ AssocMap.delete cs val
+           in inf {txInInfoResolved = inf.txInInfoResolved {txOutValue = newVal}}
         ScriptCredential (ValidatorHash bs) ->
           case AssocMap.lookup cs val of
             Nothing -> inf
@@ -266,6 +271,77 @@ instance HasPermutationGenerator TreasuryTxProp TreasuryTxModel where
                       }
                 }
         }
+    , Morphism
+        { name = "Ensure GAT is not burned"
+        , match = Var GATIsBurned
+        , contract = remove GATIsBurned
+        , morphism = \m ->
+            let ctx' = m.ctx
+                txInfo = ctx'.scriptContextTxInfo
+                mint = txInfo.txInfoMint
+                newMint = replaceValue mint m.gatCs "gat" 0
+             in return
+                  m
+                    { ctx =
+                        ctx'
+                          { scriptContextTxInfo =
+                              txInfo
+                                { txInfoMint = newMint
+                                }
+                          }
+                    }
+        }
+    , Morphism
+        { name = "Ensure ScriptPurpose is not Minting"
+        , match = Var ScriptPurposeIsMinting
+        , contract = remove ScriptPurposeIsMinting
+        , morphism = \m -> do
+            newPurpose <-
+              choice
+                [ Spending <$> txOutRef
+                , Rewarding <$> stakingCredential
+                , Certifying <$> dCert
+                ]
+            return m {ctx = m.ctx {scriptContextPurpose = newPurpose}}
+        }
+    , Morphism
+        { name = "Ensure not all GATs are valid."
+        , match = Var AllGATsValid
+        , contract = remove AllGATsValid
+        , morphism = \m -> do
+            dummyInp <- txInInfo
+            let ctx' = m.ctx
+                txInfo = ctx'.scriptContextTxInfo
+                inputs = txInfo.txInfoInputs
+                firstIn = listToMaybe inputs
+                inp = case firstIn of
+                  Nothing -> dummyInp
+                  Just inp' -> inp'
+                inVal = inp.txInInfoResolved.txOutValue
+                invalidGat =
+                  Value $
+                    singleton m.gatCs $
+                      singleton "notAnAddress" (-1)
+                newVal = Value.unionWith (+) inVal invalidGat
+                newIn =
+                  inp
+                    { txInInfoResolved =
+                        inp.txInInfoResolved
+                          { txOutValue = newVal
+                          }
+                    }
+                newInputs = newIn : drop 1 inputs
+            return
+              m
+                { ctx =
+                    ctx'
+                      { scriptContextTxInfo =
+                          txInfo
+                            { txInfoInputs = newInputs
+                            }
+                      }
+                }
+        }
     ]
 
 instance ScriptModel TreasuryTxProp TreasuryTxModel where
@@ -274,7 +350,6 @@ instance ScriptModel TreasuryTxProp TreasuryTxModel where
     Var GATIsBurned
       :&&: Var AllGATsValid
       :&&: Var ScriptPurposeIsMinting
-
   script :: (TreasuryTxModel :+ TreasuryTxProp) -> TreasuryTxModel -> Script
   script _ m = compile result
     where

From 4fe380b4c29827831bc40a988159ea305050f4eb Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Wed, 4 May 2022 17:06:26 +0100
Subject: [PATCH 16/24] Added treasury samples and tests

---
 agora-test/Spec.hs                 |  13 ++-
 agora-test/Spec/Sample/Treasury.hs | 165 ++++++++++++++++++++++++++++-
 agora-test/Spec/Treasury.hs        |  96 ++++++++++++++++-
 agora-test/Spec/Util.hs            |  29 ++++-
 4 files changed, 296 insertions(+), 7 deletions(-)

diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs
index ca36558..709be31 100644
--- a/agora-test/Spec.hs
+++ b/agora-test/Spec.hs
@@ -1,4 +1,11 @@
-{-# OPTIONS_GHC -Wwarn #-}
+{- |
+Module: Main
+Description: Agora test suite.
+Maintainer: emi@haskell.fyi
+
+This module is the root of Agora's test suite.
+-}
+module Main (main) where
 
 --------------------------------------------------------------------------------
 
@@ -15,6 +22,7 @@ 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
+import Spec.Treasury qualified as Treasury
 
 -- | The Agora test suite.
 main :: IO ()
@@ -45,4 +53,7 @@ main =
       , testGroup
           "AuthorityToken tests"
           AuthorityToken.tests
+      , testGroup
+          "Treasury tests"
+          Treasury.tests
       ]
diff --git a/agora-test/Spec/Sample/Treasury.hs b/agora-test/Spec/Sample/Treasury.hs
index c3ffbd6..09cf7f7 100644
--- a/agora-test/Spec/Sample/Treasury.hs
+++ b/agora-test/Spec/Sample/Treasury.hs
@@ -1 +1,164 @@
-module Spec.Sample.Treasury () where
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wwarn #-}
+
+{- |
+Module: Spec.Sample.Treasury
+Description: Sample data for `Spec.Treasury`.
+Maintainer: jack@mlabs.city
+
+This module contains sample data, used in the tests written in
+`Spec.Treasury`.
+-}
+module Spec.Sample.Treasury (
+  BadTreasuryRedeemer (NukeTheSystem),
+  gatCs,
+  validCtx,
+  treasuryRef,
+  gatTn,
+) where
+
+import Agora.Effect.NoOp (noOpValidator)
+import Agora.Treasury (TreasuryRedeemer (SpendTreasuryGAT), treasuryValidator)
+import GHC.Generics qualified as GHC
+import Generics.SOP (Generic, I (I))
+import Plutarch.Api.V1 (mkValidator, validatorHash)
+import Plutarch.DataRepr (
+  DerivePConstantViaData (..),
+  PIsDataReprInstances (..),
+ )
+import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
+import Plutus.V1.Ledger.Address (Address (..))
+import Plutus.V1.Ledger.Api (BuiltinByteString)
+import Plutus.V1.Ledger.Contexts (
+  ScriptContext (..),
+  ScriptPurpose (Minting),
+  TxInInfo (..),
+  TxInfo (..),
+  TxOut (..),
+  TxOutRef (..),
+ )
+import Plutus.V1.Ledger.Credential (Credential (ScriptCredential))
+import Plutus.V1.Ledger.Interval qualified as Interval
+import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash (ValidatorHash))
+import Plutus.V1.Ledger.Value (CurrencySymbol, TokenName (TokenName))
+import Plutus.V1.Ledger.Value qualified as Value
+import PlutusTx qualified
+import Spec.Sample.Shared (signer)
+import Spec.Util (datumPair, toDatumHash)
+
+{- | Arbitrary 'CurrencySymbol', representing the 'CurrencySymbol'
+     of a valid governance authority token (GAT).
+-}
+gatCs :: CurrencySymbol
+gatCs = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
+
+trValidator :: Validator
+trValidator = mkValidator (treasuryValidator gatCs)
+
+{- | A `ScriptContext` that should be compatible with treasury
+     transactions.
+-}
+validCtx :: ScriptContext
+validCtx =
+  ScriptContext
+    { scriptContextPurpose = Minting gatCs
+    , scriptContextTxInfo =
+        TxInfo
+          { txInfoInputs =
+              [ treasuryIn
+              , effectIn
+              ]
+          , txInfoOutputs =
+              [ treasuryOut
+              ]
+          , -- Ensure sufficient ADA for transaction costs.
+            txInfoFee = Value.singleton "" "" 2 -- 2 ADA.
+          , -- Burn the GAT.
+            txInfoMint = Value.singleton gatCs gatTn (-1)
+          , txInfoDCert = []
+          , txInfoWdrl = []
+          , txInfoValidRange = Interval.always
+          , txInfoSignatories = [signer]
+          , txInfoData =
+              [ datumPair treasuryIn
+              , datumPair treasuryOut
+              , datumPair effectIn
+              ]
+          , txInfoId =
+              "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
+          }
+    }
+  where
+    treasuryIn =
+      TxInInfo
+        { txInInfoOutRef = treasuryRef
+        , txInInfoResolved = treasuryOut
+        }
+    effectIn =
+      TxInInfo
+        { txInInfoOutRef = effectRef
+        , txInInfoResolved =
+            TxOut
+              { txOutAddress =
+                  Address (ScriptCredential $ validatorHash mockEffect) Nothing
+              , txOutValue = Value.singleton gatCs gatTn 1
+              , txOutDatumHash = Just (toDatumHash ())
+              }
+        }
+    treasuryOut :: TxOut =
+      TxOut
+        { txOutAddress =
+            Address
+              (ScriptCredential $ validatorHash trValidator)
+              Nothing
+        , txOutValue = Value.singleton "" "" 0
+        , txOutDatumHash = Just (toDatumHash ())
+        }
+
+treasuryRef :: TxOutRef
+treasuryRef = TxOutRef "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" 1
+
+effectRef :: TxOutRef
+effectRef = TxOutRef "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3" 0
+
+mockEffect :: Validator
+mockEffect = mkValidator $ noOpValidator gatCs
+
+addressBs :: BuiltinByteString
+(ValidatorHash addressBs) = validatorHash mockEffect
+
+gatTn :: TokenName
+gatTn = TokenName addressBs
+
+------------------------------------------------------------------
+
+-- Invalid treasury redeemer.
+
+data BadTreasuryRedeemer = NukeTheSystem
+  deriving stock (Eq, Show, GHC.Generic)
+
+PlutusTx.makeIsDataIndexed
+  ''BadTreasuryRedeemer
+  [ ('NukeTheSystem, 0)
+  ]
+
+data PBadTreasuryRedeemer (s :: S)
+  = PNukeTheSystem (Term s (PDataRecord '[]))
+  deriving stock (GHC.Generic)
+  deriving anyclass (Generic)
+  deriving anyclass (PIsDataRepr)
+  deriving
+    (PlutusType, PIsData)
+    via PIsDataReprInstances PBadTreasuryRedeemer
+
+instance PUnsafeLiftDecl PBadTreasuryRedeemer where
+  type PLifted PBadTreasuryRedeemer = BadTreasuryRedeemer
+deriving via
+  ( DerivePConstantViaData
+      BadTreasuryRedeemer
+      PBadTreasuryRedeemer
+  )
+  instance
+    (PConstantDecl BadTreasuryRedeemer)
+
+------------------------------------------------------------------
diff --git a/agora-test/Spec/Treasury.hs b/agora-test/Spec/Treasury.hs
index 2285b7b..d431a96 100644
--- a/agora-test/Spec/Treasury.hs
+++ b/agora-test/Spec/Treasury.hs
@@ -1,10 +1,102 @@
+{-# OPTIONS_GHC -Wwarn #-}
+
+{- |
+Module: Spec.Treasury
+Description: Tests for Agora treasury.
+Maintainer: jack@mlabs.city
+
+This module exports `tests`, a list of `TestTree`s, which ensure
+that Agora's treasury component works as desired.
+-}
 module Spec.Treasury (tests) where
 
+import Agora.Treasury (
+  TreasuryRedeemer (SpendTreasuryGAT),
+  treasuryValidator,
+ )
+import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
+import Plutus.V1.Ledger.Contexts (
+  ScriptContext (scriptContextPurpose, scriptContextTxInfo),
+  ScriptPurpose (Spending),
+  TxInfo (txInfoMint),
+ )
+import Plutus.V1.Ledger.Value qualified as Value
+import PlutusTx qualified
+import Spec.Sample.Treasury (
+  BadTreasuryRedeemer (NukeTheSystem),
+  gatCs,
+  gatTn,
+  treasuryRef,
+  validCtx,
+ )
+import Spec.Util (validatorFailsWith, validatorSucceedsWith)
 import Test.Tasty (TestTree, testGroup)
 
+{-
+
+`Spec.Util` provides a number of useful functions:
+
+  - policySucceedsWith: checks that a minting policy succeeds.
+
+  - policyFailsWith: checks that a minting policy fails.
+
+  - validatorSucceedsWith: checks that validator succeeds.
+
+  - validatorFailsWith: checks that validator fails.
+
+  - scriptSucceeds: checks that an arbitrary script does not
+    `perror`.
+
+  - scriptFails: checks that an arbitrary script `perror`s out.
+
+-}
+
+{-
+
+Tests need to fail when:
+
+  1. The reedeemer is of inproper form.
+  2. The script purpose is not minting.
+  3. `singleAuthorityTokenBurned` returns false.
+    a. Multiple GATs burned.
+    b. An input returns 'False' for 'authorityTokensValidIn'
+
+-}
+
 tests :: [TestTree]
 tests =
   [ testGroup
-      "treasury"
-      []
+      "validator"
+      [ validatorSucceedsWith
+          "Allows for effect changes"
+          (treasuryValidator gatCs)
+          ()
+          SpendTreasuryGAT
+          validCtx
+      , validatorFailsWith
+          "Fails with invalid redeemer"
+          (treasuryValidator gatCs)
+          ()
+          (NukeTheSystem)
+          validCtx
+      , validatorFailsWith
+          "Fails with ScriptPurpose not Minting"
+          (treasuryValidator gatCs)
+          ()
+          SpendTreasuryGAT
+          validCtx
+            { scriptContextPurpose = Spending treasuryRef
+            }
+      , validatorFailsWith
+          "Fails when multiple GATs burned"
+          (treasuryValidator gatCs)
+          ()
+          SpendTreasuryGAT
+          validCtx
+            { scriptContextTxInfo =
+                validCtx.scriptContextTxInfo
+                  { txInfoMint = Value.singleton gatCs gatTn (-2)
+                  }
+            }
+      ]
   ]
diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs
index 365ad50..31347e1 100644
--- a/agora-test/Spec/Util.hs
+++ b/agora-test/Spec/Util.hs
@@ -3,7 +3,24 @@ Module     : Spec.Util
 Maintainer : emi@haskell.fyi
 Description: Utility functions for testing Plutarch scripts with ScriptContext
 
-Utility functions for testing Plutarch scripts with ScriptContext
+Utility functions for testing Plutarch scripts with ScriptContext:
+
+  - 'policySucceedsWith': checks that a minting policy succeeds.
+
+  - 'policyFailsWith': checks that a minting policy fails.
+
+  - 'validatorSucceedsWith': checks that validator succeeds.
+
+  - 'validatorFailsWith': checks that validator fails.
+
+  - 'effectSucceedsWith': checks that effect succeeds.
+
+  - 'effectFailsWith': checks that effect fails.
+
+  - 'scriptSucceeds': checks that an arbitrary script does not
+    `perror`.
+
+  - 'scriptFails': checks that an arbitrary script `perror`s out.
 -}
 module Spec.Util (
   -- * Testing utils
@@ -131,7 +148,9 @@ validatorFailsWith tag validator datum redeemer scriptContext =
           # pconstant scriptContext
       )
 
--- | Check that a validator script succeeds, given a name and arguments.
+{- | Check that a validator script succeeds, given a name and arguments.
+     TODO: Change docstring.
+-}
 effectSucceedsWith ::
   ( PLift datum
   , PlutusTx.ToData (PLifted datum)
@@ -143,7 +162,11 @@ effectSucceedsWith ::
   TestTree
 effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum ()
 
--- | Check that a validator script fails, given a name and arguments.
+-- TODO: Change docstring.
+
+{- | Check that a validator script fails, given a name and arguments.
+     TODO: Change docstring.
+-}
 effectFailsWith ::
   ( PLift datum
   , PlutusTx.ToData (PLifted datum)

From a64f10c7128f37e04bbc295e0979e240109a3b28 Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Thu, 5 May 2022 12:03:10 +0100
Subject: [PATCH 17/24] finished first draft of treasury tests

---
 agora-test/Spec/Sample/Treasury.hs |  78 +++++++---
 agora-test/Spec/Treasury.hs        | 220 ++++++++++++++++++++---------
 agora.cabal                        |   1 +
 agora/Agora/Treasury.hs            |   8 +-
 4 files changed, 219 insertions(+), 88 deletions(-)

diff --git a/agora-test/Spec/Sample/Treasury.hs b/agora-test/Spec/Sample/Treasury.hs
index 09cf7f7..529c477 100644
--- a/agora-test/Spec/Sample/Treasury.hs
+++ b/agora-test/Spec/Sample/Treasury.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE TemplateHaskell #-}
-{-# OPTIONS_GHC -Wwarn #-}
 
 {- |
 Module: Spec.Sample.Treasury
@@ -15,10 +14,14 @@ module Spec.Sample.Treasury (
   validCtx,
   treasuryRef,
   gatTn,
+  walletIn,
+  trCredential,
 ) where
 
 import Agora.Effect.NoOp (noOpValidator)
-import Agora.Treasury (TreasuryRedeemer (SpendTreasuryGAT), treasuryValidator)
+import Agora.Treasury (
+  treasuryValidator,
+ )
 import GHC.Generics qualified as GHC
 import Generics.SOP (Generic, I (I))
 import Plutarch.Api.V1 (mkValidator, validatorHash)
@@ -28,7 +31,11 @@ import Plutarch.DataRepr (
  )
 import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
 import Plutus.V1.Ledger.Address (Address (..))
-import Plutus.V1.Ledger.Api (BuiltinByteString)
+import Plutus.V1.Ledger.Api (
+  BuiltinByteString,
+  Credential (PubKeyCredential),
+  PubKeyHash (PubKeyHash),
+ )
 import Plutus.V1.Ledger.Contexts (
   ScriptContext (..),
   ScriptPurpose (Minting),
@@ -39,8 +46,14 @@ import Plutus.V1.Ledger.Contexts (
  )
 import Plutus.V1.Ledger.Credential (Credential (ScriptCredential))
 import Plutus.V1.Ledger.Interval qualified as Interval
-import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash (ValidatorHash))
-import Plutus.V1.Ledger.Value (CurrencySymbol, TokenName (TokenName))
+import Plutus.V1.Ledger.Scripts (
+  Validator,
+  ValidatorHash (ValidatorHash),
+ )
+import Plutus.V1.Ledger.Value (
+  CurrencySymbol,
+  TokenName (TokenName),
+ )
 import Plutus.V1.Ledger.Value qualified as Value
 import PlutusTx qualified
 import Spec.Sample.Shared (signer)
@@ -107,34 +120,64 @@ validCtx =
         }
     treasuryOut :: TxOut =
       TxOut
-        { txOutAddress =
-            Address
-              (ScriptCredential $ validatorHash trValidator)
-              Nothing
+        { txOutAddress = Address trCredential Nothing
         , txOutValue = Value.singleton "" "" 0
         , txOutDatumHash = Just (toDatumHash ())
         }
 
+-- | Reference to treasury output.
 treasuryRef :: TxOutRef
-treasuryRef = TxOutRef "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" 1
+treasuryRef =
+  TxOutRef
+    "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
+    1
 
+-- | Reference to dummy effect output.
 effectRef :: TxOutRef
-effectRef = TxOutRef "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3" 0
+effectRef =
+  TxOutRef
+    "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
+    0
 
+-- | `ScriptCredential` used for the dummy treasury validator.
+trCredential :: Credential
+trCredential = ScriptCredential $ validatorHash trValidator
+
+-- | Mock effect script, used for testing.
 mockEffect :: Validator
 mockEffect = mkValidator $ noOpValidator gatCs
 
+-- | The hash of the mock effect script.
 addressBs :: BuiltinByteString
 (ValidatorHash addressBs) = validatorHash mockEffect
 
+-- | `TokenName` for GAT generated from address of `mockEffect`.
 gatTn :: TokenName
 gatTn = TokenName addressBs
 
-------------------------------------------------------------------
+-- | Input representing a user wallet with a valid GAT.
+walletIn :: TxInInfo
+walletIn =
+  TxInInfo
+    { txInInfoOutRef =
+        TxOutRef
+          "cf4a8b33dd8e4493187e3339ecc3802d0cc000c947fb5559b7614153947d4e83"
+          0
+    , txInInfoResolved =
+        TxOut
+          { txOutDatumHash = Nothing
+          , txOutValue = Value.singleton gatCs gatTn 1
+          , txOutAddress =
+              Address
+                (PubKeyCredential $ PubKeyHash addressBs)
+                Nothing
+          }
+    }
 
--- Invalid treasury redeemer.
-
-data BadTreasuryRedeemer = NukeTheSystem
+-- | Unsupported treasury redeemer.
+data BadTreasuryRedeemer
+  = -- | Unsupported treasury redeemer.
+    NukeTheSystem Integer
   deriving stock (Eq, Show, GHC.Generic)
 
 PlutusTx.makeIsDataIndexed
@@ -142,8 +185,9 @@ PlutusTx.makeIsDataIndexed
   [ ('NukeTheSystem, 0)
   ]
 
+-- | Plutarch implementation of `BadTreasuryRedeemer`.
 data PBadTreasuryRedeemer (s :: S)
-  = PNukeTheSystem (Term s (PDataRecord '[]))
+  = PNukeTheSystem (Term s (PDataRecord '["_0" ':= PInteger]))
   deriving stock (GHC.Generic)
   deriving anyclass (Generic)
   deriving anyclass (PIsDataRepr)
@@ -160,5 +204,3 @@ deriving via
   )
   instance
     (PConstantDecl BadTreasuryRedeemer)
-
-------------------------------------------------------------------
diff --git a/agora-test/Spec/Treasury.hs b/agora-test/Spec/Treasury.hs
index d431a96..96790f0 100644
--- a/agora-test/Spec/Treasury.hs
+++ b/agora-test/Spec/Treasury.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -Wwarn #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 {- |
 Module: Spec.Treasury
@@ -7,6 +7,17 @@ Maintainer: jack@mlabs.city
 
 This module exports `tests`, a list of `TestTree`s, which ensure
 that Agora's treasury component works as desired.
+
+Tests need to fail when:
+
+  1. The reedeemer is of inproper form. TODO: Inquire.
+  2. The script purpose is not minting.
+  3. `singleAuthorityTokenBurned` returns false.
+    a. @n /= -1@ GATs burned.
+    b. An input returns 'False' for 'authorityTokensValidIn'
+      i. A wallet input has a GAT.
+      ii. A script has a GAT, the token name for which does /not/
+          match the script's validator hash.
 -}
 module Spec.Treasury (tests) where
 
@@ -14,89 +25,162 @@ import Agora.Treasury (
   TreasuryRedeemer (SpendTreasuryGAT),
   treasuryValidator,
  )
-import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
+import Plutus.V1.Ledger.Address (Address (Address))
+import Plutus.V1.Ledger.Api (
+  BuiltinByteString,
+  DCert (DCertDelegRegKey),
+ )
 import Plutus.V1.Ledger.Contexts (
   ScriptContext (scriptContextPurpose, scriptContextTxInfo),
-  ScriptPurpose (Spending),
-  TxInfo (txInfoMint),
+  ScriptPurpose (Certifying, Rewarding, Spending),
+  TxInfo (txInfoInputs, txInfoMint),
+  txInInfoResolved,
+  txOutAddress,
+ )
+import Plutus.V1.Ledger.Credential (
+  Credential (ScriptCredential),
+  StakingCredential (StakingHash),
+ )
+import Plutus.V1.Ledger.Scripts (
+  ValidatorHash (ValidatorHash),
  )
 import Plutus.V1.Ledger.Value qualified as Value
-import PlutusTx qualified
 import Spec.Sample.Treasury (
   BadTreasuryRedeemer (NukeTheSystem),
   gatCs,
   gatTn,
+  trCredential,
   treasuryRef,
   validCtx,
+  walletIn,
  )
 import Spec.Util (validatorFailsWith, validatorSucceedsWith)
 import Test.Tasty (TestTree, testGroup)
 
-{-
-
-`Spec.Util` provides a number of useful functions:
-
-  - policySucceedsWith: checks that a minting policy succeeds.
-
-  - policyFailsWith: checks that a minting policy fails.
-
-  - validatorSucceedsWith: checks that validator succeeds.
-
-  - validatorFailsWith: checks that validator fails.
-
-  - scriptSucceeds: checks that an arbitrary script does not
-    `perror`.
-
-  - scriptFails: checks that an arbitrary script `perror`s out.
-
--}
-
-{-
-
-Tests need to fail when:
-
-  1. The reedeemer is of inproper form.
-  2. The script purpose is not minting.
-  3. `singleAuthorityTokenBurned` returns false.
-    a. Multiple GATs burned.
-    b. An input returns 'False' for 'authorityTokensValidIn'
-
--}
-
 tests :: [TestTree]
 tests =
   [ testGroup
-      "validator"
-      [ validatorSucceedsWith
-          "Allows for effect changes"
-          (treasuryValidator gatCs)
-          ()
-          SpendTreasuryGAT
-          validCtx
-      , validatorFailsWith
-          "Fails with invalid redeemer"
-          (treasuryValidator gatCs)
-          ()
-          (NukeTheSystem)
-          validCtx
-      , validatorFailsWith
-          "Fails with ScriptPurpose not Minting"
-          (treasuryValidator gatCs)
-          ()
-          SpendTreasuryGAT
-          validCtx
-            { scriptContextPurpose = Spending treasuryRef
-            }
-      , validatorFailsWith
-          "Fails when multiple GATs burned"
-          (treasuryValidator gatCs)
-          ()
-          SpendTreasuryGAT
-          validCtx
-            { scriptContextTxInfo =
-                validCtx.scriptContextTxInfo
-                  { txInfoMint = Value.singleton gatCs gatTn (-2)
-                  }
-            }
+      "Validator"
+      [ testGroup
+          "Positive"
+          [ validatorSucceedsWith
+              "Allows for effect changes"
+              (treasuryValidator gatCs)
+              ()
+              SpendTreasuryGAT
+              validCtx
+          ]
+      , testGroup
+          "Negative"
+          [ testGroup
+              "Fails with ScriptPurpose not Minting"
+              [ validatorFailsWith
+                  "Spending"
+                  (treasuryValidator gatCs)
+                  ()
+                  SpendTreasuryGAT
+                  validCtx
+                    { scriptContextPurpose = Spending treasuryRef
+                    }
+              , validatorFailsWith
+                  "Rewarding"
+                  (treasuryValidator gatCs)
+                  ()
+                  SpendTreasuryGAT
+                  validCtx
+                    { scriptContextPurpose =
+                        Rewarding $
+                          StakingHash trCredential
+                    }
+              , validatorFailsWith
+                  "Certifying"
+                  (treasuryValidator gatCs)
+                  ()
+                  SpendTreasuryGAT
+                  validCtx
+                    { scriptContextPurpose =
+                        Certifying $
+                          DCertDelegRegKey $
+                            StakingHash trCredential
+                    }
+              ]
+          , -- , validatorFailsWith -- TODO: Check.
+            --     "Fails with invalid redeemer"
+            --     (treasuryValidator gatCs)
+            --     ()
+            --     (NukeTheSystem 72)
+            --     validCtx
+
+            validatorFailsWith -- TODO: Use QuickCheck.
+              "Fails when multiple GATs burned"
+              (treasuryValidator gatCs)
+              ()
+              SpendTreasuryGAT
+              validCtx
+                { scriptContextTxInfo =
+                    validCtx.scriptContextTxInfo
+                      { txInfoMint =
+                          Value.singleton
+                            gatCs
+                            gatTn
+                            (-2)
+                      }
+                }
+          , validatorFailsWith
+              "Fails when GAT token name is not script address"
+              (treasuryValidator gatCs)
+              ()
+              SpendTreasuryGAT
+              ( let txInfo = validCtx.scriptContextTxInfo
+                    inputs = txInfo.txInfoInputs
+                    effectIn = inputs !! 1
+                    invalidEff =
+                      effectIn
+                        { txInInfoResolved =
+                            effectIn.txInInfoResolved
+                              { txOutAddress =
+                                  Address
+                                    ( ScriptCredential $
+                                        ValidatorHash
+                                          wrongHash
+                                    )
+                                    Nothing
+                              }
+                        }
+                 in validCtx
+                      { scriptContextTxInfo =
+                          txInfo
+                            { txInfoInputs =
+                                [ inputs !! 0
+                                , invalidEff
+                                ]
+                            }
+                      }
+              )
+          , validatorFailsWith
+              "Fails with wallet as input"
+              (treasuryValidator gatCs)
+              ()
+              SpendTreasuryGAT
+              ( let txInfo = validCtx.scriptContextTxInfo
+                    inputs = txInfo.txInfoInputs
+                    newInputs =
+                      [ inputs !! 0
+                      , walletIn
+                      ]
+                 in validCtx
+                      { scriptContextTxInfo =
+                          txInfo
+                            { txInfoInputs = newInputs
+                            }
+                      }
+              )
+          ]
       ]
   ]
+
+{- | A SHA-256 hash which (in all certainty) should not match the
+     hash of the dummy effect script.
+-}
+wrongHash :: BuiltinByteString
+wrongHash = "a21bc4a1d95600f9fa0a00b97ed0fa49a152a72de76253cb706f90b4b40f837b"
diff --git a/agora.cabal b/agora.cabal
index 4d90182..2cbc0a8 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -113,6 +113,7 @@ common test-deps
   build-depends:
     , apropos
     , apropos-tx
+    , lens
     , QuickCheck
     , quickcheck-instances
     , tasty
diff --git a/agora/Agora/Treasury.hs b/agora/Agora/Treasury.hs
index 6e75c8e..1d113f9 100644
--- a/agora/Agora/Treasury.hs
+++ b/agora/Agora/Treasury.hs
@@ -60,8 +60,12 @@ deriving via
   instance
     PTryFrom PData (PAsData PTreasuryRedeemer)
 
-instance PUnsafeLiftDecl PTreasuryRedeemer where type PLifted PTreasuryRedeemer = TreasuryRedeemer
-deriving via (DerivePConstantViaData TreasuryRedeemer PTreasuryRedeemer) instance (PConstantDecl TreasuryRedeemer)
+instance PUnsafeLiftDecl PTreasuryRedeemer where
+  type PLifted PTreasuryRedeemer = TreasuryRedeemer
+deriving via
+  (DerivePConstantViaData TreasuryRedeemer PTreasuryRedeemer)
+  instance
+    (PConstantDecl TreasuryRedeemer)
 
 --------------------------------------------------------------------------------
 

From 7811636571c555c6138e64ec827ef6031730b876 Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Thu, 5 May 2022 13:40:56 +0100
Subject: [PATCH 18/24] applied linting and formatting suggestions

---
 agora-test/Spec/Sample/Treasury.hs | 4 ++--
 agora-test/Spec/Treasury.hs        | 6 +++---
 2 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/agora-test/Spec/Sample/Treasury.hs b/agora-test/Spec/Sample/Treasury.hs
index 529c477..9255275 100644
--- a/agora-test/Spec/Sample/Treasury.hs
+++ b/agora-test/Spec/Sample/Treasury.hs
@@ -175,7 +175,7 @@ walletIn =
     }
 
 -- | Unsupported treasury redeemer.
-data BadTreasuryRedeemer
+newtype BadTreasuryRedeemer
   = -- | Unsupported treasury redeemer.
     NukeTheSystem Integer
   deriving stock (Eq, Show, GHC.Generic)
@@ -186,7 +186,7 @@ PlutusTx.makeIsDataIndexed
   ]
 
 -- | Plutarch implementation of `BadTreasuryRedeemer`.
-data PBadTreasuryRedeemer (s :: S)
+newtype PBadTreasuryRedeemer (s :: S)
   = PNukeTheSystem (Term s (PDataRecord '["_0" ':= PInteger]))
   deriving stock (GHC.Generic)
   deriving anyclass (Generic)
diff --git a/agora-test/Spec/Treasury.hs b/agora-test/Spec/Treasury.hs
index 96790f0..dd319d0 100644
--- a/agora-test/Spec/Treasury.hs
+++ b/agora-test/Spec/Treasury.hs
@@ -46,7 +46,7 @@ import Plutus.V1.Ledger.Scripts (
  )
 import Plutus.V1.Ledger.Value qualified as Value
 import Spec.Sample.Treasury (
-  BadTreasuryRedeemer (NukeTheSystem),
+  -- BadTreasuryRedeemer (NukeTheSystem),
   gatCs,
   gatTn,
   trCredential,
@@ -151,7 +151,7 @@ tests =
                       { scriptContextTxInfo =
                           txInfo
                             { txInfoInputs =
-                                [ inputs !! 0
+                                [ head inputs
                                 , invalidEff
                                 ]
                             }
@@ -165,7 +165,7 @@ tests =
               ( let txInfo = validCtx.scriptContextTxInfo
                     inputs = txInfo.txInfoInputs
                     newInputs =
-                      [ inputs !! 0
+                      [ head inputs
                       , walletIn
                       ]
                  in validCtx

From f075d33b0d2b7913057e4c3b65f70a55755d6e82 Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Fri, 6 May 2022 10:36:21 +0100
Subject: [PATCH 19/24] Added review changes

---
 agora-test/Spec.hs                 |  23 ++-----
 agora-test/Spec/Sample/Shared.hs   |  55 ++++++++++++++++
 agora-test/Spec/Sample/Treasury.hs | 101 +++++------------------------
 agora-test/Spec/Treasury.hs        |  17 ++---
 agora.cabal                        |   4 +-
 5 files changed, 85 insertions(+), 115 deletions(-)

diff --git a/agora-test/Spec.hs b/agora-test/Spec.hs
index 709be31..5df4023 100644
--- a/agora-test/Spec.hs
+++ b/agora-test/Spec.hs
@@ -1,14 +1,3 @@
-{- |
-Module: Main
-Description: Agora test suite.
-Maintainer: emi@haskell.fyi
-
-This module is the root of Agora's test suite.
--}
-module Main (main) where
-
---------------------------------------------------------------------------------
-
 import Prelude
 
 --------------------------------------------------------------------------------
@@ -42,6 +31,12 @@ main =
       , testGroup
           "Proposal tests"
           Proposal.tests
+      , testGroup
+          "AuthorityToken tests"
+          AuthorityToken.tests
+      , testGroup
+          "Treasury tests"
+          Treasury.tests
       , testGroup
           "Multisig tests"
           [ testGroup
@@ -50,10 +45,4 @@ main =
               , MultiSig.genTests
               ]
           ]
-      , testGroup
-          "AuthorityToken tests"
-          AuthorityToken.tests
-      , testGroup
-          "Treasury tests"
-          Treasury.tests
       ]
diff --git a/agora-test/Spec/Sample/Shared.hs b/agora-test/Spec/Sample/Shared.hs
index bd4957f..bec7174 100644
--- a/agora-test/Spec/Sample/Shared.hs
+++ b/agora-test/Spec/Sample/Shared.hs
@@ -9,6 +9,8 @@ module Spec.Sample.Shared (
   -- * Misc
   signer,
   signer2,
+  minAda,
+  withMinAda,
 
   -- * Components
 
@@ -30,8 +32,16 @@ module Spec.Sample.Shared (
   proposalPolicySymbol,
   proposalValidatorHash,
   proposalValidatorAddress,
+
+  -- ** Treasury
+  treasuryOut,
+  gatTn,
+  gatCs,
+  mockTrEffect,
+  trCredential,
 ) where
 
+import Agora.Effect.NoOp (noOpValidator)
 import Agora.Governor (
   Governor (Governor),
   governorPolicy,
@@ -47,6 +57,8 @@ import Agora.Proposal.Scripts (
  )
 import Agora.Stake (Stake (..))
 import Agora.Stake.Scripts (stakePolicy, stakeValidator)
+import Agora.Treasury (treasuryValidator)
+import Agora.Utils (validatorHashToTokenName)
 import Plutarch.Api.V1 (
   mintingPolicySymbol,
   mkMintingPolicy,
@@ -62,7 +74,11 @@ import Plutus.V1.Ledger.Api (
   MintingPolicy (..),
   PubKeyHash,
  )
+import Plutus.V1.Ledger.Contexts (
+  TxOut (..),
+ )
 import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash)
+import Plutus.V1.Ledger.Value (TokenName, Value)
 import Plutus.V1.Ledger.Value qualified as Value
 
 --------------------------------------------------------------------------------
@@ -131,3 +147,42 @@ defaultProposalThresholds =
     , create = Tagged 1
     , startVoting = Tagged 10
     }
+
+------------------------------------------------------------------
+
+treasuryOut :: TxOut
+treasuryOut =
+  TxOut
+    { txOutAddress = Address trCredential Nothing
+    , txOutValue = minAda
+    , txOutDatumHash = Nothing
+    }
+
+{- | Arbitrary 'CurrencySymbol', representing the 'CurrencySymbol'
+     of a valid governance authority token (GAT).
+-}
+gatCs :: CurrencySymbol
+gatCs = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
+
+trValidator :: Validator
+trValidator = mkValidator (treasuryValidator gatCs)
+
+-- | `ScriptCredential` used for the dummy treasury validator.
+trCredential :: Credential
+trCredential = ScriptCredential $ validatorHash trValidator
+
+-- | `TokenName` for GAT generated from address of `mockTrEffect`.
+gatTn :: TokenName
+gatTn = validatorHashToTokenName $ validatorHash mockTrEffect
+
+-- | Mock treasury effect script, used for testing.
+mockTrEffect :: Validator
+mockTrEffect = mkValidator $ noOpValidator gatCs
+
+------------------------------------------------------------------
+
+minAda :: Value
+minAda = Value.singleton "" "" 10_000_000
+
+withMinAda :: Value -> Value
+withMinAda v = v <> minAda
diff --git a/agora-test/Spec/Sample/Treasury.hs b/agora-test/Spec/Sample/Treasury.hs
index 9255275..c4836d6 100644
--- a/agora-test/Spec/Sample/Treasury.hs
+++ b/agora-test/Spec/Sample/Treasury.hs
@@ -9,27 +9,14 @@ This module contains sample data, used in the tests written in
 `Spec.Treasury`.
 -}
 module Spec.Sample.Treasury (
-  BadTreasuryRedeemer (NukeTheSystem),
   gatCs,
   validCtx,
   treasuryRef,
   gatTn,
   walletIn,
-  trCredential,
 ) where
 
-import Agora.Effect.NoOp (noOpValidator)
-import Agora.Treasury (
-  treasuryValidator,
- )
-import GHC.Generics qualified as GHC
-import Generics.SOP (Generic, I (I))
-import Plutarch.Api.V1 (mkValidator, validatorHash)
-import Plutarch.DataRepr (
-  DerivePConstantViaData (..),
-  PIsDataReprInstances (..),
- )
-import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
+import Plutarch.Api.V1 (validatorHash)
 import Plutus.V1.Ledger.Address (Address (..))
 import Plutus.V1.Ledger.Api (
   BuiltinByteString,
@@ -47,26 +34,18 @@ import Plutus.V1.Ledger.Contexts (
 import Plutus.V1.Ledger.Credential (Credential (ScriptCredential))
 import Plutus.V1.Ledger.Interval qualified as Interval
 import Plutus.V1.Ledger.Scripts (
-  Validator,
   ValidatorHash (ValidatorHash),
  )
-import Plutus.V1.Ledger.Value (
-  CurrencySymbol,
-  TokenName (TokenName),
- )
 import Plutus.V1.Ledger.Value qualified as Value
-import PlutusTx qualified
-import Spec.Sample.Shared (signer)
-import Spec.Util (datumPair, toDatumHash)
-
-{- | Arbitrary 'CurrencySymbol', representing the 'CurrencySymbol'
-     of a valid governance authority token (GAT).
--}
-gatCs :: CurrencySymbol
-gatCs = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
-
-trValidator :: Validator
-trValidator = mkValidator (treasuryValidator gatCs)
+import Spec.Sample.Shared (
+  gatCs,
+  gatTn,
+  mockTrEffect,
+  signer,
+  treasuryOut,
+  withMinAda,
+ )
+import Spec.Util (datumPair)
 
 {- | A `ScriptContext` that should be compatible with treasury
      transactions.
@@ -113,17 +92,11 @@ validCtx =
         , txInInfoResolved =
             TxOut
               { txOutAddress =
-                  Address (ScriptCredential $ validatorHash mockEffect) Nothing
-              , txOutValue = Value.singleton gatCs gatTn 1
-              , txOutDatumHash = Just (toDatumHash ())
+                  Address (ScriptCredential $ validatorHash mockTrEffect) Nothing
+              , txOutValue = withMinAda $ Value.singleton gatCs gatTn 1
+              , txOutDatumHash = Nothing
               }
         }
-    treasuryOut :: TxOut =
-      TxOut
-        { txOutAddress = Address trCredential Nothing
-        , txOutValue = Value.singleton "" "" 0
-        , txOutDatumHash = Just (toDatumHash ())
-        }
 
 -- | Reference to treasury output.
 treasuryRef :: TxOutRef
@@ -139,22 +112,6 @@ effectRef =
     "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
     0
 
--- | `ScriptCredential` used for the dummy treasury validator.
-trCredential :: Credential
-trCredential = ScriptCredential $ validatorHash trValidator
-
--- | Mock effect script, used for testing.
-mockEffect :: Validator
-mockEffect = mkValidator $ noOpValidator gatCs
-
--- | The hash of the mock effect script.
-addressBs :: BuiltinByteString
-(ValidatorHash addressBs) = validatorHash mockEffect
-
--- | `TokenName` for GAT generated from address of `mockEffect`.
-gatTn :: TokenName
-gatTn = TokenName addressBs
-
 -- | Input representing a user wallet with a valid GAT.
 walletIn :: TxInInfo
 walletIn =
@@ -174,33 +131,5 @@ walletIn =
           }
     }
 
--- | Unsupported treasury redeemer.
-newtype BadTreasuryRedeemer
-  = -- | Unsupported treasury redeemer.
-    NukeTheSystem Integer
-  deriving stock (Eq, Show, GHC.Generic)
-
-PlutusTx.makeIsDataIndexed
-  ''BadTreasuryRedeemer
-  [ ('NukeTheSystem, 0)
-  ]
-
--- | Plutarch implementation of `BadTreasuryRedeemer`.
-newtype PBadTreasuryRedeemer (s :: S)
-  = PNukeTheSystem (Term s (PDataRecord '["_0" ':= PInteger]))
-  deriving stock (GHC.Generic)
-  deriving anyclass (Generic)
-  deriving anyclass (PIsDataRepr)
-  deriving
-    (PlutusType, PIsData)
-    via PIsDataReprInstances PBadTreasuryRedeemer
-
-instance PUnsafeLiftDecl PBadTreasuryRedeemer where
-  type PLifted PBadTreasuryRedeemer = BadTreasuryRedeemer
-deriving via
-  ( DerivePConstantViaData
-      BadTreasuryRedeemer
-      PBadTreasuryRedeemer
-  )
-  instance
-    (PConstantDecl BadTreasuryRedeemer)
+addressBs :: BuiltinByteString
+(ValidatorHash addressBs) = validatorHash mockTrEffect
diff --git a/agora-test/Spec/Treasury.hs b/agora-test/Spec/Treasury.hs
index dd319d0..fc191c4 100644
--- a/agora-test/Spec/Treasury.hs
+++ b/agora-test/Spec/Treasury.hs
@@ -45,11 +45,15 @@ import Plutus.V1.Ledger.Scripts (
   ValidatorHash (ValidatorHash),
  )
 import Plutus.V1.Ledger.Value qualified as Value
+
+-- BadTreasuryRedeemer (NukeTheSystem),
+
+import Spec.Sample.Shared (
+  trCredential,
+ )
 import Spec.Sample.Treasury (
-  -- BadTreasuryRedeemer (NukeTheSystem),
   gatCs,
   gatTn,
-  trCredential,
   treasuryRef,
   validCtx,
   walletIn,
@@ -104,14 +108,7 @@ tests =
                             StakingHash trCredential
                     }
               ]
-          , -- , validatorFailsWith -- TODO: Check.
-            --     "Fails with invalid redeemer"
-            --     (treasuryValidator gatCs)
-            --     ()
-            --     (NukeTheSystem 72)
-            --     validCtx
-
-            validatorFailsWith -- TODO: Use QuickCheck.
+          , validatorFailsWith -- TODO: Use QuickCheck.
               "Fails when multiple GATs burned"
               (treasuryValidator gatCs)
               ()
diff --git a/agora.cabal b/agora.cabal
index 2cbc0a8..0f5f221 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -111,6 +111,7 @@ common deps
 
 common test-deps
   build-depends:
+    , agora
     , apropos
     , apropos-tx
     , lens
@@ -137,11 +138,10 @@ library
     Agora.Stake
     Agora.Stake.Scripts
     Agora.Treasury
-
-  other-modules:
     Agora.Utils
     Agora.Utils.Value
 
+  other-modules:
   hs-source-dirs:  agora
 
 library pprelude

From 012aeda6812d28007ad5db0a8744a992bfca53db Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Fri, 6 May 2022 10:54:03 +0100
Subject: [PATCH 20/24] removed outdated reference

---
 agora-test/Spec/Treasury.hs | 3 ---
 1 file changed, 3 deletions(-)

diff --git a/agora-test/Spec/Treasury.hs b/agora-test/Spec/Treasury.hs
index fc191c4..039ec6d 100644
--- a/agora-test/Spec/Treasury.hs
+++ b/agora-test/Spec/Treasury.hs
@@ -45,9 +45,6 @@ import Plutus.V1.Ledger.Scripts (
   ValidatorHash (ValidatorHash),
  )
 import Plutus.V1.Ledger.Value qualified as Value
-
--- BadTreasuryRedeemer (NukeTheSystem),
-
 import Spec.Sample.Shared (
   trCredential,
  )

From 8296834b99e93a914923afca6393e1602c07493b Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Fri, 6 May 2022 10:55:09 +0100
Subject: [PATCH 21/24] added lint function to Makefile

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

diff --git a/Makefile b/Makefile
index 6a3164c..5891d3d 100644
--- a/Makefile
+++ b/Makefile
@@ -1,7 +1,7 @@
 # This really ought to be `/usr/bin/env bash`, but nix flakes don't like that.
 SHELL := /bin/sh
 
-.PHONY: hoogle format haddock usage
+.PHONY: hoogle format haddock usage lint
 
 usage:
 	@echo "usage: make <command> [OPTIONS]"
@@ -40,3 +40,5 @@ haddock:
 tag:
 	hasktags -x agora agora-bench agora-test
 
+lint:
+	hlint agora agora-bench agora-test

From cddc6e8adf24627cfc25923e6d19db8e15c84755 Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Fri, 6 May 2022 11:22:40 +0100
Subject: [PATCH 22/24] Added echo message for Makefile lint

---
 Makefile | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/Makefile b/Makefile
index 5891d3d..3077e0b 100644
--- a/Makefile
+++ b/Makefile
@@ -1,7 +1,7 @@
 # This really ought to be `/usr/bin/env bash`, but nix flakes don't like that.
 SHELL := /bin/sh
 
-.PHONY: hoogle format haddock usage lint
+.PHONY: hoogle format haddock usage tag lint
 
 usage:
 	@echo "usage: make <command> [OPTIONS]"
@@ -11,6 +11,7 @@ usage:
 	@echo "  format -- Format the project"
 	@echo "  haddock -- Generate Haddock docs for project"
 	@echo "  tag -- Generate CTAGS and ETAGS files for project"
+	@echo "  lint -- Get hlint suggestions for project"
 
 hoogle:
 	pkill hoogle || true

From cb0f61eb2cf272ee13e21a25ce3b61825c1dec9a Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Mon, 9 May 2022 12:17:49 +0100
Subject: [PATCH 23/24] Applied Emily's suggestions

---
 agora-test/Spec/Sample/Shared.hs   | 11 +++++++-
 agora-test/Spec/Sample/Treasury.hs | 24 +++++++++++++++++
 agora-test/Spec/Treasury.hs        | 42 ++----------------------------
 agora.cabal                        |  1 -
 4 files changed, 36 insertions(+), 42 deletions(-)

diff --git a/agora-test/Spec/Sample/Shared.hs b/agora-test/Spec/Sample/Shared.hs
index bec7174..d97c5ff 100644
--- a/agora-test/Spec/Sample/Shared.hs
+++ b/agora-test/Spec/Sample/Shared.hs
@@ -39,6 +39,7 @@ module Spec.Sample.Shared (
   gatCs,
   mockTrEffect,
   trCredential,
+  wrongEffHash,
 ) where
 
 import Agora.Effect.NoOp (noOpValidator)
@@ -77,7 +78,7 @@ import Plutus.V1.Ledger.Api (
 import Plutus.V1.Ledger.Contexts (
   TxOut (..),
  )
-import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash)
+import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash (..))
 import Plutus.V1.Ledger.Value (TokenName, Value)
 import Plutus.V1.Ledger.Value qualified as Value
 
@@ -179,6 +180,14 @@ gatTn = validatorHashToTokenName $ validatorHash mockTrEffect
 mockTrEffect :: Validator
 mockTrEffect = mkValidator $ noOpValidator gatCs
 
+{- | A SHA-256 hash which (in all certainty) should not match the
+     hash of the dummy effect script.
+-}
+wrongEffHash :: ValidatorHash
+wrongEffHash =
+  ValidatorHash
+    "a21bc4a1d95600f9fa0a00b97ed0fa49a152a72de76253cb706f90b4b40f837b"
+
 ------------------------------------------------------------------
 
 minAda :: Value
diff --git a/agora-test/Spec/Sample/Treasury.hs b/agora-test/Spec/Sample/Treasury.hs
index c4836d6..8597cbb 100644
--- a/agora-test/Spec/Sample/Treasury.hs
+++ b/agora-test/Spec/Sample/Treasury.hs
@@ -14,6 +14,7 @@ module Spec.Sample.Treasury (
   treasuryRef,
   gatTn,
   walletIn,
+  trCtxGATNameNotAddress,
 ) where
 
 import Plutarch.Api.V1 (validatorHash)
@@ -44,6 +45,7 @@ import Spec.Sample.Shared (
   signer,
   treasuryOut,
   withMinAda,
+  wrongEffHash,
  )
 import Spec.Util (datumPair)
 
@@ -133,3 +135,25 @@ walletIn =
 
 addressBs :: BuiltinByteString
 (ValidatorHash addressBs) = validatorHash mockTrEffect
+
+trCtxGATNameNotAddress :: ScriptContext
+trCtxGATNameNotAddress =
+  let txInfo = validCtx.scriptContextTxInfo
+      inputs = txInfo.txInfoInputs
+      effectIn = inputs !! 1
+      invalidEff =
+        effectIn
+          { txInInfoResolved =
+              effectIn.txInInfoResolved
+                { txOutAddress = Address (ScriptCredential wrongEffHash) Nothing
+                }
+          }
+   in validCtx
+        { scriptContextTxInfo =
+            txInfo
+              { txInfoInputs =
+                  [ head inputs
+                  , invalidEff
+                  ]
+              }
+        }
diff --git a/agora-test/Spec/Treasury.hs b/agora-test/Spec/Treasury.hs
index 039ec6d..dd1044a 100644
--- a/agora-test/Spec/Treasury.hs
+++ b/agora-test/Spec/Treasury.hs
@@ -25,25 +25,17 @@ import Agora.Treasury (
   TreasuryRedeemer (SpendTreasuryGAT),
   treasuryValidator,
  )
-import Plutus.V1.Ledger.Address (Address (Address))
 import Plutus.V1.Ledger.Api (
-  BuiltinByteString,
   DCert (DCertDelegRegKey),
  )
 import Plutus.V1.Ledger.Contexts (
   ScriptContext (scriptContextPurpose, scriptContextTxInfo),
   ScriptPurpose (Certifying, Rewarding, Spending),
   TxInfo (txInfoInputs, txInfoMint),
-  txInInfoResolved,
-  txOutAddress,
  )
 import Plutus.V1.Ledger.Credential (
-  Credential (ScriptCredential),
   StakingCredential (StakingHash),
  )
-import Plutus.V1.Ledger.Scripts (
-  ValidatorHash (ValidatorHash),
- )
 import Plutus.V1.Ledger.Value qualified as Value
 import Spec.Sample.Shared (
   trCredential,
@@ -51,6 +43,7 @@ import Spec.Sample.Shared (
 import Spec.Sample.Treasury (
   gatCs,
   gatTn,
+  trCtxGATNameNotAddress,
   treasuryRef,
   validCtx,
   walletIn,
@@ -125,32 +118,7 @@ tests =
               (treasuryValidator gatCs)
               ()
               SpendTreasuryGAT
-              ( let txInfo = validCtx.scriptContextTxInfo
-                    inputs = txInfo.txInfoInputs
-                    effectIn = inputs !! 1
-                    invalidEff =
-                      effectIn
-                        { txInInfoResolved =
-                            effectIn.txInInfoResolved
-                              { txOutAddress =
-                                  Address
-                                    ( ScriptCredential $
-                                        ValidatorHash
-                                          wrongHash
-                                    )
-                                    Nothing
-                              }
-                        }
-                 in validCtx
-                      { scriptContextTxInfo =
-                          txInfo
-                            { txInfoInputs =
-                                [ head inputs
-                                , invalidEff
-                                ]
-                            }
-                      }
-              )
+              trCtxGATNameNotAddress
           , validatorFailsWith
               "Fails with wallet as input"
               (treasuryValidator gatCs)
@@ -172,9 +140,3 @@ tests =
           ]
       ]
   ]
-
-{- | A SHA-256 hash which (in all certainty) should not match the
-     hash of the dummy effect script.
--}
-wrongHash :: BuiltinByteString
-wrongHash = "a21bc4a1d95600f9fa0a00b97ed0fa49a152a72de76253cb706f90b4b40f837b"
diff --git a/agora.cabal b/agora.cabal
index 0f5f221..36cd7f5 100644
--- a/agora.cabal
+++ b/agora.cabal
@@ -114,7 +114,6 @@ common test-deps
     , agora
     , apropos
     , apropos-tx
-    , lens
     , QuickCheck
     , quickcheck-instances
     , tasty

From 704ec4a38a0603dd14bc1aec32a612f192158fd0 Mon Sep 17 00:00:00 2001
From: Jack Hodgkinson <30505104+jhodgdev@users.noreply.github.com>
Date: Mon, 9 May 2022 13:54:20 +0100
Subject: [PATCH 24/24] replaced use of withMinAda

---
 agora-test/Spec/Sample/Shared.hs   | 4 ----
 agora-test/Spec/Sample/Treasury.hs | 8 ++++++--
 2 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/agora-test/Spec/Sample/Shared.hs b/agora-test/Spec/Sample/Shared.hs
index d97c5ff..8245e52 100644
--- a/agora-test/Spec/Sample/Shared.hs
+++ b/agora-test/Spec/Sample/Shared.hs
@@ -10,7 +10,6 @@ module Spec.Sample.Shared (
   signer,
   signer2,
   minAda,
-  withMinAda,
 
   -- * Components
 
@@ -192,6 +191,3 @@ wrongEffHash =
 
 minAda :: Value
 minAda = Value.singleton "" "" 10_000_000
-
-withMinAda :: Value -> Value
-withMinAda v = v <> minAda
diff --git a/agora-test/Spec/Sample/Treasury.hs b/agora-test/Spec/Sample/Treasury.hs
index 8597cbb..1cfb02c 100644
--- a/agora-test/Spec/Sample/Treasury.hs
+++ b/agora-test/Spec/Sample/Treasury.hs
@@ -41,10 +41,10 @@ import Plutus.V1.Ledger.Value qualified as Value
 import Spec.Sample.Shared (
   gatCs,
   gatTn,
+  minAda,
   mockTrEffect,
   signer,
   treasuryOut,
-  withMinAda,
   wrongEffHash,
  )
 import Spec.Util (datumPair)
@@ -95,7 +95,11 @@ validCtx =
             TxOut
               { txOutAddress =
                   Address (ScriptCredential $ validatorHash mockTrEffect) Nothing
-              , txOutValue = withMinAda $ Value.singleton gatCs gatTn 1
+              , txOutValue =
+                  mconcat
+                    [ Value.singleton gatCs gatTn 1
+                    , minAda
+                    ]
               , txOutDatumHash = Nothing
               }
         }