fix compilation errors
This commit is contained in:
Hongrui Fang
parent
14aacf206f
commit
f248dbab49
36 changed files with 1325 additions and 1271 deletions
|
|
@ -8,7 +8,6 @@ import Data.ByteString.Short qualified as SBS
|
|||
import Data.Csv (DefaultOrdered, ToNamedRecord, header, headerOrder, namedRecord, toNamedRecord, (.=))
|
||||
import Data.List (intercalate)
|
||||
import Data.Text (Text, pack)
|
||||
import GHC.Generics (Generic)
|
||||
import Plutarch.Evaluate (evalScript)
|
||||
import PlutusLedgerApi.V1 (
|
||||
ExBudget (ExBudget),
|
||||
|
|
|
|||
|
|
@ -107,7 +107,12 @@ agoraScripts params =
|
|||
|
||||
governorSTAssetClass :: AssetClass
|
||||
governorSTAssetClass =
|
||||
Value.assetClass (mintingPolicySymbol $ mkMintingPolicy $ governorPolicy governor) ""
|
||||
Value.assetClass
|
||||
( mintingPolicySymbol $
|
||||
mkMintingPolicy def $
|
||||
governorPolicy governor
|
||||
)
|
||||
""
|
||||
|
||||
proposal :: Proposal
|
||||
proposal = proposalFromGovernor governor
|
||||
|
|
|
|||
|
|
@ -114,8 +114,10 @@ genInput = do
|
|||
val <- genSingletonValue
|
||||
return $
|
||||
input $
|
||||
credential cred
|
||||
. withValue val
|
||||
mconcat
|
||||
[ credential cred
|
||||
, withValue val
|
||||
]
|
||||
|
||||
genOutput :: Builder a => Gen a
|
||||
genOutput = do
|
||||
|
|
@ -123,8 +125,10 @@ genOutput = do
|
|||
val <- genSingletonValue
|
||||
return $
|
||||
output $
|
||||
credential cred
|
||||
. withValue val
|
||||
mconcat
|
||||
[ credential cred
|
||||
, withValue val
|
||||
]
|
||||
|
||||
genOutRef :: Gen TxOutRef
|
||||
genOutRef = do
|
||||
|
|
|
|||
|
|
@ -157,7 +157,13 @@ governorMintingProperty =
|
|||
-}
|
||||
gst = assetClassValue govAssetClass 1
|
||||
mintAmount x = mint . mconcat $ replicate x gst
|
||||
outputToGov = output $ script govValidatorHash . withValue gst . withDatum govDatum
|
||||
outputToGov =
|
||||
output $
|
||||
mconcat
|
||||
[ script govValidatorHash
|
||||
, withValue gst
|
||||
, withDatum govDatum
|
||||
]
|
||||
referencedInput = input $ withOutRef gstUTXORef
|
||||
|
||||
govDatum :: GovernorDatum
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ import Test.Util (datumPair, toDatumHash)
|
|||
|
||||
-- | The effect validator instance.
|
||||
effectValidator :: Validator
|
||||
effectValidator = mkValidator $ mutateGovernorValidator governor
|
||||
effectValidator = mkValidator def $ mutateGovernorValidator governor
|
||||
|
||||
-- | The hash of the validator instance.
|
||||
effectValidatorHash :: ValidatorHash
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@ import Agora.Effect.TreasuryWithdrawal (
|
|||
TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
|
||||
treasuryWithdrawalValidator,
|
||||
)
|
||||
import Data.Default (def)
|
||||
import Plutarch.Api.V1 (mkValidator, validatorHash)
|
||||
import PlutusLedgerApi.V1 (
|
||||
Address (Address),
|
||||
|
|
@ -147,7 +148,7 @@ buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs _) = f <$> xs
|
|||
|
||||
-- | Effect validator instance.
|
||||
validator :: Validator
|
||||
validator = mkValidator $ treasuryWithdrawalValidator currSymbol
|
||||
validator = mkValidator def $ treasuryWithdrawalValidator currSymbol
|
||||
|
||||
-- | 'TokenName' that represents the hash of the 'Agora.Stake.Stake' validator.
|
||||
validatorHashTN :: TokenName
|
||||
|
|
|
|||
|
|
@ -114,7 +114,7 @@ govValidatorHash :: ValidatorHash
|
|||
govValidatorHash = governorValidatorHash governor
|
||||
|
||||
govPolicy :: MintingPolicy
|
||||
govPolicy = mkMintingPolicy (governorPolicy governor)
|
||||
govPolicy = mkMintingPolicy def (governorPolicy governor)
|
||||
|
||||
govSymbol :: CurrencySymbol
|
||||
govSymbol = mintingPolicySymbol govPolicy
|
||||
|
|
@ -169,12 +169,16 @@ mintGST ps = builder
|
|||
then
|
||||
mconcat
|
||||
[ input $
|
||||
pubKey witnessPubKey
|
||||
. withValue witnessValue
|
||||
. withOutRef witnessRef
|
||||
mconcat
|
||||
[ pubKey witnessPubKey
|
||||
, withValue witnessValue
|
||||
, withOutRef witnessRef
|
||||
]
|
||||
, output $
|
||||
pubKey witnessPubKey
|
||||
. withValue witnessValue
|
||||
mconcat
|
||||
[ pubKey witnessPubKey
|
||||
, withValue witnessValue
|
||||
]
|
||||
]
|
||||
else mempty
|
||||
|
||||
|
|
@ -184,11 +188,13 @@ mintGST ps = builder
|
|||
let datum =
|
||||
if ps.withGovernorDatum
|
||||
then withDatum governorOutputDatum
|
||||
else id
|
||||
else mempty
|
||||
in output $
|
||||
script govValidatorHash
|
||||
. withValue governorValue
|
||||
. datum
|
||||
mconcat
|
||||
[ script govValidatorHash
|
||||
, withValue governorValue
|
||||
, datum
|
||||
]
|
||||
--
|
||||
builder =
|
||||
mconcat
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ import Sample.Shared (
|
|||
minAda,
|
||||
)
|
||||
import Test.Specification (SpecificationTree, testValidator)
|
||||
import Test.Util (CombinableBuilder, mkSpending, pubKeyHashes, sortValue, validatorHashes, withOptional)
|
||||
import Test.Util (CombinableBuilder, mkSpending, pubKeyHashes, sortValue, validatorHashes)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -142,18 +142,22 @@ mkGovernorBuilder ps =
|
|||
then pubKey $ head pubKeyHashes
|
||||
else script govValidatorHash
|
||||
withGSTDatum =
|
||||
withOptional withDatum $
|
||||
maybe mempty withDatum $
|
||||
mkGovernorOutputDatum ps.governorOutputDatumValidity
|
||||
in mconcat
|
||||
[ input $
|
||||
script govValidatorHash
|
||||
. withDatum governorInputDatum
|
||||
. withValue value
|
||||
. withOutRef governorRef
|
||||
mconcat
|
||||
[ script govValidatorHash
|
||||
, withDatum governorInputDatum
|
||||
, withValue value
|
||||
, withOutRef governorRef
|
||||
]
|
||||
, output $
|
||||
gstOutput
|
||||
. withGSTDatum
|
||||
. withValue value
|
||||
mconcat
|
||||
[ gstOutput
|
||||
, withGSTDatum
|
||||
, withValue value
|
||||
]
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -162,7 +166,7 @@ mockEffectValidator :: ClosedTerm PValidator
|
|||
mockEffectValidator = noOpValidator authorityTokenSymbol
|
||||
|
||||
mockEffectValidatorHash :: ValidatorHash
|
||||
mockEffectValidatorHash = validatorHash $ mkValidator mockEffectValidator
|
||||
mockEffectValidatorHash = validatorHash $ mkValidator def mockEffectValidator
|
||||
|
||||
mkGATValue :: GATValidity -> Integer -> Value
|
||||
mkGATValue NoGAT _ = mempty
|
||||
|
|
@ -187,11 +191,15 @@ mkMockEffectBuilder ps =
|
|||
in mconcat
|
||||
[ mint burnt
|
||||
, input $
|
||||
script mockEffectValidatorHash
|
||||
. withValue inputValue
|
||||
mconcat
|
||||
[ script mockEffectValidatorHash
|
||||
, withValue inputValue
|
||||
]
|
||||
, output $
|
||||
script mockEffectValidatorHash
|
||||
. withValue outputValue
|
||||
mconcat
|
||||
[ script mockEffectValidatorHash
|
||||
, withValue outputValue
|
||||
]
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -321,14 +321,18 @@ mkProposalBuilder ps =
|
|||
value = sortValue $ minAda <> pst
|
||||
in mconcat
|
||||
[ input $
|
||||
script proposalValidatorHash
|
||||
. withOutRef proposalRef
|
||||
. withDatum (mkProposalInputDatum ps)
|
||||
. withValue value
|
||||
mconcat
|
||||
[ script proposalValidatorHash
|
||||
, withOutRef proposalRef
|
||||
, withDatum (mkProposalInputDatum ps)
|
||||
, withValue value
|
||||
]
|
||||
, output $
|
||||
script proposalValidatorHash
|
||||
. withDatum (mkProposalOutputDatum ps)
|
||||
. withValue value
|
||||
mconcat
|
||||
[ script proposalValidatorHash
|
||||
, withDatum (mkProposalOutputDatum ps)
|
||||
, withValue value
|
||||
]
|
||||
]
|
||||
|
||||
{- | The proposal redeemer used to spend the proposal UTXO, which is always
|
||||
|
|
@ -400,14 +404,18 @@ mkStakeBuilder ps =
|
|||
in mconcat
|
||||
[ withSig
|
||||
, input $
|
||||
script stakeValidatorHash
|
||||
. withOutRef (mkStakeRef idx)
|
||||
. withValue perStakeValue
|
||||
. withDatum i
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withOutRef (mkStakeRef idx)
|
||||
, withValue perStakeValue
|
||||
, withDatum i
|
||||
]
|
||||
, output $
|
||||
script stakeValidatorHash
|
||||
. withValue perStakeValue
|
||||
. withDatum o
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue perStakeValue
|
||||
, withDatum o
|
||||
]
|
||||
]
|
||||
in mconcat $
|
||||
zipWith3
|
||||
|
|
@ -457,15 +465,19 @@ mkGovernorBuilder ps =
|
|||
value = sortValue $ gst <> minAda
|
||||
in mconcat
|
||||
[ input $
|
||||
script govValidatorHash
|
||||
. withValue value
|
||||
. withOutRef governorRef
|
||||
. withDatum governorInputDatum
|
||||
mconcat
|
||||
[ script govValidatorHash
|
||||
, withValue value
|
||||
, withOutRef governorRef
|
||||
, withDatum governorInputDatum
|
||||
]
|
||||
, output $
|
||||
script govValidatorHash
|
||||
. withValue value
|
||||
. withOutRef governorRef
|
||||
. withDatum (mkGovernorOutputDatum ps)
|
||||
mconcat
|
||||
[ script govValidatorHash
|
||||
, withValue value
|
||||
, withOutRef governorRef
|
||||
, withDatum (mkGovernorOutputDatum ps)
|
||||
]
|
||||
]
|
||||
|
||||
{- | The proposal redeemer used to spend the governor UTXO, which is always
|
||||
|
|
@ -501,9 +513,11 @@ mkAuthorityTokenBuilder (AuthorityTokenParameters es mdt invalidTokenName) =
|
|||
in mconcat
|
||||
[ mint minted
|
||||
, output $
|
||||
script vh
|
||||
. maybe id withDatum mdt
|
||||
. withValue value
|
||||
mconcat
|
||||
[ script vh
|
||||
, maybe mempty withDatum mdt
|
||||
, withValue value
|
||||
]
|
||||
]
|
||||
|
||||
-- | The redeemer used while running the authority token policy.
|
||||
|
|
|
|||
|
|
@ -162,15 +162,19 @@ cosign ps = builder
|
|||
else stakeDatum
|
||||
in mconcat
|
||||
[ input $
|
||||
script stakeValidatorHash
|
||||
. withValue stakeValue
|
||||
. withDatum stakeDatum
|
||||
. withTxId stakeTxRef
|
||||
. withOutRef (mkStakeRef refIdx)
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue stakeValue
|
||||
, withDatum stakeDatum
|
||||
, withTxId stakeTxRef
|
||||
, withOutRef (mkStakeRef refIdx)
|
||||
]
|
||||
, output $
|
||||
script stakeValidatorHash
|
||||
. withValue stakeValue
|
||||
. withDatum stakeOutputDatum
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue stakeValue
|
||||
, withDatum stakeOutputDatum
|
||||
]
|
||||
, signedWith stakeDatum.owner
|
||||
]
|
||||
)
|
||||
|
|
@ -189,15 +193,19 @@ cosign ps = builder
|
|||
proposalBuilder =
|
||||
mconcat
|
||||
[ input $
|
||||
script proposalValidatorHash
|
||||
. withValue pst
|
||||
. withDatum proposalInputDatum
|
||||
. withTxId proposalTxRef
|
||||
. withOutRef proposalRef
|
||||
mconcat
|
||||
[ script proposalValidatorHash
|
||||
, withValue pst
|
||||
, withDatum proposalInputDatum
|
||||
, withTxId proposalTxRef
|
||||
, withOutRef proposalRef
|
||||
]
|
||||
, output $
|
||||
script proposalValidatorHash
|
||||
. withValue (sortValue (pst <> minAda))
|
||||
. withDatum proposalOutputDatum
|
||||
mconcat
|
||||
[ script proposalValidatorHash
|
||||
, withValue (sortValue (pst <> minAda))
|
||||
, withDatum proposalOutputDatum
|
||||
]
|
||||
]
|
||||
|
||||
validTimeRange :: POSIXTimeRange
|
||||
|
|
|
|||
|
|
@ -302,29 +302,39 @@ createProposal ps = builder
|
|||
, ---
|
||||
timeRange $ mkTimeRange ps
|
||||
, input $
|
||||
script govValidatorHash
|
||||
. withValue governorValue
|
||||
. withDatum governorInputDatum
|
||||
. withOutRef governorRef
|
||||
mconcat
|
||||
[ script govValidatorHash
|
||||
, withValue governorValue
|
||||
, withDatum governorInputDatum
|
||||
, withOutRef governorRef
|
||||
]
|
||||
, output $
|
||||
script govValidatorHash
|
||||
. withValue governorValue
|
||||
. withDatum (mkGovernorOutputDatum ps)
|
||||
mconcat
|
||||
[ script govValidatorHash
|
||||
, withValue governorValue
|
||||
, withDatum (mkGovernorOutputDatum ps)
|
||||
]
|
||||
, ---
|
||||
input $
|
||||
script stakeValidatorHash
|
||||
. withValue stakeValue
|
||||
. withDatum (mkStakeInputDatum ps)
|
||||
. withOutRef stakeRef
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue stakeValue
|
||||
, withDatum (mkStakeInputDatum ps)
|
||||
, withOutRef stakeRef
|
||||
]
|
||||
, output $
|
||||
script stakeValidatorHash
|
||||
. withValue stakeValue
|
||||
. withDatum (mkStakeOutputDatum ps)
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue stakeValue
|
||||
, withDatum (mkStakeOutputDatum ps)
|
||||
]
|
||||
, ---
|
||||
output $
|
||||
script proposalValidatorHash
|
||||
. withValue proposalValue
|
||||
. withDatum (mkProposalOutputDatum ps)
|
||||
mconcat
|
||||
[ script proposalValidatorHash
|
||||
, withValue proposalValue
|
||||
, withDatum (mkProposalOutputDatum ps)
|
||||
]
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -257,14 +257,18 @@ unlockStake ps =
|
|||
( \((i, o), idx) ->
|
||||
mconcat
|
||||
[ input $
|
||||
script proposalValidatorHash
|
||||
. withValue pst
|
||||
. withDatum i
|
||||
. withOutRef (mkProposalRef idx)
|
||||
mconcat
|
||||
[ script proposalValidatorHash
|
||||
, withValue pst
|
||||
, withDatum i
|
||||
, withOutRef (mkProposalRef idx)
|
||||
]
|
||||
, output $
|
||||
script proposalValidatorHash
|
||||
. withValue (sortValue $ pst <> minAda)
|
||||
. withDatum o
|
||||
mconcat
|
||||
[ script proposalValidatorHash
|
||||
, withValue (sortValue $ pst <> minAda)
|
||||
, withDatum o
|
||||
]
|
||||
]
|
||||
)
|
||||
(zip pIODatums [0 ..])
|
||||
|
|
@ -285,14 +289,18 @@ unlockStake ps =
|
|||
stakes =
|
||||
mconcat
|
||||
[ input $
|
||||
script stakeValidatorHash
|
||||
. withValue stakeValue
|
||||
. withDatum sInDatum
|
||||
. withOutRef stakeRef
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue stakeValue
|
||||
, withDatum sInDatum
|
||||
, withOutRef stakeRef
|
||||
]
|
||||
, output $
|
||||
script stakeValidatorHash
|
||||
. withValue stakeValue
|
||||
. withDatum sOutDatum
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue stakeValue
|
||||
, withDatum sOutDatum
|
||||
]
|
||||
]
|
||||
|
||||
builder =
|
||||
|
|
|
|||
|
|
@ -219,23 +219,31 @@ vote params =
|
|||
, signedWith signer
|
||||
, timeRange validTimeRange
|
||||
, input $
|
||||
script proposalValidatorHash
|
||||
. withValue pst
|
||||
. withDatum proposalInputDatum
|
||||
. withOutRef proposalRef
|
||||
mconcat
|
||||
[ script proposalValidatorHash
|
||||
, withValue pst
|
||||
, withDatum proposalInputDatum
|
||||
, withOutRef proposalRef
|
||||
]
|
||||
, input $
|
||||
script stakeValidatorHash
|
||||
. withValue stakeValue
|
||||
. withDatum stakeInputDatum
|
||||
. withOutRef stakeRef
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue stakeValue
|
||||
, withDatum stakeInputDatum
|
||||
, withOutRef stakeRef
|
||||
]
|
||||
, output $
|
||||
script proposalValidatorHash
|
||||
. withValue pst
|
||||
. withDatum proposalOutputDatum
|
||||
mconcat
|
||||
[ script proposalValidatorHash
|
||||
, withValue pst
|
||||
, withDatum proposalOutputDatum
|
||||
]
|
||||
, output $
|
||||
script stakeValidatorHash
|
||||
. withValue stakeValue
|
||||
. withDatum stakeOutputDatum
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue stakeValue
|
||||
, withDatum stakeOutputDatum
|
||||
]
|
||||
]
|
||||
in builder
|
||||
|
||||
|
|
|
|||
|
|
@ -141,10 +141,10 @@ governor = Governor oref gt mc
|
|||
mc = 20
|
||||
|
||||
govPolicy :: MintingPolicy
|
||||
govPolicy = mkMintingPolicy (governorPolicy governor)
|
||||
govPolicy = mkMintingPolicy def (governorPolicy governor)
|
||||
|
||||
govValidator :: Validator
|
||||
govValidator = mkValidator (governorValidator governor)
|
||||
govValidator = mkValidator def (governorValidator governor)
|
||||
|
||||
govSymbol :: CurrencySymbol
|
||||
govSymbol = mintingPolicySymbol govPolicy
|
||||
|
|
@ -239,7 +239,7 @@ gatCs :: CurrencySymbol
|
|||
gatCs = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
|
||||
|
||||
trValidator :: Validator
|
||||
trValidator = mkValidator (treasuryValidator gatCs)
|
||||
trValidator = mkValidator def (treasuryValidator gatCs)
|
||||
|
||||
-- | `ScriptCredential` used for the dummy treasury validator.
|
||||
trCredential :: Credential
|
||||
|
|
@ -251,7 +251,7 @@ gatTn = validatorHashToTokenName $ validatorHash mockTrEffect
|
|||
|
||||
-- | Mock treasury effect script, used for testing.
|
||||
mockTrEffect :: Validator
|
||||
mockTrEffect = mkValidator $ noOpValidator gatCs
|
||||
mockTrEffect = mkValidator def $ noOpValidator gatCs
|
||||
|
||||
-- | Mock treasury effect validator hash
|
||||
mockTrEffectHash :: ValidatorHash
|
||||
|
|
|
|||
|
|
@ -26,6 +26,7 @@ import Agora.Stake (
|
|||
StakeDatum (StakeDatum, stakedAmount),
|
||||
)
|
||||
import Agora.Stake.Scripts (stakeValidator)
|
||||
import Data.Default (def)
|
||||
import Data.Tagged (Tagged, untag)
|
||||
import Plutarch.Api.V1 (mkValidator, validatorHash)
|
||||
import Plutarch.Context (
|
||||
|
|
@ -69,7 +70,10 @@ import Sample.Shared (
|
|||
|
||||
-- | 'TokenName' that represents the hash of the 'Stake' validator.
|
||||
validatorHashTN :: TokenName
|
||||
validatorHashTN = let ValidatorHash vh = validatorHash (mkValidator $ stakeValidator stake) in TokenName vh
|
||||
validatorHashTN =
|
||||
let validator = mkValidator def $ stakeValidator stake
|
||||
ValidatorHash vh = validatorHash validator
|
||||
in TokenName vh
|
||||
|
||||
-- | This script context should be a valid transaction.
|
||||
stakeCreation :: ScriptContext
|
||||
|
|
@ -85,9 +89,11 @@ stakeCreation =
|
|||
, signedWith signer
|
||||
, mint st
|
||||
, output $
|
||||
script stakeValidatorHash
|
||||
. withValue (st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242)
|
||||
. withDatum datum
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue (st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242)
|
||||
, withDatum datum
|
||||
]
|
||||
, withMinting stakeSymbol
|
||||
]
|
||||
in buildMintingUnsafe builder
|
||||
|
|
@ -143,14 +149,18 @@ stakeDepositWithdraw config =
|
|||
, signedWith signer
|
||||
, mint st
|
||||
, input $
|
||||
script stakeValidatorHash
|
||||
. withValue (st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount))
|
||||
. withDatum stakeAfter
|
||||
. withOutRef stakeRef
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue (st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount))
|
||||
, withDatum stakeAfter
|
||||
, withOutRef stakeRef
|
||||
]
|
||||
, output $
|
||||
script stakeValidatorHash
|
||||
. withValue (st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount))
|
||||
. withDatum stakeAfter
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue (st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount))
|
||||
, withDatum stakeAfter
|
||||
]
|
||||
, withSpendingOutRef stakeRef
|
||||
]
|
||||
in buildSpendingUnsafe builder
|
||||
|
|
|
|||
|
|
@ -129,14 +129,18 @@ setDelegate ps = buildSpendingUnsafe builder
|
|||
[ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
|
||||
, signedWith signer
|
||||
, input $
|
||||
script stakeValidatorHash
|
||||
. withValue stakeValue
|
||||
. withDatum stakeInput
|
||||
. withOutRef stakeRef
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue stakeValue
|
||||
, withDatum stakeInput
|
||||
, withOutRef stakeRef
|
||||
]
|
||||
, output $
|
||||
script stakeValidatorHash
|
||||
. withValue stakeValue
|
||||
. withDatum stakeOutput
|
||||
mconcat
|
||||
[ script stakeValidatorHash
|
||||
, withValue stakeValue
|
||||
, withDatum stakeOutput
|
||||
]
|
||||
, withSpendingOutRef stakeRef
|
||||
]
|
||||
|
||||
|
|
|
|||
|
|
@ -19,7 +19,6 @@ module Sample.Treasury (
|
|||
|
||||
import Plutarch.Context (
|
||||
MintingBuilder,
|
||||
UTXO,
|
||||
buildMintingUnsafe,
|
||||
credential,
|
||||
input,
|
||||
|
|
@ -57,11 +56,12 @@ import Sample.Shared (
|
|||
|
||||
baseCtxBuilder :: MintingBuilder
|
||||
baseCtxBuilder =
|
||||
let treasury :: UTXO -> UTXO
|
||||
treasury =
|
||||
credential trCredential
|
||||
. withValue minAda
|
||||
. withTxId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
|
||||
let treasury =
|
||||
mconcat
|
||||
[ credential trCredential
|
||||
, withValue minAda
|
||||
, withTxId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
|
||||
]
|
||||
in mconcat
|
||||
[ txId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
|
||||
, signedWith signer
|
||||
|
|
@ -81,9 +81,11 @@ validCtx =
|
|||
mconcat
|
||||
[ baseCtxBuilder
|
||||
, input $
|
||||
script mockTrEffectHash
|
||||
. withValue (Value.singleton gatCs gatTn 1 <> minAda)
|
||||
. withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
|
||||
mconcat
|
||||
[ script mockTrEffectHash
|
||||
, withValue (Value.singleton gatCs gatTn 1 <> minAda)
|
||||
, withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
|
||||
]
|
||||
]
|
||||
in buildMintingUnsafe builder
|
||||
|
||||
|
|
@ -122,8 +124,10 @@ trCtxGATNameNotAddress =
|
|||
mconcat
|
||||
[ baseCtxBuilder
|
||||
, input $
|
||||
script wrongEffHash
|
||||
. withValue (Value.singleton gatCs gatTn 1 <> minAda)
|
||||
. withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
|
||||
mconcat
|
||||
[ script wrongEffHash
|
||||
, withValue (Value.singleton gatCs gatTn 1 <> minAda)
|
||||
, withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
|
||||
]
|
||||
]
|
||||
in buildMintingUnsafe builder
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@ Tests for Authority token functions
|
|||
module Spec.AuthorityToken (specs) where
|
||||
|
||||
import Agora.AuthorityToken (singleAuthorityTokenBurned)
|
||||
import Plutarch (ClosedTerm, POpaque, compile, perror, popaque)
|
||||
import Plutarch (ClosedTerm, POpaque, perror, popaque)
|
||||
import Plutarch.Extra.Compile (mustCompile)
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
import PlutusLedgerApi.V1 (
|
||||
Address (Address),
|
||||
|
|
@ -60,7 +61,7 @@ singleAuthorityTokenBurnedTest mint outs =
|
|||
actual
|
||||
(popaque (pconstant ()))
|
||||
perror
|
||||
in compile s
|
||||
in mustCompile s
|
||||
|
||||
-- | The SpecificationTree exported by this module.
|
||||
specs :: [SpecificationTree]
|
||||
|
|
|
|||
|
|
@ -52,6 +52,7 @@ module Test.Specification (
|
|||
import Plutarch.Api.V1 (PMintingPolicy, PValidator)
|
||||
import Plutarch.Builtin (pforgetData)
|
||||
import Plutarch.Evaluate (evalScript)
|
||||
import Plutarch.Extra.Compile (mustCompile)
|
||||
import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
|
||||
import PlutusLedgerApi.V1 (Script, ScriptContext)
|
||||
import PlutusTx.IsData qualified as PlutusTx (ToData)
|
||||
|
|
@ -164,7 +165,7 @@ policySucceedsWith ::
|
|||
SpecificationTree
|
||||
policySucceedsWith tag policy redeemer scriptContext =
|
||||
scriptSucceeds tag $
|
||||
compile
|
||||
mustCompile
|
||||
( policy
|
||||
# pforgetData (pconstantData redeemer)
|
||||
# pconstant scriptContext
|
||||
|
|
@ -182,7 +183,7 @@ policyFailsWith ::
|
|||
SpecificationTree
|
||||
policyFailsWith tag policy redeemer scriptContext =
|
||||
scriptFails tag $
|
||||
compile
|
||||
mustCompile
|
||||
( policy
|
||||
# pforgetData (pconstantData redeemer)
|
||||
# pconstant scriptContext
|
||||
|
|
@ -203,7 +204,7 @@ validatorSucceedsWith ::
|
|||
SpecificationTree
|
||||
validatorSucceedsWith tag validator datum redeemer scriptContext =
|
||||
scriptSucceeds tag $
|
||||
compile
|
||||
mustCompile
|
||||
( validator
|
||||
# pforgetData (pconstantData datum)
|
||||
# pforgetData (pconstantData redeemer)
|
||||
|
|
@ -225,7 +226,7 @@ validatorFailsWith ::
|
|||
SpecificationTree
|
||||
validatorFailsWith tag validator datum redeemer scriptContext =
|
||||
scriptFails tag $
|
||||
compile
|
||||
mustCompile
|
||||
( validator
|
||||
# pforgetData (pconstantData datum)
|
||||
# pforgetData (pconstantData redeemer)
|
||||
|
|
|
|||
|
|
@ -19,7 +19,6 @@ module Test.Util (
|
|||
scriptCredentials,
|
||||
validatorHashes,
|
||||
groupsOfN,
|
||||
withOptional,
|
||||
mkSpending,
|
||||
mkMinting,
|
||||
CombinableBuilder,
|
||||
|
|
@ -37,7 +36,6 @@ import Data.ByteString.Lazy qualified as ByteString.Lazy
|
|||
import Data.List (sortOn)
|
||||
import Plutarch.Context (
|
||||
Builder,
|
||||
UTXO,
|
||||
buildMintingUnsafe,
|
||||
buildSpendingUnsafe,
|
||||
withMinting,
|
||||
|
|
@ -182,15 +180,6 @@ groupsOfN n xs =
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Optionally apply a modifier to the given 'UTXO'.
|
||||
withOptional ::
|
||||
(a -> UTXO -> UTXO) ->
|
||||
Maybe a ->
|
||||
UTXO ->
|
||||
UTXO
|
||||
withOptional f (Just b) = f b
|
||||
withOptional _ _ = id
|
||||
|
||||
{- | Given the builder generator and the parameters, create a 'ScriptContext'
|
||||
that spends the UTXO that referenced by the given 'TxOutRef'.
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -12,7 +12,6 @@ module Agora.AuthorityToken (
|
|||
AuthorityToken (..),
|
||||
) where
|
||||
|
||||
import GHC.Generics qualified as GHC
|
||||
import Plutarch.Api.V1 (
|
||||
AmountGuarantees,
|
||||
KeyGuarantees,
|
||||
|
|
@ -53,7 +52,7 @@ newtype AuthorityToken = AuthorityToken
|
|||
}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -105,7 +104,7 @@ authorityTokensValidIn = phoistAcyclic $
|
|||
singleAuthorityTokenBurned ::
|
||||
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
|
||||
Term s PCurrencySymbol ->
|
||||
Term s (PBuiltinList (PAsData PTxInInfo)) ->
|
||||
Term s (PBuiltinList PTxInInfo) ->
|
||||
Term s (PValue keys amounts) ->
|
||||
Term s PBool
|
||||
singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
|
||||
|
|
@ -120,7 +119,7 @@ singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
|
|||
pall
|
||||
# plam
|
||||
( \txInInfo' -> unTermCont $ do
|
||||
PTxInInfo txInInfo <- pmatchC (pfromData txInInfo')
|
||||
PTxInInfo txInInfo <- pmatchC txInInfo'
|
||||
let txOut' = pfield @"resolved" # txInInfo
|
||||
pure $ authorityTokensValidIn # gatCs # pfromData txOut'
|
||||
)
|
||||
|
|
@ -156,9 +155,7 @@ authorityTokenPolicy params =
|
|||
pguardC "All outputs only emit valid GATs" $
|
||||
pall
|
||||
# plam
|
||||
( (authorityTokensValidIn # ownSymbol #)
|
||||
. pfromData
|
||||
)
|
||||
(authorityTokensValidIn # ownSymbol #)
|
||||
# txInfo.outputs
|
||||
pure $ popaque $ pconstant ()
|
||||
)
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ import PlutusLedgerApi.V1.Value (CurrencySymbol)
|
|||
-}
|
||||
makeEffect ::
|
||||
forall (datum :: PType).
|
||||
(PIsData datum, PTryFrom PData (PAsData datum)) =>
|
||||
(PTryFrom PData datum) =>
|
||||
CurrencySymbol ->
|
||||
(forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
|
||||
ClosedTerm PValidator
|
||||
|
|
@ -34,7 +34,7 @@ makeEffect gatCs' f =
|
|||
-- convert input datum, PData, into desierable type
|
||||
-- the way this conversion is performed should be defined
|
||||
-- by PTryFrom for each datum in effect script.
|
||||
(pfromData -> datum', _) <- ptryFromC datum
|
||||
(datum', _) <- ptryFromC datum
|
||||
|
||||
-- ensure purpose is Spending.
|
||||
PSpending txOutRef <- pmatchC $ pfromData ctx.purpose
|
||||
|
|
|
|||
|
|
@ -30,8 +30,7 @@ import Agora.Governor.Scripts (
|
|||
governorSTAssetClassFromGovernor,
|
||||
)
|
||||
import Agora.Plutarch.Orphans ()
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP (Generic, I (I))
|
||||
import Generics.SOP qualified as SOP
|
||||
import Plutarch.Api.V1 (
|
||||
PTxOutRef,
|
||||
PValidator,
|
||||
|
|
@ -42,7 +41,6 @@ import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (pvalueOf)
|
|||
import Plutarch.DataRepr (
|
||||
DerivePConstantViaData (..),
|
||||
PDataFields,
|
||||
PIsDataReprInstances (PIsDataReprInstances),
|
||||
)
|
||||
import Plutarch.Extra.Maybe (
|
||||
passertPDJust,
|
||||
|
|
@ -66,8 +64,16 @@ data MutateGovernorDatum = MutateGovernorDatum
|
|||
, newDatum :: GovernorDatum
|
||||
-- ^ The new settings for the governor.
|
||||
}
|
||||
deriving stock (Show, GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving stock
|
||||
( -- | @since 0.1.ç
|
||||
Show
|
||||
, -- | @since 0.1.ç
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.ç
|
||||
SOP.Generic
|
||||
)
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''MutateGovernorDatum [('MutateGovernorDatum, 0)]
|
||||
|
||||
|
|
@ -88,19 +94,13 @@ newtype PMutateGovernorDatum (s :: S)
|
|||
)
|
||||
)
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
PIsDataRepr
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
SOP.Generic
|
||||
, -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
|
|
@ -109,7 +109,9 @@ newtype PMutateGovernorDatum (s :: S)
|
|||
, -- | @since 0.1.0
|
||||
PEq
|
||||
)
|
||||
via (PIsDataReprInstances PMutateGovernorDatum)
|
||||
|
||||
instance DerivePlutusType PMutateGovernorDatum where
|
||||
type DPTStrat _ = PlutusTypeData
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PUnsafeLiftDecl PMutateGovernorDatum where type PLifted PMutateGovernorDatum = MutateGovernorDatum
|
||||
|
|
@ -118,7 +120,7 @@ instance PUnsafeLiftDecl PMutateGovernorDatum where type PLifted PMutateGovernor
|
|||
deriving via (DerivePConstantViaData MutateGovernorDatum PMutateGovernorDatum) instance (PConstantDecl MutateGovernorDatum)
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via PAsData (PIsDataReprInstances PMutateGovernorDatum) instance PTryFrom PData (PAsData PMutateGovernorDatum)
|
||||
deriving anyclass instance PTryFrom PData PMutateGovernorDatum
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -195,7 +197,7 @@ mutateGovernorValidator gov = makeEffect (authorityTokenSymbolFromGovernor gov)
|
|||
plength # pfromData txInfoF.outputs #== 1
|
||||
|
||||
let govAddress = pfield @"address" #$ govInInfo.resolved
|
||||
govOutput' = pfromData $ phead # pfromData txInfoF.outputs
|
||||
govOutput' = phead # pfromData txInfoF.outputs
|
||||
|
||||
govOutput <- pletFieldsC @'["address", "value", "datumHash"] govOutput'
|
||||
|
||||
|
|
@ -208,9 +210,8 @@ mutateGovernorValidator gov = makeEffect (authorityTokenSymbolFromGovernor gov)
|
|||
let governorOutputDatumHash =
|
||||
passertPDJust # "Governor output doesn't have datum" # govOutput.datumHash
|
||||
governorOutputDatum =
|
||||
pfromData @PGovernorDatum $
|
||||
passertPJust # "Governor output datum not found"
|
||||
#$ ptryFindDatum # governorOutputDatumHash # txInfoF.datums
|
||||
passertPJust @PGovernorDatum # "Governor output datum not found"
|
||||
#$ ptryFindDatum # governorOutputDatumHash # txInfoF.datums
|
||||
|
||||
-- Ensure the output governor datum is what we want.
|
||||
pguardC "Unexpected governor datum" $ datumF.newDatum #== governorOutputDatum
|
||||
|
|
|
|||
|
|
@ -7,11 +7,9 @@ A dumb effect that only burns its GAT.
|
|||
-}
|
||||
module Agora.Effect.NoOp (noOpValidator, PNoOp) where
|
||||
|
||||
import Control.Applicative (Const)
|
||||
|
||||
import Agora.Effect (makeEffect)
|
||||
import Agora.Plutarch.Orphans ()
|
||||
import Plutarch.Api.V1 (PValidator)
|
||||
import Plutarch.TryFrom (PTryFrom (..))
|
||||
import PlutusLedgerApi.V1.Value (CurrencySymbol)
|
||||
|
||||
{- | Dummy datum for NoOp effect.
|
||||
|
|
@ -19,22 +17,23 @@ import PlutusLedgerApi.V1.Value (CurrencySymbol)
|
|||
@since 0.1.0
|
||||
-}
|
||||
newtype PNoOp (s :: S) = PNoOp (Term s PUnit)
|
||||
deriving
|
||||
deriving stock
|
||||
( -- | @since 0.2.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
)
|
||||
via (DerivePNewtype PNoOp PUnit)
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PTryFrom PData (PAsData PNoOp) where
|
||||
type PTryFromExcess PData (PAsData PNoOp) = Const ()
|
||||
ptryFrom' _ cont =
|
||||
-- JUSTIFICATION:
|
||||
-- We don't care anything about data.
|
||||
-- It should always be reduced to Unit.
|
||||
cont (pdata $ pcon $ PNoOp (pconstant ()), ())
|
||||
-- | @since 0.2.0
|
||||
instance DerivePlutusType PNoOp where
|
||||
type DPTStrat _ = PlutusTypeNewtype
|
||||
|
||||
-- | @since 0.2.0
|
||||
instance PTryFrom PData (PAsData PNoOp)
|
||||
|
||||
{- | Dummy effect which can only burn its GAT.
|
||||
|
||||
|
|
@ -42,4 +41,4 @@ instance PTryFrom PData (PAsData PNoOp) where
|
|||
-}
|
||||
noOpValidator :: CurrencySymbol -> ClosedTerm PValidator
|
||||
noOpValidator curr = makeEffect curr $
|
||||
\_ (_datum :: Term s PNoOp) _ _ -> popaque (pconstant ())
|
||||
\_ (_datum :: Term s (PAsData PNoOp)) _ _ -> popaque (pconstant ())
|
||||
|
|
|
|||
|
|
@ -15,8 +15,7 @@ module Agora.Effect.TreasuryWithdrawal (
|
|||
|
||||
import Agora.Effect (makeEffect)
|
||||
import Agora.Plutarch.Orphans ()
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP (Generic, I (I))
|
||||
import Generics.SOP qualified as SOP
|
||||
import Plutarch.Api.V1 (
|
||||
AmountGuarantees (Positive),
|
||||
KeyGuarantees (Sorted),
|
||||
|
|
@ -31,7 +30,6 @@ import "plutarch" Plutarch.Api.V1.Value (pnormalize)
|
|||
import Plutarch.DataRepr (
|
||||
DerivePConstantViaData (..),
|
||||
PDataFields,
|
||||
PIsDataReprInstances (..),
|
||||
)
|
||||
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC)
|
||||
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
|
||||
|
|
@ -57,11 +55,11 @@ data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum
|
|||
( -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
SOP.Generic
|
||||
)
|
||||
|
||||
-- | @since 0.1.0
|
||||
|
|
@ -86,23 +84,21 @@ newtype PTreasuryWithdrawalDatum (s :: S)
|
|||
)
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
SOP.Generic
|
||||
, -- | @since 0.1.0
|
||||
PIsDataRepr
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
, -- | @since 0.1.0
|
||||
PDataFields
|
||||
)
|
||||
via PIsDataReprInstances PTreasuryWithdrawalDatum
|
||||
|
||||
instance DerivePlutusType PTreasuryWithdrawalDatum where
|
||||
type DPTStrat _ = PlutusTypeData
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where
|
||||
|
|
@ -115,10 +111,7 @@ deriving via
|
|||
(PConstantDecl TreasuryWithdrawalDatum)
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances PTreasuryWithdrawalDatum)
|
||||
instance
|
||||
PTryFrom PData (PAsData PTreasuryWithdrawalDatum)
|
||||
instance PTryFrom PData PTreasuryWithdrawalDatum
|
||||
|
||||
{- | Withdraws given list of values to specific target addresses.
|
||||
It can be evoked by burning GAT. The transaction should have correct
|
||||
|
|
@ -150,17 +143,17 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
|
|||
pletC $
|
||||
pmap
|
||||
# plam
|
||||
( \(pfromData -> txOut') -> unTermCont $ do
|
||||
( \txOut' -> unTermCont $ do
|
||||
txOut <- pletFieldsC @'["address", "value"] $ txOut'
|
||||
let cred = pfield @"credential" # pfromData txOut.address
|
||||
pure . pdata $ ptuple # cred # txOut.value
|
||||
)
|
||||
# txInfo.outputs
|
||||
# pfromData txInfo.outputs
|
||||
inputValues <-
|
||||
pletC $
|
||||
pmap
|
||||
# plam
|
||||
( \((pfield @"resolved" #) . pfromData -> txOut') -> unTermCont $ do
|
||||
( \((pfield @"resolved" #) -> txOut') -> unTermCont $ do
|
||||
txOut <- pletFieldsC @'["address", "value"] $ txOut'
|
||||
let cred = pfield @"credential" # pfromData txOut.address
|
||||
pure . pdata $ ptuple # cred # txOut.value
|
||||
|
|
@ -189,7 +182,7 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
|
|||
pnot #$ pany
|
||||
# plam
|
||||
( \x ->
|
||||
effInput.address #== pfield @"address" # pfromData x
|
||||
effInput.address #== pfield @"address" # x
|
||||
)
|
||||
# pfromData txInfo.outputs
|
||||
inputsAreOnlyTreasuriesOrCollateral =
|
||||
|
|
|
|||
|
|
@ -40,18 +40,16 @@ import Agora.Proposal.Time (
|
|||
)
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Data.Tagged (Tagged (..))
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP (Generic, I (I))
|
||||
import Generics.SOP qualified as SOP
|
||||
import Plutarch.DataRepr (
|
||||
DerivePConstantViaData (..),
|
||||
PDataFields,
|
||||
PIsDataReprInstances (PIsDataReprInstances),
|
||||
)
|
||||
import Plutarch.Extra.IsData (
|
||||
DerivePConstantViaEnum (..),
|
||||
EnumIsData (..),
|
||||
PlutusTypeEnumData,
|
||||
)
|
||||
import Plutarch.Extra.Other (DerivePNewtype' (..))
|
||||
import Plutarch.Extra.TermCont (pletFieldsC)
|
||||
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
|
||||
import PlutusLedgerApi.V1 (TxOutRef)
|
||||
|
|
@ -78,7 +76,12 @@ data GovernorDatum = GovernorDatum
|
|||
-- ^ The maximum number of unfinished proposals that a stake is allowed to be
|
||||
-- associated to.
|
||||
}
|
||||
deriving stock (Show, GHC.Generic)
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
|
||||
-- | @since 0.1.0
|
||||
PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)]
|
||||
|
|
@ -105,7 +108,7 @@ data GovernorRedeemer
|
|||
( -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
, -- | @since 0.2.0
|
||||
Enum
|
||||
, -- | @since 0.2.0
|
||||
|
|
@ -113,7 +116,7 @@ data GovernorRedeemer
|
|||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.2.0
|
||||
Generic
|
||||
SOP.Generic
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
|
|
@ -136,7 +139,12 @@ data Governor = Governor
|
|||
-- ^ Arbitrary limit for maximum amount of cosigners on a proposal.
|
||||
-- See `Agora.Proposal.proposalDatumValid`.
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
, -- | @since 0.2.0
|
||||
Show
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -158,18 +166,14 @@ newtype PGovernorDatum (s :: S) = PGovernorDatum
|
|||
)
|
||||
}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
PIsDataRepr
|
||||
SOP.Generic
|
||||
)
|
||||
deriving
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
|
|
@ -179,7 +183,10 @@ newtype PGovernorDatum (s :: S) = PGovernorDatum
|
|||
, -- | @since 0.1.0
|
||||
PEq
|
||||
)
|
||||
via PIsDataReprInstances PGovernorDatum
|
||||
|
||||
-- | @since 0.2.0
|
||||
instance DerivePlutusType PGovernorDatum where
|
||||
type DPTStrat _ = PlutusTypeData
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PUnsafeLiftDecl PGovernorDatum where type PLifted PGovernorDatum = GovernorDatum
|
||||
|
|
@ -188,29 +195,41 @@ instance PUnsafeLiftDecl PGovernorDatum where type PLifted PGovernorDatum = Gove
|
|||
deriving via (DerivePConstantViaData GovernorDatum PGovernorDatum) instance (PConstantDecl GovernorDatum)
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via PAsData (PIsDataReprInstances PGovernorDatum) instance PTryFrom PData (PAsData PGovernorDatum)
|
||||
deriving anyclass instance PTryFrom PData PGovernorDatum
|
||||
|
||||
{- | Plutarch-level version of 'GovernorRedeemer'.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
newtype PGovernorRedeemer (s :: S)
|
||||
= PGovernorRedeemer (Term s PInteger)
|
||||
data PGovernorRedeemer (s :: S)
|
||||
= PCreateProposal
|
||||
| PMintGATs
|
||||
| PMutateGovernor
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
, -- | @since 0.2.0
|
||||
Enum
|
||||
, -- | @since 0.2.0
|
||||
Bounded
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
SOP.Generic
|
||||
, -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
, -- | @since 0.2.0
|
||||
PEq
|
||||
)
|
||||
via (DerivePNewtype' PGovernorRedeemer)
|
||||
|
||||
-- | @since 0.2.0
|
||||
instance PTryFrom PData (PAsData PGovernorRedeemer)
|
||||
|
||||
-- | @since 0.2.0
|
||||
instance DerivePlutusType PGovernorRedeemer where
|
||||
type DPTStrat _ = PlutusTypeEnumData
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PUnsafeLiftDecl PGovernorRedeemer where type PLifted PGovernorRedeemer = GovernorRedeemer
|
||||
|
|
@ -255,9 +274,9 @@ pisGovernorDatumValid = phoistAcyclic $
|
|||
foldr1
|
||||
(#&&)
|
||||
[ ptraceIfFalse "thresholds valid" $
|
||||
pisProposalThresholdsValid # datumF.proposalThresholds
|
||||
pisProposalThresholdsValid # pfromData datumF.proposalThresholds
|
||||
, ptraceIfFalse "timings valid" $
|
||||
pisProposalTimingConfigValid # datumF.proposalTimings
|
||||
pisProposalTimingConfigValid # pfromData datumF.proposalTimings
|
||||
, ptraceIfFalse "time range valid" $
|
||||
pisMaxTimeRangeWidthValid # datumF.createProposalTimeRangeMaxWidth
|
||||
]
|
||||
|
|
|
|||
|
|
@ -74,6 +74,7 @@ import Agora.Utils (
|
|||
validatorHashToAddress,
|
||||
validatorHashToTokenName,
|
||||
)
|
||||
import Data.Default (def)
|
||||
import Plutarch.Api.V1 (
|
||||
PAddress,
|
||||
PCurrencySymbol,
|
||||
|
|
@ -93,15 +94,6 @@ import Plutarch.Api.V1.AssetClass (
|
|||
passetClass,
|
||||
passetClassValueOf,
|
||||
)
|
||||
import Plutarch.Extra.IsData (pmatchEnumFromData)
|
||||
import Plutarch.Extra.List (pfirstJust)
|
||||
import Plutarch.Extra.Map (
|
||||
plookup,
|
||||
plookup',
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutarch.Api.V1.ScriptContext (
|
||||
pfindOutputsToAddress,
|
||||
pfindTxInByTxOutRef,
|
||||
|
|
@ -112,6 +104,12 @@ import Plutarch.Api.V1.ScriptContext (
|
|||
)
|
||||
import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (phasOnlyOneTokenOfCurrencySymbol, psymbolValueOf)
|
||||
import Plutarch.Extra.Field (pletAllC)
|
||||
import Plutarch.Extra.IsData (pmatchEnumFromData)
|
||||
import Plutarch.Extra.List (pfirstJust)
|
||||
import Plutarch.Extra.Map (
|
||||
plookup,
|
||||
plookup',
|
||||
)
|
||||
import Plutarch.Extra.Maybe (passertPDJust, passertPJust, pisDJust)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
|
||||
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
|
||||
|
|
@ -177,12 +175,12 @@ governorPolicy gov =
|
|||
# "Governor output not found"
|
||||
#$ pfind
|
||||
# plam
|
||||
( \((pfield @"value" #) . pfromData -> value) ->
|
||||
( \((pfield @"value" #) -> value) ->
|
||||
psymbolValueOf # ownSymbol # value #== 1
|
||||
)
|
||||
# pfromData txInfoF.outputs
|
||||
|
||||
let datumHash = pfield @"datumHash" # pfromData govOutput
|
||||
let datumHash = pfield @"datumHash" # govOutput
|
||||
datum = mustFindDatum' @PGovernorDatum # datumHash # txInfoF.datums
|
||||
|
||||
pguardC "Governor output datum valid" $ pisGovernorDatumValid # datum
|
||||
|
|
@ -292,7 +290,7 @@ governorValidator gov =
|
|||
ownInputF <- pletFieldsC @'["address", "value"] ownInput
|
||||
let ownAddress = pfromData $ ownInputF.address
|
||||
|
||||
(pfromData -> (oldGovernorDatum :: Term _ PGovernorDatum), _) <- ptryFromC datum'
|
||||
(oldGovernorDatum :: Term _ PGovernorDatum, _) <- ptryFromC datum'
|
||||
oldGovernorDatumF <- pletAllC oldGovernorDatum
|
||||
|
||||
-- Check that GST will be returned to the governor.
|
||||
|
|
@ -314,9 +312,8 @@ governorValidator gov =
|
|||
passertPDJust # "Governor output doesn't have datum" # ownOutput.datumHash
|
||||
newGovernorDatum <-
|
||||
pletC $
|
||||
pfromData $
|
||||
passertPJust # "Ouput governor state datum not found"
|
||||
#$ ptryFindDatum # outputGovernorStateDatumHash # txInfoF.datums
|
||||
passertPJust # "Ouput governor state datum not found"
|
||||
#$ ptryFindDatum # outputGovernorStateDatumHash # txInfoF.datums
|
||||
|
||||
pguardC "New datum is valid" $ pisGovernorDatumValid # newGovernorDatum
|
||||
|
||||
|
|
@ -368,9 +365,9 @@ governorValidator gov =
|
|||
pguardC "Stake input doesn't have datum" $
|
||||
pisDJust # stakeInputF.datumHash
|
||||
|
||||
let stakeInputDatum = mustFindDatum' @PStakeDatum # stakeInputF.datumHash # txInfoF.datums
|
||||
let stakeInputDatum = mustFindDatum' @(PAsData PStakeDatum) # stakeInputF.datumHash # txInfoF.datums
|
||||
|
||||
stakeInputDatumF <- pletAllC stakeInputDatum
|
||||
stakeInputDatumF <- pletAllC $ pto $ pfromData stakeInputDatum
|
||||
|
||||
pguardC "Proposals created by the stake must not exceed the number stored in the governor." $
|
||||
pnumCreatedProposals # stakeInputDatumF.lockedBy
|
||||
|
|
@ -400,11 +397,11 @@ governorValidator gov =
|
|||
|
||||
proposalOutputDatum' <-
|
||||
pletC $
|
||||
mustFindDatum' @PProposalDatum
|
||||
mustFindDatum' @(PAsData PProposalDatum)
|
||||
# outputDatumHash
|
||||
# txInfoF.datums
|
||||
|
||||
proposalOutputDatum <- pletAllC proposalOutputDatum'
|
||||
proposalOutputDatum <- pletAllC $ pto $ pfromData proposalOutputDatum'
|
||||
|
||||
let expectedStartingTime =
|
||||
createProposalStartingTime
|
||||
|
|
@ -462,7 +459,7 @@ governorValidator gov =
|
|||
#$ ptryFindDatum # stakeOutputDatumHash # txInfoF.datums
|
||||
|
||||
stakeOutputLocks =
|
||||
pfromData $ pfield @"lockedBy" # stakeOutputDatum
|
||||
pfromData $ pfield @"lockedBy" #$ pto $ pfromData stakeOutputDatum
|
||||
|
||||
-- The stake should be locked by the newly created proposal.
|
||||
newLock =
|
||||
|
|
@ -493,29 +490,28 @@ governorValidator gov =
|
|||
proposalInputF <-
|
||||
pletFieldsC @'["datumHash"] $
|
||||
pfield @"resolved"
|
||||
#$ pfromData
|
||||
$ passertPJust
|
||||
# "Proposal input not found"
|
||||
#$ pfind
|
||||
# plam
|
||||
( \((pfield @"resolved" #) -> txOut) -> unTermCont $ do
|
||||
txOutF <- pletFieldsC @'["address", "value"] txOut
|
||||
#$ passertPJust
|
||||
# "Proposal input not found"
|
||||
#$ pfind
|
||||
# plam
|
||||
( \((pfield @"resolved" #) -> txOut) -> unTermCont $ do
|
||||
txOutF <- pletFieldsC @'["address", "value"] txOut
|
||||
|
||||
pure $
|
||||
psymbolValueOf # ppstSymbol # txOutF.value #== 1
|
||||
#&& txOutF.address #== pdata pproposalValidatorAddress
|
||||
)
|
||||
# pfromData txInfoF.inputs
|
||||
pure $
|
||||
psymbolValueOf # ppstSymbol # txOutF.value #== 1
|
||||
#&& txOutF.address #== pdata pproposalValidatorAddress
|
||||
)
|
||||
# pfromData txInfoF.inputs
|
||||
|
||||
proposalInputDatum <-
|
||||
pletC $
|
||||
mustFindDatum' @PProposalDatum
|
||||
mustFindDatum' @(PAsData PProposalDatum)
|
||||
# proposalInputF.datumHash
|
||||
# txInfoF.datums
|
||||
|
||||
proposalInputDatumF <-
|
||||
pletFieldsC @'["effects", "status", "thresholds", "votes"]
|
||||
proposalInputDatum
|
||||
pletFieldsC @'["effects", "status", "thresholds", "votes"] $
|
||||
pto $ pfromData proposalInputDatum
|
||||
|
||||
-- Check that the proposal state is advanced so that a proposal cannot be executed twice.
|
||||
|
||||
|
|
@ -552,12 +548,12 @@ governorValidator gov =
|
|||
pguardC "Output GATs is more than minted GATs" $
|
||||
plength # outputsWithGAT #== gatCount
|
||||
|
||||
let gatOutputValidator' :: Term s (PMap _ PValidatorHash PDatumHash :--> PAsData PTxOut :--> PBool)
|
||||
let gatOutputValidator' :: Term s (PMap _ PValidatorHash PDatumHash :--> PTxOut :--> PBool)
|
||||
gatOutputValidator' =
|
||||
phoistAcyclic $
|
||||
plam
|
||||
( \effects (pfromData -> output') -> unTermCont $ do
|
||||
output <- pletFieldsC @'["address", "datumHash"] $ output'
|
||||
( \effects output' -> unTermCont $ do
|
||||
output <- pletFieldsC @'["address", "datumHash"] output'
|
||||
|
||||
let scriptHash =
|
||||
passertPJust # "GAT receiver is not a script"
|
||||
|
|
@ -644,7 +640,7 @@ governorSTSymbolFromGovernor :: Governor -> CurrencySymbol
|
|||
governorSTSymbolFromGovernor gov = mintingPolicySymbol policy
|
||||
where
|
||||
policy :: MintingPolicy
|
||||
policy = mkMintingPolicy $ governorPolicy gov
|
||||
policy = mkMintingPolicy def $ governorPolicy gov
|
||||
|
||||
{- | Get the 'AssetClass' of GST.
|
||||
|
||||
|
|
@ -664,7 +660,7 @@ proposalSTSymbolFromGovernor :: Governor -> CurrencySymbol
|
|||
proposalSTSymbolFromGovernor gov = symbol
|
||||
where
|
||||
gstAC = governorSTAssetClassFromGovernor gov
|
||||
policy = mkMintingPolicy $ proposalPolicy gstAC
|
||||
policy = mkMintingPolicy def $ proposalPolicy gstAC
|
||||
symbol = mintingPolicySymbol policy
|
||||
|
||||
{- | Get the 'AssetClass' of the proposal state token.
|
||||
|
|
@ -683,7 +679,7 @@ proposalSTAssetClassFromGovernor gov = AssetClass (symbol, "")
|
|||
stakeSTSymbolFromGovernor :: Governor -> CurrencySymbol
|
||||
stakeSTSymbolFromGovernor gov = mintingPolicySymbol policy
|
||||
where
|
||||
policy = mkMintingPolicy $ stakePolicy gov.gtClassRef
|
||||
policy = mkMintingPolicy def $ stakePolicy gov.gtClassRef
|
||||
|
||||
{- | Get the 'AssetClass' of the stake token.
|
||||
|
||||
|
|
@ -717,7 +713,7 @@ stakeValidatorHashFromGovernor :: Governor -> ValidatorHash
|
|||
stakeValidatorHashFromGovernor gov = validatorHash validator
|
||||
where
|
||||
params = stakeFromGovernor gov
|
||||
validator = mkValidator $ stakeValidator params
|
||||
validator = mkValidator def $ stakeValidator params
|
||||
|
||||
{- | Get the 'Proposal' parameter, given the 'Governor' parameter.
|
||||
|
||||
|
|
@ -738,7 +734,7 @@ proposalValidatorHashFromGovernor :: Governor -> ValidatorHash
|
|||
proposalValidatorHashFromGovernor gov = validatorHash validator
|
||||
where
|
||||
params = proposalFromGovernor gov
|
||||
validator = mkValidator $ proposalValidator params
|
||||
validator = mkValidator def $ proposalValidator params
|
||||
|
||||
{- | Get the hash of 'Agora.Proposal.proposalValidator'.
|
||||
|
||||
|
|
@ -747,7 +743,7 @@ proposalValidatorHashFromGovernor gov = validatorHash validator
|
|||
governorValidatorHash :: Governor -> ValidatorHash
|
||||
governorValidatorHash gov = validatorHash validator
|
||||
where
|
||||
validator = mkValidator $ governorValidator gov
|
||||
validator = mkValidator def $ governorValidator gov
|
||||
|
||||
{- | Get the 'AuthorityToken' parameter given the 'Governor' parameter.
|
||||
|
||||
|
|
@ -763,5 +759,5 @@ authorityTokenFromGovernor gov = AuthorityToken $ governorSTAssetClassFromGovern
|
|||
authorityTokenSymbolFromGovernor :: Governor -> CurrencySymbol
|
||||
authorityTokenSymbolFromGovernor gov = mintingPolicySymbol policy
|
||||
where
|
||||
policy = mkMintingPolicy $ authorityTokenPolicy params
|
||||
policy = mkMintingPolicy def $ authorityTokenPolicy params
|
||||
params = authorityTokenFromGovernor gov
|
||||
|
|
|
|||
|
|
@ -1,135 +1,15 @@
|
|||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
{- FIXME: All of the following instances and
|
||||
types ought to belong in either plutarch or
|
||||
plutarch-extra.
|
||||
|
||||
A number of these have been "stolen" from Mango's
|
||||
PR: https://github.com/Plutonomicon/plutarch/pull/438/
|
||||
-}
|
||||
|
||||
module Agora.Plutarch.Orphans () where
|
||||
|
||||
import Control.Arrow (first)
|
||||
import Plutarch.Api.V1 (PAddress, PCredential, PCurrencySymbol, PDatumHash, PMap, PMaybeData, PPOSIXTime, PPubKeyHash, PStakingCredential, PTokenName, PTxId, PTxOutRef, PValidatorHash, PValue)
|
||||
import Plutarch.Builtin (PBuiltinMap)
|
||||
import Plutarch.DataRepr (PIsDataReprInstances (..))
|
||||
import Plutarch.Extra.TermCont (ptryFromC)
|
||||
import Plutarch.Numeric.Additive (AdditiveSemigroup ((+)))
|
||||
import Plutarch.Reducible (Reduce, Reducible)
|
||||
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
import Prelude hiding ((+))
|
||||
import Plutarch.Api.V1 (PDatumHash)
|
||||
import Plutarch.Builtin (PIsData (..))
|
||||
|
||||
instance Reducible (f x y) => Reducible (Flip f y x) where
|
||||
type Reduce (Flip f y x) = Reduce (f x y)
|
||||
-- TODO: add checks
|
||||
instance PTryFrom PData (PAsData PDatumHash)
|
||||
|
||||
newtype Flip f a b = Flip (f b a)
|
||||
instance PTryFrom PData (PAsData PUnit)
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PTryFrom PData (PAsData b) => PTryFrom PData (PAsData (DerivePNewtype c b)) where
|
||||
type
|
||||
PTryFromExcess PData (PAsData (DerivePNewtype c b)) =
|
||||
PTryFromExcess PData (PAsData b)
|
||||
ptryFrom' d k =
|
||||
ptryFrom' @_ @(PAsData b) d $ k . first punsafeCoerce
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PTryFrom PData (PAsData PPubKeyHash) where
|
||||
type PTryFromExcess PData (PAsData PPubKeyHash) = Flip Term PPubKeyHash
|
||||
ptryFrom' opq = runTermCont $ do
|
||||
(wrapped :: Term _ (PAsData PByteString), unwrapped :: Term _ PByteString) <-
|
||||
ptryFromC @(PAsData PByteString) opq
|
||||
tcont $ \f -> pif (plengthBS # unwrapped #== 28) (f ()) (ptraceError "a PubKeyHash should be 28 bytes long")
|
||||
pure (punsafeCoerce wrapped, punsafeCoerce unwrapped)
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance AdditiveSemigroup (Term s PPOSIXTime) where
|
||||
(punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (DerivePNewtype PPOSIXTime PInteger)
|
||||
instance
|
||||
PTryFrom PData (PAsData PPOSIXTime)
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances PTxId)
|
||||
instance
|
||||
PTryFrom PData (PAsData PTxId)
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances PTxOutRef)
|
||||
instance
|
||||
PTryFrom PData (PAsData PTxOutRef)
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (DerivePNewtype (PMap g k v) (PBuiltinMap k v))
|
||||
instance
|
||||
( PTryFrom PData (PAsData k)
|
||||
, PTryFrom PData (PAsData v)
|
||||
) =>
|
||||
PTryFrom PData (PAsData (PMap g k v))
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PTryFrom PData (PAsData PValidatorHash) where
|
||||
type PTryFromExcess PData (PAsData PValidatorHash) = Flip Term PValidatorHash
|
||||
ptryFrom' opq = runTermCont $ do
|
||||
(wrapped :: Term _ (PAsData PByteString), unwrapped :: Term _ PByteString) <-
|
||||
ptryFromC @(PAsData PByteString) opq
|
||||
tcont $ \f -> pif (plengthBS # unwrapped #== 28) (f ()) (ptraceError "a ValidatorHash should be 28 bytes long")
|
||||
pure (punsafeCoerce wrapped, punsafeCoerce unwrapped)
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PTryFrom PData (PAsData PDatumHash) where
|
||||
type PTryFromExcess PData (PAsData PDatumHash) = Flip Term PDatumHash
|
||||
ptryFrom' opq = runTermCont $ do
|
||||
(wrapped :: Term _ (PAsData PByteString), unwrapped :: Term _ PByteString) <-
|
||||
tcont $ ptryFrom @(PAsData PByteString) opq
|
||||
tcont $ \f -> pif (plengthBS # unwrapped #== 32) (f ()) (ptraceError "a DatumHash should be 32 bytes long")
|
||||
pure (punsafeCoerce wrapped, punsafeCoerce unwrapped)
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (DerivePNewtype PCurrencySymbol PByteString)
|
||||
instance
|
||||
PTryFrom PData (PAsData PCurrencySymbol)
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (DerivePNewtype PTokenName PByteString)
|
||||
instance
|
||||
PTryFrom PData (PAsData PTokenName)
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (DerivePNewtype (PValue k v) (PMap k PCurrencySymbol (PMap k PTokenName PInteger)))
|
||||
instance
|
||||
PTryFrom PData (PAsData (PValue k v))
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances (PMaybeData a))
|
||||
instance
|
||||
PTryFrom PData (PAsData a) => PTryFrom PData (PAsData (PMaybeData a))
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances PAddress)
|
||||
instance
|
||||
PTryFrom PData (PAsData PAddress)
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances PCredential)
|
||||
instance
|
||||
PTryFrom PData (PAsData PCredential)
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances PStakingCredential)
|
||||
instance
|
||||
PTryFrom PData (PAsData PStakingCredential)
|
||||
instance (PIsData a) => PIsData (PAsData a) where
|
||||
pfromDataImpl = pfromData
|
||||
pdataImpl = pdataImpl . pfromData
|
||||
|
|
|
|||
|
|
@ -39,11 +39,11 @@ module Agora.Proposal (
|
|||
pisProposalThresholdsValid,
|
||||
) where
|
||||
|
||||
import Agora.Plutarch.Orphans ()
|
||||
import Agora.Proposal.Time (PProposalStartingTime, PProposalTimingConfig, ProposalStartingTime, ProposalTimingConfig)
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Data.Tagged (Tagged)
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP (Generic, I (I))
|
||||
import Generics.SOP qualified as SOP
|
||||
import Plutarch.Api.V1 (
|
||||
KeyGuarantees (Unsorted),
|
||||
PDatumHash,
|
||||
|
|
@ -52,7 +52,7 @@ import Plutarch.Api.V1 (
|
|||
PValidatorHash,
|
||||
)
|
||||
import Plutarch.Api.V1.AssocMap qualified as PAssocMap
|
||||
import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields, PIsDataReprInstances (..))
|
||||
import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields)
|
||||
import Plutarch.Extra.Comonad (pextract)
|
||||
import Plutarch.Extra.Field (pletAllC)
|
||||
import Plutarch.Extra.Function (pbuiltinUncurry)
|
||||
|
|
@ -60,13 +60,13 @@ import Plutarch.Extra.IsData (
|
|||
DerivePConstantViaDataList (..),
|
||||
DerivePConstantViaEnum (..),
|
||||
EnumIsData (..),
|
||||
PlutusTypeEnumData,
|
||||
ProductIsData (ProductIsData),
|
||||
)
|
||||
import Plutarch.Extra.List (pfirstJust)
|
||||
import Plutarch.Extra.Map qualified as PM
|
||||
import Plutarch.Extra.Map.Unsorted qualified as PUM
|
||||
import Plutarch.Extra.Maybe (pfromJust)
|
||||
import Plutarch.Extra.Other (DerivePNewtype' (..))
|
||||
import Plutarch.Extra.TermCont (pguardC, pletC, pmatchC)
|
||||
import Plutarch.Lift (
|
||||
DerivePConstantViaNewtype (..),
|
||||
|
|
@ -92,6 +92,14 @@ import PlutusTx.AssocMap qualified as AssocMap
|
|||
@since 0.1.0
|
||||
-}
|
||||
newtype ProposalId = ProposalId {proposalTag :: Integer}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
Eq
|
||||
, -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
deriving newtype
|
||||
( -- | @since 0.1.0
|
||||
PlutusTx.ToData
|
||||
|
|
@ -100,13 +108,9 @@ newtype ProposalId = ProposalId {proposalTag :: Integer}
|
|||
, -- | @since 0.1.0
|
||||
PlutusTx.UnsafeFromData
|
||||
)
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
Eq
|
||||
, -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
deriving anyclass
|
||||
( -- | @since 0.2.0
|
||||
SOP.Generic
|
||||
)
|
||||
|
||||
{- | Encodes a result. Typically, for a Yes/No proposal, we encode it like this:
|
||||
|
|
@ -127,7 +131,7 @@ newtype ResultTag = ResultTag {getResultTag :: Integer}
|
|||
, -- | @since 0.1.0
|
||||
Ord
|
||||
, -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
)
|
||||
deriving newtype
|
||||
( -- | @since 0.1.0
|
||||
|
|
@ -137,6 +141,10 @@ newtype ResultTag = ResultTag {getResultTag :: Integer}
|
|||
, -- | @since 0.1.0
|
||||
PlutusTx.UnsafeFromData
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.2.0
|
||||
SOP.Generic
|
||||
)
|
||||
|
||||
{- | 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".
|
||||
|
|
@ -186,7 +194,7 @@ data ProposalStatus
|
|||
, -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
, -- | @since 0.2.0
|
||||
Enum
|
||||
, -- | @since 0.2.0
|
||||
|
|
@ -194,7 +202,7 @@ data ProposalStatus
|
|||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.2.0
|
||||
Generic
|
||||
SOP.Generic
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
|
|
@ -230,9 +238,9 @@ data ProposalThresholds = ProposalThresholds
|
|||
, -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (SOP.Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed 'ProposalThresholds [('ProposalThresholds, 0)]
|
||||
|
||||
|
|
@ -252,19 +260,23 @@ PlutusTx.makeIsDataIndexed 'ProposalThresholds [('ProposalThresholds, 0)]
|
|||
newtype ProposalVotes = ProposalVotes
|
||||
{ getProposalVotes :: AssocMap.Map ResultTag Integer
|
||||
}
|
||||
deriving newtype
|
||||
( -- | @since 0.1.0
|
||||
PlutusTx.ToData
|
||||
, -- | @since 0.1.0
|
||||
PlutusTx.FromData
|
||||
)
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
Eq
|
||||
, -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
)
|
||||
deriving newtype
|
||||
( -- | @since 0.1.0
|
||||
PlutusTx.ToData
|
||||
, -- | @since 0.1.0
|
||||
PlutusTx.FromData
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.2.0
|
||||
SOP.Generic
|
||||
)
|
||||
|
||||
{- | Create a 'ProposalVotes' that has the same shape as the 'effects' field.
|
||||
|
|
@ -307,9 +319,12 @@ data ProposalDatum = ProposalDatum
|
|||
, -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.2.0
|
||||
SOP.Generic
|
||||
)
|
||||
deriving anyclass (Generic)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
PlutusTx.ToData
|
||||
|
|
@ -367,7 +382,11 @@ data ProposalRedeemer
|
|||
, -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.2.0
|
||||
SOP.Generic
|
||||
)
|
||||
|
||||
-- | @since 0.1.0
|
||||
|
|
@ -395,7 +414,11 @@ data Proposal = Proposal
|
|||
, -- | @since 0.1.0
|
||||
Eq
|
||||
, -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.2.0
|
||||
SOP.Generic
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -406,19 +429,33 @@ data Proposal = Proposal
|
|||
@since 0.1.0
|
||||
-}
|
||||
newtype PResultTag (s :: S) = PResultTag (Term s PInteger)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
deriving stock
|
||||
( -- | @since 0.2.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.2.0
|
||||
SOP.Generic
|
||||
, -- @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
, -- | @since 0.1.0
|
||||
PEq
|
||||
, -- | @since 0.2.0
|
||||
PPartialOrd
|
||||
, -- | @since 0.1.0
|
||||
POrd
|
||||
, -- | @since 0.2.0
|
||||
PShow
|
||||
)
|
||||
via (DerivePNewtype PResultTag PInteger)
|
||||
|
||||
-- | @since 0.2.0
|
||||
instance DerivePlutusType PResultTag where
|
||||
type DPTStrat _ = PlutusTypeNewtype
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PTryFrom PData (PAsData PResultTag)
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PUnsafeLiftDecl PResultTag where type PLifted PResultTag = ResultTag
|
||||
|
|
@ -429,36 +466,38 @@ deriving via
|
|||
instance
|
||||
(PConstantDecl ResultTag)
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (DerivePNewtype PResultTag PInteger)
|
||||
instance
|
||||
PTryFrom PData (PAsData PResultTag)
|
||||
|
||||
{- | Plutarch-level version of 'PProposalId'.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
newtype PProposalId (s :: S) = PProposalId (Term s PInteger)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
deriving stock
|
||||
( -- | @since 0.2.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.2.0
|
||||
SOP.Generic
|
||||
, -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
, -- | @since 0.1.0
|
||||
PEq
|
||||
, -- | @since 0.2.0
|
||||
PPartialOrd
|
||||
, -- | @since 0.1.0
|
||||
POrd
|
||||
, -- | @since 0.2.0
|
||||
PShow
|
||||
)
|
||||
via (DerivePNewtype PProposalId PInteger)
|
||||
|
||||
-- | @since 0.2.0
|
||||
instance DerivePlutusType PProposalId where
|
||||
type DPTStrat _ = PlutusTypeNewtype
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (DerivePNewtype PProposalId PInteger)
|
||||
instance
|
||||
PTryFrom PData (PAsData PProposalId)
|
||||
instance PTryFrom PData (PAsData PProposalId)
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PUnsafeLiftDecl PProposalId where type PLifted PProposalId = ProposalId
|
||||
|
|
@ -473,30 +512,43 @@ deriving via
|
|||
|
||||
@since 0.1.0
|
||||
-}
|
||||
newtype PProposalStatus (s :: S) = PProposalStatus (Term s PInteger)
|
||||
data PProposalStatus (s :: S)
|
||||
= -- | @since 0.2.0
|
||||
PDraft
|
||||
| -- | @since 0.2.0
|
||||
PVoting
|
||||
| -- | @since 0.2.0
|
||||
PLocked
|
||||
| -- | @since 0.2.0
|
||||
PFinished
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
, -- | @since 0.2.0
|
||||
Bounded
|
||||
, -- | @since 0.2.0
|
||||
Enum
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
SOP.Generic
|
||||
, -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
, -- | @since 0.1.0
|
||||
PEq
|
||||
)
|
||||
via (DerivePNewtype' PProposalStatus)
|
||||
|
||||
-- | @since 0.2.0
|
||||
instance DerivePlutusType PProposalStatus where
|
||||
type DPTStrat _ = PlutusTypeEnumData
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via PAsData (DerivePNewtype' PProposalStatus) instance PTryFrom PData (PAsData PProposalStatus)
|
||||
instance PTryFrom PData (PAsData PProposalStatus)
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via (DerivePConstantViaEnum ProposalStatus PProposalStatus) instance (PConstantDecl ProposalStatus)
|
||||
|
|
@ -517,32 +569,26 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds
|
|||
)
|
||||
}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
PIsDataRepr
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
SOP.Generic
|
||||
, -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
, -- | @since 0.1.0
|
||||
PDataFields
|
||||
)
|
||||
via (PIsDataReprInstances PProposalThresholds)
|
||||
|
||||
-- | @since 0.2.0
|
||||
instance DerivePlutusType PProposalThresholds where
|
||||
type DPTStrat _ = PlutusTypeData
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances PProposalThresholds)
|
||||
instance
|
||||
PTryFrom PData (PAsData PProposalThresholds)
|
||||
instance PTryFrom PData PProposalThresholds
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds
|
||||
|
|
@ -559,19 +605,25 @@ deriving via
|
|||
-}
|
||||
newtype PProposalVotes (s :: S)
|
||||
= PProposalVotes (Term s (PMap 'Unsorted PResultTag PInteger))
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
deriving stock
|
||||
( -- | @since 0.2.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.2.0
|
||||
SOP.Generic
|
||||
, -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
)
|
||||
via (DerivePNewtype PProposalVotes (PMap 'Unsorted PResultTag PInteger))
|
||||
|
||||
-- | @since 0.2.0
|
||||
instance DerivePlutusType PProposalVotes where
|
||||
type DPTStrat _ = PlutusTypeNewtype
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (DerivePNewtype PProposalVotes (PMap 'Unsorted PResultTag PInteger))
|
||||
instance
|
||||
PTryFrom PData (PAsData PProposalVotes)
|
||||
instance PTryFrom PData (PAsData PProposalVotes)
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = ProposalVotes
|
||||
|
|
@ -603,31 +655,25 @@ newtype PProposalDatum (s :: S) = PProposalDatum
|
|||
)
|
||||
}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
PIsDataRepr
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
SOP.Generic
|
||||
, -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
, -- | @since 0.1.0
|
||||
PDataFields
|
||||
, -- | @since 0.1.0
|
||||
PEq
|
||||
)
|
||||
via (DerivePNewtype' PProposalDatum)
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via PAsData (DerivePNewtype' PProposalDatum) instance PTryFrom PData (PAsData PProposalDatum)
|
||||
-- | @since 0.2.0
|
||||
instance DerivePlutusType PProposalDatum where
|
||||
type DPTStrat _ = PlutusTypeNewtype
|
||||
|
||||
instance PTryFrom PData (PAsData PProposalDatum)
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
|
||||
|
|
@ -645,30 +691,24 @@ data PProposalRedeemer (s :: S)
|
|||
| PUnlock (Term s (PDataRecord '[]))
|
||||
| PAdvanceProposal (Term s (PDataRecord '[]))
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
PIsDataRepr
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
SOP.Generic
|
||||
, -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
)
|
||||
via PIsDataReprInstances PProposalRedeemer
|
||||
|
||||
-- | @since 0.2.0
|
||||
instance DerivePlutusType PProposalRedeemer where
|
||||
type DPTStrat _ = PlutusTypeData
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances PProposalRedeemer)
|
||||
instance
|
||||
PTryFrom PData (PAsData PProposalRedeemer)
|
||||
instance PTryFrom PData PProposalRedeemer
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer
|
||||
|
|
|
|||
|
|
@ -174,12 +174,10 @@ proposalValidator proposal =
|
|||
PJust ((pfield @"resolved" #) -> txOut) <- pmatchC $ pfindTxInByTxOutRef # txOutRef # txInfoF.inputs
|
||||
txOutF <- pletFieldsC @'["address", "value"] $ txOut
|
||||
|
||||
(pfromData -> proposalDatum, _) <-
|
||||
ptryFromC @(PAsData PProposalDatum) datum
|
||||
(pfromData -> proposalRedeemer, _) <-
|
||||
ptryFromC @(PAsData PProposalRedeemer) redeemer
|
||||
proposalDatum <- pfromData . fst <$> ptryFromC @(PAsData PProposalDatum) datum
|
||||
proposalRedeemer <- fst <$> ptryFromC @PProposalRedeemer redeemer
|
||||
|
||||
proposalF <- pletAllC proposalDatum
|
||||
proposalF <- pletAllC $ pto proposalDatum
|
||||
|
||||
ownAddress <- pletC $ txOutF.address
|
||||
|
||||
|
|
@ -211,11 +209,12 @@ proposalValidator proposal =
|
|||
-- TODO: this is highly inefficient: O(n) for every output,
|
||||
-- Maybe we can cache the sorted datum map?
|
||||
let datum =
|
||||
mustFindDatum' @PProposalDatum
|
||||
# inputF.datumHash
|
||||
# txInfoF.datums
|
||||
pfromData $
|
||||
mustFindDatum' @(PAsData PProposalDatum)
|
||||
# inputF.datumHash
|
||||
# txInfoF.datums
|
||||
|
||||
proposalId = pfield @"proposalId" # datum
|
||||
proposalId = pfield @"proposalId" # pto datum
|
||||
|
||||
pure $
|
||||
inputF.address #== ownAddress
|
||||
|
|
@ -226,21 +225,34 @@ proposalValidator proposal =
|
|||
|
||||
proposalOut <-
|
||||
pletC $
|
||||
mustFindDatum' @PProposalDatum
|
||||
# (pfield @"datumHash" # ownOutput)
|
||||
# txInfoF.datums
|
||||
pfromData $
|
||||
mustFindDatum' @(PAsData PProposalDatum)
|
||||
# (pfield @"datumHash" # ownOutput)
|
||||
# txInfoF.datums
|
||||
|
||||
proposalUnchanged <- pletC $ proposalOut #== proposalDatum
|
||||
|
||||
proposalOutStatus <-
|
||||
pletC $
|
||||
pfromData $
|
||||
pfield @"status" # proposalOut
|
||||
pfield @"status" # pto proposalOut
|
||||
|
||||
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
|
||||
|
|
@ -263,9 +275,9 @@ proposalValidator proposal =
|
|||
stakeSTAssetClass <-
|
||||
pletC $ passetClass # pconstant stakeSym # pconstant stakeTn
|
||||
|
||||
filterStakeDatumHash :: Term _ (PAsData PTxOut :--> PMaybe (PAsData PDatumHash)) <-
|
||||
filterStakeDatumHash :: Term _ (PTxOut :--> PMaybe (PAsData PDatumHash)) <-
|
||||
pletC $
|
||||
plam $ \(pfromData -> txOut) -> unTermCont $ do
|
||||
plam $ \txOut -> unTermCont $ do
|
||||
txOutF <- pletFieldsC @'["value", "datumHash"] txOut
|
||||
pure $
|
||||
pif
|
||||
|
|
@ -333,12 +345,11 @@ proposalValidator proposal =
|
|||
let stake =
|
||||
pfromData $
|
||||
pfromJust
|
||||
#$ ptryFindDatum
|
||||
@(PAsData PStakeDatum)
|
||||
#$ ptryFindDatum @(PAsData PStakeDatum)
|
||||
# pfromData dh
|
||||
# txInfoF.datums
|
||||
|
||||
stakeF <- pletFieldsC @'["stakedAmount", "owner"] stake
|
||||
stakeF <- pletFieldsC @'["stakedAmount", "owner"] $ pto stake
|
||||
|
||||
PPair amount owners <- pmatchC l
|
||||
|
||||
|
|
@ -369,14 +380,10 @@ proposalValidator proposal =
|
|||
stakeOutputHash <- pletC $ pfromData $ phead # stakeOutputDatumHashes
|
||||
|
||||
stakeIn :: Term _ PStakeDatum <-
|
||||
pletC $
|
||||
pfromData $
|
||||
pfromJust #$ ptryFindDatum # stakeInputHash # txInfoF.datums
|
||||
pletC $ pfromData $ pfromJust #$ ptryFindDatum # stakeInputHash # txInfoF.datums
|
||||
|
||||
stakeOut :: Term _ PStakeDatum <-
|
||||
pletC $
|
||||
pfromData $
|
||||
pfromJust #$ ptryFindDatum # stakeOutputHash # txInfoF.datums
|
||||
pletC $ pfromData $ pfromJust #$ ptryFindDatum # stakeOutputHash # txInfoF.datums
|
||||
|
||||
stakeUnchanged <- pletC $ stakeInputHash #== stakeOutputHash
|
||||
|
||||
|
|
@ -391,7 +398,7 @@ proposalValidator proposal =
|
|||
|
||||
withSingleStake val =
|
||||
withSingleStake' #$ plam $ \stakeIn stakeOut stakeUnchange -> unTermCont $ do
|
||||
stakeInF <- pletAllC stakeIn
|
||||
stakeInF <- pletAllC $ pto stakeIn
|
||||
|
||||
val stakeInF stakeOut stakeUnchange
|
||||
|
||||
|
|
@ -581,7 +588,7 @@ proposalValidator proposal =
|
|||
$ ptraceIfFalse "Proposal unchanged" proposalUnchanged
|
||||
|
||||
-- At last, we ensure that all locks belong to this proposal will be removed.
|
||||
stakeOutputLocks <- pletC $ pfield @"lockedBy" # stakeOut
|
||||
stakeOutputLocks <- pletC $ pfield @"lockedBy" # pto stakeOut
|
||||
|
||||
let templateStakeOut =
|
||||
mkRecordConstr
|
||||
|
|
@ -662,13 +669,12 @@ proposalValidator proposal =
|
|||
pany
|
||||
# plam
|
||||
( \( (pfield @"value" #)
|
||||
. (pfield @"resolved" #)
|
||||
. pfromData ->
|
||||
. (pfield @"resolved" #) ->
|
||||
value
|
||||
) ->
|
||||
psymbolValueOf # gstSymbol # value #== 1
|
||||
)
|
||||
# txInfoF.inputs
|
||||
# pfromData txInfoF.inputs
|
||||
|
||||
let toFailedState = unTermCont $ do
|
||||
pguardC "Proposal should fail: not on time" $
|
||||
|
|
|
|||
|
|
@ -30,9 +30,7 @@ module Agora.Proposal.Time (
|
|||
pisMaxTimeRangeWidthValid,
|
||||
) where
|
||||
|
||||
import Agora.Plutarch.Orphans ()
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP (Generic, HasDatatypeInfo, I (I))
|
||||
import Generics.SOP qualified as SOP
|
||||
import Plutarch.Api.V1 (
|
||||
PExtended (PFinite),
|
||||
PInterval (PInterval),
|
||||
|
|
@ -44,7 +42,6 @@ import Plutarch.Api.V1 (
|
|||
import Plutarch.DataRepr (
|
||||
DerivePConstantViaData (..),
|
||||
PDataFields,
|
||||
PIsDataReprInstances (..),
|
||||
)
|
||||
import Plutarch.Extra.Field (pletAllC)
|
||||
import Plutarch.Extra.TermCont (pguardC, pmatchC)
|
||||
|
|
@ -53,10 +50,9 @@ import Plutarch.Lift (
|
|||
PConstantDecl,
|
||||
PUnsafeLiftDecl (..),
|
||||
)
|
||||
import Plutarch.Numeric.Additive (AdditiveSemigroup ((+)))
|
||||
import PlutusLedgerApi.V1.Time (POSIXTime)
|
||||
import PlutusTx qualified
|
||||
import Prelude hiding ((+))
|
||||
import Prelude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -67,8 +63,22 @@ import Prelude hiding ((+))
|
|||
newtype ProposalStartingTime = ProposalStartingTime
|
||||
{ getProposalStartingTime :: POSIXTime
|
||||
}
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
deriving stock (Eq, Show, GHC.Generic)
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
Eq
|
||||
, -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
deriving newtype
|
||||
( -- | @since 0.1.0
|
||||
PlutusTx.ToData
|
||||
, -- | @since 0.1.0
|
||||
PlutusTx.FromData
|
||||
, -- | @since 0.1.0
|
||||
PlutusTx.UnsafeFromData
|
||||
)
|
||||
|
||||
{- | Configuration of proposal timings.
|
||||
|
||||
|
|
@ -92,9 +102,12 @@ data ProposalTimingConfig = ProposalTimingConfig
|
|||
, -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
SOP.Generic
|
||||
)
|
||||
deriving anyclass (Generic)
|
||||
|
||||
PlutusTx.makeIsDataIndexed 'ProposalTimingConfig [('ProposalTimingConfig, 0)]
|
||||
|
||||
|
|
@ -108,7 +121,7 @@ newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
|
|||
, -- | @since 0.1.0
|
||||
Ord
|
||||
, -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
)
|
||||
deriving newtype
|
||||
( -- | @since 0.1.0
|
||||
|
|
@ -154,41 +167,47 @@ data PProposalTime (s :: S) = PProposalTime
|
|||
}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
SOP.Generic
|
||||
, -- | @since 0.1.0
|
||||
SOP.HasDatatypeInfo
|
||||
, -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
HasDatatypeInfo
|
||||
, -- | @since 0.1.0
|
||||
PEq
|
||||
)
|
||||
|
||||
instance DerivePlutusType PProposalTime where
|
||||
type DPTStrat _ = PlutusTypeScott
|
||||
|
||||
-- | Plutarch-level version of 'ProposalStartingTime'.
|
||||
newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime)
|
||||
deriving
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
SOP.Generic
|
||||
, -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
, -- | @since 0.1.0
|
||||
PEq
|
||||
, -- | @since 0.1.0
|
||||
POrd
|
||||
)
|
||||
via (DerivePNewtype PProposalStartingTime PPOSIXTime)
|
||||
|
||||
instance DerivePlutusType PProposalStartingTime where
|
||||
type DPTStrat _ = PlutusTypeNewtype
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PUnsafeLiftDecl PProposalStartingTime where
|
||||
type PLifted PProposalStartingTime = ProposalStartingTime
|
||||
|
||||
deriving via
|
||||
PAsData (DerivePNewtype PProposalStartingTime PPOSIXTime)
|
||||
instance
|
||||
PTryFrom PData (PAsData PProposalStartingTime)
|
||||
instance PTryFrom PData (PAsData PProposalStartingTime)
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
|
|
@ -213,29 +232,25 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
|
|||
)
|
||||
}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
PIsDataRepr
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
SOP.Generic
|
||||
, -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
, -- | @since 0.1.0
|
||||
PDataFields
|
||||
)
|
||||
via (PIsDataReprInstances PProposalTimingConfig)
|
||||
|
||||
instance DerivePlutusType PProposalTimingConfig where
|
||||
type DPTStrat _ = PlutusTypeData
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via PAsData (PIsDataReprInstances PProposalTimingConfig) instance PTryFrom PData (PAsData PProposalTimingConfig)
|
||||
instance PTryFrom PData PProposalTimingConfig
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PUnsafeLiftDecl PProposalTimingConfig where
|
||||
|
|
@ -250,20 +265,30 @@ deriving via
|
|||
-- | Plutarch-level version of 'MaxTimeRangeWidth'.
|
||||
newtype PMaxTimeRangeWidth (s :: S)
|
||||
= PMaxTimeRangeWidth (Term s PPOSIXTime)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
deriving stock
|
||||
( -- | @since 0.2.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.2.0
|
||||
SOP.Generic
|
||||
, -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
, -- | @since 0.1.0
|
||||
PEq
|
||||
, -- | @since 0.2.0
|
||||
PPartialOrd
|
||||
, -- | @since 0.1.0
|
||||
POrd
|
||||
)
|
||||
via (DerivePNewtype PMaxTimeRangeWidth PPOSIXTime)
|
||||
|
||||
instance DerivePlutusType PMaxTimeRangeWidth where
|
||||
type DPTStrat _ = PlutusTypeNewtype
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via PAsData (DerivePNewtype PMaxTimeRangeWidth PPOSIXTime) instance PTryFrom PData (PAsData PMaxTimeRangeWidth)
|
||||
instance PTryFrom PData (PAsData PMaxTimeRangeWidth)
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PUnsafeLiftDecl PMaxTimeRangeWidth where type PLifted PMaxTimeRangeWidth = MaxTimeRangeWidth
|
||||
|
|
|
|||
|
|
@ -31,20 +31,16 @@ module Agora.Stake (
|
|||
pisIrrelevant,
|
||||
) where
|
||||
|
||||
import Agora.Plutarch.Orphans ()
|
||||
import Agora.Proposal (PProposalId, PResultTag, ProposalId (..), ResultTag (..))
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Data.Tagged (Tagged (..))
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP (Generic, HasDatatypeInfo, I (I))
|
||||
import Generics.SOP qualified as SOP
|
||||
import Plutarch.Api.V1 (
|
||||
PMaybeData,
|
||||
PPubKeyHash,
|
||||
)
|
||||
import Plutarch.DataRepr (
|
||||
DerivePConstantViaData (..),
|
||||
PDataFields,
|
||||
PIsDataReprInstances (PIsDataReprInstances),
|
||||
)
|
||||
import Plutarch.Extra.Field (pletAll)
|
||||
import Plutarch.Extra.IsData (
|
||||
|
|
@ -52,7 +48,6 @@ import Plutarch.Extra.IsData (
|
|||
ProductIsData (ProductIsData),
|
||||
)
|
||||
import Plutarch.Extra.List (pnotNull)
|
||||
import Plutarch.Extra.Other (DerivePNewtype' (..))
|
||||
import Plutarch.Extra.Sum (PSum (..))
|
||||
import Plutarch.Extra.Traversable (pfoldMap)
|
||||
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
|
||||
|
|
@ -76,7 +71,7 @@ data Stake = Stake
|
|||
}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
)
|
||||
|
||||
{- | Locks that are stored in the stake datums for various purposes.
|
||||
|
|
@ -133,11 +128,11 @@ data ProposalLock
|
|||
( -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
SOP.Generic
|
||||
)
|
||||
|
||||
PlutusTx.makeIsDataIndexed
|
||||
|
|
@ -176,7 +171,12 @@ data StakeRedeemer
|
|||
DelegateTo PubKeyHash
|
||||
| -- | Revoke the existing delegation.
|
||||
ClearDelegate
|
||||
deriving stock (Show, GHC.Generic)
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
|
||||
PlutusTx.makeIsDataIndexed
|
||||
''StakeRedeemer
|
||||
|
|
@ -208,8 +208,16 @@ data StakeDatum = StakeDatum
|
|||
-- ^ The current proposals locking this stake. This field must be empty
|
||||
-- for the stake to be usable for deposits and withdrawals.
|
||||
}
|
||||
deriving stock (Show, GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
SOP.Generic
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
PlutusTx.ToData
|
||||
|
|
@ -231,34 +239,28 @@ newtype PStakeDatum (s :: S) = PStakeDatum
|
|||
( PDataRecord
|
||||
'[ "stakedAmount" ':= PDiscrete GTTag
|
||||
, "owner" ':= PPubKeyHash
|
||||
, "delegatedTo" ':= PMaybeData PPubKeyHash
|
||||
, "delegatedTo" ':= PMaybeData (PAsData PPubKeyHash)
|
||||
, "lockedBy" ':= PBuiltinList (PAsData PProposalLock)
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
PIsDataRepr
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
SOP.Generic
|
||||
, -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
, -- | @since 0.1.0
|
||||
PDataFields
|
||||
, -- | @since 0.1.0
|
||||
PEq
|
||||
)
|
||||
via (DerivePNewtype' PStakeDatum)
|
||||
|
||||
instance DerivePlutusType PStakeDatum where
|
||||
type DPTStrat _ = PlutusTypeNewtype
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance Plutarch.Lift.PUnsafeLiftDecl PStakeDatum where
|
||||
|
|
@ -271,10 +273,7 @@ deriving via
|
|||
(Plutarch.Lift.PConstantDecl StakeDatum)
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (DerivePNewtype' PStakeDatum)
|
||||
instance
|
||||
PTryFrom PData (PAsData PStakeDatum)
|
||||
instance PTryFrom PData (PAsData PStakeDatum)
|
||||
|
||||
{- | Plutarch-level redeemer for Stake scripts.
|
||||
|
||||
|
|
@ -291,30 +290,23 @@ data PStakeRedeemer (s :: S)
|
|||
| PDelegateTo (Term s (PDataRecord '["pkh" ':= PPubKeyHash]))
|
||||
| PClearDelegate (Term s (PDataRecord '[]))
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
PIsDataRepr
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
SOP.Generic
|
||||
, -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
)
|
||||
via PIsDataReprInstances PStakeRedeemer
|
||||
|
||||
instance DerivePlutusType PStakeRedeemer where
|
||||
type DPTStrat _ = PlutusTypeData
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances PStakeRedeemer)
|
||||
instance
|
||||
PTryFrom PData (PAsData PStakeRedeemer)
|
||||
instance PTryFrom PData PStakeRedeemer
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance Plutarch.Lift.PUnsafeLiftDecl PStakeRedeemer where
|
||||
|
|
@ -331,7 +323,13 @@ deriving via
|
|||
@since 0.2.0
|
||||
-}
|
||||
data PProposalLock (s :: S)
|
||||
= PCreated (Term s (PDataRecord '["created" ':= PProposalId]))
|
||||
= PCreated
|
||||
( Term
|
||||
s
|
||||
( PDataRecord
|
||||
'["created" ':= PProposalId]
|
||||
)
|
||||
)
|
||||
| PVoted
|
||||
( Term
|
||||
s
|
||||
|
|
@ -342,34 +340,30 @@ data PProposalLock (s :: S)
|
|||
)
|
||||
)
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
, -- | @since 0.1.0
|
||||
HasDatatypeInfo
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
PIsDataRepr
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
SOP.Generic
|
||||
, -- | @since 0.1.0
|
||||
SOP.HasDatatypeInfo
|
||||
, -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
, -- | @since 0.1.0
|
||||
PEq
|
||||
)
|
||||
via (PIsDataReprInstances PProposalLock)
|
||||
|
||||
instance DerivePlutusType PProposalLock where
|
||||
type DPTStrat _ = PlutusTypeData
|
||||
|
||||
-- | @since 0.1.0
|
||||
deriving via
|
||||
PAsData (PIsDataReprInstances PProposalLock)
|
||||
instance
|
||||
PTryFrom PData (PAsData PProposalLock)
|
||||
instance PTryFrom PData PProposalLock
|
||||
|
||||
-- | @since 0.2.0
|
||||
instance PTryFrom PData (PAsData PProposalLock)
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance Plutarch.Lift.PUnsafeLiftDecl PProposalLock where
|
||||
|
|
@ -399,9 +393,7 @@ instance PShow PProposalLock where
|
|||
pstakeLocked :: forall (s :: S). Term s (PStakeDatum :--> PBool)
|
||||
pstakeLocked = phoistAcyclic $
|
||||
plam $ \stakeDatum ->
|
||||
let locks :: Term _ (PBuiltinList (PAsData PProposalLock))
|
||||
locks = pfield @"lockedBy" # stakeDatum
|
||||
in pnotNull # locks
|
||||
pnotNull #$ pfield @"lockedBy" @(PBuiltinList _) # pto stakeDatum
|
||||
|
||||
{- | Get the number of *alive* proposals that were created by the given stake.
|
||||
|
||||
|
|
@ -439,19 +431,22 @@ data PStakeRole (s :: S)
|
|||
PIrrelevant
|
||||
deriving stock
|
||||
( -- | @since 0.2.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.2.0
|
||||
Generic
|
||||
SOP.Generic
|
||||
, -- | @since 0.2.0
|
||||
PlutusType
|
||||
, -- | @since 0.2.0
|
||||
HasDatatypeInfo
|
||||
SOP.HasDatatypeInfo
|
||||
, -- | @since 0.2.0
|
||||
PEq
|
||||
)
|
||||
|
||||
instance DerivePlutusType PStakeRole where
|
||||
type DPTStrat _ = PlutusTypeScott
|
||||
|
||||
{- | Retutn true if the stake was used to voted on the proposal.
|
||||
|
||||
@since 0.2.0
|
||||
|
|
|
|||
|
|
@ -19,9 +19,9 @@ import Agora.Utils (
|
|||
mustFindDatum',
|
||||
pdjust,
|
||||
pdnothing,
|
||||
pmaybeData,
|
||||
pvalidatorHashToTokenName,
|
||||
)
|
||||
import Data.Default (def)
|
||||
import Data.Function (on)
|
||||
import Data.Tagged (Tagged (..), untag)
|
||||
import Plutarch.Api.V1 (
|
||||
|
|
@ -106,7 +106,11 @@ stakePolicy gtClassRef =
|
|||
pure $
|
||||
pif
|
||||
(psymbolValueOf # ownSymbol # txOutF.value #== 1)
|
||||
( let datum = mustFindDatum' @PStakeDatum # txOutF.datumHash # txInfoF.datums
|
||||
( let datum =
|
||||
pfromData $
|
||||
mustFindDatum' @(PAsData PStakeDatum)
|
||||
# txOutF.datumHash
|
||||
# txInfoF.datums
|
||||
in pnot # (pstakeLocked # datum)
|
||||
)
|
||||
(pconstant False)
|
||||
|
|
@ -146,7 +150,9 @@ stakePolicy gtClassRef =
|
|||
pletFieldsC @'["value", "address", "datumHash"] scriptOutputWithStakeST
|
||||
datumF <-
|
||||
pletFieldsC @'["owner", "stakedAmount"] $
|
||||
mustFindDatum' @PStakeDatum # outputF.datumHash # txInfoF.datums
|
||||
pto $
|
||||
pfromData $
|
||||
mustFindDatum' @(PAsData PStakeDatum) # outputF.datumHash # txInfoF.datums
|
||||
|
||||
let hasExpectedStake =
|
||||
ptraceIfFalse "Stake ouput has expected amount of stake token" $
|
||||
|
|
@ -232,12 +238,12 @@ stakeValidator stake =
|
|||
]
|
||||
txInfo
|
||||
|
||||
(pfromData -> stakeRedeemer, _) <- ptryFromC redeemer
|
||||
stakeRedeemer <- fst <$> ptryFromC redeemer
|
||||
|
||||
-- TODO: Use PTryFrom
|
||||
let stakeDatum' :: Term _ PStakeDatum
|
||||
stakeDatum' = pfromData $ punsafeCoerce datum
|
||||
stakeDatum <- pletAllC stakeDatum'
|
||||
stakeDatum <- pletAllC $ pto stakeDatum'
|
||||
|
||||
PSpending txOutRef <- pmatchC $ pfromData ctx.purpose
|
||||
|
||||
|
|
@ -253,16 +259,16 @@ stakeValidator stake =
|
|||
|
||||
ownerSignsTransaction <- pletC $ signedBy # stakeDatum.owner
|
||||
delegateSignsTransaction <-
|
||||
pletC $
|
||||
pmaybeData # pconstant False
|
||||
# plam ((signedBy #) . pdata)
|
||||
# stakeDatum.delegatedTo
|
||||
pletC $ pconstant False
|
||||
-- pmaybeData # pconstant False
|
||||
-- # plam (signedBy #)
|
||||
-- # stakeDatum.delegatedTo
|
||||
|
||||
stCurrencySymbol <-
|
||||
pletC $
|
||||
pconstant $
|
||||
mintingPolicySymbol $
|
||||
mkMintingPolicy (stakePolicy stake.gtClassRef)
|
||||
mkMintingPolicy def (stakePolicy stake.gtClassRef)
|
||||
mintedST <- pletC $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
|
||||
valueSpent <- pletC $ pvalueSpent # txInfoF.inputs
|
||||
spentST <- pletC $ psymbolValueOf # stCurrencySymbol #$ valueSpent
|
||||
|
|
@ -340,10 +346,10 @@ stakeValidator stake =
|
|||
)
|
||||
# pfromData txInfoF.inputs
|
||||
|
||||
sortTxOuts :: Term _ (PBuiltinList (PAsData PTxOut) :--> PBuiltinList (PAsData PTxOut))
|
||||
sortTxOuts :: Term _ (PBuiltinList PTxOut :--> PBuiltinList PTxOut)
|
||||
sortTxOuts = phoistAcyclic $ plam (pmsortBy # plam ((#<) `on` (getDatumHash #)) #)
|
||||
where
|
||||
getDatumHash :: Term _ (PAsData PTxOut :--> PDatumHash)
|
||||
getDatumHash :: Term _ (PTxOut :--> PDatumHash)
|
||||
getDatumHash = phoistAcyclic $ plam ((pfromDJust #) . pfromData . (pfield @"datumHash" #))
|
||||
|
||||
sortedOwnInputs = sortTxOuts # ownInputs
|
||||
|
|
@ -360,13 +366,14 @@ stakeValidator stake =
|
|||
pguardC "ST at inputs must be 1" $
|
||||
spentST #== 1
|
||||
|
||||
ownOutput <- pletC $ pfromData $ phead # ownOutputs
|
||||
ownOutput <- pletC $ phead # ownOutputs
|
||||
|
||||
stakeOut <-
|
||||
pletC $
|
||||
mustFindDatum' @PStakeDatum
|
||||
# (pfield @"datumHash" # ownOutput)
|
||||
# txInfoF.datums
|
||||
pfromData $
|
||||
mustFindDatum' @(PAsData PStakeDatum)
|
||||
# (pfield @"datumHash" # ownOutput)
|
||||
# txInfoF.datums
|
||||
|
||||
ownOutputValue <-
|
||||
pletC $
|
||||
|
|
@ -384,7 +391,7 @@ stakeValidator stake =
|
|||
( #stakedAmount .= stakeDatum.stakedAmount
|
||||
.& #owner .= stakeDatum.owner
|
||||
.& #delegatedTo .= stakeDatum.delegatedTo
|
||||
.& #lockedBy .= pfield @"lockedBy" # stakeOut
|
||||
.& #lockedBy .= pfield @"lockedBy" # pto stakeOut
|
||||
)
|
||||
in stakeOut #== templateStakeDatum
|
||||
|
||||
|
|
@ -524,7 +531,7 @@ stakeValidator stake =
|
|||
pguardC "Cannot delegate to the owner" $
|
||||
pnot #$ stakeDatum.owner #== pkh
|
||||
|
||||
pure $ setDelegate #$ pdjust # pkh
|
||||
pure $ setDelegate #$ pdjust # pdata pkh
|
||||
------------------------------------------------------------
|
||||
|
||||
PClearDelegate _ ->
|
||||
|
|
|
|||
|
|
@ -11,14 +11,16 @@ treasury.
|
|||
module Agora.Treasury (module Agora.Treasury) where
|
||||
|
||||
import Agora.AuthorityToken (singleAuthorityTokenBurned)
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP (Generic)
|
||||
import Generics.SOP qualified as SOP
|
||||
import Plutarch.Api.V1 (PValidator)
|
||||
import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting))
|
||||
import "plutarch" Plutarch.Api.V1.Value (PValue)
|
||||
import Plutarch.Builtin (pforgetData)
|
||||
import Plutarch.Extra.IsData (DerivePConstantViaEnum (..), EnumIsData (..))
|
||||
import Plutarch.Extra.Other (DerivePNewtype' (..))
|
||||
import Plutarch.Extra.IsData (
|
||||
DerivePConstantViaEnum (..),
|
||||
EnumIsData (..),
|
||||
PlutusTypeEnumData,
|
||||
)
|
||||
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC)
|
||||
import Plutarch.Lift (PConstantDecl (..), PLifted (..), PUnsafeLiftDecl)
|
||||
import Plutarch.TryFrom ()
|
||||
|
|
@ -38,7 +40,7 @@ data TreasuryRedeemer
|
|||
, -- | @since 0.1.0
|
||||
Show
|
||||
, -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
, -- | @since 0.2.0
|
||||
Enum
|
||||
, -- | @since 0.2.0
|
||||
|
|
@ -46,7 +48,7 @@ data TreasuryRedeemer
|
|||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.2.0
|
||||
Generic
|
||||
SOP.Generic
|
||||
)
|
||||
deriving
|
||||
( -- | @since 0.1.0
|
||||
|
|
@ -63,23 +65,29 @@ data TreasuryRedeemer
|
|||
|
||||
@since 0.1.0
|
||||
-}
|
||||
newtype PTreasuryRedeemer (s :: S)
|
||||
= PTreasuryRedeemer (Term s PInteger)
|
||||
data PTreasuryRedeemer (s :: S)
|
||||
= PSpendTreasuryGAT
|
||||
deriving stock
|
||||
( -- | @since 0.1.0
|
||||
GHC.Generic
|
||||
Generic
|
||||
, -- | @since 0.2.0
|
||||
Bounded
|
||||
, -- | @since 0.2.0
|
||||
Enum
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
Generic
|
||||
SOP.Generic
|
||||
)
|
||||
deriving
|
||||
deriving anyclass
|
||||
( -- | @since 0.1.0
|
||||
PlutusType
|
||||
, -- | @since 0.1.0
|
||||
PIsData
|
||||
)
|
||||
via (DerivePNewtype' PTreasuryRedeemer)
|
||||
|
||||
instance DerivePlutusType PTreasuryRedeemer where
|
||||
type DPTStrat _ = PlutusTypeEnumData
|
||||
|
||||
-- | @since 0.1.0
|
||||
instance PUnsafeLiftDecl PTreasuryRedeemer where
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE QuantifiedConstraints #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
|
||||
{- |
|
||||
Module : Agora.Utils
|
||||
|
|
@ -30,6 +31,7 @@ module Agora.Utils (
|
|||
pdnothing,
|
||||
) where
|
||||
|
||||
import Data.Default (Default (def))
|
||||
import Plutarch.Api.V1 (
|
||||
AmountGuarantees,
|
||||
KeyGuarantees,
|
||||
|
|
@ -139,7 +141,7 @@ pvalidatorHashToTokenName vh = pcon (PTokenName (pto vh))
|
|||
@since 0.1.0
|
||||
-}
|
||||
getMintingPolicySymbol :: ClosedTerm PMintingPolicy -> CurrencySymbol
|
||||
getMintingPolicySymbol v = mintingPolicySymbol $ mkMintingPolicy v
|
||||
getMintingPolicySymbol v = mintingPolicySymbol $ mkMintingPolicy def v
|
||||
|
||||
{- | The entire value only contains one token of the given currency symbol.
|
||||
|
||||
|
|
@ -159,7 +161,7 @@ hasOnlyOneTokenOfCurrencySymbol = phoistAcyclic $
|
|||
-}
|
||||
mustFindDatum' ::
|
||||
forall (datum :: PType).
|
||||
(PIsData datum, PTryFrom PData (PAsData datum)) =>
|
||||
(PIsData datum, PTryFrom PData datum) =>
|
||||
forall s.
|
||||
Term
|
||||
s
|
||||
|
|
@ -172,7 +174,7 @@ mustFindDatum' = phoistAcyclic $
|
|||
let dh = mustBePDJust # "Given TxOut dones't have a datum" # mdh
|
||||
dt = mustBePJust # "Datum not found in the transaction" #$ plookupTuple # dh # datums
|
||||
(d, _) <- ptryFromC $ pforgetData $ pdata dt
|
||||
pure $ pfromData d
|
||||
pure d
|
||||
|
||||
{- | Extract the value stored in a PMaybe container.
|
||||
If there's no value, throw an error with the given message.
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue