Merge pull request #48 from Liqwid-Labs/emiflake/stake-locking

Various changes & stake lock datum
2022-04-05 12:46:16 +02:00 · 2022-04-05 12:46:16 +02:00 · 1174fc7e13
commit 1174fc7e13
parent 6379e6b722 ae7191e0ac
14 changed files with 417 additions and 242 deletions
--- a/README.md
+++ b/README.md
@ -1,4 +1,5 @@
-# Agora
+# Agora :classical_building:
+![integrate.yaml badge](https://github.com/Liqwid-Labs/agora/actions/workflows/integrate.yaml/badge.svg?branch=master)

 Agora is a set of Plutus scripts that compose together to form a governance system.

--- a/agora-test/Spec/Sample/Stake.hs
+++ b/agora-test/Spec/Sample/Stake.hs
@ -51,8 +51,9 @@ import Plutus.V1.Ledger.Value qualified as Value

 --------------------------------------------------------------------------------

-import Agora.SafeMoney
+import Agora.SafeMoney (GTTag)
 import Agora.Stake
+import Plutarch.SafeMoney
 import Spec.Util (datumPair, toDatumHash)

 --------------------------------------------------------------------------------
@ -62,7 +63,7 @@ stake :: Stake
 stake =
  Stake
    { gtClassRef =
-        AssetClassRef
+        Tagged
          ( AssetClass
              ( "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
              , "LQ"
@ -94,7 +95,7 @@ stakeCreation :: ScriptContext
 stakeCreation =
  let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
      datum :: Datum
-      datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer)
+      datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer [])
   in ScriptContext
        { scriptContextTxInfo =
            TxInfo
@ -122,7 +123,7 @@ stakeCreation =
 stakeCreationWrongDatum :: ScriptContext
 stakeCreationWrongDatum =
  let datum :: Datum
-      datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer) -- Too much GT
+      datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer []) -- Too much GT
   in ScriptContext
        { scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]}
        , scriptContextPurpose = Minting policySymbol
@ -143,9 +144,9 @@ stakeCreationUnsigned =

 -- | Config for creating a ScriptContext that deposits or withdraws.
 data DepositWithdrawExample = DepositWithdrawExample
-  { startAmount :: Discrete GTTag
+  { startAmount :: Tagged GTTag Integer
  -- ^ The amount of GT stored before the transaction.
-  , delta :: Discrete GTTag
+  , delta :: Tagged GTTag Integer
  -- ^ The amount of GT deposited or withdrawn from the Stake.
  }

@ -154,7 +155,7 @@ stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
 stakeDepositWithdraw config =
  let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST
      stakeBefore :: StakeDatum
-      stakeBefore = StakeDatum config.startAmount signer
+      stakeBefore = StakeDatum config.startAmount signer []

      stakeAfter :: StakeDatum
      stakeAfter = stakeBefore {stakedAmount = stakeBefore.stakedAmount + config.delta}
@ -168,7 +169,7 @@ stakeDepositWithdraw config =
                        { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
                        , txOutValue =
                            st
-                              <> discreteValue stake.gtClassRef stakeBefore.stakedAmount
+                              <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount)
                        , txOutDatumHash = Just (toDatumHash stakeAfter)
                        }
                  ]
@ -177,7 +178,7 @@ stakeDepositWithdraw config =
                      { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
                      , txOutValue =
                          st
-                            <> discreteValue stake.gtClassRef stakeAfter.stakedAmount
+                            <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
                      , txOutDatumHash = Just (toDatumHash stakeAfter)
                      }
                  ]
--- a/agora-test/Spec/Stake.hs
+++ b/agora-test/Spec/Stake.hs
@ -52,19 +52,19 @@ tests =
      , validatorSucceedsWith
          "stakeDepositWithdraw deposit"
          (stakeValidator Stake.stake)
-          (toDatum $ StakeDatum 100_000 signer)
+          (toDatum $ StakeDatum 100_000 signer [])
          (toDatum $ DepositWithdraw 100_000)
          (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = 100_000})
      , validatorSucceedsWith
          "stakeDepositWithdraw withdraw"
          (stakeValidator Stake.stake)
-          (toDatum $ StakeDatum 100_000 signer)
+          (toDatum $ StakeDatum 100_000 signer [])
          (toDatum $ DepositWithdraw $ negate 100_000)
          (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 100_000})
      , validatorFailsWith
          "stakeDepositWithdraw negative GT"
          (stakeValidator Stake.stake)
-          (toDatum $ StakeDatum 100_000 signer)
+          (toDatum $ StakeDatum 100_000 signer [])
          (toDatum $ DepositWithdraw 1_000_000)
          (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 1_000_000})
      ]
--- a/agora.cabal
+++ b/agora.cabal
@ -97,6 +97,7 @@ common deps
    , plutarch
    , plutarch-extra
    , plutarch-numeric
+    , plutarch-safemoney
    , plutus-core
    , plutus-ledger-api
    , plutus-tx
--- a/agora/Agora/AuthorityToken.hs
+++ b/agora/Agora/AuthorityToken.hs
@ -8,6 +8,7 @@ Tokens acting as redeemable proofs of DAO authority.
 module Agora.AuthorityToken (
  authorityTokenPolicy,
  authorityTokensValidIn,
+  singleAuthorityTokenBurned,
  AuthorityToken (..),
 ) where

@ -32,7 +33,15 @@ import Prelude

 --------------------------------------------------------------------------------

-import Agora.Utils (allOutputs, passert, passetClassValueOf, passetClassValueOf', plookup)
+import Agora.Utils (
+  allInputs,
+  allOutputs,
+  passert,
+  passetClassValueOf,
+  passetClassValueOf',
+  plookup,
+  psymbolValueOf,
+ )

 --------------------------------------------------------------------------------

@ -85,6 +94,27 @@ authorityTokensValidIn = phoistAcyclic $
        -- No GATs exist at this output!
        pconstant True

+-- | Assert that a single authority token has been burned.
+singleAuthorityTokenBurned ::
+  forall (s :: S).
+  Term s PCurrencySymbol ->
+  Term s (PAsData PTxInfo) ->
+  Term s PValue ->
+  Term s PBool
+singleAuthorityTokenBurned gatCs txInfo mint = P.do
+  let gatAmountMinted :: Term _ PInteger
+      gatAmountMinted = psymbolValueOf # gatCs # mint
+
+  foldr1
+    (#&&)
+    [ ptraceIfFalse "GAT not burned." $ gatAmountMinted #== -1
+    , ptraceIfFalse "All inputs only have valid GATs" $
+        allInputs @PUnit # pfromData txInfo #$ plam $ \txOut _value _address _datum ->
+          authorityTokensValidIn
+            # gatCs
+            # txOut
+    ]
+
 -- | Policy given 'AuthorityToken' params.
 authorityTokenPolicy ::
  AuthorityToken ->
--- a/agora/Agora/Effect.hs
+++ b/agora/Agora/Effect.hs
@ -5,33 +5,61 @@ Description: Helpers for constructing effects

 Helpers for constructing effects.
 -}
-module Agora.Effect (makeEffect) where
+module Agora.Effect (
+  makeEffect,
+  noopEffect,
+) where

-import Plutarch.Api.V1 (PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator)
+import Agora.AuthorityToken (singleAuthorityTokenBurned)
+import Agora.Utils (passert)
+import Plutarch (popaque)
+import Plutarch.Api.V1 (PCurrencySymbol, PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator, PValue)
 import Plutarch.Internal (punsafeCoerce)
 import Plutarch.Monadic qualified as P
+import Plutus.V1.Ledger.Value (CurrencySymbol)

 --------------------------------------------------------------------------------

-- | Helper "template" for creating effect validator.
+{- | Helper "template" for creating effect validator.
+
+     In some situations, it may be the case that we need more control over how
+     an effect is implemented. In such situations, it's okay to not use this
+     helper.
+-}
 makeEffect ::
-  forall (datum :: PType) (s :: S).
+  forall (datum :: PType).
  PIsData datum =>
-  (Term s datum -> Term s PTxOutRef -> Term s PTxInfo -> Term s POpaque) ->
-  Term s PValidator
-makeEffect f =
+  CurrencySymbol ->
+  (forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
+  ClosedTerm PValidator
+makeEffect gatCs' f =
  plam $ \datum _redeemer ctx' -> P.do
    ctx <- pletFields @'["txInfo", "purpose"] ctx'
    txInfo' <- plet ctx.txInfo

+    -- TODO: Use PTryFrom
    let datum' :: Term _ datum
        datum' = pfromData $ punsafeCoerce datum

    PSpending txOutRef <- pmatch $ pfromData ctx.purpose
    txOutRef' <- plet (pfield @"_0" # txOutRef)

-    -- TODO: Here, check that a *single* GAT is burned.
+    txInfo <- pletFields @'["mint"] txInfo'
+    let mint :: Term _ PValue
+        mint = txInfo.mint

-    f datum' txOutRef' txInfo'
+    gatCs <- plet $ pconstant gatCs'
+
+    passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint
+
+    f gatCs datum' txOutRef' txInfo'

 --------------------------------------------------------------------------------
+
+-- | Dummy effect which can only burn its GAT.
+noopEffect :: CurrencySymbol -> ClosedTerm PValidator
+noopEffect =
+  ( `makeEffect`
+      \_gatCs (_datum :: Term _ PUnit) _txOutRef _txInfo -> P.do
+        popaque (pconstant ())
+  )
--- a/agora/Agora/Governor.hs
+++ b/agora/Agora/Governor.hs
@ -5,14 +5,29 @@ Description: Governor entity scripts acting as authority of entire system.

 Governor entity scripts acting as authority of entire system.
 -}
-module Agora.Governor (GovernorDatum (..), GovernorRedeemer (..), Governor (..)) where
+module Agora.Governor (
+  -- * Haskell-land
+  GovernorDatum (..),
+  GovernorRedeemer (..),
+  Governor (..),

-import Agora.Proposal (ProposalThresholds)
+  -- * Plutarch-land
+
+  -- * Scripts
+  governorPolicy,
+  governorValidator,
+) where
+
+import Agora.Proposal (ProposalTag, ProposalThresholds)
+import Plutarch (popaque)
+import Plutarch.Api.V1 (PMintingPolicy, PValidator)

 -- | Datum for the Governor script.
-newtype GovernorDatum = GovernorDatum
+data GovernorDatum = GovernorDatum
  { proposalThresholds :: ProposalThresholds
  -- ^ Gets copied over upon creation of a 'Agora.Proposal.ProposalDatum'.
+  , nextProposalTag :: ProposalTag
+  -- ^ What tag the next proposal will get upon creating.
  }

 {- | Redeemer for Governor script. The governor has two primary
@ -31,3 +46,17 @@ data GovernorRedeemer
 -- | Parameters for creating Governor scripts.
 data Governor
  = Governor
+
+--------------------------------------------------------------------------------
+
+-- | Policy for Governors.
+governorPolicy :: Governor -> ClosedTerm PMintingPolicy
+governorPolicy _ =
+  plam $ \_redeemer _ctx' -> P.do
+    popaque (pconstant ())
+
+-- | Validator for Governors.
+governorValidator :: Governor -> ClosedTerm PValidator
+governorValidator _ =
+  plam $ \_datum _redeemer _ctx' -> P.do
+    popaque (pconstant ())
--- a/agora/Agora/Proposal.hs
+++ b/agora/Agora/Proposal.hs
@ -14,11 +14,20 @@ module Agora.Proposal (
  ProposalStatus (..),
  ProposalThresholds (..),
  ProposalVotes (..),
+  ProposalTag (..),
  ResultTag (..),

  -- * Plutarch-land
  PProposalDatum (..),
+  PProposalStatus (..),
+  PProposalThresholds (..),
+  PProposalVotes (..),
+  PProposalTag (..),
  PResultTag (..),
+
+  -- * Scripts
+  proposalValidator,
+  proposalPolicy,
 ) where

 import GHC.Generics qualified as GHC
@ -26,19 +35,26 @@ import Generics.SOP (Generic, I (I))
 import Plutarch.Api.V1 (
  PDatumHash,
  PMap,
+  PMintingPolicy,
  PPubKeyHash,
+  PValidator,
  PValidatorHash,
 )
 import Plutarch.DataRepr (
+  DerivePConstantViaData (..),
  PDataFields,
  PIsDataReprInstances (PIsDataReprInstances),
 )
 import Plutus.V1.Ledger.Api (DatumHash, PubKeyHash, ValidatorHash)
 import PlutusTx qualified
+import PlutusTx.AssocMap qualified as AssocMap

 --------------------------------------------------------------------------------

-import Agora.SafeMoney (Discrete, GTTag, PDiscrete)
+import Agora.SafeMoney (GTTag)
+import Plutarch (popaque)
+import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..))
+import Plutarch.SafeMoney (PDiscrete, Tagged)

 --------------------------------------------------------------------------------
 -- Haskell-land
@ -51,7 +67,7 @@ import Agora.SafeMoney (Discrete, GTTag, PDiscrete)
@
 -}
 newtype ResultTag = ResultTag {getResultTag :: Integer}
-  deriving stock (Eq, Show)
+  deriving stock (Eq, Show, Ord)
  deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)

 {- | The "status" of the proposal. This is only useful for state transitions,
@ -84,6 +100,7 @@ data ProposalStatus
    --
    --   TODO: The owner of the proposal may choose to reclaim their proposal.
    Finished
+  deriving stock (Eq, Show, GHC.Generic)

 PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Finished, 2)]

@ -92,14 +109,15 @@ PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('F
     to 'Proposal's when they are created.
 -}
 data ProposalThresholds = ProposalThresholds
-  { execute :: Discrete GTTag
+  { execute :: Tagged GTTag Integer
  -- ^ How much GT minimum must a particular 'ResultTag' accumulate for it to pass.
-  , draft :: Discrete GTTag
+  , draft :: Tagged GTTag Integer
  -- ^ How much GT required to "create" a proposal.
-  , vote :: Discrete GTTag
+  , vote :: Tagged GTTag Integer
  -- ^ How much GT required to allow voting to happen.
  -- (i.e. to move into 'VotingReady')
  }
+  deriving stock (Eq, Show, GHC.Generic)

 PlutusTx.makeIsDataIndexed ''ProposalThresholds [('ProposalThresholds, 0)]

@ -115,9 +133,10 @@ PlutusTx.makeIsDataIndexed ''ProposalThresholds [('ProposalThresholds, 0)]
   @[('ResultTag' 0, n), ('ResultTag' 1, m)]@
 -}
 newtype ProposalVotes = ProposalVotes
-  { getProposalVotes :: [(ResultTag, Integer)]
+  { getProposalVotes :: AssocMap.Map ResultTag Integer
  }
  deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
+  deriving stock (Eq, Show, GHC.Generic)

 -- | Haskell-level datum for Proposal scripts.
 data ProposalDatum = ProposalDatum
@ -135,9 +154,19 @@ data ProposalDatum = ProposalDatum
  , votes :: ProposalVotes
  -- ^ Vote tally on the proposal
  }
+  deriving stock (Eq, Show, GHC.Generic)

 PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)]

+{- | Identifies a Proposal, issued upon creation of a proposal.
+     In practice, this number starts at zero, and increments by one
+     for each proposal. The 100th proposal will be @'ProposalTag' 99@.
+     This counter lives in the 'Governor', see 'nextProposalTag'.
+-}
+newtype ProposalTag = ProposalTag {proposalTag :: Integer}
+  deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
+  deriving stock (Eq, Show, GHC.Generic)
+
 -- | Parameters that identify the Proposal validator script.
 data Proposal = Proposal

@ -148,6 +177,22 @@ data Proposal = Proposal
 newtype PResultTag (s :: S) = PResultTag (Term s PInteger)
  deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PResultTag PInteger)

+instance PUnsafeLiftDecl PResultTag where type PLifted PResultTag = ResultTag
+deriving via
+  (DerivePConstantViaNewtype ResultTag PResultTag PInteger)
+  instance
+    (PConstant ResultTag)
+
+-- | Plutarch-level version of 'PProposalTag'.
+newtype PProposalTag (s :: S) = PProposalTag (Term s PInteger)
+  deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalTag PInteger)
+
+instance PUnsafeLiftDecl PProposalTag where type PLifted PProposalTag = ProposalTag
+deriving via
+  (DerivePConstantViaNewtype ProposalTag PProposalTag PInteger)
+  instance
+    (PConstant ProposalTag)
+
 -- | Plutarch-level version of 'ProposalStatus'.
 data PProposalStatus (s :: S)
  = -- TODO: 'PProposalStatus' ought te be encoded as 'PInteger'.
@ -162,6 +207,9 @@ data PProposalStatus (s :: S)
    (PlutusType, PIsData)
    via PIsDataReprInstances PProposalStatus

+instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus
+deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (PConstant ProposalStatus)
+
 -- | Plutarch-level version of 'ProposalThresholds'.
 newtype PProposalThresholds (s :: S) = PProposalThresholds
  { getProposalThresholds ::
@ -181,11 +229,20 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds
    (PlutusType, PIsData, PDataFields)
    via (PIsDataReprInstances PProposalThresholds)

+instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds
+deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) instance (PConstant ProposalThresholds)
+
 -- | Plutarch-level version of 'ProposalVotes'.
 newtype PProposalVotes (s :: S)
  = PProposalVotes (Term s (PMap PResultTag PInteger))
  deriving (PlutusType, PIsData) via (DerivePNewtype PProposalVotes (PMap PResultTag PInteger))

+instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = ProposalVotes
+deriving via
+  (DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap PResultTag PInteger))
+  instance
+    (PConstant ProposalVotes)
+
 -- | Plutarch-level version of 'ProposalDatum'.
 newtype PProposalDatum (s :: S) = PProposalDatum
  { getProposalDatum ::
@ -206,3 +263,20 @@ newtype PProposalDatum (s :: S) = PProposalDatum
  deriving
    (PlutusType, PIsData, PDataFields)
    via (PIsDataReprInstances PProposalDatum)
+
+instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
+deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstant ProposalDatum)
+
+--------------------------------------------------------------------------------
+
+-- | Policy for Proposals.
+proposalPolicy :: Proposal -> ClosedTerm PMintingPolicy
+proposalPolicy _ =
+  plam $ \_redeemer _ctx' -> P.do
+    popaque (pconstant ())
+
+-- | Validator for Proposals.
+proposalValidator :: Proposal -> ClosedTerm PValidator
+proposalValidator _ =
+  plam $ \_datum _redeemer _ctx' -> P.do
+    popaque (pconstant ())
--- a/agora/Agora/SafeMoney.hs
+++ b/agora/Agora/SafeMoney.hs
@ -1,51 +1,21 @@
 {- |
 Module     : Agora.SafeMoney
 Maintainer : emi@haskell.fyi
-Description: Phantom-type protected types for handling money in Plutus.
+Description: Tags and bonuses for Plutarch.SafeMoney.

-Phantom-type protected types for handling money in Plutus.
+Tags and extras for "Plutarch.SafeMoney".
 -}
 module Agora.SafeMoney (
-  -- * Types
-  PDiscrete (..),
-  Discrete (..),
-
-  -- * Tags and refs
-  AssetClassRef (..),
  ADATag,
  GTTag,
  adaRef,
-
-  -- * Utility functions
-  paddDiscrete,
-  pgeqDiscrete,
-  pzeroDiscrete,
-
-  -- * Conversions
-  pdiscreteValue,
-  pvalueDiscrete,
-  discreteValue,
 ) where

-import Prelude
-
 --------------------------------------------------------------------------------

-import Plutus.V1.Ledger.Value (AssetClass (AssetClass), Value)
-import Plutus.V1.Ledger.Value qualified as Value
-import PlutusTx qualified
+import Plutus.V1.Ledger.Value (AssetClass (AssetClass))

-import Plutarch.Api.V1 (PValue)
-import Plutarch.Builtin ()
-import Plutarch.Internal ()
-import Plutarch.Monadic qualified as P
-
--------------------------------------------------------------------------------
-
-import Agora.Utils (
-  passetClassValueOf',
-  psingletonValue,
- )
+import Plutarch.SafeMoney

 --------------------------------------------------------------------------------
 -- Example tags
@ -58,89 +28,6 @@ data ADATag

 --------------------------------------------------------------------------------

-- | A tagged AssetClass. Use to resolve a reference inside of a PDiscrete
-newtype AssetClassRef (tag :: Type) = AssetClassRef {getAssetClass :: AssetClass}
-
 -- | Resolves ada tags.
-adaRef :: AssetClassRef ADATag
-adaRef = AssetClassRef (AssetClass ("", ""))
-
-- TODO: Currently it's possible to transmute from one discrete to another.
-- How do we prevent this?
--
-- @
--   transmute :: forall (a :: Type) (b :: Type). Discrete a -> Discrete b
--   transmute = Discrete . getDiscrete
-- @
-
-{- | Represents a single asset in a 'Plutus.V1.Ledger.Value.Value' related to a particular 'AssetClass'
-     through 'AssetClassRef'.
-}
-newtype Discrete (tag :: Type) = Discrete {getDiscrete :: Integer}
-  deriving stock (Show, Eq)
-  deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
-  deriving newtype (Num) -- TODO: Use plutarch-numeric
-
-{- | Represents a single asset in a 'PValue' related to a particular 'AssetClass'
-     through 'AssetClassRef'.
-}
-newtype PDiscrete (tag :: Type) (s :: S)
-  = PDiscrete (Term s PInteger)
-  deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (PDiscrete tag) PInteger)
-
-- | Check if one 'PDiscrete' is greater than another.
-pgeqDiscrete :: forall (tag :: Type) (s :: S). Term s (PDiscrete tag :--> PDiscrete tag :--> PBool)
-pgeqDiscrete = phoistAcyclic $
-  plam $ \x y -> P.do
-    PDiscrete x' <- pmatch x
-    PDiscrete y' <- pmatch y
-    y' #<= x'
-
-- | Returns a zero-value 'PDiscrete' unit for any tag.
-pzeroDiscrete :: forall (tag :: Type) (s :: S). Term s (PDiscrete tag)
-pzeroDiscrete = phoistAcyclic $ pcon (PDiscrete 0)
-
-- | Add two 'PDiscrete' values of the same tag.
-paddDiscrete :: forall (tag :: Type) (s :: S). Term s (PDiscrete tag :--> PDiscrete tag :--> PDiscrete tag)
-paddDiscrete = phoistAcyclic $
-  -- In the future, this should use plutarch-numeric
-  plam $ \x y -> P.do
-    PDiscrete x' <- pmatch x
-    PDiscrete y' <- pmatch y
-    pcon (PDiscrete $ x' + y')
-
--------------------------------------------------------------------------------
-
-- | Downcast a `PValue` to a `PDiscrete` unit.
-pvalueDiscrete ::
-  forall (tag :: Type) (s :: S).
-  AssetClassRef tag ->
-  Term s (PValue :--> PDiscrete tag)
-pvalueDiscrete (AssetClassRef ac) = phoistAcyclic $
-  plam $ \f ->
-    pcon . PDiscrete $ passetClassValueOf' ac # f
-
-{- | Get a `PValue` from a `PDiscrete`.
-     __NOTE__: `pdiscreteValue` after `pvalueDiscrete` is not a round-trip.
-     It filters for a particular tag.
-}
-pdiscreteValue ::
-  forall (tag :: Type) (s :: S).
-  AssetClassRef tag ->
-  Term s (PDiscrete tag :--> PValue)
-pdiscreteValue (AssetClassRef (AssetClass (cs, tn))) = phoistAcyclic $
-  plam $ \f -> pmatch f $ \case
-    PDiscrete p ->
-      psingletonValue
-        # pconstant cs
-        # pconstant tn
-        # p
-
-- | Get a `Value` from a `Discrete`.
-discreteValue ::
-  forall (tag :: Type).
-  AssetClassRef tag ->
-  Discrete tag ->
-  Value
-discreteValue (AssetClassRef (AssetClass (cs, tn))) (Discrete v) =
-  Value.singleton cs tn v
+adaRef :: Tagged ADATag AssetClass
+adaRef = Tagged (AssetClass ("", ""))
--- a/agora/Agora/Stake.hs
+++ b/agora/Agora/Stake.hs
@ -12,6 +12,8 @@ module Agora.Stake (
  PStakeRedeemer (..),
  StakeDatum (..),
  StakeRedeemer (..),
+  ProposalLock (..),
+  PProposalLock (..),
  Stake (..),
  stakePolicy,
  stakeValidator,
@ -22,7 +24,7 @@ module Agora.Stake (

 import GHC.Generics qualified as GHC
 import Generics.SOP (Generic, I (I))
-import Prelude
+import Prelude hiding (Num (..))

 --------------------------------------------------------------------------------

@ -43,76 +45,148 @@ import Plutarch.Api.V1 (
  mkMintingPolicy,
 )
 import Plutarch.DataRepr (
+  DerivePConstantViaData (..),
  PDataFields,
  PIsDataReprInstances (PIsDataReprInstances),
 )
 import Plutarch.Internal (punsafeCoerce)
+import Plutarch.Lift (PUnsafeLiftDecl (..))
 import Plutarch.Monadic qualified as P
 import Plutus.V1.Ledger.Value (AssetClass (AssetClass))

 --------------------------------------------------------------------------------

-import Agora.SafeMoney (
-  AssetClassRef (..),
-  Discrete,
-  GTTag,
-  PDiscrete,
-  paddDiscrete,
-  pdiscreteValue,
-  pgeqDiscrete,
-  pzeroDiscrete,
- )
+import Agora.Proposal (PProposalTag, PResultTag, ProposalTag (..), ResultTag (..))
+import Agora.SafeMoney (GTTag)
 import Agora.Utils (
  anyInput,
  anyOutput,
  paddValue,
  passert,
-  passetClassValueOf',
  pfindTxInByTxOutRef,
  pgeqByClass,
  pgeqByClass',
  pgeqBySymbol,
+  pnotNull,
  psingletonValue,
  psymbolValueOf,
  ptxSignedBy,
  pvalueSpent,
 )
+import Plutarch.Numeric
+import Plutarch.SafeMoney (
+  PDiscrete,
+  Tagged (..),
+  pdiscreteValue,
+  untag,
+ )

 --------------------------------------------------------------------------------

 -- | Parameters for creating Stake scripts.
 newtype Stake = Stake
-  { gtClassRef :: AssetClassRef GTTag
+  { gtClassRef :: Tagged GTTag AssetClass
  -- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code.
  }

-- | Plutarch-level redeemer for Stake scripts.
-data PStakeRedeemer (s :: S)
-  = -- | Deposit or withdraw a discrete amount of the staked governance token.
-    PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag]))
-  | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
-    PDestroy (Term s (PDataRecord '[]))
-  deriving stock (GHC.Generic)
-  deriving anyclass (Generic)
-  deriving anyclass (PIsDataRepr)
-  deriving
-    (PlutusType, PIsData)
-    via PIsDataReprInstances PStakeRedeemer
+{- | A lock placed on a Stake datum in order to prevent
+     depositing and withdrawing when votes are in place.
+
+     NOTE: Due to retracting votes always being possible,
+     this lock will only lock with contention on the proposal.
+
+     FIXME: Contention on Proposals could create contention
+     on voting which in turn creates contention on stakers.
+
+     Vaguely this is the dependency graph for this locking
+     interaction. Both the stake validator and the proposal
+     validator are only able to check for one another through
+     the datum belonging to the ST:
+
+     @
+     ┌─────────────────┐   ┌────────────────────┐
+     │ Stake Validator ├─┐ │ Proposal Validator │
+     └────────┬────────┘ │ └──────┬─────┬───────┘
+              │          │        │     │
+              │        ┌─┼────────┘     │
+              ▼        │ │              ▼
+     ┌──────────────┐  │ │ ┌─────────────────┐
+     │ Stake Policy │◄─┘ └►│ Proposal Policy │
+     └──────────────┘      └─────────────────┘
+     @
+-}
+data ProposalLock = ProposalLock
+  { vote :: ResultTag
+  -- ^ What was voted on. This allows retracting votes to
+  --   undo their vote.
+  , proposalTag :: ProposalTag
+  -- ^ Identifies the proposal. See 'ProposalTag' for further
+  -- comments on its significance.
+  }
+  deriving stock (Show, GHC.Generic)
+
+PlutusTx.makeIsDataIndexed ''ProposalLock [('ProposalLock, 0)]

 -- | Haskell-level redeemer for Stake scripts.
 data StakeRedeemer
  = -- | Deposit or withdraw a discrete amount of the staked governance token.
-    DepositWithdraw (Discrete GTTag)
+    --   Stake must be unlocked.
+    DepositWithdraw (Tagged GTTag Integer)
  | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
+    --   Stake must be unlocked.
    Destroy
+  | -- | Permit a Vote to be added onto a 'Proposal'.
+    --   This also adds a lock to the 'lockedBy' field. See 'ProposalLock'.
+    --   This needs to be done in sync with casting a vote, otherwise
+    --   it's possible for a lock to be permanently placed on the stake,
+    --   and then the funds are lost.
+    PermitVote ProposalLock
+  | -- | Retract a vote, removing it from the 'lockedBy' field. See 'ProposalLock'.
+    --   This action checks for permission of the 'Proposal'. Finished proposals are
+    --   always allowed to have votes retracted and won't affect the Proposal datum,
+    --   allowing 'Stake's to be unlocked.
+    RetractVotes [ProposalLock]
  deriving stock (Show, GHC.Generic)

-PlutusTx.makeIsDataIndexed ''StakeRedeemer [('DepositWithdraw, 0), ('Destroy, 1)]
+PlutusTx.makeIsDataIndexed
+  ''StakeRedeemer
+  [ ('DepositWithdraw, 0)
+  , ('Destroy, 1)
+  , ('PermitVote, 2)
+  , ('RetractVotes, 3)
+  ]
+
+-- | Haskell-level datum for Stake scripts.
+data StakeDatum = StakeDatum
+  { stakedAmount :: Tagged GTTag Integer
+  -- ^ Tracks the amount of governance token staked in the datum.
+  -- This also acts as the voting weight for 'Proposal's.
+  , owner :: PubKeyHash
+  -- ^ The hash of the public key this stake belongs to.
+  --
+  -- TODO Support for MultiSig/Scripts is tracked here:
+  --      https://github.com/Liqwid-Labs/agora/issues/45
+  , lockedBy :: [ProposalLock]
+  -- ^ The current proposals locking this stake. This field must be empty
+  -- for the stake to be usable for deposits and withdrawals.
+  }
+  deriving stock (Show, GHC.Generic)
+
+PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)]
+
+--------------------------------------------------------------------------------

 -- | Plutarch-level datum for Stake scripts.
 newtype PStakeDatum (s :: S) = PStakeDatum
  { getStakeDatum ::
-    Term s (PDataRecord '["stakedAmount" ':= PDiscrete GTTag, "owner" ':= PPubKeyHash])
+    Term
+      s
+      ( PDataRecord
+          '[ "stakedAmount" ':= PDiscrete GTTag
+           , "owner" ':= PPubKeyHash
+           , "lockedBy" ':= PBuiltinList (PAsData PProposalLock)
+           ]
+      )
  }
  deriving stock (GHC.Generic)
  deriving anyclass (Generic)
@ -121,14 +195,46 @@ newtype PStakeDatum (s :: S) = PStakeDatum
    (PlutusType, PIsData, PDataFields)
    via (PIsDataReprInstances PStakeDatum)

-- | Haskell-level datum for Stake scripts.
-data StakeDatum = StakeDatum
-  { stakedAmount :: Discrete GTTag
-  , owner :: PubKeyHash
-  }
-  deriving stock (Show, GHC.Generic)
+instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum
+deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstant StakeDatum)

-PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)]
+-- | Plutarch-level redeemer for Stake scripts.
+data PStakeRedeemer (s :: S)
+  = -- | Deposit or withdraw a discrete amount of the staked governance token.
+    PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag]))
+  | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
+    PDestroy (Term s (PDataRecord '[]))
+  | PPermitVote (Term s (PDataRecord '["lock" ':= PProposalLock]))
+  | PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList PProposalLock]))
+  deriving stock (GHC.Generic)
+  deriving anyclass (Generic)
+  deriving anyclass (PIsDataRepr)
+  deriving
+    (PlutusType, PIsData)
+    via PIsDataReprInstances PStakeRedeemer
+
+instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer
+deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstant StakeRedeemer)
+
+newtype PProposalLock (s :: S) = PProposalLock
+  { getProposalLock ::
+    Term
+      s
+      ( PDataRecord
+          '[ "vote" ':= PResultTag
+           , "proposalTag" ':= PProposalTag
+           ]
+      )
+  }
+  deriving stock (GHC.Generic)
+  deriving anyclass (Generic)
+  deriving anyclass (PIsDataRepr)
+  deriving
+    (PlutusType, PIsData, PDataFields)
+    via (PIsDataReprInstances PProposalLock)
+
+instance PUnsafeLiftDecl PProposalLock where type PLifted PProposalLock = ProposalLock
+deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PConstant ProposalLock)

 --------------------------------------------------------------------------------
 {- What this Policy does
@ -146,10 +252,7 @@ PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)]
 --------------------------------------------------------------------------------

 -- | Policy for Stake state threads.
-stakePolicy ::
-  forall (s :: S).
-  Stake ->
-  Term s PMintingPolicy
+stakePolicy :: Stake -> ClosedTerm PMintingPolicy
 stakePolicy stake =
  plam $ \_redeemer ctx' -> P.do
    ctx <- pletFields @'["txInfo", "purpose"] ctx'
@ -223,7 +326,7 @@ stakePolicy stake =
                          foldr1
                            (#&&)
                            [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
-                            , pgeqByClass' stake.gtClassRef.getAssetClass
+                            , pgeqByClass' (untag stake.gtClassRef)
                                # value
                                # expectedValue
                            , pgeqByClass
@ -242,17 +345,14 @@ stakePolicy stake =
 --------------------------------------------------------------------------------

 -- | Validator intended for Stake UTXOs to live in.
-stakeValidator ::
-  forall (s :: S).
-  Stake ->
-  Term s PValidator
+stakeValidator :: Stake -> ClosedTerm PValidator
 stakeValidator stake =
  plam $ \datum redeemer ctx' -> P.do
    ctx <- pletFields @'["txInfo", "purpose"] ctx'
    txInfo' <- plet ctx.txInfo
    txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo'

-    -- Coercion is safe in that if coercion fails we crash hard.
+    -- TODO: Use PTryFrom
    let stakeRedeemer :: Term _ PStakeRedeemer
        stakeRedeemer = pfromData $ punsafeCoerce redeemer
        stakeDatum' :: Term _ PStakeDatum
@ -264,28 +364,48 @@ stakeValidator stake =
    PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfo'
    ownAddress <- plet $ pfield @"address" #$ pfield @"resolved" # txInInfo
    let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo
+
+    -- Whether the owner signs this transaction or not.
    ownerSignsTransaction <- plet $ ptxSignedBy # ctx.txInfo # stakeDatum.owner
+
    stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake)
    mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfo.mint
    spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfo'

+    -- Is the stake currently locked?
+    stakeIsLocked <- plet $ stakeLocked # stakeDatum'
+
    pmatch stakeRedeemer $ \case
      PDestroy _ -> P.do
        passert "ST at inputs must be 1" $
          spentST #== 1
        passert "Should burn ST" $
          mintedST #== -1
-        passert "Stake unlocked" $
-          pnot #$ stakeLocked # stakeDatum'
+        passert "Stake unlocked" $ pnot # stakeIsLocked
        passert
          "Owner signs this transaction"
          ownerSignsTransaction
        popaque (pconstant ())
+      --------------------------------------------------------------------------
+      PRetractVotes _ -> P.do
+        passert
+          "Owner signs this transaction"
+          ownerSignsTransaction
+        -- TODO: check proposal constraints
+        popaque (pconstant ())
+      --------------------------------------------------------------------------
+      PPermitVote _ -> P.do
+        passert
+          "Owner signs this transaction"
+          ownerSignsTransaction
+        -- TODO: check proposal constraints
+        popaque (pconstant ())
+      --------------------------------------------------------------------------
      PDepositWithdraw r -> P.do
        passert "ST at inputs must be 1" $
          spentST #== 1
        passert "Stake unlocked" $
-          pnot #$ stakeLocked # stakeDatum'
+          pnot #$ stakeIsLocked
        passert
          "Owner signs this transaction"
          ownerSignsTransaction
@ -300,16 +420,13 @@ stakeValidator stake =
                    foldr1
                      (#&&)
                      [ stakeDatum.owner #== newStakeDatum.owner
-                      , (paddDiscrete # stakeDatum.stakedAmount # delta) #== newStakeDatum.stakedAmount
+                      , (stakeDatum.stakedAmount + delta) #== newStakeDatum.stakedAmount
                      , -- We can't magically conjure GT anyway (no input to spend!)
                        -- do we need to check this, really?
-                        pgeqDiscrete # (pfromData newStakeDatum.stakedAmount) # pzeroDiscrete
+                        zero #<= pfromData newStakeDatum.stakedAmount
                      ]
              let expectedValue = paddValue # continuingValue # (pdiscreteValue stake.gtClassRef # delta)

-              ptrace (pshow $ passetClassValueOf' stake.gtClassRef.getAssetClass # value)
-              ptrace (pshow $ passetClassValueOf' stake.gtClassRef.getAssetClass # expectedValue)
-
              -- TODO: Same as above. This is quite inefficient now, as it does two lookups
              -- instead of a more efficient single pass,
              -- but it doesn't really matter for this. At least it's correct.
@ -317,7 +434,7 @@ stakeValidator stake =
                    foldr1
                      (#&&)
                      [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
-                      , pgeqByClass' stake.gtClassRef.getAssetClass
+                      , pgeqByClass' (untag stake.gtClassRef)
                          # value
                          # expectedValue
                      , pgeqBySymbol
@ -340,6 +457,7 @@ stakeValidator stake =
 -- | Check whether a Stake is locked. If it is locked, various actions are unavailable.
 stakeLocked :: forall (s :: S). Term s (PStakeDatum :--> PBool)
 stakeLocked = phoistAcyclic $
-  plam $ \_stakeDatum ->
-    -- TODO: when we extend this to support proposals, this will need to do something
-    pcon PFalse
+  plam $ \stakeDatum ->
+    let locks :: Term _ (PBuiltinList (PAsData PProposalLock))
+        locks = pfield @"lockedBy" # stakeDatum
+     in pnotNull # locks
--- a/agora/Agora/Treasury.hs
+++ b/agora/Agora/Treasury.hs
@ -10,7 +10,7 @@ module Agora.Treasury (module Agora.Treasury) where

 import GHC.Generics qualified as GHC
 import Generics.SOP
-import Plutarch.Api.V1.Contexts (PScriptContext, PScriptPurpose (PMinting))
+import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting))
 import Plutarch.Api.V1.Value (PCurrencySymbol, PValue)
 import Plutarch.DataRepr (
  PDataFields,
@ -21,23 +21,25 @@ import Plutus.V1.Ledger.Value (CurrencySymbol)

 --------------------------------------------------------------------------------

-import Agora.AuthorityToken (authorityTokensValidIn)
-import Agora.Utils (allInputs, passert, psymbolValueOf)
+import Agora.AuthorityToken (singleAuthorityTokenBurned)
+import Agora.Utils (passert)
+import Plutarch (popaque)
+import Plutarch.Api.V1 (PValidator)
+import Plutarch.Unsafe (punsafeCoerce)

 {- | Validator ensuring that transactions consuming the treasury
     do so in a valid manner.
 -}
-treasuryV ::
-  forall {s :: S}.
+treasuryValidator ::
  CurrencySymbol ->
-  Term
-    s
-    ( PAsData PTreasuryDatum
-        :--> PAsData PTreasuryRedeemer
-        :--> PAsData PScriptContext
-        :--> PUnit
-    )
-treasuryV cs = plam $ \_d r ctx' -> P.do
+  ClosedTerm PValidator
+treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do
+  -- TODO: Use PTryFrom
+  let treasuryRedeemer :: Term _ (PAsData PTreasuryRedeemer)
+      treasuryRedeemer = punsafeCoerce redeemer
+      _treasuryDatum' :: Term _ (PAsData PTreasuryDatum)
+      _treasuryDatum' = punsafeCoerce datum
+
  -- plet required fields from script context.
  ctx <- pletFields @["txInfo", "purpose"] ctx'

@ -45,25 +47,19 @@ treasuryV cs = plam $ \_d r ctx' -> P.do
  PMinting _ <- pmatch ctx.purpose

  -- Ensure redeemer type is valid.
-  PAlterTreasuryParams _ <- pmatch $ pfromData r
+  PAlterTreasuryParams _ <- pmatch $ pfromData treasuryRedeemer

  -- Get the minted value from txInfo.
  txInfo' <- plet ctx.txInfo
  txInfo <- pletFields @'["mint"] txInfo'
-  let mint :: Term s PValue
+  let mint :: Term _ PValue
      mint = txInfo.mint
-      gatAmountMinted :: Term s PInteger
-      gatAmountMinted = psymbolValueOf # pconstant cs # mint

-  passert "GAT not burned." $ gatAmountMinted #== -1
+  gatCs <- plet $ pconstant gatCs'

-  passert "All inputs only have valid GATs" $
-    allInputs @PUnit # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
-      authorityTokensValidIn
-        # pconstant cs
-        # txOut
+  passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint

-  pconstant ()
+  popaque $ pconstant ()

 {- | Plutarch level type representing datum of the treasury.
     Contains:
--- a/agora/Agora/Utils.hs
+++ b/agora/Agora/Utils.hs
@ -25,6 +25,7 @@ module Agora.Utils (
  pfindTxInByTxOutRef,
  psingletonValue,
  pfindMap,
+  pnotNull,

  -- * Functions which should (probably) not be upstreamed
  anyOutput,
@ -281,6 +282,10 @@ pfindTxInByTxOutRef = phoistAcyclic $
          )
        #$ (pfield @"inputs" # txInfo)

+-- | True if a list is not empty.
+pnotNull :: forall list a. PIsListLike list a => Term _ (list a :--> PBool)
+pnotNull = phoistAcyclic $ plam $ pelimList (\_ _ -> pcon PTrue) (pcon PFalse)
+
 --------------------------------------------------------------------------------
 {- Functions which should (probably) not be upstreamed
   All of these functions are quite inefficient.
--- a/flake.lock
+++ b/flake.lock
@ -939,8 +939,6 @@
        "hpc-coveralls": "hpc-coveralls_3",
        "nix-tools": "nix-tools_3",
        "nixpkgs": [
-          "plutarch",
-          "haskell-nix",
          "nixpkgs-2111"
        ],
        "nixpkgs-2003": "nixpkgs-2003_3",
@ -1623,17 +1621,17 @@
        "validity": "validity"
      },
      "locked": {
-        "lastModified": 1648578429,
-        "narHash": "sha256-nEB6ujvX5aSpSk1EJ7/tAxW2lxB/eWXzJmyj7qyInpQ=",
+        "lastModified": 1648639396,
+        "narHash": "sha256-pAkEsIDXJckVYufVPUzD/4sq4/uE7iyV0IR2BuLhZjY=",
        "owner": "peter-mlabs",
        "repo": "plutarch",
-        "rev": "b4e71dc0f685d0d0c325eabbaac8c5b3352bfcf8",
+        "rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6",
        "type": "github"
      },
      "original": {
        "owner": "peter-mlabs",
-        "ref": "liqwid/extra",
        "repo": "plutarch",
+        "rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6",
        "type": "github"
      }
    },
--- a/flake.nix
+++ b/flake.nix
@ -7,7 +7,9 @@
  # see https://github.com/NixOS/nix/issues/6013
  inputs.nixpkgs-2111 = { url = "github:NixOS/nixpkgs/nixpkgs-21.11-darwin"; };

-  inputs.plutarch.url = "github:peter-mlabs/plutarch/liqwid/extra";
+  # Rev is this PR https://github.com/peter-mlabs/plutarch/pull/5.
+  inputs.plutarch.url =
+    "github:peter-mlabs/plutarch?rev=a7a410da209b9c14c834a41e07b1c197c2a4dcd6";
  inputs.plutarch.inputs.nixpkgs.follows =
    "plutarch/haskell-nix/nixpkgs-unstable";

@ -25,7 +27,6 @@
  inputs.apropos.inputs.nixpkgs.follows =
    "plutarch/haskell-nix/nixpkgs-unstable";

-
  outputs = inputs@{ self, nixpkgs, haskell-nix, plutarch, ... }:
    let
      supportedSystems = with nixpkgs.lib.systems.supported;
@ -57,8 +58,13 @@
          extraSources = plutarch.extraSources ++ [
            {
              src = inputs.plutarch;
-              subdirs =
-                [ "." "plutarch-test" "plutarch-extra" "plutarch-numeric" ];
+              subdirs = [
+                "."
+                "plutarch-test"
+                "plutarch-extra"
+                "plutarch-numeric"
+                "plutarch-safemoney"
+              ];
            }
            {
              src = inputs.apropos-tx;
@ -98,6 +104,7 @@
              ps.apropos
              ps.plutarch-extra
              ps.plutarch-numeric
+              ps.plutarch-safemoney
              ps.plutarch-test
              ps.apropos
            ];