add locks in datums, add documentation, ClosedTerm on scripts

Also added more lifting instances

agora/Agora/Effect.hs

@@ -23,11 +23,11 @@ import Plutus.V1.Ledger.Value (CurrencySymbol)
      helper.
 -}
 makeEffect ::
-  forall (datum :: PType) (s :: S).
+  forall (datum :: PType).
   PIsData datum =>
   CurrencySymbol ->
-  (Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
+  (forall (s :: S). Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
-  Term s PValidator
+  ClosedTerm PValidator
 makeEffect gatCs' f =
   plam $ \datum _redeemer ctx' -> P.do
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
@@ -40,7 +40,7 @@ makeEffect gatCs' f =
     txOutRef' <- plet (pfield @"_0" # txOutRef)
 
     txInfo <- pletFields @'["mint"] txInfo'
-    let mint :: Term s PValue
+    let mint :: Term _ PValue
         mint = txInfo.mint
 
     gatCs <- plet $ pconstant gatCs'

agora/Agora/Proposal.hs

@@ -24,6 +24,10 @@ module Agora.Proposal (
   PProposalVotes (..),
   PProposalTag (..),
   PResultTag (..),
+
+  -- * Scripts
+  proposalValidator,
+  proposalPolicy,
 ) where
 
 import GHC.Generics qualified as GHC
@@ -31,19 +35,25 @@ 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 (GTTag)
+import Plutarch (popaque)
+import Plutarch.Lift (DerivePConstantViaNewtype (..), PUnsafeLiftDecl (..))
 import Plutarch.SafeMoney (PDiscrete, Tagged)
 
 --------------------------------------------------------------------------------
@@ -57,7 +67,7 @@ import Plutarch.SafeMoney (PDiscrete, Tagged)
 @
 -}
 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,
@@ -123,7 +133,7 @@ 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)
@@ -163,10 +173,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'.
@@ -181,6 +203,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 ::
@@ -200,11 +225,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 ::
@@ -225,3 +259,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/Stake.hs

@@ -63,11 +63,11 @@ import Agora.Utils (
   anyOutput,
   paddValue,
   passert,
-  passetClassValueOf',
   pfindTxInByTxOutRef,
   pgeqByClass,
   pgeqByClass',
   pgeqBySymbol,
+  pnotNull,
   psingletonValue,
   psymbolValueOf,
   ptxSignedBy,
@@ -89,27 +89,72 @@ newtype Stake = Stake
   -- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code.
   }
 
--- | Haskell-level redeemer for Stake scripts.
+{- | A lock placed on a Stake datum in order to prevent
-data StakeRedeemer
+     depositing and withdrawing when votes are in place.
-  = -- | Deposit or withdraw a discrete amount of the staked governance token.
-    DepositWithdraw (Tagged GTTag Integer)
-  | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
-    Destroy
-  deriving stock (Show, GHC.Generic)
 
-PlutusTx.makeIsDataIndexed ''StakeRedeemer [('DepositWithdraw, 0), ('Destroy, 1)]
+     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 vaalidator and the proposal
+     validator are only able to check for eachother 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.
+  -- ^ 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.
+    --   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 be retracted with.
+    RetractVotes [ProposalLock]
+  deriving stock (Show, GHC.Generic)
+
+PlutusTx.makeIsDataIndexed
+  ''StakeRedeemer
+  [ ('DepositWithdraw, 0)
+  , ('Destroy, 1)
+  , ('PermitVote, 2)
+  , ('RetractVotes, 3)
+  ]
+
 -- | Haskell-level datum for Stake scripts.
 data StakeDatum = StakeDatum
   { stakedAmount :: Tagged GTTag Integer
@@ -158,6 +203,8 @@ data PStakeRedeemer (s :: S)
     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)
@@ -204,10 +251,7 @@ deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PCons
 --------------------------------------------------------------------------------
 
 -- | 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'
@@ -300,10 +344,7 @@ 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'
@@ -322,28 +363,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
@@ -365,9 +426,6 @@ stakeValidator stake =
                       ]
               let expectedValue = paddValue # continuingValue # (pdiscreteValue stake.gtClassRef # delta)
 
-              ptrace (pshow $ passetClassValueOf' (untag stake.gtClassRef) # value)
-              ptrace (pshow $ passetClassValueOf' (untag stake.gtClassRef) # 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.
@@ -401,5 +459,4 @@ stakeLocked = phoistAcyclic $
   plam $ \stakeDatum ->
     let locks :: Term _ (PBuiltinList (PAsData PProposalLock))
         locks = pfield @"lockedBy" # stakeDatum
-     in -- 'pnotNull' ?
+     in pnotNull # locks
-        pelimList (\_ _ -> pcon PTrue) (pcon PFalse) locks

agora/Agora/Treasury.hs

@@ -28,10 +28,8 @@ import Agora.Utils (passert)
      do so in a valid manner.
 -}
 treasuryV ::
-  forall {s :: S}.
   CurrencySymbol ->
-  Term
+  ClosedTerm
-    s
     ( PAsData PTreasuryDatum
         :--> PAsData PTreasuryRedeemer
         :--> PAsData PScriptContext
@@ -50,7 +48,7 @@ treasuryV gatCs' = plam $ \_d r ctx' -> P.do
   -- 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
 
   gatCs <- plet $ pconstant gatCs'

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.