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

Various changes & stake lock datum

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.
 

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)
                       }
                   ]

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})
       ]

agora.cabal

@@ -97,6 +97,7 @@ common deps
     , plutarch
     , plutarch-extra
     , plutarch-numeric
+    , plutarch-safemoney
     , plutus-core
     , plutus-ledger-api
     , plutus-tx

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 ->

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) ->
+  CurrencySymbol ->
-  Term s PValidator
+  (forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
-makeEffect f =
+  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 ())
+  )

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 ())

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 ())

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 (AssetClass (AssetClass))
-import Plutus.V1.Ledger.Value qualified as Value
-import PlutusTx qualified
 
-import Plutarch.Api.V1 (PValue)
+import Plutarch.SafeMoney
-import Plutarch.Builtin ()
-import Plutarch.Internal ()
-import Plutarch.Monadic qualified as P
-
---------------------------------------------------------------------------------
-
-import Agora.Utils (
-  passetClassValueOf',
-  psingletonValue,
- )
 
 --------------------------------------------------------------------------------
 -- 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 :: Tagged ADATag AssetClass
-adaRef = AssetClassRef (AssetClass ("", ""))
+adaRef = Tagged (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

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 (
+import Agora.Proposal (PProposalTag, PResultTag, ProposalTag (..), ResultTag (..))
-  AssetClassRef (..),
+import Agora.SafeMoney (GTTag)
-  Discrete,
-  GTTag,
-  PDiscrete,
-  paddDiscrete,
-  pdiscreteValue,
-  pgeqDiscrete,
-  pzeroDiscrete,
- )
 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.
+{- | A lock placed on a Stake datum in order to prevent
-data PStakeRedeemer (s :: S)
+     depositing and withdrawing when votes are in place.
-  = -- | Deposit or withdraw a discrete amount of the staked governance token.
+
-    PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag]))
+     NOTE: Due to retracting votes always being possible,
-  | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
+     this lock will only lock with contention on the proposal.
-    PDestroy (Term s (PDataRecord '[]))
+
-  deriving stock (GHC.Generic)
+     FIXME: Contention on Proposals could create contention
-  deriving anyclass (Generic)
+     on voting which in turn creates contention on stakers.
-  deriving anyclass (PIsDataRepr)
+
-  deriving
+     Vaguely this is the dependency graph for this locking
-    (PlutusType, PIsData)
+     interaction. Both the stake validator and the proposal
-    via PIsDataReprInstances PStakeRedeemer
+     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.
+instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum
-data StakeDatum = StakeDatum
+deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstant StakeDatum)
-  { stakedAmount :: Discrete GTTag
-  , owner :: PubKeyHash
-  }
-  deriving stock (Show, GHC.Generic)
 
-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 ::
+stakePolicy :: Stake -> ClosedTerm PMintingPolicy
-  forall (s :: S).
-  Stake ->
-  Term s 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 ::
+stakeValidator :: Stake -> ClosedTerm PValidator
-  forall (s :: S).
-  Stake ->
-  Term s 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" $
+        passert "Stake unlocked" $ pnot # stakeIsLocked
-          pnot #$ stakeLocked # stakeDatum'
         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 ->
+  plam $ \stakeDatum ->
-    -- TODO: when we extend this to support proposals, this will need to do something
+    let locks :: Term _ (PBuiltinList (PAsData PProposalLock))
-    pcon PFalse
+        locks = pfield @"lockedBy" # stakeDatum
+     in pnotNull # locks

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.AuthorityToken (singleAuthorityTokenBurned)
-import Agora.Utils (allInputs, passert, psymbolValueOf)
+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 ::
+treasuryValidator ::
-  forall {s :: S}.
   CurrencySymbol ->
-  Term
+  ClosedTerm PValidator
-    s
+treasuryValidator gatCs' = plam $ \datum redeemer ctx' -> P.do
-    ( PAsData PTreasuryDatum
+  -- TODO: Use PTryFrom
-        :--> PAsData PTreasuryRedeemer
+  let treasuryRedeemer :: Term _ (PAsData PTreasuryRedeemer)
-        :--> PAsData PScriptContext
+      treasuryRedeemer = punsafeCoerce redeemer
-        :--> PUnit
+      _treasuryDatum' :: Term _ (PAsData PTreasuryDatum)
-    )
+      _treasuryDatum' = punsafeCoerce datum
-treasuryV cs = plam $ \_d r ctx' -> P.do
+
   -- 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" $
+  passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint
-    allInputs @PUnit # pfromData ctx.txInfo #$ plam $ \txOut _value _address _datum ->
-      authorityTokensValidIn
-        # pconstant cs
-        # txOut
 
-  pconstant ()
+  popaque $ pconstant ()
 
 {- | Plutarch level type representing datum of the treasury.
      Contains:

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.

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,
+        "lastModified": 1648639396,
-        "narHash": "sha256-nEB6ujvX5aSpSk1EJ7/tAxW2lxB/eWXzJmyj7qyInpQ=",
+        "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"
       }
     },

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 =
+              subdirs = [
-                [ "." "plutarch-test" "plutarch-extra" "plutarch-numeric" ];
+                "."
+                "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
             ];