parameterize scripts over AgoraScripts
This commit is contained in:
Hongrui Fang
parent
f248dbab49
commit
91f7118ec3
15 changed files with 423 additions and 572 deletions
|
|
@ -31,14 +31,12 @@ agoraTypes =
|
|||
, mkSumType (Proxy @Proposal.ProposalVotes)
|
||||
, mkSumType (Proxy @Proposal.ProposalDatum)
|
||||
, mkSumType (Proxy @Proposal.ProposalRedeemer)
|
||||
, mkSumType (Proxy @Proposal.Proposal)
|
||||
, -- Governor
|
||||
mkSumType (Proxy @Governor.GovernorDatum)
|
||||
, mkSumType (Proxy @Governor.GovernorRedeemer)
|
||||
, mkSumType (Proxy @Governor.Governor)
|
||||
, -- Stake
|
||||
mkSumType (Proxy @Stake.Stake)
|
||||
, mkSumType (Proxy @Stake.ProposalLock)
|
||||
mkSumType (Proxy @Stake.ProposalLock)
|
||||
, mkSumType (Proxy @Stake.StakeRedeemer)
|
||||
, mkSumType (Proxy @Stake.StakeDatum)
|
||||
, -- Treasury
|
||||
|
|
|
|||
|
|
@ -8,16 +8,11 @@
|
|||
-}
|
||||
module Main (main) where
|
||||
|
||||
import Agora.AuthorityToken (AuthorityToken, authorityTokenPolicy)
|
||||
import Agora.Governor (Governor (Governor))
|
||||
import Agora.Governor qualified as Governor
|
||||
import Agora.Governor.Scripts (authorityTokenFromGovernor, authorityTokenSymbolFromGovernor, governorPolicy, governorValidator, proposalFromGovernor, stakeFromGovernor)
|
||||
import Agora.Proposal (Proposal)
|
||||
import Agora.Proposal.Scripts (proposalPolicy, proposalValidator)
|
||||
import Agora.Bootstrap qualified as Bootstrap
|
||||
import Agora.Governor (Governor (..))
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Stake (Stake)
|
||||
import Agora.Stake.Scripts (stakePolicy, stakeValidator)
|
||||
import Agora.Treasury (treasuryValidator)
|
||||
import Agora.Scripts qualified as Scripts
|
||||
import Agora.Utils (CompiledMintingPolicy (..), CompiledValidator (..))
|
||||
import Data.Aeson qualified as Aeson
|
||||
import Data.Default (def)
|
||||
import Data.Function ((&))
|
||||
|
|
@ -25,13 +20,16 @@ import Data.Tagged (Tagged)
|
|||
import Data.Text (Text)
|
||||
import Development.GitRev (gitBranch, gitHash)
|
||||
import GHC.Generics qualified as GHC
|
||||
import Plutarch.Api.V1 (mintingPolicySymbol, mkMintingPolicy)
|
||||
import PlutusLedgerApi.V1 (TxOutRef)
|
||||
import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol)
|
||||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import Plutarch (Config (..), TracingMode (DoTracing))
|
||||
import PlutusLedgerApi.V1 (
|
||||
MintingPolicy (getMintingPolicy),
|
||||
TxOutRef,
|
||||
Validator (getValidator),
|
||||
)
|
||||
import PlutusLedgerApi.V1.Value (AssetClass)
|
||||
import ScriptExport.API (runServer)
|
||||
import ScriptExport.Options (parseOptions)
|
||||
import ScriptExport.ScriptInfo (ScriptInfo, mkPolicyInfo, mkValidatorInfo)
|
||||
import ScriptExport.ScriptInfo (ScriptInfo (..), mkPolicyInfo, mkScriptInfo, mkValidatorInfo)
|
||||
import ScriptExport.Types (Builders, insertBuilder)
|
||||
|
||||
main :: IO ()
|
||||
|
|
@ -81,44 +79,23 @@ builders =
|
|||
agoraScripts :: ScriptParams -> AgoraScripts
|
||||
agoraScripts params =
|
||||
AgoraScripts
|
||||
{ governorPolicyInfo = mkPolicyInfo (governorPolicy governor)
|
||||
, governorValidatorInfo = mkValidatorInfo (governorValidator governor)
|
||||
, stakePolicyInfo = mkPolicyInfo (stakePolicy params.gtClassRef)
|
||||
, stakeValidatorInfo = mkValidatorInfo (stakeValidator stake)
|
||||
, proposalPolicyInfo = mkPolicyInfo (proposalPolicy governorSTAssetClass)
|
||||
, proposalValidatorInfo = mkValidatorInfo (proposalValidator proposal)
|
||||
, treasuryValidatorInfo = mkValidatorInfo (treasuryValidator authorityTokenSymbol)
|
||||
, authorityTokenPolicyInfo = mkPolicyInfo (authorityTokenPolicy authorityToken)
|
||||
{ governorPolicyInfo = mkPolicyInfo' scripts.compiledGovernorPolicy
|
||||
, governorValidatorInfo = mkValidatorInfo' scripts.compiledGovernorValidator
|
||||
, stakePolicyInfo = mkPolicyInfo' scripts.compiledStakePolicy
|
||||
, stakeValidatorInfo = mkValidatorInfo' scripts.compiledStakeValidator
|
||||
, proposalPolicyInfo = mkPolicyInfo' scripts.compiledProposalPolicy
|
||||
, proposalValidatorInfo = mkValidatorInfo' scripts.compiledProposalValidator
|
||||
, treasuryValidatorInfo = mkValidatorInfo' scripts.compiledTreasuryValidator
|
||||
, authorityTokenPolicyInfo = mkPolicyInfo' scripts.compiledAuthorityTokenPolicy
|
||||
}
|
||||
where
|
||||
governor :: Governor
|
||||
governor =
|
||||
Governor
|
||||
{ Governor.gstOutRef = params.governorInitialSpend
|
||||
, Governor.gtClassRef = params.gtClassRef
|
||||
, Governor.maximumCosigners = params.maximumCosigners
|
||||
}
|
||||
Agora.Governor.Governor
|
||||
params.governorInitialSpend
|
||||
params.gtClassRef
|
||||
params.maximumCosigners
|
||||
|
||||
authorityToken :: AuthorityToken
|
||||
authorityToken = authorityTokenFromGovernor governor
|
||||
|
||||
authorityTokenSymbol :: CurrencySymbol
|
||||
authorityTokenSymbol = authorityTokenSymbolFromGovernor governor
|
||||
|
||||
governorSTAssetClass :: AssetClass
|
||||
governorSTAssetClass =
|
||||
Value.assetClass
|
||||
( mintingPolicySymbol $
|
||||
mkMintingPolicy def $
|
||||
governorPolicy governor
|
||||
)
|
||||
""
|
||||
|
||||
proposal :: Proposal
|
||||
proposal = proposalFromGovernor governor
|
||||
|
||||
stake :: Stake
|
||||
stake = stakeFromGovernor governor
|
||||
scripts = Bootstrap.agoraScripts plutarchConfig governor
|
||||
|
||||
{- | Params required for creating script export.
|
||||
|
||||
|
|
@ -162,3 +139,26 @@ data AgoraScripts = AgoraScripts
|
|||
, -- | @since 0.2.0
|
||||
GHC.Generic
|
||||
)
|
||||
|
||||
{- | Default plutarch configuration for compiling scripts.
|
||||
|
||||
TODO: we should have an option to control this.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
plutarchConfig :: Config
|
||||
plutarchConfig = Config {tracingMode = DoTracing}
|
||||
|
||||
{- | Turn a precompiled minting policy to a 'ScriptInfo'.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
mkPolicyInfo' :: forall redeemer. CompiledMintingPolicy redeemer -> ScriptInfo
|
||||
mkPolicyInfo' = mkScriptInfo . getMintingPolicy . getCompiledMintingPolicy
|
||||
|
||||
{- | Turn a precompiled validator to a 'ScriptInfo'.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
mkValidatorInfo' :: forall redeemer datum. CompiledValidator datum redeemer -> ScriptInfo
|
||||
mkValidatorInfo' = mkScriptInfo . getValidator . getCompiledValidator
|
||||
|
|
|
|||
|
|
@ -95,6 +95,7 @@ common deps
|
|||
, bytestring
|
||||
, cardano-binary
|
||||
, cardano-prelude
|
||||
, composition-prelude
|
||||
, containers
|
||||
, data-default
|
||||
, data-default-class
|
||||
|
|
@ -143,6 +144,7 @@ library
|
|||
exposed-modules:
|
||||
Agora.Aeson.Orphans
|
||||
Agora.AuthorityToken
|
||||
Agora.Bootstrap
|
||||
Agora.Effect
|
||||
Agora.Effect.GovernorMutation
|
||||
Agora.Effect.NoOp
|
||||
|
|
@ -154,6 +156,7 @@ library
|
|||
Agora.Proposal.Scripts
|
||||
Agora.Proposal.Time
|
||||
Agora.SafeMoney
|
||||
Agora.Scripts
|
||||
Agora.Stake
|
||||
Agora.Stake.Scripts
|
||||
Agora.Treasury
|
||||
|
|
|
|||
67
agora/Agora/Bootstrap.hs
Normal file
67
agora/Agora/Bootstrap.hs
Normal file
|
|
@ -0,0 +1,67 @@
|
|||
{- | Module : Agora.Bootstrap
|
||||
Maintainer : connor@mlabs.city
|
||||
Description: Initialize a governance system
|
||||
|
||||
Initialize a governance system
|
||||
-}
|
||||
module Agora.Bootstrap (agoraScripts) where
|
||||
|
||||
import Agora.AuthorityToken (AuthorityToken (..), authorityTokenPolicy)
|
||||
import Agora.Governor (Governor (..))
|
||||
import Agora.Governor.Scripts (governorPolicy, governorValidator)
|
||||
import Agora.Proposal.Scripts (proposalPolicy, proposalValidator)
|
||||
import Agora.Scripts (AgoraScripts (AgoraScripts))
|
||||
import Agora.Scripts qualified as Scripts
|
||||
import Agora.Stake.Scripts (stakePolicy, stakeValidator)
|
||||
import Agora.Treasury (treasuryValidator)
|
||||
import Agora.Utils (
|
||||
CompiledMintingPolicy (..),
|
||||
CompiledValidator (..),
|
||||
)
|
||||
import Plutarch (Config)
|
||||
import Plutarch.Api.V1 (
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
mkValidator,
|
||||
)
|
||||
import PlutusLedgerApi.V1.Value (AssetClass (..))
|
||||
|
||||
{- | Parameterize and precompiled core scripts, given the
|
||||
'Agora.Governor.Governor' parameters and plutarch configurations.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
agoraScripts :: Config -> Governor -> AgoraScripts
|
||||
agoraScripts conf gov = scripts
|
||||
where
|
||||
mkMintingPolicy' = mkMintingPolicy conf
|
||||
mkValidator' = mkValidator conf
|
||||
|
||||
compiledGovernorPolicy = mkMintingPolicy' $ governorPolicy gov.gstOutRef
|
||||
compiledGovernorValidator = mkValidator' $ governorValidator scripts
|
||||
governorSymbol = mintingPolicySymbol compiledGovernorPolicy
|
||||
governorAssetClass = AssetClass (governorSymbol, "")
|
||||
|
||||
authority = AuthorityToken governorAssetClass
|
||||
compiledAuthorityPolicy = mkMintingPolicy' $ authorityTokenPolicy authority
|
||||
authorityTokenSymbol = mintingPolicySymbol compiledAuthorityPolicy
|
||||
|
||||
compiledProposalPolicy = mkMintingPolicy' $ proposalPolicy governorAssetClass
|
||||
compiledProposalValidator = mkValidator' $ proposalValidator scripts gov.maximumCosigners
|
||||
|
||||
compiledStakePolicy = mkMintingPolicy' $ stakePolicy gov.gtClassRef
|
||||
compiledStakeValidator = mkValidator' $ stakeValidator scripts gov.gtClassRef
|
||||
|
||||
compiledTreasuryValidator = mkValidator' $ treasuryValidator authorityTokenSymbol
|
||||
|
||||
scripts =
|
||||
AgoraScripts
|
||||
{ Scripts.compiledGovernorPolicy = CompiledMintingPolicy compiledGovernorPolicy
|
||||
, Scripts.compiledGovernorValidator = CompiledValidator compiledGovernorValidator
|
||||
, Scripts.compiledStakePolicy = CompiledMintingPolicy compiledStakePolicy
|
||||
, Scripts.compiledStakeValidator = CompiledValidator compiledStakeValidator
|
||||
, Scripts.compiledProposalPolicy = CompiledMintingPolicy compiledProposalPolicy
|
||||
, Scripts.compiledProposalValidator = CompiledValidator compiledProposalValidator
|
||||
, Scripts.compiledTreasuryValidator = CompiledValidator compiledTreasuryValidator
|
||||
, Scripts.compiledAuthorityTokenPolicy = CompiledMintingPolicy compiledAuthorityPolicy
|
||||
}
|
||||
|
|
@ -23,7 +23,7 @@ import PlutusLedgerApi.V1.Value (CurrencySymbol)
|
|||
-}
|
||||
makeEffect ::
|
||||
forall (datum :: PType).
|
||||
(PTryFrom PData datum) =>
|
||||
(PTryFrom PData datum, PIsData datum) =>
|
||||
CurrencySymbol ->
|
||||
(forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
|
||||
ClosedTerm PValidator
|
||||
|
|
|
|||
|
|
@ -20,16 +20,12 @@ module Agora.Effect.GovernorMutation (
|
|||
|
||||
import Agora.Effect (makeEffect)
|
||||
import Agora.Governor (
|
||||
Governor,
|
||||
GovernorDatum,
|
||||
PGovernorDatum,
|
||||
pisGovernorDatumValid,
|
||||
)
|
||||
import Agora.Governor.Scripts (
|
||||
authorityTokenSymbolFromGovernor,
|
||||
governorSTAssetClassFromGovernor,
|
||||
)
|
||||
import Agora.Plutarch.Orphans ()
|
||||
import Agora.Scripts (AgoraScripts, authorityTokenSymbol, governorSTAssetClass)
|
||||
import Generics.SOP qualified as SOP
|
||||
import Plutarch.Api.V1 (
|
||||
PTxOutRef,
|
||||
|
|
@ -149,8 +145,11 @@ deriving anyclass instance PTryFrom PData PMutateGovernorDatum
|
|||
|
||||
@since 0.1.0
|
||||
-}
|
||||
mutateGovernorValidator :: Governor -> ClosedTerm PValidator
|
||||
mutateGovernorValidator gov = makeEffect (authorityTokenSymbolFromGovernor gov) $
|
||||
mutateGovernorValidator ::
|
||||
-- | Lazy precompiled scripts. This is beacuse we need the symbol of GST.
|
||||
AgoraScripts ->
|
||||
ClosedTerm PValidator
|
||||
mutateGovernorValidator as = makeEffect (authorityTokenSymbol as) $
|
||||
\_gatCs (datum :: Term _ PMutateGovernorDatum) _ txInfo -> unTermCont $ do
|
||||
datumF <- pletFieldsC @'["newDatum", "governorRef"] datum
|
||||
txInfoF <- pletFieldsC @'["mint", "inputs", "outputs", "datums"] txInfo
|
||||
|
|
@ -223,4 +222,4 @@ mutateGovernorValidator gov = makeEffect (authorityTokenSymbolFromGovernor gov)
|
|||
gstValueOf :: Term s (PValue _ _ :--> PInteger)
|
||||
gstValueOf = phoistAcyclic $ plam $ \v -> pvalueOf # v # pconstant cs # pconstant tn
|
||||
where
|
||||
AssetClass (cs, tn) = governorSTAssetClassFromGovernor gov
|
||||
AssetClass (cs, tn) = governorSTAssetClass as
|
||||
|
|
|
|||
|
|
@ -12,33 +12,15 @@ module Agora.Governor.Scripts (
|
|||
-- * Scripts
|
||||
governorPolicy,
|
||||
governorValidator,
|
||||
|
||||
-- * Bridges
|
||||
governorSTSymbolFromGovernor,
|
||||
governorSTAssetClassFromGovernor,
|
||||
proposalSTAssetClassFromGovernor,
|
||||
stakeSTSymbolFromGovernor,
|
||||
stakeFromGovernor,
|
||||
stakeValidatorHashFromGovernor,
|
||||
proposalFromGovernor,
|
||||
proposalValidatorHashFromGovernor,
|
||||
proposalSTSymbolFromGovernor,
|
||||
stakeSTAssetClassFromGovernor,
|
||||
governorValidatorHash,
|
||||
authorityTokenFromGovernor,
|
||||
authorityTokenSymbolFromGovernor,
|
||||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.AuthorityToken (
|
||||
AuthorityToken (..),
|
||||
authorityTokenPolicy,
|
||||
authorityTokensValidIn,
|
||||
singleAuthorityTokenBurned,
|
||||
)
|
||||
import Agora.Governor (
|
||||
Governor (gstOutRef, gtClassRef, maximumCosigners),
|
||||
GovernorRedeemer (..),
|
||||
PGovernorDatum (PGovernorDatum),
|
||||
pgetNextProposalId,
|
||||
|
|
@ -46,7 +28,6 @@ import Agora.Governor (
|
|||
)
|
||||
import Agora.Proposal (
|
||||
PProposalDatum (..),
|
||||
Proposal (..),
|
||||
ProposalStatus (Draft, Locked),
|
||||
phasNeutralEffect,
|
||||
pisEffectsVotesCompatible,
|
||||
|
|
@ -54,27 +35,17 @@ import Agora.Proposal (
|
|||
pneutralOption,
|
||||
pwinner,
|
||||
)
|
||||
import Agora.Proposal.Scripts (
|
||||
proposalPolicy,
|
||||
proposalValidator,
|
||||
)
|
||||
import Agora.Proposal.Time (createProposalStartingTime)
|
||||
import Agora.Scripts (AgoraScripts, authorityTokenSymbol, governorSTSymbol, proposalSTSymbol, proposalValidatoHash, stakeSTSymbol)
|
||||
import Agora.Stake (
|
||||
PProposalLock (..),
|
||||
PStakeDatum (..),
|
||||
Stake (..),
|
||||
pnumCreatedProposals,
|
||||
)
|
||||
import Agora.Stake.Scripts (
|
||||
stakePolicy,
|
||||
stakeValidator,
|
||||
)
|
||||
import Agora.Utils (
|
||||
mustFindDatum',
|
||||
validatorHashToAddress,
|
||||
validatorHashToTokenName,
|
||||
)
|
||||
import Data.Default (def)
|
||||
import Plutarch.Api.V1 (
|
||||
PAddress,
|
||||
PCurrencySymbol,
|
||||
|
|
@ -85,10 +56,6 @@ import Plutarch.Api.V1 (
|
|||
PTxOut,
|
||||
PValidator,
|
||||
PValidatorHash,
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
mkValidator,
|
||||
validatorHash,
|
||||
)
|
||||
import Plutarch.Api.V1.AssetClass (
|
||||
passetClass,
|
||||
|
|
@ -110,17 +77,10 @@ import Plutarch.Extra.Map (
|
|||
plookup,
|
||||
plookup',
|
||||
)
|
||||
import Plutarch.Extra.Maybe (passertPDJust, passertPJust, pisDJust)
|
||||
import Plutarch.Extra.Maybe (passertPDJust, passertPJust, pfromJust, pisDJust)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
|
||||
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
|
||||
import PlutusLedgerApi.V1 (
|
||||
CurrencySymbol (..),
|
||||
MintingPolicy,
|
||||
)
|
||||
import PlutusLedgerApi.V1.Scripts (ValidatorHash (..))
|
||||
import PlutusLedgerApi.V1.Value (
|
||||
AssetClass (..),
|
||||
)
|
||||
import PlutusLedgerApi.V1 (TxOutRef)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -151,10 +111,10 @@ import PlutusLedgerApi.V1.Value (
|
|||
|
||||
@since 0.1.0
|
||||
-}
|
||||
governorPolicy :: Governor -> ClosedTerm PMintingPolicy
|
||||
governorPolicy gov =
|
||||
governorPolicy :: TxOutRef -> ClosedTerm PMintingPolicy
|
||||
governorPolicy initialSpend =
|
||||
plam $ \_ ctx' -> unTermCont $ do
|
||||
let oref = pconstant gov.gstOutRef
|
||||
let oref = pconstant initialSpend
|
||||
|
||||
PMinting ((pfield @"_0" #) -> ownSymbol) <- pmatchC (pfromData $ pfield @"purpose" # ctx')
|
||||
let ownAssetClass = passetClass # ownSymbol # pconstant ""
|
||||
|
|
@ -273,8 +233,11 @@ governorPolicy gov =
|
|||
|
||||
@since 0.1.0
|
||||
-}
|
||||
governorValidator :: Governor -> ClosedTerm PValidator
|
||||
governorValidator gov =
|
||||
governorValidator ::
|
||||
-- | Lazy precompiled scripts.
|
||||
AgoraScripts ->
|
||||
ClosedTerm PValidator
|
||||
governorValidator as =
|
||||
plam $ \datum' redeemer' ctx' -> unTermCont $ do
|
||||
ctxF <- pletAllC ctx'
|
||||
|
||||
|
|
@ -404,7 +367,7 @@ governorValidator gov =
|
|||
proposalOutputDatum <- pletAllC $ pto $ pfromData proposalOutputDatum'
|
||||
|
||||
let expectedStartingTime =
|
||||
createProposalStartingTime
|
||||
pfromJust #$ createProposalStartingTime
|
||||
# oldGovernorDatumF.createProposalTimeRangeMaxWidth
|
||||
# txInfoF.validRange
|
||||
|
||||
|
|
@ -604,160 +567,23 @@ governorValidator gov =
|
|||
where
|
||||
-- The currency symbol of authority token.
|
||||
patSymbol :: Term s PCurrencySymbol
|
||||
patSymbol = phoistAcyclic $ pconstant $ authorityTokenSymbolFromGovernor gov
|
||||
patSymbol = pconstant $ authorityTokenSymbol as
|
||||
|
||||
-- The currency symbol of the proposal state token.
|
||||
ppstSymbol :: Term s PCurrencySymbol
|
||||
ppstSymbol =
|
||||
let AssetClass (sym, _) = proposalSTAssetClassFromGovernor gov
|
||||
in phoistAcyclic $ pconstant sym
|
||||
ppstSymbol = pconstant $ proposalSTSymbol as
|
||||
|
||||
-- The address of the proposal validator.
|
||||
pproposalValidatorAddress :: Term s PAddress
|
||||
pproposalValidatorAddress =
|
||||
let vh = proposalValidatorHashFromGovernor gov
|
||||
in phoistAcyclic $ pconstant $ validatorHashToAddress vh
|
||||
pconstant $
|
||||
validatorHashToAddress $
|
||||
proposalValidatoHash as
|
||||
|
||||
-- The currency symbol of the stake state token.
|
||||
psstSymbol :: Term s PCurrencySymbol
|
||||
psstSymbol =
|
||||
let sym = stakeSTSymbolFromGovernor gov
|
||||
in phoistAcyclic $ pconstant sym
|
||||
psstSymbol = pconstant $ stakeSTSymbol as
|
||||
|
||||
-- The currency symbol of the governor state token.
|
||||
pgstSymbol :: Term s PCurrencySymbol
|
||||
pgstSymbol =
|
||||
let sym = governorSTSymbolFromGovernor gov
|
||||
in phoistAcyclic $ pconstant sym
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | Get the 'CurrencySymbol' of GST.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
governorSTSymbolFromGovernor :: Governor -> CurrencySymbol
|
||||
governorSTSymbolFromGovernor gov = mintingPolicySymbol policy
|
||||
where
|
||||
policy :: MintingPolicy
|
||||
policy = mkMintingPolicy def $ governorPolicy gov
|
||||
|
||||
{- | Get the 'AssetClass' of GST.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
governorSTAssetClassFromGovernor :: Governor -> AssetClass
|
||||
governorSTAssetClassFromGovernor gov = AssetClass (symbol, "")
|
||||
where
|
||||
symbol :: CurrencySymbol
|
||||
symbol = governorSTSymbolFromGovernor gov
|
||||
|
||||
{- | Get the 'CurrencySymbol' of the proposal state token.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
proposalSTSymbolFromGovernor :: Governor -> CurrencySymbol
|
||||
proposalSTSymbolFromGovernor gov = symbol
|
||||
where
|
||||
gstAC = governorSTAssetClassFromGovernor gov
|
||||
policy = mkMintingPolicy def $ proposalPolicy gstAC
|
||||
symbol = mintingPolicySymbol policy
|
||||
|
||||
{- | Get the 'AssetClass' of the proposal state token.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
proposalSTAssetClassFromGovernor :: Governor -> AssetClass
|
||||
proposalSTAssetClassFromGovernor gov = AssetClass (symbol, "")
|
||||
where
|
||||
symbol = proposalSTSymbolFromGovernor gov
|
||||
|
||||
{- | Get the 'CurrencySymbol' of the stake token/
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
stakeSTSymbolFromGovernor :: Governor -> CurrencySymbol
|
||||
stakeSTSymbolFromGovernor gov = mintingPolicySymbol policy
|
||||
where
|
||||
policy = mkMintingPolicy def $ stakePolicy gov.gtClassRef
|
||||
|
||||
{- | Get the 'AssetClass' of the stake token.
|
||||
|
||||
Note that the token is tagged with the hash of the stake validator.
|
||||
See 'Agora.Stake.Script.stakePolicy'.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
stakeSTAssetClassFromGovernor :: Governor -> AssetClass
|
||||
stakeSTAssetClassFromGovernor gov = AssetClass (symbol, tokenName)
|
||||
where
|
||||
symbol = stakeSTSymbolFromGovernor gov
|
||||
|
||||
-- Tag with the address where the token is being sent to.
|
||||
tokenName = validatorHashToTokenName $ stakeValidatorHashFromGovernor gov
|
||||
|
||||
{- | Get the 'Stake' parameter, given the 'Governor' parameter.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
stakeFromGovernor :: Governor -> Stake
|
||||
stakeFromGovernor gov =
|
||||
Stake gov.gtClassRef $
|
||||
proposalSTAssetClassFromGovernor gov
|
||||
|
||||
{- | Get the hash of 'Agora.Stake.Script.stakePolicy'.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
stakeValidatorHashFromGovernor :: Governor -> ValidatorHash
|
||||
stakeValidatorHashFromGovernor gov = validatorHash validator
|
||||
where
|
||||
params = stakeFromGovernor gov
|
||||
validator = mkValidator def $ stakeValidator params
|
||||
|
||||
{- | Get the 'Proposal' parameter, given the 'Governor' parameter.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
proposalFromGovernor :: Governor -> Proposal
|
||||
proposalFromGovernor gov = Proposal gstAC sstAC mc
|
||||
where
|
||||
gstAC = governorSTAssetClassFromGovernor gov
|
||||
mc = gov.maximumCosigners
|
||||
sstAC = stakeSTAssetClassFromGovernor gov
|
||||
|
||||
{- | Get the hash of 'Agora.Proposal.proposalPolicy'.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
proposalValidatorHashFromGovernor :: Governor -> ValidatorHash
|
||||
proposalValidatorHashFromGovernor gov = validatorHash validator
|
||||
where
|
||||
params = proposalFromGovernor gov
|
||||
validator = mkValidator def $ proposalValidator params
|
||||
|
||||
{- | Get the hash of 'Agora.Proposal.proposalValidator'.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
governorValidatorHash :: Governor -> ValidatorHash
|
||||
governorValidatorHash gov = validatorHash validator
|
||||
where
|
||||
validator = mkValidator def $ governorValidator gov
|
||||
|
||||
{- | Get the 'AuthorityToken' parameter given the 'Governor' parameter.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
authorityTokenFromGovernor :: Governor -> AuthorityToken
|
||||
authorityTokenFromGovernor gov = AuthorityToken $ governorSTAssetClassFromGovernor gov
|
||||
|
||||
{- | Get the 'CurrencySymbol' of the authority token.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
authorityTokenSymbolFromGovernor :: Governor -> CurrencySymbol
|
||||
authorityTokenSymbolFromGovernor gov = mintingPolicySymbol policy
|
||||
where
|
||||
policy = mkMintingPolicy def $ authorityTokenPolicy params
|
||||
params = authorityTokenFromGovernor gov
|
||||
pgstSymbol = pconstant $ governorSTSymbol as
|
||||
|
|
|
|||
|
|
@ -1,15 +1,39 @@
|
|||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
{- FIXME: All of the following instances and
|
||||
types ought to belong in either plutarch or
|
||||
plutarch-extra.
|
||||
-}
|
||||
|
||||
module Agora.Plutarch.Orphans () where
|
||||
|
||||
import Plutarch.Api.V1 (PDatumHash)
|
||||
import Plutarch.Api.V1 (PDatumHash (..))
|
||||
import Plutarch.Builtin (PIsData (..))
|
||||
import Plutarch.Extra.TermCont (ptryFromC)
|
||||
import Plutarch.TryFrom (PTryFrom (..))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
|
||||
-- TODO: add checks
|
||||
instance PTryFrom PData (PAsData PDatumHash)
|
||||
newtype Flip f a b = Flip (f b a) deriving stock (Generic)
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PTryFrom PData (PAsData PDatumHash) where
|
||||
type PTryFromExcess PData (PAsData PDatumHash) = Flip Term PDatumHash
|
||||
ptryFrom' opq = runTermCont $ do
|
||||
(pfromData -> unwrapped, _) <- ptryFromC @(PAsData PByteString) opq
|
||||
|
||||
tcont $ \f ->
|
||||
pif
|
||||
-- Blake2b_256 hash: 256 bits/32 bytes.
|
||||
(plengthBS # unwrapped #== 32)
|
||||
(f ())
|
||||
(ptraceError "ptryFrom(PDatumHash): must be 32 bytes long")
|
||||
|
||||
pure (punsafeCoerce opq, pcon $ PDatumHash unwrapped)
|
||||
|
||||
-- | @since 0.2.0
|
||||
instance PTryFrom PData (PAsData PUnit)
|
||||
|
||||
-- | @since 0.2.0
|
||||
instance (PIsData a) => PIsData (PAsData a) where
|
||||
pfromDataImpl = pfromData
|
||||
pfromDataImpl = punsafeCoerce
|
||||
pdataImpl = pdataImpl . pfromData
|
||||
|
|
|
|||
|
|
@ -9,7 +9,8 @@ Proposal scripts encoding effects that operate on the system.
|
|||
-}
|
||||
module Agora.Proposal (
|
||||
-- * Haskell-land
|
||||
Proposal (..),
|
||||
|
||||
-- Proposal (..),
|
||||
ProposalDatum (..),
|
||||
ProposalRedeemer (..),
|
||||
ProposalStatus (..),
|
||||
|
|
@ -76,7 +77,6 @@ import Plutarch.Lift (
|
|||
import Plutarch.SafeMoney (PDiscrete (..))
|
||||
import Plutarch.Show (PShow (..))
|
||||
import PlutusLedgerApi.V1 (DatumHash, PubKeyHash, ValidatorHash)
|
||||
import PlutusLedgerApi.V1.Value (AssetClass)
|
||||
import PlutusTx qualified
|
||||
import PlutusTx.AssocMap qualified as AssocMap
|
||||
|
||||
|
|
@ -398,29 +398,6 @@ PlutusTx.makeIsDataIndexed
|
|||
, ('AdvanceProposal, 3)
|
||||
]
|
||||
|
||||
{- | Parameters that identify the Proposal validator script.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
data Proposal = Proposal
|
||||
{ governorSTAssetClass :: AssetClass
|
||||
, stakeSTAssetClass :: AssetClass
|
||||
, maximumCosigners :: Integer
|
||||
-- ^ Arbitrary limit for maximum amount of cosigners on a proposal.
|
||||
}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
Eq
|
||||
, -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.2.0
|
||||
SOP.Generic
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Plutarch-land
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,6 @@ import Agora.Proposal (
|
|||
PProposalDatum (PProposalDatum),
|
||||
PProposalRedeemer (..),
|
||||
PProposalVotes (PProposalVotes),
|
||||
Proposal (..),
|
||||
ProposalStatus (..),
|
||||
pretractVotes,
|
||||
pwinner',
|
||||
|
|
@ -26,6 +25,7 @@ import Agora.Proposal.Time (
|
|||
isLockingPeriod,
|
||||
isVotingPeriod,
|
||||
)
|
||||
import Agora.Scripts (AgoraScripts, governorSTSymbol, proposalSTSymbol, stakeSTAssetClass)
|
||||
import Agora.Stake (
|
||||
PProposalLock (..),
|
||||
PStakeDatum (..),
|
||||
|
|
@ -37,7 +37,6 @@ import Agora.Stake (
|
|||
pisVoter,
|
||||
)
|
||||
import Agora.Utils (
|
||||
getMintingPolicySymbol,
|
||||
mustFindDatum',
|
||||
pltAsData,
|
||||
)
|
||||
|
|
@ -75,7 +74,7 @@ import Plutarch.Extra.TermCont (
|
|||
)
|
||||
import Plutarch.SafeMoney (PDiscrete (..))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass, unAssetClass))
|
||||
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
|
||||
|
||||
{- | Policy for Proposals.
|
||||
|
||||
|
|
@ -152,8 +151,13 @@ proposalPolicy (AssetClass (govCs, govTn)) =
|
|||
|
||||
@since 0.1.0
|
||||
-}
|
||||
proposalValidator :: Proposal -> ClosedTerm PValidator
|
||||
proposalValidator proposal =
|
||||
proposalValidator ::
|
||||
-- | Lazy precompiled scripts.
|
||||
AgoraScripts ->
|
||||
-- | See 'Agora.Governor.Governor.maximumCosigners'.
|
||||
Integer ->
|
||||
ClosedTerm PValidator
|
||||
proposalValidator as maximumCosigners =
|
||||
plam $ \datum redeemer ctx' -> unTermCont $ do
|
||||
PScriptContext ctx' <- pmatchC ctx'
|
||||
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
|
||||
|
|
@ -185,8 +189,7 @@ proposalValidator proposal =
|
|||
|
||||
currentStatus <- pletC $ pfromData $ proposalF.status
|
||||
|
||||
let stCurrencySymbol =
|
||||
pconstant $ getMintingPolicySymbol (proposalPolicy proposal.governorSTAssetClass)
|
||||
let stCurrencySymbol = pconstant $ proposalSTSymbol as
|
||||
|
||||
signedBy <- pletC $ ptxSignedBy # txInfoF.signatories
|
||||
|
||||
|
|
@ -239,20 +242,6 @@ proposalValidator proposal =
|
|||
|
||||
onlyStatusChanged <-
|
||||
pletC $
|
||||
-- Only the status of proposals is updated.
|
||||
|
||||
-- Only the status of proposals is updated.
|
||||
|
||||
-- Only the status of proposals is updated.
|
||||
|
||||
-- Only the status of proposals is updated.
|
||||
|
||||
-- Only the status of proposals is updated.
|
||||
|
||||
-- Only the status of proposals is updated.
|
||||
|
||||
-- Only the status of proposals is updated.
|
||||
|
||||
-- Only the status of proposals is updated.
|
||||
proposalOut
|
||||
#== mkRecordConstr
|
||||
|
|
@ -271,7 +260,7 @@ proposalValidator proposal =
|
|||
|
||||
-- Find the stake inputs/outputs by SST.
|
||||
|
||||
let AssetClass (stakeSym, stakeTn) = proposal.stakeSTAssetClass
|
||||
let AssetClass (stakeSym, stakeTn) = stakeSTAssetClass as
|
||||
stakeSTAssetClass <-
|
||||
pletC $ passetClass # pconstant stakeSym # pconstant stakeTn
|
||||
|
||||
|
|
@ -421,7 +410,7 @@ proposalValidator proposal =
|
|||
# proposalF.cosigners
|
||||
|
||||
pguardC "Less cosigners than maximum limit" $
|
||||
plength # updatedSigs #< pconstant proposal.maximumCosigners
|
||||
plength # updatedSigs #< pconstant maximumCosigners
|
||||
|
||||
pguardC "Cosigners are unique" $
|
||||
pisUniq' # updatedSigs
|
||||
|
|
@ -456,6 +445,7 @@ proposalValidator proposal =
|
|||
pguardC "Proposal time should be wthin the voting period" $
|
||||
isVotingPeriod # proposalF.timingConfig
|
||||
# proposalF.startingTime
|
||||
#$ pfromJust
|
||||
# currentTime
|
||||
|
||||
-- Ensure the transaction is voting to a valid 'ResultTag'(outcome).
|
||||
|
|
@ -610,8 +600,9 @@ proposalValidator proposal =
|
|||
----------------------------------------------------------------------
|
||||
|
||||
PAdvanceProposal _ ->
|
||||
let fromDraft = withMultipleStakes $ \totalStakedAmount sortedStakeOwners ->
|
||||
pmatchC (isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime) >>= \case
|
||||
let currentTime' = pfromJust # currentTime
|
||||
fromDraft = withMultipleStakes $ \totalStakedAmount sortedStakeOwners ->
|
||||
pmatchC (isDraftPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime') >>= \case
|
||||
PTrue -> do
|
||||
pguardC "More cosigns than minimum amount" $
|
||||
punsafeCoerce (pfromData thresholdsF.vote) #< totalStakedAmount
|
||||
|
|
@ -636,9 +627,9 @@ proposalValidator proposal =
|
|||
"Only status changes in the output proposal"
|
||||
onlyStatusChanged
|
||||
|
||||
inVotingPeriod <- pletC $ isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
|
||||
inLockedPeriod <- pletC $ isLockingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
|
||||
inExecutionPeriod <- pletC $ isExecutionPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime
|
||||
inVotingPeriod <- pletC $ isVotingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
|
||||
inLockedPeriod <- pletC $ isLockingPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
|
||||
inExecutionPeriod <- pletC $ isExecutionPeriod # proposalF.timingConfig # proposalF.startingTime # currentTime'
|
||||
|
||||
proposalStatus <- pletC $ pto $ pfromData proposalF.status
|
||||
|
||||
|
|
@ -659,10 +650,7 @@ proposalValidator proposal =
|
|||
pguardC "Cannot advance ahead of time" notTooEarly
|
||||
pguardC "Finished proposals cannot be advanced" $ pnot # isFinished
|
||||
|
||||
let gstSymbol =
|
||||
pconstant $
|
||||
fst $
|
||||
unAssetClass proposal.governorSTAssetClass
|
||||
let gstSymbol = pconstant $ governorSTSymbol as
|
||||
|
||||
gstMoved <-
|
||||
pletC $
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@ module Agora.Proposal.Time (
|
|||
pisMaxTimeRangeWidthValid,
|
||||
) where
|
||||
|
||||
import Control.Composition ((.*))
|
||||
import Generics.SOP qualified as SOP
|
||||
import Plutarch.Api.V1 (
|
||||
PExtended (PFinite),
|
||||
|
|
@ -43,14 +44,16 @@ import Plutarch.DataRepr (
|
|||
DerivePConstantViaData (..),
|
||||
PDataFields,
|
||||
)
|
||||
import Plutarch.Extra.Field (pletAllC)
|
||||
import Plutarch.Extra.TermCont (pguardC, pmatchC)
|
||||
import Plutarch.Extra.Applicative (PApply (pliftA2))
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing)
|
||||
import Plutarch.Extra.TermCont (pmatchC)
|
||||
import Plutarch.Lift (
|
||||
DerivePConstantViaNewtype (..),
|
||||
PConstantDecl,
|
||||
PUnsafeLiftDecl (..),
|
||||
)
|
||||
import PlutusLedgerApi.V1.Time (POSIXTime)
|
||||
import PlutusLedgerApi.V1 (POSIXTime)
|
||||
import PlutusTx qualified
|
||||
import Prelude
|
||||
|
||||
|
|
@ -344,23 +347,33 @@ pisMaxTimeRangeWidthValid =
|
|||
|
||||
@since 0.1.0
|
||||
-}
|
||||
createProposalStartingTime :: forall (s :: S). Term s (PMaxTimeRangeWidth :--> PPOSIXTimeRange :--> PProposalStartingTime)
|
||||
createProposalStartingTime ::
|
||||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
( PMaxTimeRangeWidth
|
||||
:--> PPOSIXTimeRange
|
||||
:--> PMaybe PProposalStartingTime
|
||||
)
|
||||
createProposalStartingTime = phoistAcyclic $
|
||||
plam $ \(pto -> maxDuration) iv -> unTermCont $ do
|
||||
currentTimeF <- pmatchC $ currentProposalTime # iv
|
||||
plam $ \(pto -> maxDuration) iv ->
|
||||
let ct = currentProposalTime # iv
|
||||
|
||||
-- Use the middle of the current time range as the starting time.
|
||||
let duration = currentTimeF.upperBound - currentTimeF.lowerBound
|
||||
f :: Term _ (PProposalTime :--> PMaybe PProposalStartingTime)
|
||||
f = plam $
|
||||
flip pmatch $ \(PProposalTime lb ub) ->
|
||||
let duration = ub - lb
|
||||
|
||||
startingTime =
|
||||
pdiv
|
||||
# (currentTimeF.lowerBound + currentTimeF.upperBound)
|
||||
# 2
|
||||
|
||||
pguardC "createProposalStartingTime: given time range should be tight enough" $
|
||||
duration #<= maxDuration
|
||||
|
||||
pure $ pcon $ PProposalStartingTime startingTime
|
||||
startingTime = pdiv # (lb + ub) # 2
|
||||
in pif
|
||||
(duration #<= maxDuration)
|
||||
(pjust #$ pcon $ PProposalStartingTime startingTime)
|
||||
( ptrace
|
||||
"createProposalStartingTime: given time range should be tight enough"
|
||||
pnothing
|
||||
)
|
||||
in -- TODO: PMonad when?
|
||||
pmaybe # pnothing # f # ct
|
||||
|
||||
{- | Get the current proposal time, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
|
||||
|
||||
|
|
@ -369,33 +382,30 @@ createProposalStartingTime = phoistAcyclic $
|
|||
|
||||
@since 0.1.0
|
||||
-}
|
||||
currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PProposalTime)
|
||||
currentProposalTime :: forall (s :: S). Term s (PPOSIXTimeRange :--> PMaybe PProposalTime)
|
||||
currentProposalTime = phoistAcyclic $
|
||||
plam $ \iv -> unTermCont $ do
|
||||
PInterval iv' <- pmatchC iv
|
||||
ivf <- pletAllC iv'
|
||||
PLowerBound lb <- pmatchC ivf.from
|
||||
PUpperBound ub <- pmatchC ivf.to
|
||||
lbf <- pletAllC lb
|
||||
ubf <- pletAllC ub
|
||||
pure $
|
||||
pcon $
|
||||
PProposalTime
|
||||
{ lowerBound =
|
||||
pmatch
|
||||
lbf._0
|
||||
( \case
|
||||
PFinite ((pfield @"_0" #) -> d) -> d
|
||||
_ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time."
|
||||
|
||||
let getBound = phoistAcyclic $
|
||||
plam $
|
||||
flip pletAll $ \f ->
|
||||
pif
|
||||
f._1
|
||||
( pmatch f._0 $ \case
|
||||
PFinite (pfromData . (pfield @"_0" #) -> d) -> pjust # d
|
||||
_ -> ptrace "currentProposalTime: time range should be bounded" pnothing
|
||||
)
|
||||
, upperBound =
|
||||
pmatch
|
||||
ubf._0
|
||||
( \case
|
||||
PFinite ((pfield @"_0" #) -> d) -> d
|
||||
_ -> ptraceError "currentProposalTime: Can't get fully-bounded proposal time."
|
||||
)
|
||||
}
|
||||
(ptrace "currentProposalTime: time range should be inclusive" pnothing)
|
||||
|
||||
lowerBound = getBound # lb
|
||||
upperBound = getBound # ub
|
||||
|
||||
mkTime = phoistAcyclic $ plam $ pcon .* PProposalTime
|
||||
pure $ pliftA2 # mkTime # lowerBound # upperBound
|
||||
|
||||
{- | Check if 'PProposalTime' is within two 'PPOSIXTime'. Inclusive.
|
||||
|
||||
|
|
|
|||
138
agora/Agora/Scripts.hs
Normal file
138
agora/Agora/Scripts.hs
Normal file
|
|
@ -0,0 +1,138 @@
|
|||
{- | Module : Agora.Scripts
|
||||
Maintainer : connor@mlabs.city
|
||||
Description: Precompiled core scripts and utilities
|
||||
|
||||
Precompiled core scripts and utilities
|
||||
-}
|
||||
module Agora.Scripts (
|
||||
AgoraScripts (..),
|
||||
governorSTSymbol,
|
||||
governorSTAssetClass,
|
||||
governorValidatorHash,
|
||||
proposalSTSymbol,
|
||||
proposalSTAssetClass,
|
||||
proposalValidatoHash,
|
||||
stakeSTSymbol,
|
||||
stakeSTAssetClass,
|
||||
stakeValidatorHash,
|
||||
authorityTokenSymbol,
|
||||
treasuryValidatorHash,
|
||||
) where
|
||||
|
||||
import Agora.Governor (GovernorDatum, GovernorRedeemer)
|
||||
import Agora.Proposal (ProposalDatum, ProposalRedeemer)
|
||||
import Agora.Stake (StakeDatum, StakeRedeemer)
|
||||
import Agora.Treasury (TreasuryRedeemer)
|
||||
import Agora.Utils (CompiledMintingPolicy (..), CompiledValidator (..), validatorHashToTokenName)
|
||||
import Plutarch.Api.V1 (mintingPolicySymbol, validatorHash)
|
||||
import PlutusLedgerApi.V1 (CurrencySymbol)
|
||||
import PlutusLedgerApi.V1.Scripts (ValidatorHash)
|
||||
import PlutusLedgerApi.V1.Value (AssetClass (..))
|
||||
|
||||
{- | Precompiled core scripts.
|
||||
|
||||
Including:
|
||||
|
||||
- Governor policy
|
||||
- Governor validator
|
||||
- Proposal policy
|
||||
- Proposal validator
|
||||
- Stake policy
|
||||
- Stake validator
|
||||
- Treasury validator
|
||||
- Authority token policy
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
data AgoraScripts = AgoraScripts
|
||||
{ compiledGovernorPolicy :: CompiledMintingPolicy ()
|
||||
, compiledGovernorValidator :: CompiledValidator GovernorDatum GovernorRedeemer
|
||||
, compiledStakePolicy :: CompiledMintingPolicy ()
|
||||
, compiledStakeValidator :: CompiledValidator StakeDatum StakeRedeemer
|
||||
, compiledProposalPolicy :: CompiledMintingPolicy ()
|
||||
, compiledProposalValidator :: CompiledValidator ProposalDatum ProposalRedeemer
|
||||
, compiledTreasuryValidator :: CompiledValidator () TreasuryRedeemer
|
||||
, compiledAuthorityTokenPolicy :: CompiledMintingPolicy ()
|
||||
}
|
||||
|
||||
{- | Get the currency symbol of the governor state token.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
governorSTSymbol :: AgoraScripts -> CurrencySymbol
|
||||
governorSTSymbol = mintingPolicySymbol . getCompiledMintingPolicy . compiledGovernorPolicy
|
||||
|
||||
{- | Get the asset class of the governor state token.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
governorSTAssetClass :: AgoraScripts -> AssetClass
|
||||
governorSTAssetClass as = AssetClass (governorSTSymbol as, "")
|
||||
|
||||
{- | Get the script hash of the governor validator.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
governorValidatorHash :: AgoraScripts -> ValidatorHash
|
||||
governorValidatorHash = validatorHash . getCompiledValidator . compiledGovernorValidator
|
||||
|
||||
{- | Get the currency symbol of the propsoal state token.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
proposalSTSymbol :: AgoraScripts -> CurrencySymbol
|
||||
proposalSTSymbol as = mintingPolicySymbol $ getCompiledMintingPolicy as.compiledProposalPolicy
|
||||
|
||||
{- | Get the asset class of the governor state token.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
proposalSTAssetClass :: AgoraScripts -> AssetClass
|
||||
proposalSTAssetClass as = AssetClass (proposalSTSymbol as, "")
|
||||
|
||||
{- | Get the script hash of the proposal validator.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
proposalValidatoHash :: AgoraScripts -> ValidatorHash
|
||||
proposalValidatoHash = validatorHash . getCompiledValidator . compiledProposalValidator
|
||||
|
||||
{- | Get the script hash of the governor validator.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
stakeSTSymbol :: AgoraScripts -> CurrencySymbol
|
||||
stakeSTSymbol = mintingPolicySymbol . getCompiledMintingPolicy . compiledStakePolicy
|
||||
|
||||
{- | Get the asset class of the stake state token.
|
||||
|
||||
Note that this token is tagged with the hash of the stake validator.
|
||||
See 'Agora.Stake.Script.stakePolicy'.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
stakeSTAssetClass :: AgoraScripts -> AssetClass
|
||||
stakeSTAssetClass as =
|
||||
let tn = validatorHashToTokenName $ stakeValidatorHash as
|
||||
in AssetClass (stakeSTSymbol as, tn)
|
||||
|
||||
{- | Get the script hash of the stake validator.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
stakeValidatorHash :: AgoraScripts -> ValidatorHash
|
||||
stakeValidatorHash = validatorHash . getCompiledValidator . compiledStakeValidator
|
||||
|
||||
{- | Get the currency symbol of the authority token.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
authorityTokenSymbol :: AgoraScripts -> CurrencySymbol
|
||||
authorityTokenSymbol = mintingPolicySymbol . getCompiledMintingPolicy . compiledAuthorityTokenPolicy
|
||||
|
||||
{- | Get the script hash of the treasury validator.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
treasuryValidatorHash :: AgoraScripts -> ValidatorHash
|
||||
treasuryValidatorHash = validatorHash . getCompiledValidator . compiledTreasuryValidator
|
||||
|
|
@ -11,7 +11,6 @@ module Agora.Stake (
|
|||
-- * Haskell-land
|
||||
StakeDatum (..),
|
||||
StakeRedeemer (..),
|
||||
Stake (..),
|
||||
ProposalLock (..),
|
||||
|
||||
-- * Plutarch-land
|
||||
|
|
@ -54,26 +53,11 @@ import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
|
|||
import Plutarch.SafeMoney (PDiscrete)
|
||||
import Plutarch.Show (PShow (..))
|
||||
import PlutusLedgerApi.V1 (PubKeyHash)
|
||||
import PlutusLedgerApi.V1.Value (AssetClass)
|
||||
import PlutusTx qualified
|
||||
import Prelude hiding (Num (..))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | Parameters for creating Stake scripts.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
data Stake = Stake
|
||||
{ gtClassRef :: Tagged GTTag AssetClass
|
||||
-- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code.
|
||||
, proposalSTClass :: AssetClass
|
||||
}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
|
||||
{- | Locks that are stored in the stake datums for various purposes.
|
||||
|
||||
NOTE: Due to retracting votes always being possible,
|
||||
|
|
|
|||
|
|
@ -8,20 +8,17 @@ Plutus Scripts for Stakes.
|
|||
module Agora.Stake.Scripts (stakePolicy, stakeValidator) where
|
||||
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Scripts (AgoraScripts, proposalSTAssetClass, stakeSTSymbol)
|
||||
import Agora.Stake (
|
||||
PStakeDatum (PStakeDatum),
|
||||
PStakeRedeemer (..),
|
||||
Stake (gtClassRef, proposalSTClass),
|
||||
StakeRedeemer (WitnessStake),
|
||||
pstakeLocked,
|
||||
)
|
||||
import Agora.Utils (
|
||||
mustFindDatum',
|
||||
pdjust,
|
||||
pdnothing,
|
||||
pvalidatorHashToTokenName,
|
||||
)
|
||||
import Data.Default (def)
|
||||
import Data.Function (on)
|
||||
import Data.Tagged (Tagged (..), untag)
|
||||
import Plutarch.Api.V1 (
|
||||
|
|
@ -35,18 +32,15 @@ import Plutarch.Api.V1 (
|
|||
PTxOut,
|
||||
PValidator,
|
||||
PValue,
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
)
|
||||
import Plutarch.Api.V1.AssetClass (passetClass, passetClassValueOf, pvalueOf)
|
||||
import Plutarch.Api.V1.ScriptContext (pfindTxInByTxOutRef, ptxSignedBy, pvalueSpent)
|
||||
import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (pgeqByClass', pgeqBySymbol, psymbolValueOf)
|
||||
import Plutarch.Extra.Field (pletAllC)
|
||||
import Plutarch.Extra.List (pmapMaybe, pmsortBy)
|
||||
import Plutarch.Extra.Maybe (passertPJust, pfromDJust)
|
||||
import Plutarch.Extra.Maybe (passertPJust, pdjust, pdnothing, pfromDJust, pmaybeData)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
|
||||
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
import Plutarch.Numeric.Additive (AdditiveMonoid (zero), AdditiveSemigroup ((+)))
|
||||
import Plutarch.SafeMoney (
|
||||
pdiscreteValue',
|
||||
|
|
@ -223,8 +217,13 @@ stakePolicy gtClassRef =
|
|||
|
||||
@since 0.1.0
|
||||
-}
|
||||
stakeValidator :: Stake -> ClosedTerm PValidator
|
||||
stakeValidator stake =
|
||||
stakeValidator ::
|
||||
-- | Lazy precompiled scripts.
|
||||
AgoraScripts ->
|
||||
-- | See 'Agora.Governor.Governor.gtClassRef'.
|
||||
Tagged GTTag AssetClass ->
|
||||
ClosedTerm PValidator
|
||||
stakeValidator as gtClassRef =
|
||||
plam $ \datum redeemer ctx' -> unTermCont $ do
|
||||
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
|
||||
txInfo <- pletC $ pfromData ctx.txInfo
|
||||
|
|
@ -240,9 +239,7 @@ stakeValidator stake =
|
|||
|
||||
stakeRedeemer <- fst <$> ptryFromC redeemer
|
||||
|
||||
-- TODO: Use PTryFrom
|
||||
let stakeDatum' :: Term _ PStakeDatum
|
||||
stakeDatum' = pfromData $ punsafeCoerce datum
|
||||
stakeDatum' <- pfromData . fst <$> ptryFromC datum
|
||||
stakeDatum <- pletAllC $ pto stakeDatum'
|
||||
|
||||
PSpending txOutRef <- pmatchC $ pfromData ctx.purpose
|
||||
|
|
@ -258,17 +255,14 @@ stakeValidator stake =
|
|||
signedBy <- pletC $ ptxSignedBy # txInfoF.signatories
|
||||
|
||||
ownerSignsTransaction <- pletC $ signedBy # stakeDatum.owner
|
||||
delegateSignsTransaction <-
|
||||
pletC $ pconstant False
|
||||
-- pmaybeData # pconstant False
|
||||
-- # plam (signedBy #)
|
||||
-- # stakeDatum.delegatedTo
|
||||
|
||||
stCurrencySymbol <-
|
||||
delegateSignsTransaction <-
|
||||
pletC $
|
||||
pconstant $
|
||||
mintingPolicySymbol $
|
||||
mkMintingPolicy def (stakePolicy stake.gtClassRef)
|
||||
pmaybeData # pconstant False
|
||||
# signedBy
|
||||
# stakeDatum.delegatedTo
|
||||
|
||||
stCurrencySymbol <- pletC $ pconstant $ stakeSTSymbol as
|
||||
mintedST <- pletC $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
|
||||
valueSpent <- pletC $ pvalueSpent # txInfoF.inputs
|
||||
spentST <- pletC $ psymbolValueOf # stCurrencySymbol #$ valueSpent
|
||||
|
|
@ -294,7 +288,7 @@ stakeValidator stake =
|
|||
-- Handle redeemers that require own stake output.
|
||||
|
||||
_ -> unTermCont $ do
|
||||
let AssetClass (propCs, propTn) = stake.proposalSTClass
|
||||
let AssetClass (propCs, propTn) = proposalSTAssetClass as
|
||||
proposalSTClass = passetClass # pconstant propCs # pconstant propTn
|
||||
spentProposalST = passetClassValueOf # valueSpent # proposalSTClass
|
||||
|
||||
|
|
@ -496,7 +490,7 @@ stakeValidator stake =
|
|||
datumCorrect = stakeOut #== expectedDatum
|
||||
|
||||
let valueDelta :: Term _ (PValue _ 'Positive)
|
||||
valueDelta = pdiscreteValue' stake.gtClassRef # delta
|
||||
valueDelta = pdiscreteValue' gtClassRef # delta
|
||||
|
||||
expectedValue =
|
||||
resolvedF.value <> valueDelta
|
||||
|
|
@ -507,7 +501,7 @@ stakeValidator stake =
|
|||
[ pgeqByClass' (AssetClass ("", ""))
|
||||
# ownOutputValue
|
||||
# expectedValue
|
||||
, pgeqByClass' (untag stake.gtClassRef)
|
||||
, pgeqByClass' (untag gtClassRef)
|
||||
# ownOutputValue
|
||||
# expectedValue
|
||||
, pgeqBySymbol
|
||||
|
|
|
|||
|
|
@ -9,57 +9,35 @@ Description: Plutarch utility functions that should be upstreamed or don't belon
|
|||
Plutarch utility functions that should be upstreamed or don't belong anywhere else.
|
||||
-}
|
||||
module Agora.Utils (
|
||||
scriptHashFromAddress,
|
||||
findOutputsToAddress,
|
||||
findTxOutDatum,
|
||||
validatorHashToTokenName,
|
||||
pvalidatorHashToTokenName,
|
||||
getMintingPolicySymbol,
|
||||
hasOnlyOneTokenOfCurrencySymbol,
|
||||
mustFindDatum',
|
||||
mustBePJust,
|
||||
mustBePDJust,
|
||||
validatorHashToAddress,
|
||||
isScriptAddress,
|
||||
isPubKey,
|
||||
pltAsData,
|
||||
pon,
|
||||
withBuiltinPairAsData,
|
||||
pmaybeData,
|
||||
pmaybe,
|
||||
pdjust,
|
||||
pdnothing,
|
||||
CompiledValidator (..),
|
||||
CompiledMintingPolicy (..),
|
||||
CompiledEffect (..),
|
||||
) where
|
||||
|
||||
import Data.Default (Default (def))
|
||||
import Plutarch.Api.V1 (
|
||||
AmountGuarantees,
|
||||
KeyGuarantees,
|
||||
PAddress,
|
||||
PCredential (PScriptCredential),
|
||||
PCurrencySymbol,
|
||||
PDatum,
|
||||
PDatumHash,
|
||||
PMaybeData (PDJust, PDNothing),
|
||||
PMintingPolicy,
|
||||
PMaybeData,
|
||||
PTokenName (PTokenName),
|
||||
PTuple,
|
||||
PTxOut,
|
||||
PValidatorHash,
|
||||
PValue,
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
)
|
||||
import Plutarch.Api.V1.ScriptContext (pfindDatum)
|
||||
import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (psymbolValueOf)
|
||||
import Plutarch.Builtin (pforgetData)
|
||||
import Plutarch.Extra.List (plookupTuple)
|
||||
import Plutarch.Extra.TermCont (pletC, pmatchC, ptryFromC)
|
||||
import Plutarch.Extra.Maybe (passertPDJust, passertPJust)
|
||||
import Plutarch.Extra.TermCont (ptryFromC)
|
||||
import PlutusLedgerApi.V1 (
|
||||
Address (..),
|
||||
Credential (..),
|
||||
CurrencySymbol,
|
||||
MintingPolicy,
|
||||
TokenName (..),
|
||||
Validator,
|
||||
ValidatorHash (..),
|
||||
)
|
||||
|
||||
|
|
@ -67,60 +45,6 @@ import PlutusLedgerApi.V1 (
|
|||
All of these functions are quite inefficient.
|
||||
-}
|
||||
|
||||
{- | Get script hash from an Address.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
scriptHashFromAddress :: Term s (PAddress :--> PMaybe PValidatorHash)
|
||||
scriptHashFromAddress = phoistAcyclic $
|
||||
plam $ \addr ->
|
||||
pmatch (pfromData $ pfield @"credential" # addr) $ \case
|
||||
PScriptCredential ((pfield @"_0" #) -> h) -> pcon $ PJust h
|
||||
_ -> pcon PNothing
|
||||
|
||||
{- | Return true if the given address is a script address.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
isScriptAddress :: Term s (PAddress :--> PBool)
|
||||
isScriptAddress = phoistAcyclic $
|
||||
plam $ \addr -> pnot #$ isPubKey #$ pfromData $ pfield @"credential" # addr
|
||||
|
||||
{- | Return true if the given credential is a pub-key-hash.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
isPubKey :: Term s (PCredential :--> PBool)
|
||||
isPubKey = phoistAcyclic $
|
||||
plam $ \cred ->
|
||||
pmatch cred $ \case
|
||||
PScriptCredential _ -> pconstant False
|
||||
_ -> pconstant True
|
||||
|
||||
{- | Find all TxOuts sent to an Address
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
findOutputsToAddress :: Term s (PBuiltinList (PAsData PTxOut) :--> PAddress :--> PBuiltinList (PAsData PTxOut))
|
||||
findOutputsToAddress = phoistAcyclic $
|
||||
plam $ \outputs address' -> unTermCont $ do
|
||||
address <- pletC $ pdata address'
|
||||
pure $
|
||||
pfilter # plam (\(pfromData -> txOut) -> pfield @"address" # txOut #== address)
|
||||
# outputs
|
||||
|
||||
{- | 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 = phoistAcyclic $
|
||||
plam $ \datums out -> unTermCont $ do
|
||||
datumHash' <- pmatchC $ pfromData $ pfield @"datumHash" # out
|
||||
pure $ case datumHash' of
|
||||
PDJust ((pfield @"_0" #) -> datumHash) -> pfindDatum # datumHash # datums
|
||||
_ -> pcon PNothing
|
||||
|
||||
{- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging
|
||||
tokens for extra safety.
|
||||
|
||||
|
|
@ -136,25 +60,6 @@ validatorHashToTokenName (ValidatorHash hash) = TokenName hash
|
|||
pvalidatorHashToTokenName :: forall (s :: S). Term s PValidatorHash -> Term s PTokenName
|
||||
pvalidatorHashToTokenName vh = pcon (PTokenName (pto vh))
|
||||
|
||||
{- | Get the CurrencySymbol of a PMintingPolicy.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
getMintingPolicySymbol :: ClosedTerm PMintingPolicy -> CurrencySymbol
|
||||
getMintingPolicySymbol v = mintingPolicySymbol $ mkMintingPolicy def v
|
||||
|
||||
{- | The entire value only contains one token of the given currency symbol.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
hasOnlyOneTokenOfCurrencySymbol ::
|
||||
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
|
||||
Term s (PCurrencySymbol :--> PValue keys amounts :--> PBool)
|
||||
hasOnlyOneTokenOfCurrencySymbol = phoistAcyclic $
|
||||
plam $ \cs vs -> P.do
|
||||
psymbolValueOf # cs # vs #== 1
|
||||
#&& (plength #$ pto $ pto $ pto vs) #== 1
|
||||
|
||||
{- | Find datum given a maybe datum hash
|
||||
|
||||
@since 0.1.0
|
||||
|
|
@ -171,33 +76,11 @@ mustFindDatum' ::
|
|||
)
|
||||
mustFindDatum' = phoistAcyclic $
|
||||
plam $ \mdh datums -> unTermCont $ do
|
||||
let dh = mustBePDJust # "Given TxOut dones't have a datum" # mdh
|
||||
dt = mustBePJust # "Datum not found in the transaction" #$ plookupTuple # dh # datums
|
||||
let dh = passertPDJust # "Given TxOut dones't have a datum" # mdh
|
||||
dt = passertPJust # "Datum not found in the transaction" #$ plookupTuple # dh # datums
|
||||
(d, _) <- ptryFromC $ pforgetData $ pdata dt
|
||||
pure d
|
||||
|
||||
{- | Extract the value stored in a PMaybe container.
|
||||
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 = phoistAcyclic $
|
||||
plam $ \emsg mv' -> pmatch mv' $ \case
|
||||
PJust v -> v
|
||||
_ -> ptraceError emsg
|
||||
|
||||
{- | Extract the value stored in a PMaybeData container.
|
||||
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 = phoistAcyclic $
|
||||
plam $ \emsg mv' -> pmatch mv' $ \case
|
||||
PDJust ((pfield @"_0" #) -> v) -> v
|
||||
_ -> ptraceError emsg
|
||||
|
||||
{- | Create an 'Address' from a given 'ValidatorHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'.
|
||||
|
||||
@since 0.1.0
|
||||
|
|
@ -217,19 +100,6 @@ pltAsData = phoistAcyclic $
|
|||
plam $
|
||||
\(pfromData -> l) (pfromData -> r) -> l #< r
|
||||
|
||||
{- | Plutarch level 'Data.Function.on'.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
pon ::
|
||||
forall (a :: PType) (b :: PType) (c :: PType) (s :: S).
|
||||
Term s ((b :--> b :--> c) :--> (a :--> b) :--> a :--> a :--> c)
|
||||
pon = phoistAcyclic $
|
||||
plam $ \f g x y ->
|
||||
let a = g # x
|
||||
b = g # y
|
||||
in f # a # b
|
||||
|
||||
{- | Extract data stored in a 'PBuiltinPair' and call a function to process it.
|
||||
|
||||
@since 0.2.0
|
||||
|
|
@ -247,53 +117,26 @@ withBuiltinPairAsData f p =
|
|||
b = pfromData $ psndBuiltin # p
|
||||
in f a b
|
||||
|
||||
{- | Plutarch version of 'Data.Maybe.maybe'. Take a default value and a function
|
||||
@f@. If the given 'PMaybe' value is @'PJust' x@, apply the function @f@ to
|
||||
@x@, otherewise the default value will be retuned.
|
||||
{- | Type-safe wrapper for compiled plutus validator.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
pmaybe ::
|
||||
forall (a :: PType) (b :: PType) (s :: S).
|
||||
Term s (b :--> (a :--> b) :--> PMaybe a :--> b)
|
||||
pmaybe = phoistAcyclic $
|
||||
plam $ \n f m -> pmatch m $ \case
|
||||
PJust x -> f # x
|
||||
_ -> n
|
||||
newtype CompiledValidator (datum :: Type) (redeemer :: Type) = CompiledValidator
|
||||
{ getCompiledValidator :: Validator
|
||||
}
|
||||
|
||||
{- | Special version of 'pmaybe' that works with 'PMaybedata'.
|
||||
{- | Type-safe wrapper for compiled plutus miting policy.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
pmaybeData ::
|
||||
forall (a :: PType) (b :: PType) (s :: S).
|
||||
PIsData a =>
|
||||
Term s (b :--> (a :--> b) :--> PMaybeData a :--> b)
|
||||
pmaybeData = phoistAcyclic $
|
||||
plam $ \n f m -> pmatch m $ \case
|
||||
PDJust ((pfield @"_0" #) -> x) -> f # x
|
||||
_ -> n
|
||||
newtype CompiledMintingPolicy (redeemer :: Type) = CompiledMintingPolicy
|
||||
{ getCompiledMintingPolicy :: MintingPolicy
|
||||
}
|
||||
|
||||
{- Construct a 'PDJust' value.
|
||||
{- | Type-safe wrapper for compiled plutus effect.
|
||||
|
||||
@since 0.2.0
|
||||
@since 0.2.0
|
||||
-}
|
||||
pdjust ::
|
||||
forall (a :: PType) (s :: S).
|
||||
(PIsData a) =>
|
||||
Term s (a :--> PMaybeData a)
|
||||
pdjust = phoistAcyclic $
|
||||
plam $ \x ->
|
||||
pcon $
|
||||
PDJust $
|
||||
pdcons @"_0" # pdata x #$ pdnil
|
||||
|
||||
{- Construct a 'PDNothing' value.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
pdnothing ::
|
||||
forall (a :: PType) (s :: S).
|
||||
(PIsData a) =>
|
||||
Term s (PMaybeData a)
|
||||
pdnothing = phoistAcyclic $ pcon $ PDNothing pdnil
|
||||
newtype CompiledEffect (datum :: Type) = CompiledEffect
|
||||
{ getCompiledEffect :: Validator
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue