Sulkta-OSS/agora
3
0
Fork 0
Code Issues 1 Pull requests Projects Releases Packages Wiki Activity Actions

add @since tags to everything

Browse source
This commit is contained in:
Emily Martins 2022-06-22 18:15:20 +02:00
parent 9f98653ca6
commit c9ec0d05c4
19 changed files with 1213 additions and 445 deletions
Download patch file Download diff file Expand all files Collapse all files

6
CHANGELOG.md
View file

@ -2,4 +2,8 @@
This format is based on [Keep A Changelog](https://keepachangelog.com/en/1.0.0). This format is based on [Keep A Changelog](https://keepachangelog.com/en/1.0.0).
## Unreleased ## 0.1.0 -- 2022-06-22
### Added
* First release

2
agora.cabal
View file

@ -1,6 +1,6 @@
cabal-version: 3.0 cabal-version: 3.0
name: agora name: agora
version: 0.1 version: 0.1.0
extra-source-files: CHANGELOG.md extra-source-files: CHANGELOG.md
author: Emily Martins <emi@haskell.fyi> author: Emily Martins <emi@haskell.fyi>
license: Apache-2.0 license: Apache-2.0

36
agora/Agora/AuthorityToken.hs
View file

@ -2,6 +2,7 @@
Module : Agora.AuthorityToken Module : Agora.AuthorityToken
Maintainer : emi@haskell.fyi Maintainer : emi@haskell.fyi
Description: Tokens acting as redeemable proofs of DAO authority. Description: Tokens acting as redeemable proofs of DAO authority.
Tokens acting as redeemable proofs of DAO authority. Tokens acting as redeemable proofs of DAO authority.
-} -}
module Agora.AuthorityToken ( module Agora.AuthorityToken (
@ -11,8 +12,7 @@ module Agora.AuthorityToken (
AuthorityToken (..), AuthorityToken (..),
) where ) where
-------------------------------------------------------------------------------- import GHC.Generics qualified as GHC
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
AmountGuarantees, AmountGuarantees,
KeyGuarantees, KeyGuarantees,
@ -38,21 +38,23 @@ import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import GHC.Generics qualified as GHC
--------------------------------------------------------------------------------
{- | An AuthorityToken represents a proof that a particular token {- | An AuthorityToken represents a proof that a particular token
moved while this token was minted. In effect, this means that spent in the same transaction the AuthorityToken was minted.
the validator that locked such a token must have approved In effect, this means that the validator that locked such a token
said transaction. Said validator should be made aware of must have approved the transaction in which an AuthorityToken is minted.
*this* token's existence in order to prevent incorrect minting. Said validator should be made aware of an AuthorityToken token's existence
in order to prevent incorrect minting.
@since 0.1.0
-} -}
newtype AuthorityToken = AuthorityToken newtype AuthorityToken = AuthorityToken
{ authority :: AssetClass { authority :: AssetClass
-- ^ Token that must move in order for minting this to be valid. -- ^ Token that must move in order for minting this to be valid.
} }
deriving stock (GHC.Generic) deriving stock
( -- | @since 0.1.0
GHC.Generic
)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -64,6 +66,8 @@ newtype AuthorityToken = AuthorityToken
it was sent to, this is enough to prove validity. it was sent to, this is enough to prove validity.
In other words, check that all assets of a particular currency symbol In other words, check that all assets of a particular currency symbol
are tagged with a TokenName that matches where they live. are tagged with a TokenName that matches where they live.
@since 0.1.0
-} -}
authorityTokensValidIn :: Term s (PCurrencySymbol :--> PTxOut :--> PBool) authorityTokensValidIn :: Term s (PCurrencySymbol :--> PTxOut :--> PBool)
authorityTokensValidIn = phoistAcyclic $ authorityTokensValidIn = phoistAcyclic $
@ -94,7 +98,10 @@ authorityTokensValidIn = phoistAcyclic $
-- No GATs exist at this output! -- No GATs exist at this output!
pconstant True pconstant True
-- | Assert that a single authority token has been burned. {- | Assert that a single authority token has been burned.
@since 0.1.0
-}
singleAuthorityTokenBurned :: singleAuthorityTokenBurned ::
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S). forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
Term s PCurrencySymbol -> Term s PCurrencySymbol ->
@ -122,7 +129,10 @@ singleAuthorityTokenBurned gatCs txInfo mint = unTermCont $ do
# txInfoF.inputs # txInfoF.inputs
] ]
-- | Policy given 'AuthorityToken' params. {- | Policy given 'AuthorityToken' params.
@since 0.1.0
-}
authorityTokenPolicy :: AuthorityToken -> ClosedTerm PMintingPolicy authorityTokenPolicy :: AuthorityToken -> ClosedTerm PMintingPolicy
authorityTokenPolicy params = authorityTokenPolicy params =
plam $ \_redeemer ctx' -> plam $ \_redeemer ctx' ->

4
agora/Agora/Effect.hs
View file

@ -13,13 +13,13 @@ import Plutarch.Extra.TermCont (pguardC, pletC, pmatchC, ptryFromC)
import Plutarch.TryFrom () import Plutarch.TryFrom ()
import PlutusLedgerApi.V1.Value (CurrencySymbol) import PlutusLedgerApi.V1.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 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 an effect is implemented. In such situations, it's okay to not use this
helper. helper.
@since 0.1.0
-} -}
makeEffect :: makeEffect ::
forall (datum :: PType). forall (datum :: PType).

125
agora/Agora/Effect/GovernorMutation.hs
View file

@ -18,39 +18,6 @@ module Agora.Effect.GovernorMutation (
mutateGovernorValidator, mutateGovernorValidator,
) where ) where
--------------------------------------------------------------------------------
import Control.Applicative (Const)
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
--------------------------------------------------------------------------------
import Plutarch.Api.V1 (
PTxOutRef,
PValidator,
PValue,
)
import Plutarch.Api.V1.ScriptContext (ptryFindDatum)
import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (pvalueOf)
import Plutarch.DataRepr (
DerivePConstantViaData (..),
PDataFields,
PIsDataReprInstances (PIsDataReprInstances),
)
import Plutarch.Extra.TermCont (pguardC)
import Plutarch.Lift (PConstantDecl, PLifted, PUnsafeLiftDecl)
import Plutarch.TryFrom (PTryFrom (..))
import Plutarch.Unsafe (punsafeCoerce)
--------------------------------------------------------------------------------
import PlutusLedgerApi.V1 (TxOutRef)
import PlutusLedgerApi.V1.Value (AssetClass (..))
import PlutusTx qualified
--------------------------------------------------------------------------------
import Agora.Effect (makeEffect) import Agora.Effect (makeEffect)
import Agora.Governor ( import Agora.Governor (
Governor, Governor,
@ -67,10 +34,35 @@ import Agora.Utils (
mustBePDJust, mustBePDJust,
mustBePJust, mustBePJust,
) )
import Control.Applicative (Const)
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 (
PTxOutRef,
PValidator,
PValue,
)
import Plutarch.Api.V1.ScriptContext (ptryFindDatum)
import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (pvalueOf)
import Plutarch.DataRepr (
DerivePConstantViaData (..),
PDataFields,
PIsDataReprInstances (PIsDataReprInstances),
)
import Plutarch.Extra.TermCont (pguardC)
import Plutarch.Lift (PConstantDecl, PLifted, PUnsafeLiftDecl)
import Plutarch.TryFrom (PTryFrom (..))
import Plutarch.Unsafe (punsafeCoerce)
import PlutusLedgerApi.V1 (TxOutRef)
import PlutusLedgerApi.V1.Value (AssetClass (..))
import PlutusTx qualified
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Haskell-level datum for the governor mutation effect script. {- | Haskell-level datum for the governor mutation effect script.
@since 0.1.0
-}
data MutateGovernorDatum = MutateGovernorDatum data MutateGovernorDatum = MutateGovernorDatum
{ governorRef :: TxOutRef { governorRef :: TxOutRef
-- ^ Referenced governor state UTXO should be updated by the effect. -- ^ Referenced governor state UTXO should be updated by the effect.
@ -84,7 +76,10 @@ PlutusTx.makeIsDataIndexed ''MutateGovernorDatum [('MutateGovernorDatum, 0)]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Plutarch-level version of 'MutateGovernorDatum'. {- | Plutarch-level version of 'MutateGovernorDatum'.
@since 0.1.0
-}
newtype PMutateGovernorDatum (s :: S) newtype PMutateGovernorDatum (s :: S)
= PMutateGovernorDatum = PMutateGovernorDatum
( Term ( Term
@ -95,17 +90,39 @@ newtype PMutateGovernorDatum (s :: S)
] ]
) )
) )
deriving stock (GHC.Generic) deriving stock
deriving anyclass (Generic) ( -- | @since 0.1.0
deriving anyclass (PIsDataRepr) GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving deriving
(PlutusType, PIsData, PDataFields, PEq) ( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
, -- | @since 0.1.0
PEq
)
via (PIsDataReprInstances PMutateGovernorDatum) via (PIsDataReprInstances PMutateGovernorDatum)
-- | @since 0.1.0
instance PUnsafeLiftDecl PMutateGovernorDatum where type PLifted PMutateGovernorDatum = MutateGovernorDatum instance PUnsafeLiftDecl PMutateGovernorDatum where type PLifted PMutateGovernorDatum = MutateGovernorDatum
-- | @since 0.1.0
deriving via (DerivePConstantViaData MutateGovernorDatum PMutateGovernorDatum) instance (PConstantDecl MutateGovernorDatum) deriving via (DerivePConstantViaData MutateGovernorDatum PMutateGovernorDatum) instance (PConstantDecl MutateGovernorDatum)
-- TODO: Derive this. -- TODO: Derive this.
-- | @since 0.1.0
instance PTryFrom PData (PAsData PMutateGovernorDatum) where instance PTryFrom PData (PAsData PMutateGovernorDatum) where
type PTryFromExcess PData (PAsData PMutateGovernorDatum) = Const () type PTryFromExcess PData (PAsData PMutateGovernorDatum) = Const ()
ptryFrom' d k = ptryFrom' d k =
@ -115,26 +132,28 @@ instance PTryFrom PData (PAsData PMutateGovernorDatum) where
{- | Validator for the governor mutation effect. {- | Validator for the governor mutation effect.
This effect is implemented using the 'Agora.Effect.makeEffect' wrapper, This effect is implemented using the 'Agora.Effect.makeEffect' wrapper,
meaning that the burning of GAT is checked in said wrapper. meaning that the burning of GAT is checked in said wrapper.
In order to locate the governor, the validator is parametrized with a 'Agora.Governor.Governor'. In order to locate the governor, the validator is parametrized with a 'Agora.Governor.Governor'.
All the information it needs to validate the effect is encoded in the 'MutateGovernorDatum', All the information it needs to validate the effect is encoded in the 'MutateGovernorDatum',
so regardless what redeemer it's given, it will check: so regardless what redeemer it's given, it will check:
- No token is minted/burnt other than GAT. - No token is minted/burnt other than GAT.
- Nothing is being paid to the the effect validator. - Nothing is being paid to the the effect validator.
- The governor's state UTXO must be spent: - The governor's state UTXO must be spent:
* It carries exactly one GST. * It carries exactly one GST.
* It's referenced by 'governorRef' in the effect's datum. * It's referenced by 'governorRef' in the effect's datum.
- A new state UTXO is paid to the governor: - A new state UTXO is paid to the governor:
* It contains the GST. * It contains the GST.
* It has valid governor state datum. * It has valid governor state datum.
* The datum is exactly the same as the 'newDatum'. * The datum is exactly the same as the 'newDatum'.
@since 0.1.0
-} -}
mutateGovernorValidator :: Governor -> ClosedTerm PValidator mutateGovernorValidator :: Governor -> ClosedTerm PValidator
mutateGovernorValidator gov = makeEffect (authorityTokenSymbolFromGovernor gov) $ mutateGovernorValidator gov = makeEffect (authorityTokenSymbolFromGovernor gov) $

21
agora/Agora/Effect/NoOp.hs
View file

@ -14,10 +14,20 @@ import Plutarch.Api.V1 (PValidator)
import Plutarch.TryFrom (PTryFrom (..)) import Plutarch.TryFrom (PTryFrom (..))
import PlutusLedgerApi.V1.Value (CurrencySymbol) import PlutusLedgerApi.V1.Value (CurrencySymbol)
-- | Dummy datum for NoOp effect. {- | Dummy datum for NoOp effect.
newtype PNoOp (s :: S) = PNoOp (Term s PUnit)
deriving (PlutusType, PIsData) via (DerivePNewtype PNoOp PUnit)
@since 0.1.0
-}
newtype PNoOp (s :: S) = PNoOp (Term s PUnit)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via (DerivePNewtype PNoOp PUnit)
-- | @since 0.1.0
instance PTryFrom PData (PAsData PNoOp) where instance PTryFrom PData (PAsData PNoOp) where
type PTryFromExcess PData (PAsData PNoOp) = Const () type PTryFromExcess PData (PAsData PNoOp) = Const ()
ptryFrom' _ cont = ptryFrom' _ cont =
@ -26,7 +36,10 @@ instance PTryFrom PData (PAsData PNoOp) where
-- It should always be reduced to Unit. -- It should always be reduced to Unit.
cont (pdata $ pcon $ PNoOp (pconstant ()), ()) cont (pdata $ pcon $ PNoOp (pconstant ()), ())
-- | Dummy effect which can only burn its GAT. {- | Dummy effect which can only burn its GAT.
@since 0.1.0
-}
noOpValidator :: CurrencySymbol -> ClosedTerm PValidator noOpValidator :: CurrencySymbol -> ClosedTerm PValidator
noOpValidator curr = makeEffect curr $ noOpValidator curr = makeEffect curr $
\_ (_datum :: Term s PNoOp) _ _ -> popaque (pconstant ()) \_ (_datum :: Term s PNoOp) _ _ -> popaque (pconstant ())

72
agora/Agora/Effect/TreasuryWithdrawal.hs
View file

@ -13,12 +13,11 @@ module Agora.Effect.TreasuryWithdrawal (
treasuryWithdrawalValidator, treasuryWithdrawalValidator,
) where ) where
import Agora.Effect (makeEffect)
import Agora.Utils (isPubKey)
import Control.Applicative (Const) import Control.Applicative (Const)
import GHC.Generics qualified as GHC import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I)) import Generics.SOP (Generic, I (I))
import Agora.Effect (makeEffect)
import Agora.Utils (isPubKey)
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
AmountGuarantees (Positive), AmountGuarantees (Positive),
KeyGuarantees (Sorted), KeyGuarantees (Sorted),
@ -28,8 +27,6 @@ import Plutarch.Api.V1 (
PValue, PValue,
ptuple, ptuple,
) )
import Plutarch.Internal (punsafeCoerce)
import Plutarch.Api.V1.ScriptContext (pfindTxInByTxOutRef) import Plutarch.Api.V1.ScriptContext (pfindTxInByTxOutRef)
import "plutarch" Plutarch.Api.V1.Value (pnormalize) import "plutarch" Plutarch.Api.V1.Value (pnormalize)
import Plutarch.DataRepr ( import Plutarch.DataRepr (
@ -38,6 +35,7 @@ import Plutarch.DataRepr (
PIsDataReprInstances (..), PIsDataReprInstances (..),
) )
import Plutarch.Extra.TermCont (pguardC, pletC, pmatchC) import Plutarch.Extra.TermCont (pguardC, pletC, pmatchC)
import Plutarch.Internal (punsafeCoerce)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
import Plutarch.TryFrom (PTryFrom (..)) import Plutarch.TryFrom (PTryFrom (..))
import PlutusLedgerApi.V1.Credential (Credential) import PlutusLedgerApi.V1.Credential (Credential)
@ -46,9 +44,11 @@ import PlutusTx qualified
{- | Datum that encodes behavior of Treasury Withdrawal effect. {- | Datum that encodes behavior of Treasury Withdrawal effect.
Note: This Datum acts like a "predefined redeemer". Which is to say that Note: This Datum acts like a "predefined redeemer". Which is to say that
it encodes the properties a redeemer would, but is locked in-place until it encodes the properties a redeemer would, but is locked in-place until
spend. spend.
@since 0.1.0
-} -}
data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum
{ receivers :: [(Credential, Value)] { receivers :: [(Credential, Value)]
@ -56,13 +56,27 @@ data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum
, treasuries :: [Credential] , treasuries :: [Credential]
-- ^ What Credentials is spending from legal. -- ^ What Credentials is spending from legal.
} }
deriving stock (Show, GHC.Generic) deriving stock
deriving anyclass (Generic) ( -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
-- | @since 0.1.0
PlutusTx.makeLift ''TreasuryWithdrawalDatum PlutusTx.makeLift ''TreasuryWithdrawalDatum
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed ''TreasuryWithdrawalDatum [('TreasuryWithdrawalDatum, 0)] PlutusTx.makeIsDataIndexed ''TreasuryWithdrawalDatum [('TreasuryWithdrawalDatum, 0)]
-- | Haskell-level version of 'TreasuryWithdrawalDatum'. {- | Haskell-level version of 'TreasuryWithdrawalDatum'.
@since 0.1.0
-}
newtype PTreasuryWithdrawalDatum (s :: S) newtype PTreasuryWithdrawalDatum (s :: S)
= PTreasuryWithdrawalDatum = PTreasuryWithdrawalDatum
( Term ( Term
@ -73,20 +87,37 @@ newtype PTreasuryWithdrawalDatum (s :: S)
] ]
) )
) )
deriving stock (GHC.Generic) deriving stock
deriving anyclass (Generic, PIsDataRepr) ( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
, -- | @since 0.1.0
PIsDataRepr
)
deriving deriving
(PlutusType, PIsData, PDataFields) ( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
)
via PIsDataReprInstances PTreasuryWithdrawalDatum via PIsDataReprInstances PTreasuryWithdrawalDatum
-- | @since 0.1.0
instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where
type PLifted PTreasuryWithdrawalDatum = TreasuryWithdrawalDatum type PLifted PTreasuryWithdrawalDatum = TreasuryWithdrawalDatum
-- | @since 0.1.0
deriving via deriving via
(DerivePConstantViaData TreasuryWithdrawalDatum PTreasuryWithdrawalDatum) (DerivePConstantViaData TreasuryWithdrawalDatum PTreasuryWithdrawalDatum)
instance instance
(PConstantDecl TreasuryWithdrawalDatum) (PConstantDecl TreasuryWithdrawalDatum)
-- | @since 0.1.0
instance PTryFrom PData (PAsData PTreasuryWithdrawalDatum) where instance PTryFrom PData (PAsData PTreasuryWithdrawalDatum) where
type PTryFromExcess PData (PAsData PTreasuryWithdrawalDatum) = Const () type PTryFromExcess PData (PAsData PTreasuryWithdrawalDatum) = Const ()
ptryFrom' opq cont = ptryFrom' opq cont =
@ -101,12 +132,17 @@ instance PTryFrom PData (PAsData PTreasuryWithdrawalDatum) where
The validator does not accept any Redeemer as all "parameters" are provided The validator does not accept any Redeemer as all "parameters" are provided
via encoded Datum. via encoded Datum.
Note: NOTE: It should check...
It should check...
1. Transaction outputs should contain all of what Datum specified 1. Transaction outputs should contain all of what Datum specified
2. Left over assets should be redirected back to Treasury
2. Left over assets should be redirected back to Treasury
It can be more flexiable over... It can be more flexiable over...
- The number of outputs themselves - The number of outputs themselves
@since 0.1.0
-} -}
treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator treasuryWithdrawalValidator :: forall {s :: S}. CurrencySymbol -> Term s PValidator
treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $

113
agora/Agora/Governor.hs
View file

@ -23,15 +23,6 @@ module Agora.Governor (
governorDatumValid, governorDatumValid,
) where ) where
--------------------------------------------------------------------------------
import Control.Applicative (Const)
import Data.Tagged (Tagged (..))
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
--------------------------------------------------------------------------------
import Agora.Proposal ( import Agora.Proposal (
PProposalId (..), PProposalId (..),
PProposalThresholds (..), PProposalThresholds (..),
@ -45,9 +36,10 @@ import Agora.Proposal.Time (
ProposalTimingConfig, ProposalTimingConfig,
) )
import Agora.SafeMoney (GTTag) import Agora.SafeMoney (GTTag)
import Control.Applicative (Const)
-------------------------------------------------------------------------------- import Data.Tagged (Tagged (..))
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Plutarch.DataRepr ( import Plutarch.DataRepr (
DerivePConstantViaData (..), DerivePConstantViaData (..),
PDataFields, PDataFields,
@ -59,16 +51,16 @@ import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
import Plutarch.SafeMoney (PDiscrete (..)) import Plutarch.SafeMoney (PDiscrete (..))
import Plutarch.TryFrom (PTryFrom (..)) import Plutarch.TryFrom (PTryFrom (..))
import Plutarch.Unsafe (punsafeCoerce) import Plutarch.Unsafe (punsafeCoerce)
--------------------------------------------------------------------------------
import PlutusLedgerApi.V1 (TxOutRef) import PlutusLedgerApi.V1 (TxOutRef)
import PlutusLedgerApi.V1.Value (AssetClass (..)) import PlutusLedgerApi.V1.Value (AssetClass (..))
import PlutusTx qualified import PlutusTx qualified
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Datum for the Governor script. {- | Datum for the Governor script.
@since 0.1.0
-}
data GovernorDatum = GovernorDatum data GovernorDatum = GovernorDatum
{ proposalThresholds :: ProposalThresholds { proposalThresholds :: ProposalThresholds
-- ^ Gets copied over upon creation of a 'Agora.Proposal.ProposalDatum'. -- ^ Gets copied over upon creation of a 'Agora.Proposal.ProposalDatum'.
@ -82,6 +74,7 @@ data GovernorDatum = GovernorDatum
} }
deriving stock (Show, GHC.Generic) deriving stock (Show, GHC.Generic)
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)] PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)]
{- | Redeemer for Governor script. The governor has two primary {- | Redeemer for Governor script. The governor has two primary
@ -91,6 +84,8 @@ PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)]
2. The gating of minting authority tokens. 2. The gating of minting authority tokens.
Parameters of the governor can also be mutated by an effect. Parameters of the governor can also be mutated by an effect.
@since 0.1.0
-} -}
data GovernorRedeemer data GovernorRedeemer
= -- | Checks that a proposal was created lawfully, and allows it. = -- | Checks that a proposal was created lawfully, and allows it.
@ -102,6 +97,7 @@ data GovernorRedeemer
MutateGovernor MutateGovernor
deriving stock (Show, GHC.Generic) deriving stock (Show, GHC.Generic)
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed PlutusTx.makeIsDataIndexed
''GovernorRedeemer ''GovernorRedeemer
[ ('CreateProposal, 0) [ ('CreateProposal, 0)
@ -109,7 +105,10 @@ PlutusTx.makeIsDataIndexed
, ('MutateGovernor, 2) , ('MutateGovernor, 2)
] ]
-- | Parameters for creating Governor scripts. {- | Parameters for creating Governor scripts.
@since 0.1.0
-}
data Governor = Governor data Governor = Governor
{ gstOutRef :: TxOutRef { gstOutRef :: TxOutRef
-- ^ Referenced utxo will be spent to mint the GST. -- ^ Referenced utxo will be spent to mint the GST.
@ -123,7 +122,10 @@ data Governor = Governor
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Plutarch-level datum for the Governor script. {- | Plutarch-level datum for the Governor script.
@since 0.1.0
-}
newtype PGovernorDatum (s :: S) = PGovernorDatum newtype PGovernorDatum (s :: S) = PGovernorDatum
{ getGovernorDatum :: { getGovernorDatum ::
Term Term
@ -136,53 +138,104 @@ newtype PGovernorDatum (s :: S) = PGovernorDatum
] ]
) )
} }
deriving stock (GHC.Generic) deriving stock
deriving anyclass (Generic) ( -- | @since 0.1.0
deriving anyclass (PIsDataRepr) GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving deriving
(PlutusType, PIsData, PDataFields, PEq) ( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
, -- | @since 0.1.0
PEq
)
via PIsDataReprInstances PGovernorDatum via PIsDataReprInstances PGovernorDatum
-- | @since 0.1.0
instance PUnsafeLiftDecl PGovernorDatum where type PLifted PGovernorDatum = GovernorDatum instance PUnsafeLiftDecl PGovernorDatum where type PLifted PGovernorDatum = GovernorDatum
-- | @since 0.1.0
deriving via (DerivePConstantViaData GovernorDatum PGovernorDatum) instance (PConstantDecl GovernorDatum) deriving via (DerivePConstantViaData GovernorDatum PGovernorDatum) instance (PConstantDecl GovernorDatum)
-- FIXME: derive this via 'PIsDataReprInstances' -- FIXME: derive this via 'PIsDataReprInstances'
-- Blocked by: PProposalThresholds -- Blocked by: PProposalThresholds
-- | @since 0.1.0
instance PTryFrom PData (PAsData PGovernorDatum) where instance PTryFrom PData (PAsData PGovernorDatum) where
type PTryFromExcess PData (PAsData PGovernorDatum) = Const () type PTryFromExcess PData (PAsData PGovernorDatum) = Const ()
ptryFrom' d k = k (punsafeCoerce d, ()) ptryFrom' d k = k (punsafeCoerce d, ())
-- | Plutarch-level version of 'GovernorRedeemer'. {- | Plutarch-level version of 'GovernorRedeemer'.
@since 0.1.0
-}
data PGovernorRedeemer (s :: S) data PGovernorRedeemer (s :: S)
= PCreateProposal (Term s (PDataRecord '[])) = PCreateProposal (Term s (PDataRecord '[]))
| PMintGATs (Term s (PDataRecord '[])) | PMintGATs (Term s (PDataRecord '[]))
| PMutateGovernor (Term s (PDataRecord '[])) | PMutateGovernor (Term s (PDataRecord '[]))
deriving stock (GHC.Generic) deriving stock
deriving anyclass (Generic) ( -- | @since 0.1.0
deriving anyclass (PIsDataRepr) GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving deriving
(PlutusType, PIsData) ( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via PIsDataReprInstances PGovernorRedeemer via PIsDataReprInstances PGovernorRedeemer
-- | @since 0.1.0
instance PUnsafeLiftDecl PGovernorRedeemer where type PLifted PGovernorRedeemer = GovernorRedeemer instance PUnsafeLiftDecl PGovernorRedeemer where type PLifted PGovernorRedeemer = GovernorRedeemer
-- | @since 0.1.0
deriving via (DerivePConstantViaData GovernorRedeemer PGovernorRedeemer) instance (PConstantDecl GovernorRedeemer) deriving via (DerivePConstantViaData GovernorRedeemer PGovernorRedeemer) instance (PConstantDecl GovernorRedeemer)
-- | @since 0.1.0
deriving via PAsData (PIsDataReprInstances PGovernorRedeemer) instance PTryFrom PData (PAsData PGovernorRedeemer) deriving via PAsData (PIsDataReprInstances PGovernorRedeemer) instance PTryFrom PData (PAsData PGovernorRedeemer)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Plutrach version of 'getNextProposalId'. {- | Plutrach version of 'getNextProposalId'.
@since 0.1.0
-}
pgetNextProposalId :: Term s (PProposalId :--> PProposalId) pgetNextProposalId :: Term s (PProposalId :--> PProposalId)
pgetNextProposalId = phoistAcyclic $ plam $ \(pto -> pid) -> pcon $ PProposalId $ pid + 1 pgetNextProposalId = phoistAcyclic $ plam $ \(pto -> pid) -> pcon $ PProposalId $ pid + 1
-- | Get next proposal id. {- | Get next proposal id.
@since 0.1.0
-}
getNextProposalId :: ProposalId -> ProposalId getNextProposalId :: ProposalId -> ProposalId
getNextProposalId (ProposalId pid) = ProposalId $ pid + 1 getNextProposalId (ProposalId pid) = ProposalId $ pid + 1
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Check whether a particular 'PGovernorDatum' is well-formed. {- | Check whether a particular 'PGovernorDatum' is well-formed.
@since 0.1.0
-}
governorDatumValid :: Term s (PGovernorDatum :--> PBool) governorDatumValid :: Term s (PGovernorDatum :--> PBool)
governorDatumValid = phoistAcyclic $ governorDatumValid = phoistAcyclic $
plam $ \datum -> unTermCont $ do plam $ \datum -> unTermCont $ do

174
agora/Agora/Governor/Scripts.hs
View file

@ -154,6 +154,8 @@ import PlutusLedgerApi.V1.Value (
NOTE: It's user's responsibility to make sure the token is sent to the corresponding governor validator. NOTE: It's user's responsibility to make sure the token is sent to the corresponding governor validator.
We /can't/ really check this in the policy, otherwise we create a cyclic reference issue. We /can't/ really check this in the policy, otherwise we create a cyclic reference issue.
@since 0.1.0
-} -}
governorPolicy :: Governor -> ClosedTerm PMintingPolicy governorPolicy :: Governor -> ClosedTerm PMintingPolicy
governorPolicy gov = governorPolicy gov =
@ -191,87 +193,89 @@ governorPolicy gov =
{- | Validator for Governors. {- | Validator for Governors.
== Common checks == Common checks
The validator always ensures: The validator always ensures:
- The UTXO which holds the GST must be spent. - The UTXO which holds the GST must be spent.
- The GST always stays at the validator's address. - The GST always stays at the validator's address.
- The new state UTXO has a valid datum of type 'Agora.Governor.GovernorDatum'. - The new state UTXO has a valid datum of type 'Agora.Governor.GovernorDatum'.
== Creating a Proposal == Creating a Proposal
When the redeemer is 'Agora.Governor.CreateProposal', the script will check: When the redeemer is 'Agora.Governor.CreateProposal', the script will check:
- For governor's state datum: - For governor's state datum:
* 'Agora.Governor.nextProposalId' is advanced. * 'Agora.Governor.nextProposalId' is advanced.
* Nothing is changed other that that. * Nothing is changed other that that.
- Exactly one stake (the "input stake") must be provided in the input: - Exactly one stake (the "input stake") must be provided in the input:
* At least 'Agora.Stake.stackedAmount' of GT must be spent in the transaction. * At least 'Agora.Stake.stackedAmount' of GT must be spent in the transaction.
* The transaction must be signed by the stake owner. * The transaction must be signed by the stake owner.
- Exactly one new proposal state token is minted. - Exactly one new proposal state token is minted.
- An UTXO which holds the newly minted proposal state token is sent to the proposal validator. - An UTXO which holds the newly minted proposal state token is sent to the proposal validator.
This UTXO must have a valid datum of type 'Agora.Proposal.ProposalDatum', the datum must: This UTXO must have a valid datum of type 'Agora.Proposal.ProposalDatum', the datum must:
* Copy its id and thresholds from the governor's state. * Copy its id and thresholds from the governor's state.
* Have status set to 'Proposal.Draft'. * Have status set to 'Proposal.Draft'.
* Have zero votes. * Have zero votes.
* Have exactly one cosigner - the stake owner * Have exactly one cosigner - the stake owner
- An UTXO which holds the stake state token is sent back to the stake validator. - An UTXO which holds the stake state token is sent back to the stake validator.
This UTXO must have a valid datum of type 'Agora.Stake.StakeDatum': This UTXO must have a valid datum of type 'Agora.Stake.StakeDatum':
* The 'Agora.Stake.stakedAmount' and 'Agora.Stake.owner' should not be changed, * The 'Agora.Stake.stakedAmount' and 'Agora.Stake.owner' should not be changed,
comparing to the input stake. comparing to the input stake.
* The new proposal locks must be appended to the 'Agora.Stake.lockedBy'. * The new proposal locks must be appended to the 'Agora.Stake.lockedBy'.
== Minting GATs == Minting GATs
When the redeemer is 'Agora.Governor.MintGATs', the script will check: When the redeemer is 'Agora.Governor.MintGATs', the script will check:
- Governor's state is not changed. - Governor's state is not changed.
- Exactly only one proposal is in the inputs. Let's call this the /input proposal/. - Exactly only one proposal is in the inputs. Let's call this the /input proposal/.
- The proposal is in the 'Proposal.Executable' state. - The proposal is in the 'Proposal.Executable' state.
NOTE: The input proposal is found by looking for the UTXO with a proposal state token in the inputs. NOTE: The input proposal is found by looking for the UTXO with a proposal state token in the inputs.
=== Effect Group Selection === Effect Group Selection
Currently a proposal can have two or more than two options to vote on, Currently a proposal can have two or more than two options to vote on,
meaning that it can contains two or more effect groups, meaning that it can contains two or more effect groups,
according to [#39](https://github.com/Liqwid-Labs/agora/issues/39). according to [#39](https://github.com/Liqwid-Labs/agora/issues/39).
Either way, the shapes of 'Proposal.votes' and 'Proposal.effects' should be the same. Either way, the shapes of 'Proposal.votes' and 'Proposal.effects' should be the same.
This is checked by 'Proposal.proposalDatumValid'. This is checked by 'Proposal.proposalDatumValid'.
The script will look at the the 'Proposal.votes' to determine which group has the highest votes, The script will look at the the 'Proposal.votes' to determine which group has the highest votes,
said group shoud be executed. said group shoud be executed.
During the process, minimum votes requirement will also be enforced. During the process, minimum votes requirement will also be enforced.
Next, the script will: Next, the script will:
- Ensure that for every effect in the said effect group, - Ensure that for every effect in the said effect group,
exactly one valid GAT is minted and sent to the effect. exactly one valid GAT is minted and sent to the effect.
- The amount of GAT minted in the transaction should be equal to the number of effects. - The amount of GAT minted in the transaction should be equal to the number of effects.
- A new UTXO is sent to the proposal validator, this UTXO should: - A new UTXO is sent to the proposal validator, this UTXO should:
* Include the one proposal state token. * Include the one proposal state token.
* Have a valid datum of type 'Proposal.ProposalDatum'. * Have a valid datum of type 'Proposal.ProposalDatum'.
This datum should be as same as the one of the input proposal, This datum should be as same as the one of the input proposal,
except its status should be 'Proposal.Finished'. except its status should be 'Proposal.Finished'.
== Changing the State == Changing the State
Redeemer 'Agora.Governor.MutateGovernor' allows the state datum to be changed by an external effect. Redeemer 'Agora.Governor.MutateGovernor' allows the state datum to be changed by an external effect.
In this case, the script will check In this case, the script will check
- Exactly one GAT is burnt in the transaction. - Exactly one GAT is burnt in the transaction.
- Said GAT is tagged by the effect. - Said GAT is tagged by the effect.
@since 0.1.0
-} -}
governorValidator :: Governor -> ClosedTerm PValidator governorValidator :: Governor -> ClosedTerm PValidator
governorValidator gov = governorValidator gov =
@ -718,21 +722,30 @@ governorValidator gov =
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Get the 'CurrencySymbol' of GST. {- | Get the 'CurrencySymbol' of GST.
@since 0.1.0
-}
governorSTSymbolFromGovernor :: Governor -> CurrencySymbol governorSTSymbolFromGovernor :: Governor -> CurrencySymbol
governorSTSymbolFromGovernor gov = mintingPolicySymbol policy governorSTSymbolFromGovernor gov = mintingPolicySymbol policy
where where
policy :: MintingPolicy policy :: MintingPolicy
policy = mkMintingPolicy $ governorPolicy gov policy = mkMintingPolicy $ governorPolicy gov
-- | Get the 'AssetClass' of GST. {- | Get the 'AssetClass' of GST.
@since 0.1.0
-}
governorSTAssetClassFromGovernor :: Governor -> AssetClass governorSTAssetClassFromGovernor :: Governor -> AssetClass
governorSTAssetClassFromGovernor gov = AssetClass (symbol, "") governorSTAssetClassFromGovernor gov = AssetClass (symbol, "")
where where
symbol :: CurrencySymbol symbol :: CurrencySymbol
symbol = governorSTSymbolFromGovernor gov symbol = governorSTSymbolFromGovernor gov
-- | Get the 'CurrencySymbol' of the proposal state token. {- | Get the 'CurrencySymbol' of the proposal state token.
@since 0.1.0
-}
proposalSTSymbolFromGovernor :: Governor -> CurrencySymbol proposalSTSymbolFromGovernor :: Governor -> CurrencySymbol
proposalSTSymbolFromGovernor gov = symbol proposalSTSymbolFromGovernor gov = symbol
where where
@ -740,13 +753,19 @@ proposalSTSymbolFromGovernor gov = symbol
policy = mkMintingPolicy $ proposalPolicy gstAC policy = mkMintingPolicy $ proposalPolicy gstAC
symbol = mintingPolicySymbol policy symbol = mintingPolicySymbol policy
-- | Get the 'AssetClass' of the proposal state token. {- | Get the 'AssetClass' of the proposal state token.
@since 0.1.0
-}
proposalSTAssetClassFromGovernor :: Governor -> AssetClass proposalSTAssetClassFromGovernor :: Governor -> AssetClass
proposalSTAssetClassFromGovernor gov = AssetClass (symbol, "") proposalSTAssetClassFromGovernor gov = AssetClass (symbol, "")
where where
symbol = proposalSTSymbolFromGovernor gov symbol = proposalSTSymbolFromGovernor gov
-- | Get the 'CurrencySymbol' of the stake token/ {- | Get the 'CurrencySymbol' of the stake token/
@since 0.1.0
-}
stakeSTSymbolFromGovernor :: Governor -> CurrencySymbol stakeSTSymbolFromGovernor :: Governor -> CurrencySymbol
stakeSTSymbolFromGovernor gov = mintingPolicySymbol policy stakeSTSymbolFromGovernor gov = mintingPolicySymbol policy
where where
@ -756,6 +775,8 @@ stakeSTSymbolFromGovernor gov = mintingPolicySymbol policy
Note that the token is tagged with the hash of the stake validator. Note that the token is tagged with the hash of the stake validator.
See 'Agora.Stake.Script.stakePolicy'. See 'Agora.Stake.Script.stakePolicy'.
@since 0.1.0
-} -}
stakeSTAssetClassFromGovernor :: Governor -> AssetClass stakeSTAssetClassFromGovernor :: Governor -> AssetClass
stakeSTAssetClassFromGovernor gov = AssetClass (symbol, tokenName) stakeSTAssetClassFromGovernor gov = AssetClass (symbol, tokenName)
@ -765,20 +786,29 @@ stakeSTAssetClassFromGovernor gov = AssetClass (symbol, tokenName)
-- Tag with the address where the token is being sent to. -- Tag with the address where the token is being sent to.
tokenName = validatorHashToTokenName $ stakeValidatorHashFromGovernor gov tokenName = validatorHashToTokenName $ stakeValidatorHashFromGovernor gov
-- | Get the 'Stake' parameter, given the 'Governor' parameter. {- | Get the 'Stake' parameter, given the 'Governor' parameter.
@since 0.1.0
-}
stakeFromGovernor :: Governor -> Stake stakeFromGovernor :: Governor -> Stake
stakeFromGovernor gov = stakeFromGovernor gov =
Stake gov.gtClassRef $ Stake gov.gtClassRef $
proposalSTAssetClassFromGovernor gov proposalSTAssetClassFromGovernor gov
-- | Get the hash of 'Agora.Stake.Script.stakePolicy'. {- | Get the hash of 'Agora.Stake.Script.stakePolicy'.
@since 0.1.0
-}
stakeValidatorHashFromGovernor :: Governor -> ValidatorHash stakeValidatorHashFromGovernor :: Governor -> ValidatorHash
stakeValidatorHashFromGovernor gov = validatorHash validator stakeValidatorHashFromGovernor gov = validatorHash validator
where where
params = stakeFromGovernor gov params = stakeFromGovernor gov
validator = mkValidator $ stakeValidator params validator = mkValidator $ stakeValidator params
-- | Get the 'Proposal' parameter, given the 'Governor' parameter. {- | Get the 'Proposal' parameter, given the 'Governor' parameter.
@since 0.1.0
-}
proposalFromGovernor :: Governor -> Proposal proposalFromGovernor :: Governor -> Proposal
proposalFromGovernor gov = Proposal gstAC sstAC mc proposalFromGovernor gov = Proposal gstAC sstAC mc
where where
@ -786,24 +816,36 @@ proposalFromGovernor gov = Proposal gstAC sstAC mc
mc = gov.maximumCosigners mc = gov.maximumCosigners
sstAC = stakeSTAssetClassFromGovernor gov sstAC = stakeSTAssetClassFromGovernor gov
-- | Get the hash of 'Agora.Proposal.proposalPolicy'. {- | Get the hash of 'Agora.Proposal.proposalPolicy'.
@since 0.1.0
-}
proposalValidatorHashFromGovernor :: Governor -> ValidatorHash proposalValidatorHashFromGovernor :: Governor -> ValidatorHash
proposalValidatorHashFromGovernor gov = validatorHash validator proposalValidatorHashFromGovernor gov = validatorHash validator
where where
params = proposalFromGovernor gov params = proposalFromGovernor gov
validator = mkValidator $ proposalValidator params validator = mkValidator $ proposalValidator params
-- | Get the hash of 'Agora.Proposal.proposalValidator'. {- | Get the hash of 'Agora.Proposal.proposalValidator'.
@since 0.1.0
-}
governorValidatorHash :: Governor -> ValidatorHash governorValidatorHash :: Governor -> ValidatorHash
governorValidatorHash gov = validatorHash validator governorValidatorHash gov = validatorHash validator
where where
validator = mkValidator $ governorValidator gov validator = mkValidator $ governorValidator gov
-- | Get the 'AuthorityToken' parameter given the 'Governor' parameter. {- | Get the 'AuthorityToken' parameter given the 'Governor' parameter.
@since 0.1.0
-}
authorityTokenFromGovernor :: Governor -> AuthorityToken authorityTokenFromGovernor :: Governor -> AuthorityToken
authorityTokenFromGovernor gov = AuthorityToken $ governorSTAssetClassFromGovernor gov authorityTokenFromGovernor gov = AuthorityToken $ governorSTAssetClassFromGovernor gov
-- | Get the 'CurrencySymbol' of the authority token. {- | Get the 'CurrencySymbol' of the authority token.
@since 0.1.0
-}
authorityTokenSymbolFromGovernor :: Governor -> CurrencySymbol authorityTokenSymbolFromGovernor :: Governor -> CurrencySymbol
authorityTokenSymbolFromGovernor gov = mintingPolicySymbol policy authorityTokenSymbolFromGovernor gov = mintingPolicySymbol policy
where where

65
agora/Agora/MultiSig.hs
View file

@ -14,6 +14,8 @@ module Agora.MultiSig (
MultiSig (..), MultiSig (..),
) where ) where
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
PPubKeyHash, PPubKeyHash,
PTxInfo (..), PTxInfo (..),
@ -28,33 +30,42 @@ import Plutarch.Lift (
PLifted, PLifted,
PUnsafeLiftDecl, PUnsafeLiftDecl,
) )
import PlutusLedgerApi.V1.Crypto (PubKeyHash) import PlutusLedgerApi.V1.Crypto (PubKeyHash)
import PlutusTx qualified import PlutusTx qualified
--------------------------------------------------------------------------------
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Prelude import Prelude
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
{- | A MultiSig represents a proof that a particular set of signatures {- | A MultiSig represents a proof that a particular set of signatures
are present on a transaction. are present on a transaction.
@since 0.1.0
-} -}
data MultiSig = MultiSig data MultiSig = MultiSig
{ keys :: [PubKeyHash] { keys :: [PubKeyHash]
-- ^ List of PubKeyHashes that must be present in the list of signatories. -- ^ List of PubKeyHashes that must be present in the list of signatories.
, minSigs :: Integer , minSigs :: Integer
} }
deriving stock (GHC.Generic, Eq, Show) deriving stock
deriving anyclass (Generic) ( -- | @since 0.1.0
GHC.Generic
, -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
PlutusTx.makeLift ''MultiSig PlutusTx.makeLift ''MultiSig
PlutusTx.unstableMakeIsData ''MultiSig PlutusTx.unstableMakeIsData ''MultiSig
-- | Plutarch-level MultiSig {- | Plutarch-level MultiSig
@since 0.1.0
-}
newtype PMultiSig (s :: S) = PMultiSig newtype PMultiSig (s :: S) = PMultiSig
{ getMultiSig :: { getMultiSig ::
Term Term
@ -65,25 +76,49 @@ newtype PMultiSig (s :: S) = PMultiSig
] ]
) )
} }
deriving stock (GHC.Generic) deriving stock
deriving anyclass (Generic) ( -- | @since 0.1.0
deriving anyclass (PIsDataRepr) GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving deriving
(PlutusType, PIsData, PDataFields) ( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
)
via (PIsDataReprInstances PMultiSig) via (PIsDataReprInstances PMultiSig)
-- | @since 0.1.0
instance PUnsafeLiftDecl PMultiSig where type PLifted PMultiSig = MultiSig instance PUnsafeLiftDecl PMultiSig where type PLifted PMultiSig = MultiSig
-- | @since 0.1.0
deriving via (DerivePConstantViaData MultiSig PMultiSig) instance (PConstantDecl MultiSig) deriving via (DerivePConstantViaData MultiSig PMultiSig) instance (PConstantDecl MultiSig)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Check if a Haskell-level MultiSig signs this transaction. {- | Check if a Haskell-level MultiSig signs this transaction.
@since 0.1.0
-}
validatedByMultisig :: MultiSig -> Term s (PTxInfo :--> PBool) validatedByMultisig :: MultiSig -> Term s (PTxInfo :--> PBool)
validatedByMultisig params = validatedByMultisig params =
phoistAcyclic $ phoistAcyclic $
pvalidatedByMultisig # pconstant params pvalidatedByMultisig # pconstant params
-- | Check if a Plutarch-level MultiSig signs this transaction. {- | Check if a Plutarch-level MultiSig signs this transaction.
@since 0.1.0
-}
pvalidatedByMultisig :: Term s (PMultiSig :--> PTxInfo :--> PBool) pvalidatedByMultisig :: Term s (PMultiSig :--> PTxInfo :--> PBool)
pvalidatedByMultisig = pvalidatedByMultisig =
phoistAcyclic $ phoistAcyclic $

396
agora/Agora/Proposal.hs
View file

@ -36,23 +36,14 @@ module Agora.Proposal (
pretractVotes, pretractVotes,
) where ) where
-------------------------------------------------------------------------------- import Agora.Proposal.Time (PProposalStartingTime, PProposalTimingConfig, ProposalStartingTime, ProposalTimingConfig)
import Agora.SafeMoney (GTTag)
import Agora.Utils (mustBePJust)
import Control.Applicative (Const) import Control.Applicative (Const)
import Control.Arrow (first) import Control.Arrow (first)
import Data.Tagged (Tagged) import Data.Tagged (Tagged)
import GHC.Generics qualified as GHC import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I)) import Generics.SOP (Generic, I (I))
--------------------------------------------------------------------------------
import PlutusLedgerApi.V1 (DatumHash, PubKeyHash, ValidatorHash)
import PlutusLedgerApi.V1.Value (AssetClass)
import PlutusTx qualified
import PlutusTx.AssocMap qualified as AssocMap
--------------------------------------------------------------------------------
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
KeyGuarantees (Unsorted), KeyGuarantees (Unsorted),
PDatumHash, PDatumHash,
@ -73,12 +64,10 @@ import Plutarch.Lift (
import Plutarch.SafeMoney (PDiscrete) import Plutarch.SafeMoney (PDiscrete)
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom')) import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
import Plutarch.Unsafe (punsafeCoerce) import Plutarch.Unsafe (punsafeCoerce)
import PlutusLedgerApi.V1 (DatumHash, PubKeyHash, ValidatorHash)
-------------------------------------------------------------------------------- import PlutusLedgerApi.V1.Value (AssetClass)
import PlutusTx qualified
import Agora.Proposal.Time (PProposalStartingTime, PProposalTimingConfig, ProposalStartingTime, ProposalTimingConfig) import PlutusTx.AssocMap qualified as AssocMap
import Agora.SafeMoney (GTTag)
import Agora.Utils (mustBePJust)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Haskell-land -- Haskell-land
@ -88,21 +77,55 @@ import Agora.Utils (mustBePJust)
The 100th proposal will be @'ProposalId' 99@. This counter lives The 100th proposal will be @'ProposalId' 99@. This counter lives
in the 'Agora.Governor.Governor'. See 'Agora.Governor.nextProposalId', and in the 'Agora.Governor.Governor'. See 'Agora.Governor.nextProposalId', and
'Agora.Governor.pgetNextProposalId'. 'Agora.Governor.pgetNextProposalId'.
@since 0.1.0
-} -}
newtype ProposalId = ProposalId {proposalTag :: Integer} newtype ProposalId = ProposalId {proposalTag :: Integer}
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) deriving newtype
deriving stock (Eq, Show, GHC.Generic) ( -- | @since 0.1.0
PlutusTx.ToData
, -- | @since 0.1.0
PlutusTx.FromData
, -- | @since 0.1.0
PlutusTx.UnsafeFromData
)
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
{- | Encodes a result. Typically, for a Yes/No proposal, we encode it like this: {- | Encodes a result. Typically, for a Yes/No proposal, we encode it like this:
@ @
"No" ~ 'ResultTag' 0 "No" ~ 'ResultTag' 0
"Yes" ~ 'ResultTag' 1 "Yes" ~ 'ResultTag' 1
@ @
@since 0.1.0
-} -}
newtype ResultTag = ResultTag {getResultTag :: Integer} newtype ResultTag = ResultTag {getResultTag :: Integer}
deriving stock (Eq, Show, Ord, GHC.Generic) deriving stock
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) ( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
Ord
, -- | @since 0.1.0
GHC.Generic
)
deriving newtype
( -- | @since 0.1.0
PlutusTx.ToData
, -- | @since 0.1.0
PlutusTx.FromData
, -- | @since 0.1.0
PlutusTx.UnsafeFromData
)
{- | The "status" of the proposal. This is only useful for state transitions that {- | The "status" of the proposal. This is only useful for state transitions that
need to happen as a result of a transaction as opposed to time-based "periods". need to happen as a result of a transaction as opposed to time-based "periods".
@ -111,6 +134,8 @@ newtype ResultTag = ResultTag {getResultTag :: Integer}
If the proposal is 'VotingReady', for instance, that doesn't necessarily If the proposal is 'VotingReady', for instance, that doesn't necessarily
mean that voting is possible, as this also requires the timing to be right. mean that voting is possible, as this also requires the timing to be right.
@since 0.1.0
-} -}
data ProposalStatus data ProposalStatus
= -- | A draft proposal represents a proposal that has yet to be realized. = -- | A draft proposal represents a proposal that has yet to be realized.
@ -144,13 +169,23 @@ data ProposalStatus
-- --
-- TODO: The owner of the proposal may choose to reclaim their proposal. -- TODO: The owner of the proposal may choose to reclaim their proposal.
Finished Finished
deriving stock (Eq, Show, GHC.Generic) deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Locked, 2), ('Finished, 3)] PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Locked, 2), ('Finished, 3)]
{- | The threshold values for various state transitions to happen. {- | The threshold values for various state transitions to happen.
This data is stored centrally (in the 'Agora.Governor.Governor') and copied over This data is stored centrally (in the 'Agora.Governor.Governor') and copied over
to 'Proposal's when they are created. to 'Proposal's when they are created.
@since 0.1.0
-} -}
data ProposalThresholds = ProposalThresholds data ProposalThresholds = ProposalThresholds
{ execute :: Tagged GTTag Integer { execute :: Tagged GTTag Integer
@ -164,32 +199,62 @@ data ProposalThresholds = ProposalThresholds
-- ^ How much GT required to allow voting to happen. -- ^ How much GT required to allow voting to happen.
-- (i.e. to move into 'VotingReady') -- (i.e. to move into 'VotingReady')
} }
deriving stock (Eq, Show, GHC.Generic) deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed ''ProposalThresholds [('ProposalThresholds, 0)] PlutusTx.makeIsDataIndexed ''ProposalThresholds [('ProposalThresholds, 0)]
{- | Map which encodes the total tally for each result. {- | Map which encodes the total tally for each result.
It's important that the "shape" is consistent with the shape of 'effects'. It's important that the "shape" is consistent with the shape of 'effects'.
e.g. if the 'effects' field looks like the following: e.g. if the 'effects' field looks like the following:
@[('ResultTag' 0, []), ('ResultTag' 1, [(vh, dh)])]@ @[('ResultTag' 0, []), ('ResultTag' 1, [(vh, dh)])]@
Then 'ProposalVotes' needs be of the shape: Then 'ProposalVotes' needs be of the shape:
@[('ResultTag' 0, n), ('ResultTag' 1, m)]@ @[('ResultTag' 0, n), ('ResultTag' 1, m)]@
@since 0.1.0
-} -}
newtype ProposalVotes = ProposalVotes newtype ProposalVotes = ProposalVotes
{ getProposalVotes :: AssocMap.Map ResultTag Integer { getProposalVotes :: AssocMap.Map ResultTag Integer
} }
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) deriving newtype
deriving stock (Eq, Show, GHC.Generic) ( -- | @since 0.1.0
PlutusTx.ToData
, -- | @since 0.1.0
PlutusTx.FromData
, -- | @since 0.1.0
PlutusTx.UnsafeFromData
)
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
-- | Create a 'ProposalVotes' that has the same shape as the 'effects' field. {- | Create a 'ProposalVotes' that has the same shape as the 'effects' field.
@since 0.1.0
-}
emptyVotesFor :: forall a. AssocMap.Map ResultTag a -> ProposalVotes emptyVotesFor :: forall a. AssocMap.Map ResultTag a -> ProposalVotes
emptyVotesFor = ProposalVotes . AssocMap.mapWithKey (const . const 0) emptyVotesFor = ProposalVotes . AssocMap.mapWithKey (const . const 0)
-- | Haskell-level datum for Proposal scripts. {- | Haskell-level datum for Proposal scripts.
@since 0.1.0
-}
data ProposalDatum = ProposalDatum data ProposalDatum = ProposalDatum
{ proposalId :: ProposalId { proposalId :: ProposalId
-- ^ Identification of the proposal. -- ^ Identification of the proposal.
@ -211,11 +276,21 @@ data ProposalDatum = ProposalDatum
, startingTime :: ProposalStartingTime , startingTime :: ProposalStartingTime
-- ^ The time upon the creation of the proposal. -- ^ The time upon the creation of the proposal.
} }
deriving stock (Eq, Show, GHC.Generic) deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)] PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)]
-- | Haskell-level redeemer for Proposal scripts. {- | Haskell-level redeemer for Proposal scripts.
@since 0.1.0
-}
data ProposalRedeemer data ProposalRedeemer
= -- | Cast one or more votes towards a particular 'ResultTag'. = -- | Cast one or more votes towards a particular 'ResultTag'.
Vote ResultTag Vote ResultTag
@ -253,8 +328,16 @@ data ProposalRedeemer
-- If the proposal has run out of time for the current 'ProposalStatus', it will always be possible -- If the proposal has run out of time for the current 'ProposalStatus', it will always be possible
-- to transition into 'Finished' status, because it has expired (and failed). -- to transition into 'Finished' status, because it has expired (and failed).
AdvanceProposal AdvanceProposal
deriving stock (Eq, Show, GHC.Generic) deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed PlutusTx.makeIsDataIndexed
''ProposalRedeemer ''ProposalRedeemer
[ ('Vote, 0) [ ('Vote, 0)
@ -263,23 +346,49 @@ PlutusTx.makeIsDataIndexed
, ('AdvanceProposal, 3) , ('AdvanceProposal, 3)
] ]
-- | Parameters that identify the Proposal validator script. {- | Parameters that identify the Proposal validator script.
@since 0.1.0
-}
data Proposal = Proposal data Proposal = Proposal
{ governorSTAssetClass :: AssetClass { governorSTAssetClass :: AssetClass
, stakeSTAssetClass :: AssetClass , stakeSTAssetClass :: AssetClass
, maximumCosigners :: Integer , maximumCosigners :: Integer
-- ^ Arbitrary limit for maximum amount of cosigners on a proposal. -- ^ Arbitrary limit for maximum amount of cosigners on a proposal.
} }
deriving stock (Show, Eq, GHC.Generic) deriving stock
( -- | @since 0.1.0
Show
, -- | @since 0.1.0
Eq
, -- | @since 0.1.0
GHC.Generic
)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Plutarch-land -- Plutarch-land
-- | Plutarch-level version of 'ResultTag'. {- | Plutarch-level version of 'ResultTag'.
newtype PResultTag (s :: S) = PResultTag (Term s PInteger)
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PResultTag PInteger)
@since 0.1.0
-}
newtype PResultTag (s :: S) = PResultTag (Term s PInteger)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PEq
, -- | @since 0.1.0
POrd
)
via (DerivePNewtype PResultTag PInteger)
-- | @since 0.1.0
instance PUnsafeLiftDecl PResultTag where type PLifted PResultTag = ResultTag instance PUnsafeLiftDecl PResultTag where type PLifted PResultTag = ResultTag
-- | @since 0.1.0
deriving via deriving via
(DerivePConstantViaNewtype ResultTag PResultTag PInteger) (DerivePConstantViaNewtype ResultTag PResultTag PInteger)
instance instance
@ -287,6 +396,8 @@ deriving via
-- FIXME: This instance and the one below, for 'PProposalId', should be derived. -- FIXME: This instance and the one below, for 'PProposalId', should be derived.
-- Soon this will be possible through 'DerivePNewtype'. -- Soon this will be possible through 'DerivePNewtype'.
-- | @since 0.1.0
instance PTryFrom PData (PAsData PResultTag) where instance PTryFrom PData (PAsData PResultTag) where
type PTryFromExcess PData (PAsData PResultTag) = PTryFromExcess PData (PAsData PInteger) type PTryFromExcess PData (PAsData PResultTag) = PTryFromExcess PData (PAsData PInteger)
ptryFrom' d k = ptryFrom' d k =
@ -300,10 +411,24 @@ instance PTryFrom PData (PAsData PResultTag) where
-- Since 'PResultTag' is a simple newtype, their shape is the same. -- Since 'PResultTag' is a simple newtype, their shape is the same.
k . first punsafeCoerce k . first punsafeCoerce
-- | Plutarch-level version of 'PProposalId'. {- | Plutarch-level version of 'PProposalId'.
newtype PProposalId (s :: S) = PProposalId (Term s PInteger)
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalId PInteger)
@since 0.1.0
-}
newtype PProposalId (s :: S) = PProposalId (Term s PInteger)
deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PEq
, -- | @since 0.1.0
POrd
)
via (DerivePNewtype PProposalId PInteger)
-- | @since 0.1.0
instance PTryFrom PData (PAsData PProposalId) where instance PTryFrom PData (PAsData PProposalId) where
type PTryFromExcess PData (PAsData PProposalId) = PTryFromExcess PData (PAsData PInteger) type PTryFromExcess PData (PAsData PProposalId) = PTryFromExcess PData (PAsData PInteger)
ptryFrom' d k = ptryFrom' d k =
@ -317,13 +442,19 @@ instance PTryFrom PData (PAsData PProposalId) where
-- Since 'PProposalId' is a simple newtype, their shape is the same. -- Since 'PProposalId' is a simple newtype, their shape is the same.
k . first punsafeCoerce k . first punsafeCoerce
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalId where type PLifted PProposalId = ProposalId instance PUnsafeLiftDecl PProposalId where type PLifted PProposalId = ProposalId
-- | @since 0.1.0
deriving via deriving via
(DerivePConstantViaNewtype ProposalId PProposalId PInteger) (DerivePConstantViaNewtype ProposalId PProposalId PInteger)
instance instance
(PConstantDecl ProposalId) (PConstantDecl ProposalId)
-- | Plutarch-level version of 'ProposalStatus'. {- | Plutarch-level version of 'ProposalStatus'.
@since 0.1.0
-}
data PProposalStatus (s :: S) data PProposalStatus (s :: S)
= -- TODO: 'PProposalStatus' ought te be encoded as 'PInteger'. = -- TODO: 'PProposalStatus' ought te be encoded as 'PInteger'.
-- e.g. like Tilde used 'pmatchEnum'. -- e.g. like Tilde used 'pmatchEnum'.
@ -331,17 +462,38 @@ data PProposalStatus (s :: S)
| PVotingReady (Term s (PDataRecord '[])) | PVotingReady (Term s (PDataRecord '[]))
| PLocked (Term s (PDataRecord '[])) | PLocked (Term s (PDataRecord '[]))
| PFinished (Term s (PDataRecord '[])) | PFinished (Term s (PDataRecord '[]))
deriving stock (GHC.Generic) deriving stock
deriving anyclass (Generic) ( -- | @since 0.1.0
deriving anyclass (PIsDataRepr) GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving deriving
(PlutusType, PIsData, PEq) ( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PEq
)
via PIsDataReprInstances PProposalStatus via PIsDataReprInstances PProposalStatus
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus
-- | @since 0.1.0
deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (PConstantDecl ProposalStatus) deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (PConstantDecl ProposalStatus)
-- | Plutarch-level version of 'ProposalThresholds'. {- | Plutarch-level version of 'ProposalThresholds'.
@since 0.1.0
-}
newtype PProposalThresholds (s :: S) = PProposalThresholds newtype PProposalThresholds (s :: S) = PProposalThresholds
{ getProposalThresholds :: { getProposalThresholds ::
Term Term
@ -353,22 +505,52 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds
] ]
) )
} }
deriving stock (GHC.Generic) deriving stock
deriving anyclass (Generic) ( -- | @since 0.1.0
deriving anyclass (PIsDataRepr) GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving deriving
(PlutusType, PIsData, PDataFields) ( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
)
via (PIsDataReprInstances PProposalThresholds) via (PIsDataReprInstances PProposalThresholds)
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds
-- | @since 0.1.0
deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) instance (PConstantDecl ProposalThresholds) deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) instance (PConstantDecl ProposalThresholds)
-- | Plutarch-level version of 'ProposalVotes'. {- | Plutarch-level version of 'ProposalVotes'.
@since 0.1.0
-}
newtype PProposalVotes (s :: S) newtype PProposalVotes (s :: S)
= PProposalVotes (Term s (PMap 'Unsorted PResultTag PInteger)) = PProposalVotes (Term s (PMap 'Unsorted PResultTag PInteger))
deriving (PlutusType, PIsData) via (DerivePNewtype PProposalVotes (PMap 'Unsorted PResultTag PInteger)) deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via (DerivePNewtype PProposalVotes (PMap 'Unsorted PResultTag PInteger))
-- | Retract votes given the option and the amount of votes. {- | Retract votes given the option and the amount of votes.
@since 0.1.0
-}
pretractVotes :: Term s (PResultTag :--> PInteger :--> PProposalVotes :--> PProposalVotes) pretractVotes :: Term s (PResultTag :--> PInteger :--> PProposalVotes :--> PProposalVotes)
pretractVotes = phoistAcyclic $ pretractVotes = phoistAcyclic $
plam $ \rt count votes -> plam $ \rt count votes ->
@ -386,13 +568,19 @@ pretractVotes = phoistAcyclic $
# rt # rt
# voteMap # voteMap
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = ProposalVotes instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = ProposalVotes
-- | @since 0.1.0
deriving via deriving via
(DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap 'Unsorted PResultTag PInteger)) (DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap 'Unsorted PResultTag PInteger))
instance instance
(PConstantDecl ProposalVotes) (PConstantDecl ProposalVotes)
-- | Plutarch-level version of 'emptyVotesFor'. {- | Plutarch-level version of 'emptyVotesFor'.
@since 0.1.0
-}
pemptyVotesFor :: forall s a. (PIsData a) => Term s (PMap 'Unsorted PResultTag a :--> PProposalVotes) pemptyVotesFor :: forall s a. (PIsData a) => Term s (PMap 'Unsorted PResultTag a :--> PProposalVotes)
pemptyVotesFor = pemptyVotesFor =
phoistAcyclic $ phoistAcyclic $
@ -402,7 +590,10 @@ pemptyVotesFor =
PProposalVotes $ PM.pmap # plam (const $ pconstant 0) # m PProposalVotes $ PM.pmap # plam (const $ pconstant 0) # m
) )
-- | Plutarch-level version of 'ProposalDatum'. {- | Plutarch-level version of 'ProposalDatum'.
@since 0.1.0
-}
newtype PProposalDatum (s :: S) = PProposalDatum newtype PProposalDatum (s :: S) = PProposalDatum
{ getProposalDatum :: { getProposalDatum ::
Term Term
@ -419,36 +610,76 @@ newtype PProposalDatum (s :: S) = PProposalDatum
] ]
) )
} }
deriving stock (GHC.Generic) deriving stock
deriving anyclass (Generic) ( -- | @since 0.1.0
deriving anyclass (PIsDataRepr) GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving deriving
(PlutusType, PIsData, PDataFields, PEq) ( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
, -- | @since 0.1.0
PEq
)
via (PIsDataReprInstances PProposalDatum) via (PIsDataReprInstances PProposalDatum)
-- TODO: Derive this. -- TODO: Derive this.
-- | @since 0.1.0
instance PTryFrom PData (PAsData PProposalDatum) where instance PTryFrom PData (PAsData PProposalDatum) where
type PTryFromExcess PData (PAsData PProposalDatum) = Const () type PTryFromExcess PData (PAsData PProposalDatum) = Const ()
ptryFrom' d k = ptryFrom' d k =
k (punsafeCoerce d, ()) k (punsafeCoerce d, ())
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
-- | @since 0.1.0
deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum) deriving via (DerivePConstantViaData ProposalDatum PProposalDatum) instance (PConstantDecl ProposalDatum)
-- | Plutarch-level version of 'ProposalRedeemer'. {- | Plutarch-level version of 'ProposalRedeemer'.
@since 0.1.0
-}
data PProposalRedeemer (s :: S) data PProposalRedeemer (s :: S)
= PVote (Term s (PDataRecord '["resultTag" ':= PResultTag])) = PVote (Term s (PDataRecord '["resultTag" ':= PResultTag]))
| PCosign (Term s (PDataRecord '["newCosigners" ':= PBuiltinList (PAsData PPubKeyHash)])) | PCosign (Term s (PDataRecord '["newCosigners" ':= PBuiltinList (PAsData PPubKeyHash)]))
| PUnlock (Term s (PDataRecord '["resultTag" ':= PResultTag])) | PUnlock (Term s (PDataRecord '["resultTag" ':= PResultTag]))
| PAdvanceProposal (Term s (PDataRecord '[])) | PAdvanceProposal (Term s (PDataRecord '[]))
deriving stock (GHC.Generic) deriving stock
deriving anyclass (Generic) ( -- | @since 0.1.0
deriving anyclass (PIsDataRepr) GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving deriving
(PlutusType, PIsData) ( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via PIsDataReprInstances PProposalRedeemer via PIsDataReprInstances PProposalRedeemer
-- See below. -- See below.
-- | @since 0.1.0
instance PTryFrom PData (PAsData PProposalRedeemer) where instance PTryFrom PData (PAsData PProposalRedeemer) where
type PTryFromExcess PData (PAsData PProposalRedeemer) = Const () type PTryFromExcess PData (PAsData PProposalRedeemer) = Const ()
ptryFrom' d k = ptryFrom' d k =
@ -460,7 +691,10 @@ instance PTryFrom PData (PAsData PProposalRedeemer) where
-- instance -- instance
-- PTryFrom PData (PAsData PProposalRedeemer) -- PTryFrom PData (PAsData PProposalRedeemer)
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer
-- | @since 0.1.0
deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstantDecl ProposalRedeemer) deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instance (PConstantDecl ProposalRedeemer)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -468,6 +702,8 @@ deriving via (DerivePConstantViaData ProposalRedeemer PProposalRedeemer) instanc
{- | Check for various invariants a proposal must uphold. {- | Check for various invariants a proposal must uphold.
This can be used to check both upon creation and This can be used to check both upon creation and
upon any following state transitions in the proposal. upon any following state transitions in the proposal.
@since 0.1.0
-} -}
proposalDatumValid :: Proposal -> Term s (Agora.Proposal.PProposalDatum :--> PBool) proposalDatumValid :: Proposal -> Term s (Agora.Proposal.PProposalDatum :--> PBool)
proposalDatumValid proposal = proposalDatumValid proposal =
@ -493,8 +729,10 @@ proposalDatumValid proposal =
{- | Find the winner result tag, given the votes, the quorum the "neutral" result tag. {- | Find the winner result tag, given the votes, the quorum the "neutral" result tag.
The winner should be unambiguous, meaning that if two options have the same highest votes, The winner should be unambiguous, meaning that if two options have the same highest votes,
the "neutral" option will be the winner. the "neutral" option will be the winner.
@since 0.1.0
-} -}
pwinner :: pwinner ::
Term Term
@ -540,7 +778,10 @@ pwinner = phoistAcyclic $
winnerResultTag winnerResultTag
neutral neutral
-- | Find the winning outcome (and the corresponding vote count) given the votes. {- | Find the winning outcome (and the corresponding vote count) given the votes.
@since 0.1.0
-}
phighestVotes :: phighestVotes ::
Term Term
s s
@ -566,7 +807,10 @@ phighestVotes = phoistAcyclic $
in pif (lastVotes #< thisVotes) this last in pif (lastVotes #< thisVotes) this last
in pfoldr # f # (phead # l) # l in pfoldr # f # (phead # l) # l
-- | Find the "neutral" option (a dummy outcome with no effect) given the effects. {- | Find the "neutral" option (a dummy outcome with no effect) given the effects.
@since 0.1.0
-}
pneutralOption :: pneutralOption ::
Term Term
s s

54
agora/Agora/Proposal/Scripts.hs
View file

@ -70,21 +70,23 @@ import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
{- | Policy for Proposals. {- | Policy for Proposals.
== What this policy does == What this policy does
=== For minting: === For minting:
- Governor is happy with mint. - Governor is happy with mint.
* The governor must do most of the checking for the validity of the * The governor must do most of the checking for the validity of the
transaction. For example, the governor must check that the datum transaction. For example, the governor must check that the datum
is correct, and that the ST is correctly paid to the right validator. is correct, and that the ST is correctly paid to the right validator.
- Exactly 1 token is minted. - Exactly 1 token is minted.
=== For burning: === For burning:
- This policy cannot be burned. - This policy cannot be burned.
@since 0.1.0
-} -}
proposalPolicy :: proposalPolicy ::
-- | The assetclass of GST, see 'Agora.Governor.Scripts.governorPolicy'. -- | The assetclass of GST, see 'Agora.Governor.Scripts.governorPolicy'.
@ -119,29 +121,31 @@ proposalPolicy (AssetClass (govCs, govTn)) =
{- | The validator for Proposals. {- | The validator for Proposals.
The documentation for various of the redeemers lives at 'Agora.Proposal.ProposalRedeemer'. The documentation for various of the redeemers lives at 'Agora.Proposal.ProposalRedeemer'.
== What this validator does == What this validator does
=== Voting/unlocking === Voting/unlocking
When voting and unlocking, the proposal must witness a state transition When voting and unlocking, the proposal must witness a state transition
occuring in the relevant Stake. This transition must place a lock on occuring in the relevant Stake. This transition must place a lock on
the stake that is tagged with the right 'Agora.Proposal.ResultTag', and 'Agora.Proposal.ProposalId'. the stake that is tagged with the right 'Agora.Proposal.ResultTag', and 'Agora.Proposal.ProposalId'.
=== Periods === Periods
Most redeemers are time-sensitive. Most redeemers are time-sensitive.
A list of all time-sensitive redeemers and their requirements: A list of all time-sensitive redeemers and their requirements:
- 'Agora.Proposal.Vote' can only be used when both the status is in 'Agora.Proposal.VotingReady', - 'Agora.Proposal.Vote' can only be used when both the status is in 'Agora.Proposal.VotingReady',
and 'Agora.Proposal.Time.isVotingPeriod' is true. and 'Agora.Proposal.Time.isVotingPeriod' is true.
- 'Agora.Proposal.Cosign' can only be used when both the status is in 'Agora.Proposal.Draft', - 'Agora.Proposal.Cosign' can only be used when both the status is in 'Agora.Proposal.Draft',
and 'Agora.Proposal.Time.isDraftPeriod' is true. and 'Agora.Proposal.Time.isDraftPeriod' is true.
- 'Agora.Proposal.AdvanceProposal' can only be used when the status can be advanced - 'Agora.Proposal.AdvanceProposal' can only be used when the status can be advanced
(see 'Agora.Proposal.AdvanceProposal' docs). (see 'Agora.Proposal.AdvanceProposal' docs).
- 'Agora.Proposal.Unlock' is always valid. - 'Agora.Proposal.Unlock' is always valid.
@since 0.1.0
-} -}
proposalValidator :: Proposal -> ClosedTerm PValidator proposalValidator :: Proposal -> ClosedTerm PValidator
proposalValidator proposal = proposalValidator proposal =

187
agora/Agora/Proposal/Time.hs
View file

@ -58,7 +58,10 @@ import Prelude hiding ((+))
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Represents the starting time of the proposal. {- | Represents the starting time of the proposal.
@since 0.1.0
-}
newtype ProposalStartingTime = ProposalStartingTime newtype ProposalStartingTime = ProposalStartingTime
{ getProposalStartingTime :: POSIXTime { getProposalStartingTime :: POSIXTime
} }
@ -67,7 +70,9 @@ newtype ProposalStartingTime = ProposalStartingTime
{- | Configuration of proposal timings. {- | Configuration of proposal timings.
See: https://github.com/Liqwid-Labs/agora/blob/master/docs/tech-design/proposals.md#when-may-interactions-occur See: https://liqwid.notion.site/Proposals-589853145a994057aa77f397079f75e4#d25ea378768d4c76b52dd4c1b6bc0fcd
@since 0.1.0
-} -}
data ProposalTimingConfig = ProposalTimingConfig data ProposalTimingConfig = ProposalTimingConfig
{ draftTime :: POSIXTime { draftTime :: POSIXTime
@ -79,61 +84,115 @@ data ProposalTimingConfig = ProposalTimingConfig
, executingTime :: POSIXTime , executingTime :: POSIXTime
-- ^ "E": the length of the execution period. -- ^ "E": the length of the execution period.
} }
deriving stock (Eq, Show, GHC.Generic) deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed ''ProposalTimingConfig [('ProposalTimingConfig, 0)] PlutusTx.makeIsDataIndexed ''ProposalTimingConfig [('ProposalTimingConfig, 0)]
-- | Represents the maximum width of a 'PlutusLedgerApi.V1.Time.POSIXTimeRange'. -- | Represents the maximum width of a 'PlutusLedgerApi.V1.Time.POSIXTimeRange'.
newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime} newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
deriving stock (Eq, Show, Ord, GHC.Generic) deriving stock
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) ( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
Ord
, -- | @since 0.1.0
GHC.Generic
)
deriving newtype
( -- | @since 0.1.0
PlutusTx.ToData
, -- | @since 0.1.0
PlutusTx.FromData
, -- | @since 0.1.0
PlutusTx.UnsafeFromData
)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
{- | == Establishing timing in Proposal interactions. {- | == Establishing timing in Proposal interactions.
In Plutus, it's impossible to determine time exactly. It's also impossible In Plutus, it's impossible to determine time exactly. It's also impossible
to get a single point in time, yet often we need to check to get a single point in time, yet often we need to check
various constraints on time. various constraints on time.
For the purposes of proposals, there's a single most important feature: For the purposes of proposals, there's a single most important feature:
The ability to determine if we can perform an action. In order to correctly The ability to determine if we can perform an action. In order to correctly
determine if we are able to perform certain actions, we need to know what determine if we are able to perform certain actions, we need to know what
time it roughly is, compared to when the proposal was created. time it roughly is, compared to when the proposal was created.
'PProposalTime' represents "the time according to the proposal". 'PProposalTime' represents "the time according to the proposal".
Its representation is opaque, and doesn't matter. Its representation is opaque, and doesn't matter.
Various functions work simply on 'PProposalTime' and 'ProposalTimingConfig'. Various functions work simply on 'PProposalTime' and 'ProposalTimingConfig'.
In particular, 'currentProposalTime' is useful for extracting the time In particular, 'currentProposalTime' is useful for extracting the time
from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field
of 'PlutusLedgerApi.V1.TxInfo'. of 'PlutusLedgerApi.V1.TxInfo'.
We avoid 'PPOSIXTimeRange' where we can in order to save on operations. We avoid 'PPOSIXTimeRange' where we can in order to save on operations.
Note: 'PProposalTime' doesn't need a Haskell-level equivalent because it Note: 'PProposalTime' doesn't need a Haskell-level equivalent because it
is only used in scripts, and does not go in datums. It is also scott-encoded is only used in scripts, and does not go in datums. It is also scott-encoded
which is more efficient in usage. which is more efficient in usage.
@since 0.1.0
-} -}
data PProposalTime (s :: S) = PProposalTime data PProposalTime (s :: S) = PProposalTime
{ lowerBound :: Term s PPOSIXTime { lowerBound :: Term s PPOSIXTime
, upperBound :: Term s PPOSIXTime , upperBound :: Term s PPOSIXTime
} }
deriving stock (GHC.Generic) deriving stock
deriving anyclass (Generic, PlutusType, HasDatatypeInfo, PEq) ( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
, -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
HasDatatypeInfo
, -- | @since 0.1.0
PEq
)
-- | Plutarch-level version of 'ProposalStartingTime'. -- | Plutarch-level version of 'ProposalStartingTime'.
newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime) newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime)
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PProposalStartingTime PPOSIXTime) deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PEq
, -- | @since 0.1.0
POrd
)
via (DerivePNewtype PProposalStartingTime PPOSIXTime)
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalStartingTime where instance PUnsafeLiftDecl PProposalStartingTime where
type PLifted PProposalStartingTime = ProposalStartingTime type PLifted PProposalStartingTime = ProposalStartingTime
-- | @since 0.1.0
deriving via deriving via
(DerivePConstantViaNewtype ProposalStartingTime PProposalStartingTime PPOSIXTime) (DerivePConstantViaNewtype ProposalStartingTime PProposalStartingTime PPOSIXTime)
instance instance
(PConstantDecl ProposalStartingTime) (PConstantDecl ProposalStartingTime)
-- | Plutarch-level version of 'ProposalTimingConfig'. {- | Plutarch-level version of 'ProposalTimingConfig'.
@since 0.1.0
-}
newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
{ getProposalTimingConfig :: { getProposalTimingConfig ::
Term Term
@ -146,15 +205,33 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
] ]
) )
} }
deriving stock (GHC.Generic) deriving stock
deriving anyclass (Generic) ( -- | @since 0.1.0
deriving anyclass (PIsDataRepr) GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving deriving
(PlutusType, PIsData, PDataFields) ( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
)
via (PIsDataReprInstances PProposalTimingConfig) via (PIsDataReprInstances PProposalTimingConfig)
-- | @since 0.1.0
instance PUnsafeLiftDecl PProposalTimingConfig where instance PUnsafeLiftDecl PProposalTimingConfig where
type PLifted PProposalTimingConfig = ProposalTimingConfig type PLifted PProposalTimingConfig = ProposalTimingConfig
-- | @since 0.1.0
deriving via deriving via
(DerivePConstantViaData ProposalTimingConfig PProposalTimingConfig) (DerivePConstantViaData ProposalTimingConfig PProposalTimingConfig)
instance instance
@ -163,9 +240,22 @@ deriving via
-- | Plutarch-level version of 'MaxTimeRangeWidth'. -- | Plutarch-level version of 'MaxTimeRangeWidth'.
newtype PMaxTimeRangeWidth (s :: S) newtype PMaxTimeRangeWidth (s :: S)
= PMaxTimeRangeWidth (Term s PPOSIXTime) = PMaxTimeRangeWidth (Term s PPOSIXTime)
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PMaxTimeRangeWidth PPOSIXTime) deriving
( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PEq
, -- | @since 0.1.0
POrd
)
via (DerivePNewtype PMaxTimeRangeWidth PPOSIXTime)
-- | @since 0.1.0
instance PUnsafeLiftDecl PMaxTimeRangeWidth where type PLifted PMaxTimeRangeWidth = MaxTimeRangeWidth instance PUnsafeLiftDecl PMaxTimeRangeWidth where type PLifted PMaxTimeRangeWidth = MaxTimeRangeWidth
-- | @since 0.1.0
deriving via deriving via
(DerivePConstantViaNewtype MaxTimeRangeWidth PMaxTimeRangeWidth PPOSIXTime) (DerivePConstantViaNewtype MaxTimeRangeWidth PMaxTimeRangeWidth PPOSIXTime)
instance instance
@ -174,12 +264,16 @@ deriving via
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- FIXME: Orphan instance, move this to plutarch-extra. -- FIXME: Orphan instance, move this to plutarch-extra.
-- | @since 0.1.0
instance AdditiveSemigroup (Term s PPOSIXTime) where instance AdditiveSemigroup (Term s PPOSIXTime) where
(punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y (punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y
{- | Get the starting time of a proposal, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field. {- | Get the starting time of a proposal, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
For every proposal, this is only meant to run once upon creation. Given time range should be For every proposal, this is only meant to run once upon creation. Given time range should be
tight enough, meaning that the width of the time range should be less than the maximum value. tight enough, meaning that the width of the time range should be less than the maximum value.
@since 0.1.0
-} -}
createProposalStartingTime :: forall (s :: S). Term s (PMaxTimeRangeWidth :--> PPOSIXTimeRange :--> PProposalStartingTime) createProposalStartingTime :: forall (s :: S). Term s (PMaxTimeRangeWidth :--> PPOSIXTimeRange :--> PProposalStartingTime)
createProposalStartingTime = phoistAcyclic $ createProposalStartingTime = phoistAcyclic $
@ -201,8 +295,10 @@ createProposalStartingTime = phoistAcyclic $
{- | Get the current proposal time, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field. {- | Get the current proposal time, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
If it's impossible to get a fully-bounded time, (e.g. either end of the 'PPOSIXTimeRange' is If it's impossible to get a fully-bounded time, (e.g. either end of the 'PPOSIXTimeRange' is
an infinity) then we error out. an infinity) then we error out.
@since 0.1.0
-} -}
currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime) currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime)
currentProposalTime = phoistAcyclic $ currentProposalTime = phoistAcyclic $
@ -232,7 +328,10 @@ currentProposalTime = phoistAcyclic $
) )
} }
-- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive. {- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
@since 0.1.0
-}
proposalTimeWithin :: proposalTimeWithin ::
Term Term
s s
@ -251,7 +350,10 @@ proposalTimeWithin = phoistAcyclic $
, ut #<= h , ut #<= h
] ]
-- | True if the 'PProposalTime' is in the draft period. {- | True if the 'PProposalTime' is in the draft period.
@since 0.1.0
-}
isDraftPeriod :: isDraftPeriod ::
forall (s :: S). forall (s :: S).
Term Term
@ -265,7 +367,10 @@ isDraftPeriod = phoistAcyclic $
plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) -> plam $ \config s' -> pmatch s' $ \(PProposalStartingTime s) ->
proposalTimeWithin # s # (s + (pfield @"draftTime" # config)) proposalTimeWithin # s # (s + (pfield @"draftTime" # config))
-- | True if the 'PProposalTime' is in the voting period. {- | True if the 'PProposalTime' is in the voting period.
@since 0.1.0
-}
isVotingPeriod :: isVotingPeriod ::
forall (s :: S). forall (s :: S).
Term Term
@ -280,7 +385,10 @@ isVotingPeriod = phoistAcyclic $
pletFields @'["draftTime", "votingTime"] config $ \f -> pletFields @'["draftTime", "votingTime"] config $ \f ->
proposalTimeWithin # s # (s + f.draftTime + f.votingTime) proposalTimeWithin # s # (s + f.draftTime + f.votingTime)
-- | True if the 'PProposalTime' is in the locking period. {- | True if the 'PProposalTime' is in the locking period.
@since 0.1.0
-}
isLockingPeriod :: isLockingPeriod ::
forall (s :: S). forall (s :: S).
Term Term
@ -295,7 +403,10 @@ isLockingPeriod = phoistAcyclic $
pletFields @'["draftTime", "votingTime", "lockingTime"] config $ \f -> pletFields @'["draftTime", "votingTime", "lockingTime"] config $ \f ->
proposalTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime) proposalTimeWithin # s # (s + f.draftTime + f.votingTime + f.lockingTime)
-- | True if the 'PProposalTime' is in the execution period. {- | True if the 'PProposalTime' is in the execution period.
@since 0.1.0
-}
isExecutionPeriod :: isExecutionPeriod ::
forall (s :: S). forall (s :: S).
Term Term

38
agora/Agora/SafeMoney.hs
View file

@ -1,7 +1,7 @@
{- | {- |
Module : Agora.SafeMoney Module : Agora.SafeMoney
Maintainer : emi@haskell.fyi Maintainer : emi@haskell.fyi
Description: Tags and bonuses for Plutarch.SafeMoney. Description: Tags and extras for "Plutarch.SafeMoney".
Tags and extras for "Plutarch.SafeMoney". Tags and extras for "Plutarch.SafeMoney".
-} -}
@ -14,32 +14,42 @@ module Agora.SafeMoney (
adaRef, adaRef,
) where ) where
-------------------------------------------------------------------------------- import Data.Tagged (Tagged (Tagged))
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass)) import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
import Data.Tagged (Tagged (Tagged)) {- | Governance token.
-------------------------------------------------------------------------------- @since 0.1.0
-- Tags -}
-- | Governance token.
data GTTag data GTTag
-- | ADA. {- | ADA.
@since 0.1.0
-}
data ADATag data ADATag
-- | Governor ST token. {- | Governor ST token.
@since 0.1.0
-}
data GovernorSTTag data GovernorSTTag
-- | Stake ST token. {- | Stake ST token.
@since 0.1.0
-}
data StakeSTTag data StakeSTTag
-- | Proposal ST token. {- | Proposal ST token.
@since 0.1.0
-}
data ProposalSTTag data ProposalSTTag
-------------------------------------------------------------------------------- {- | Resolves ada tags.
-- | Resolves ada tags. @since 0.1.0
-}
adaRef :: Tagged ADATag AssetClass adaRef :: Tagged ADATag AssetClass
adaRef = Tagged (AssetClass ("", "")) adaRef = Tagged (AssetClass ("", ""))

52
agora/Agora/ScriptInfo.hs
View file

@ -22,17 +22,35 @@ import Plutarch.Api.V1 (PMintingPolicy, PValidator, mintingPolicySymbol, mkMinti
import PlutusLedgerApi.V1 (MintingPolicy, Validator, ValidatorHash) import PlutusLedgerApi.V1 (MintingPolicy, Validator, ValidatorHash)
import PlutusLedgerApi.V1.Value (CurrencySymbol) import PlutusLedgerApi.V1.Value (CurrencySymbol)
-- | Bundle containing a 'Validator' and its hash. {- | Bundle containing a 'Validator' and its hash.
@since 0.1.0
-}
data ValidatorInfo = ValidatorInfo data ValidatorInfo = ValidatorInfo
{ script :: Validator { script :: Validator
-- ^ The validator script. -- ^ The validator script.
, hash :: ValidatorHash , hash :: ValidatorHash
-- ^ Hash of the validator. -- ^ Hash of the validator.
} }
deriving stock (Show, Eq, GHC.Generic) deriving stock
deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) ( -- | @since 0.1.0
Show
, -- | @since 0.1.0
Eq
, -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Aeson.ToJSON
, -- | @since 0.1.0
Aeson.FromJSON
)
-- | Create a 'ValidatorInfo' given a Plutarch term. {- | Create a 'ValidatorInfo' given a Plutarch term.
@since 0.1.0
-}
mkValidatorInfo :: ClosedTerm PValidator -> ValidatorInfo mkValidatorInfo :: ClosedTerm PValidator -> ValidatorInfo
mkValidatorInfo term = mkValidatorInfo term =
ValidatorInfo ValidatorInfo
@ -42,17 +60,35 @@ mkValidatorInfo term =
where where
validator = mkValidator term validator = mkValidator term
-- | Bundle containing a 'MintingPolicy' and its symbol. {- | Bundle containing a 'MintingPolicy' and its symbol.
@since 0.1.0
-}
data PolicyInfo = PolicyInfo data PolicyInfo = PolicyInfo
{ policy :: MintingPolicy { policy :: MintingPolicy
-- ^ The minting policy. -- ^ The minting policy.
, currencySymbol :: CurrencySymbol , currencySymbol :: CurrencySymbol
-- ^ The symbol given by the minting policy. -- ^ The symbol given by the minting policy.
} }
deriving stock (Show, Eq, GHC.Generic) deriving stock
deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) ( -- | @since 0.1.0
Show
, -- | @since 0.1.0
Eq
, -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Aeson.ToJSON
, -- | @since 0.1.0
Aeson.FromJSON
)
-- | Create a 'PolicyInfo' given a Plutarch term. {- | Create a 'PolicyInfo' given a Plutarch term.
@since 0.1.0
-}
mkPolicyInfo :: ClosedTerm PMintingPolicy -> PolicyInfo mkPolicyInfo :: ClosedTerm PMintingPolicy -> PolicyInfo
mkPolicyInfo term = mkPolicyInfo term =
PolicyInfo PolicyInfo

131
agora/Agora/Stake.hs
View file

@ -72,13 +72,19 @@ import Agora.SafeMoney (GTTag)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Parameters for creating Stake scripts. {- | Parameters for creating Stake scripts.
@since 0.1.0
-}
data Stake = Stake data Stake = Stake
{ gtClassRef :: Tagged GTTag AssetClass { gtClassRef :: Tagged GTTag AssetClass
-- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code. -- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code.
, proposalSTClass :: AssetClass , proposalSTClass :: AssetClass
} }
deriving stock (GHC.Generic) deriving stock
( -- | @since 0.1.0
GHC.Generic
)
{- | A lock placed on a Stake datum in order to prevent {- | A lock placed on a Stake datum in order to prevent
depositing and withdrawing when votes are in place. depositing and withdrawing when votes are in place.
@ -105,6 +111,8 @@ data Stake = Stake
│ Stake Policy │◄─┘ └►│ Proposal Policy │ │ Stake Policy │◄─┘ └►│ Proposal Policy │
└──────────────┘ └─────────────────┘ └──────────────┘ └─────────────────┘
@ @
@since 0.1.0
-} -}
data ProposalLock = ProposalLock data ProposalLock = ProposalLock
{ vote :: ResultTag { vote :: ResultTag
@ -114,11 +122,19 @@ data ProposalLock = ProposalLock
-- ^ Identifies the proposal. See 'ProposalId' for further -- ^ Identifies the proposal. See 'ProposalId' for further
-- comments on its significance. -- comments on its significance.
} }
deriving stock (Show, GHC.Generic) deriving stock
( -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
PlutusTx.makeIsDataIndexed ''ProposalLock [('ProposalLock, 0)] PlutusTx.makeIsDataIndexed ''ProposalLock [('ProposalLock, 0)]
-- | Haskell-level redeemer for Stake scripts. {- | Haskell-level redeemer for Stake scripts.
@since 0.1.0
-}
data StakeRedeemer data StakeRedeemer
= -- | Deposit or withdraw a discrete amount of the staked governance token. = -- | Deposit or withdraw a discrete amount of the staked governance token.
-- Stake must be unlocked. -- Stake must be unlocked.
@ -151,7 +167,10 @@ PlutusTx.makeIsDataIndexed
, ('WitnessStake, 4) , ('WitnessStake, 4)
] ]
-- | Haskell-level datum for Stake scripts. {- | Haskell-level datum for Stake scripts.
@since 0.1.0
-}
data StakeDatum = StakeDatum data StakeDatum = StakeDatum
{ stakedAmount :: Tagged GTTag Integer { stakedAmount :: Tagged GTTag Integer
-- ^ Tracks the amount of governance token staked in the datum. -- ^ Tracks the amount of governance token staked in the datum.
@ -171,7 +190,10 @@ PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Plutarch-level datum for Stake scripts. {- | Plutarch-level datum for Stake scripts.
@since 0.1.0
-}
newtype PStakeDatum (s :: S) = PStakeDatum newtype PStakeDatum (s :: S) = PStakeDatum
{ getStakeDatum :: { getStakeDatum ::
Term Term
@ -183,11 +205,28 @@ newtype PStakeDatum (s :: S) = PStakeDatum
] ]
) )
} }
deriving stock (GHC.Generic) deriving stock
deriving anyclass (Generic) ( -- | @since 0.1.0
deriving anyclass (PIsDataRepr) GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving deriving
(PlutusType, PIsData, PDataFields, PEq) ( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
, -- | @since 0.1.0
PDataFields
, -- | @since 0.1.0
PEq
)
via (PIsDataReprInstances PStakeDatum) via (PIsDataReprInstances PStakeDatum)
instance PTryFrom PData (PAsData PStakeDatum) where instance PTryFrom PData (PAsData PStakeDatum) where
@ -198,7 +237,10 @@ instance PTryFrom PData (PAsData PStakeDatum) where
instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum instance PUnsafeLiftDecl PStakeDatum where type PLifted PStakeDatum = StakeDatum
deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstantDecl StakeDatum) deriving via (DerivePConstantViaData StakeDatum PStakeDatum) instance (PConstantDecl StakeDatum)
-- | Plutarch-level redeemer for Stake scripts. {- | Plutarch-level redeemer for Stake scripts.
@since 0.1.0
-}
data PStakeRedeemer (s :: S) data PStakeRedeemer (s :: S)
= -- | Deposit or withdraw a discrete amount of the staked governance token. = -- | Deposit or withdraw a discrete amount of the staked governance token.
PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag])) PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag]))
@ -207,11 +249,24 @@ data PStakeRedeemer (s :: S)
| PPermitVote (Term s (PDataRecord '["lock" ':= PProposalLock])) | PPermitVote (Term s (PDataRecord '["lock" ':= PProposalLock]))
| PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList (PAsData PProposalLock)])) | PRetractVotes (Term s (PDataRecord '["locks" ':= PBuiltinList (PAsData PProposalLock)]))
| PWitnessStake (Term s (PDataRecord '[])) | PWitnessStake (Term s (PDataRecord '[]))
deriving stock (GHC.Generic) deriving stock
deriving anyclass (Generic) ( -- | @since 0.1.0
deriving anyclass (PIsDataRepr) GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
PIsDataRepr
)
deriving deriving
(PlutusType, PIsData) ( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via PIsDataReprInstances PStakeRedeemer via PIsDataReprInstances PStakeRedeemer
deriving via deriving via
@ -222,7 +277,10 @@ deriving via
instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer instance PUnsafeLiftDecl PStakeRedeemer where type PLifted PStakeRedeemer = StakeRedeemer
deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstantDecl StakeRedeemer) deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PConstantDecl StakeRedeemer)
-- | Plutarch-level version of 'ProposalLock'. {- | Plutarch-level version of 'ProposalLock'.
@since 0.1.0
-}
newtype PProposalLock (s :: S) = PProposalLock newtype PProposalLock (s :: S) = PProposalLock
{ getProposalLock :: { getProposalLock ::
Term Term
@ -250,7 +308,10 @@ deriving via (DerivePConstantViaData ProposalLock PProposalLock) instance (PCons
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Check whether a Stake is locked. If it is locked, various actions are unavailable. {- | Check whether a Stake is locked. If it is locked, various actions are unavailable.
@since 0.1.0
-}
stakeLocked :: forall (s :: S). Term s (PStakeDatum :--> PBool) stakeLocked :: forall (s :: S). Term s (PStakeDatum :--> PBool)
stakeLocked = phoistAcyclic $ stakeLocked = phoistAcyclic $
plam $ \stakeDatum -> plam $ \stakeDatum ->
@ -258,7 +319,10 @@ stakeLocked = phoistAcyclic $
locks = pfield @"lockedBy" # stakeDatum locks = pfield @"lockedBy" # stakeDatum
in pnotNull # locks in pnotNull # locks
-- | Find a stake owned by a particular PK. {- | Find a stake owned by a particular PK.
@since 0.1.0
-}
findStakeOwnedBy :: findStakeOwnedBy ::
Term Term
s s
@ -281,6 +345,10 @@ findStakeOwnedBy = phoistAcyclic $
PDJust ((pfield @"_0" #) -> dh) -> PDJust ((pfield @"_0" #) -> dh) ->
ptryFindDatum @(PAsData PStakeDatum) # dh # datums ptryFindDatum @(PAsData PStakeDatum) # dh # datums
{- | Check if a StakeDatum is owned by a particular public key.
@since 0.1.0
-}
stakeDatumOwnedBy :: Term _ (PPubKeyHash :--> PStakeDatum :--> PBool) stakeDatumOwnedBy :: Term _ (PPubKeyHash :--> PStakeDatum :--> PBool)
stakeDatumOwnedBy = stakeDatumOwnedBy =
phoistAcyclic $ phoistAcyclic $
@ -288,7 +356,10 @@ stakeDatumOwnedBy =
pletFields @'["owner"] (pto stakeDatum) $ \stakeDatumF -> pletFields @'["owner"] (pto stakeDatum) $ \stakeDatumF ->
stakeDatumF.owner #== pdata pk stakeDatumF.owner #== pdata pk
-- | Does the input have a `Stake` owned by a particular PK? {- | Does the input have a `Stake` owned by a particular PK?
@since 0.1.0
-}
isInputStakeOwnedBy :: isInputStakeOwnedBy ::
Term Term
_ _
@ -317,16 +388,32 @@ isInputStakeOwnedBy =
{- | Represent the usage of a stake on a particular proposal. {- | Represent the usage of a stake on a particular proposal.
A stake can be used to either create or vote on a proposal. A stake can be used to either create or vote on a proposal.
@since 0.1.0
-} -}
data PStakeUsage (s :: S) data PStakeUsage (s :: S)
= PVotedFor (Term s PResultTag) = PVotedFor (Term s PResultTag)
| PCreated | PCreated
| PDidNothing | PDidNothing
deriving stock (GHC.Generic) deriving stock
deriving anyclass (Generic, PlutusType, HasDatatypeInfo, PEq) ( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
, -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
HasDatatypeInfo
, -- | @since 0.1.0
PEq
)
{- | / O(n) /.Return the usage of a stake on a particular proposal, {- | / O(n) /.Return the usage of a stake on a particular proposal,
given the 'lockedBy' field of a stake and the target proposal. given the 'lockedBy' field of a stake and the target proposal.
@since 0.1.0
-} -}
pgetStakeUsage :: pgetStakeUsage ::
Term Term

64
agora/Agora/Stake/Scripts.hs
View file

@ -57,6 +57,8 @@ import Prelude hiding (Num (..))
- Check that exactly one state thread is burned. - Check that exactly one state thread is burned.
- Check that datum at state thread is valid and not locked. - Check that datum at state thread is valid and not locked.
@since 0.1.0
-} -}
stakePolicy :: stakePolicy ::
-- | The (governance) token that a Stake can store. -- | The (governance) token that a Stake can store.
@ -153,53 +155,55 @@ stakePolicy gtClassRef =
{- | Validator intended for Stake UTXOs to be locked by. {- | Validator intended for Stake UTXOs to be locked by.
== What this Validator does: == What this Validator does:
=== 'DepositWithdraw' === 'DepositWithdraw'
Deposit or withdraw some GT to the stake. Deposit or withdraw some GT to the stake.
- Tx must be signed by the owner. - Tx must be signed by the owner.
- The 'stakedAmount' field must be updated. - The 'stakedAmount' field must be updated.
- The stake must not be locked. - The stake must not be locked.
- The new UTXO must have the previous value plus the difference - The new UTXO must have the previous value plus the difference
as stated by the redeemer. as stated by the redeemer.
=== 'PermitVote' === 'PermitVote'
Allow a 'ProposalLock' to be put on the stake in order to vote Allow a 'ProposalLock' to be put on the stake in order to vote
on a proposal. on a proposal.
- A proposal token must be spent alongside the stake. - A proposal token must be spent alongside the stake.
* Its total votes must be correctly updated to include this stake's * Its total votes must be correctly updated to include this stake's
contribution. contribution.
- Tx must be signed by the owner. - Tx must be signed by the owner.
=== 'RetractVotes' === 'RetractVotes'
Remove a 'ProposalLock' set when voting on a proposal. Remove a 'ProposalLock' set when voting on a proposal.
- A proposal token must be spent alongside the stake. - A proposal token must be spent alongside the stake.
- Tx must be signed by the owner. - Tx must be signed by the owner.
=== 'Destroy' === 'Destroy'
Destroy the stake in order to reclaim the min ADA. Destroy the stake in order to reclaim the min ADA.
- The stake must not be locked. - The stake must not be locked.
- Tx must be signed by the owner. - Tx must be signed by the owner.
=== 'WitnessStake' === 'WitnessStake'
Allow this Stake to be included in a transaction without making Allow this Stake to be included in a transaction without making
any changes to it. In the future, any changes to it. In the future,
this could use [CIP-31](https://cips.cardano.org/cips/cip31/) instead. this could use [CIP-31](https://cips.cardano.org/cips/cip31/) instead.
- Tx must be signed by the owner __or__ a proposal ST token must be spent - Tx must be signed by the owner __or__ a proposal ST token must be spent
alongside the stake. alongside the stake.
- The datum and value must remain unchanged. - The datum and value must remain unchanged.
@since 0.1.0
-} -}
stakeValidator :: Stake -> ClosedTerm PValidator stakeValidator :: Stake -> ClosedTerm PValidator
stakeValidator stake = stakeValidator stake =

43
agora/Agora/Treasury.hs
View file

@ -12,7 +12,7 @@ module Agora.Treasury (module Agora.Treasury) where
import Agora.AuthorityToken (singleAuthorityTokenBurned) import Agora.AuthorityToken (singleAuthorityTokenBurned)
import GHC.Generics qualified as GHC import GHC.Generics qualified as GHC
import Generics.SOP import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 (PValidator) import Plutarch.Api.V1 (PValidator)
import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting)) import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting))
import "plutarch" Plutarch.Api.V1.Value (PValue) import "plutarch" Plutarch.Api.V1.Value (PValue)
@ -26,14 +26,23 @@ import Plutarch.TryFrom ()
import PlutusLedgerApi.V1.Value (CurrencySymbol) import PlutusLedgerApi.V1.Value (CurrencySymbol)
import PlutusTx qualified import PlutusTx qualified
-------------------------------------------------------------------------------- {- | Redeemer for Treasury actions.
-- | Redeemer for Treasury actions. @since 0.1.0
-}
data TreasuryRedeemer data TreasuryRedeemer
= -- | Allow transaction to pass by delegating to GAT burn. = -- | Allow transaction to pass by delegating to GAT burn.
SpendTreasuryGAT SpendTreasuryGAT
deriving stock (Eq, Show, GHC.Generic) deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
)
-- | @since 0.1.0
PlutusTx.makeIsDataIndexed PlutusTx.makeIsDataIndexed
''TreasuryRedeemer ''TreasuryRedeemer
[ ('SpendTreasuryGAT, 0) [ ('SpendTreasuryGAT, 0)
@ -43,24 +52,42 @@ PlutusTx.makeIsDataIndexed
{- | Plutarch level type representing valid redeemers of the {- | Plutarch level type representing valid redeemers of the
treasury. treasury.
@since 0.1.0
-} -}
newtype PTreasuryRedeemer (s :: S) newtype PTreasuryRedeemer (s :: S)
= -- | Alters treasury parameters, subject to the burning of a = -- | Alters treasury parameters, subject to the burning of a
-- governance authority token. -- governance authority token.
PSpendTreasuryGAT (Term s (PDataRecord '[])) PSpendTreasuryGAT (Term s (PDataRecord '[]))
deriving stock (GHC.Generic) deriving stock
deriving anyclass (Generic, PIsDataRepr) ( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0
Generic
, -- | @since 0.1.0
PIsDataRepr
)
deriving deriving
(PlutusType, PIsData) ( -- | @since 0.1.0
PlutusType
, -- | @since 0.1.0
PIsData
)
via PIsDataReprInstances PTreasuryRedeemer via PIsDataReprInstances PTreasuryRedeemer
-- | @since 0.1.0
deriving via deriving via
PAsData (PIsDataReprInstances PTreasuryRedeemer) PAsData (PIsDataReprInstances PTreasuryRedeemer)
instance instance
PTryFrom PData (PAsData PTreasuryRedeemer) PTryFrom PData (PAsData PTreasuryRedeemer)
-- | @since 0.1.0
instance PUnsafeLiftDecl PTreasuryRedeemer where instance PUnsafeLiftDecl PTreasuryRedeemer where
type PLifted PTreasuryRedeemer = TreasuryRedeemer type PLifted PTreasuryRedeemer = TreasuryRedeemer
-- | @since 0.1.0
deriving via deriving via
(DerivePConstantViaData TreasuryRedeemer PTreasuryRedeemer) (DerivePConstantViaData TreasuryRedeemer PTreasuryRedeemer)
instance instance
@ -70,6 +97,8 @@ deriving via
{- | Validator ensuring that transactions consuming the treasury {- | Validator ensuring that transactions consuming the treasury
do so in a valid manner. do so in a valid manner.
@since 0.1.0
-} -}
treasuryValidator :: treasuryValidator ::
-- | Governance Authority Token that can unlock this validator. -- | Governance Authority Token that can unlock this validator.

75
agora/Agora/Utils.hs
View file

@ -21,18 +21,6 @@ module Agora.Utils (
isPubKey, isPubKey,
) where ) where
--------------------------------------------------------------------------------
import PlutusLedgerApi.V1 (
Address (..),
Credential (..),
CurrencySymbol,
TokenName (..),
ValidatorHash (..),
)
--------------------------------------------------------------------------------
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
AmountGuarantees, AmountGuarantees,
KeyGuarantees, KeyGuarantees,
@ -56,12 +44,22 @@ import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (psymbolValueOf)
import Plutarch.Builtin (pforgetData) import Plutarch.Builtin (pforgetData)
import Plutarch.Extra.List (plookupTuple) import Plutarch.Extra.List (plookupTuple)
import Plutarch.Extra.TermCont (pletC, pmatchC) import Plutarch.Extra.TermCont (pletC, pmatchC)
import PlutusLedgerApi.V1 (
Address (..),
Credential (..),
CurrencySymbol,
TokenName (..),
ValidatorHash (..),
)
{- Functions which should (probably) not be upstreamed {- Functions which should (probably) not be upstreamed
All of these functions are quite inefficient. All of these functions are quite inefficient.
-} -}
-- | Get script hash from an Address. {- | Get script hash from an Address.
@since 0.1.0
-}
scriptHashFromAddress :: Term s (PAddress :--> PMaybe PValidatorHash) scriptHashFromAddress :: Term s (PAddress :--> PMaybe PValidatorHash)
scriptHashFromAddress = phoistAcyclic $ scriptHashFromAddress = phoistAcyclic $
plam $ \addr -> plam $ \addr ->
@ -69,12 +67,18 @@ scriptHashFromAddress = phoistAcyclic $
PScriptCredential ((pfield @"_0" #) -> h) -> pcon $ PJust h PScriptCredential ((pfield @"_0" #) -> h) -> pcon $ PJust h
_ -> pcon PNothing _ -> pcon PNothing
-- | Return true if the given address is a script address. {- | Return true if the given address is a script address.
@since 0.1.0
-}
isScriptAddress :: Term s (PAddress :--> PBool) isScriptAddress :: Term s (PAddress :--> PBool)
isScriptAddress = phoistAcyclic $ isScriptAddress = phoistAcyclic $
plam $ \addr -> pnot #$ isPubKey #$ pfromData $ pfield @"credential" # addr plam $ \addr -> pnot #$ isPubKey #$ pfromData $ pfield @"credential" # addr
-- | Return true if the given credential is a pub-key-hash. {- | Return true if the given credential is a pub-key-hash.
@since 0.1.0
-}
isPubKey :: Term s (PCredential :--> PBool) isPubKey :: Term s (PCredential :--> PBool)
isPubKey = phoistAcyclic $ isPubKey = phoistAcyclic $
plam $ \cred -> plam $ \cred ->
@ -82,7 +86,10 @@ isPubKey = phoistAcyclic $
PScriptCredential _ -> pconstant False PScriptCredential _ -> pconstant False
_ -> pconstant True _ -> pconstant True
-- | Find all TxOuts sent to an Address {- | Find all TxOuts sent to an Address
@since 0.1.0
-}
findOutputsToAddress :: Term s (PBuiltinList (PAsData PTxOut) :--> PAddress :--> PBuiltinList (PAsData PTxOut)) findOutputsToAddress :: Term s (PBuiltinList (PAsData PTxOut) :--> PAddress :--> PBuiltinList (PAsData PTxOut))
findOutputsToAddress = phoistAcyclic $ findOutputsToAddress = phoistAcyclic $
plam $ \outputs address' -> unTermCont $ do plam $ \outputs address' -> unTermCont $ do
@ -91,7 +98,10 @@ findOutputsToAddress = phoistAcyclic $
pfilter # plam (\(pfromData -> txOut) -> pfield @"address" # txOut #== address) pfilter # plam (\(pfromData -> txOut) -> pfield @"address" # txOut #== address)
# outputs # outputs
-- | Find the data corresponding to a TxOut, if there is one {- | Find the data corresponding to a TxOut, if there is one
@since 0.1.0
-}
findTxOutDatum :: Term s (PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PTxOut :--> PMaybe PDatum) findTxOutDatum :: Term s (PBuiltinList (PAsData (PTuple PDatumHash PDatum)) :--> PTxOut :--> PMaybe PDatum)
findTxOutDatum = phoistAcyclic $ findTxOutDatum = phoistAcyclic $
plam $ \datums out -> unTermCont $ do plam $ \datums out -> unTermCont $ do
@ -102,19 +112,30 @@ findTxOutDatum = phoistAcyclic $
{- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging {- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging
tokens for extra safety. tokens for extra safety.
@since 0.1.0
-} -}
validatorHashToTokenName :: ValidatorHash -> TokenName validatorHashToTokenName :: ValidatorHash -> TokenName
validatorHashToTokenName (ValidatorHash hash) = TokenName hash validatorHashToTokenName (ValidatorHash hash) = TokenName hash
-- | Plutarch level 'validatorHashToTokenName'. {- | Plutarch level 'validatorHashToTokenName'.
@since 0.1.0
-}
pvalidatorHashToTokenName :: forall (s :: S). Term s PValidatorHash -> Term s PTokenName pvalidatorHashToTokenName :: forall (s :: S). Term s PValidatorHash -> Term s PTokenName
pvalidatorHashToTokenName vh = pcon (PTokenName (pto vh)) pvalidatorHashToTokenName vh = pcon (PTokenName (pto vh))
-- | Get the CurrencySymbol of a PMintingPolicy. {- | Get the CurrencySymbol of a PMintingPolicy.
@since 0.1.0
-}
getMintingPolicySymbol :: ClosedTerm PMintingPolicy -> CurrencySymbol getMintingPolicySymbol :: ClosedTerm PMintingPolicy -> CurrencySymbol
getMintingPolicySymbol v = mintingPolicySymbol $ mkMintingPolicy v getMintingPolicySymbol v = mintingPolicySymbol $ mkMintingPolicy v
-- | The entire value only contains one token of the given currency symbol. {- | The entire value only contains one token of the given currency symbol.
@since 0.1.0
-}
hasOnlyOneTokenOfCurrencySymbol :: hasOnlyOneTokenOfCurrencySymbol ::
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S). forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
Term s (PCurrencySymbol :--> PValue keys amounts :--> PBool) Term s (PCurrencySymbol :--> PValue keys amounts :--> PBool)
@ -123,7 +144,10 @@ hasOnlyOneTokenOfCurrencySymbol = phoistAcyclic $
psymbolValueOf # cs # vs #== 1 psymbolValueOf # cs # vs #== 1
#&& (plength #$ pto $ pto $ pto vs) #== 1 #&& (plength #$ pto $ pto $ pto vs) #== 1
-- | Find datum given a maybe datum hash {- | Find datum given a maybe datum hash
@since 0.1.0
-}
mustFindDatum' :: mustFindDatum' ::
forall (datum :: PType). forall (datum :: PType).
(PIsData datum, PTryFrom PData (PAsData datum)) => (PIsData datum, PTryFrom PData (PAsData datum)) =>
@ -143,6 +167,8 @@ mustFindDatum' = phoistAcyclic $
{- | Extract the value stored in a PMaybe container. {- | Extract the value stored in a PMaybe container.
If there's no value, throw an error with the given message. If there's no value, throw an error with the given message.
@since 0.1.0
-} -}
mustBePJust :: forall a s. Term s (PString :--> PMaybe a :--> a) mustBePJust :: forall a s. Term s (PString :--> PMaybe a :--> a)
mustBePJust = phoistAcyclic $ mustBePJust = phoistAcyclic $
@ -152,6 +178,8 @@ mustBePJust = phoistAcyclic $
{- | Extract the value stored in a PMaybeData container. {- | Extract the value stored in a PMaybeData container.
If there's no value, throw an error with the given message. If there's no value, throw an error with the given message.
@since 0.1.0
-} -}
mustBePDJust :: forall a s. (PIsData a) => Term s (PString :--> PMaybeData a :--> a) mustBePDJust :: forall a s. (PIsData a) => Term s (PString :--> PMaybeData a :--> a)
mustBePDJust = phoistAcyclic $ mustBePDJust = phoistAcyclic $
@ -159,6 +187,9 @@ mustBePDJust = phoistAcyclic $
PDJust ((pfield @"_0" #) -> v) -> v PDJust ((pfield @"_0" #) -> v) -> v
_ -> ptraceError emsg _ -> ptraceError emsg
-- | Create an 'Address' from a given 'ValidatorHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'. {- | Create an 'Address' from a given 'ValidatorHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'.
@since 0.1.0
-}
validatorHashToAddress :: ValidatorHash -> Address validatorHashToAddress :: ValidatorHash -> Address
validatorHashToAddress vh = Address (ScriptCredential vh) Nothing validatorHashToAddress vh = Address (ScriptCredential vh) Nothing