Sulkta-Coop/agora
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

fix compilation errors

Browse source
This commit is contained in:
Hongrui Fang 2022-08-03 20:59:37 +08:00
parent 14aacf206f
commit f248dbab49
No known key found for this signature in database
GPG key ID: 1E0454204FC7D755
36 changed files with 1325 additions and 1271 deletions
Download patch file Download diff file Expand all files Collapse all files

1
agora-bench/Bench.hs
View file

@ -8,7 +8,6 @@ import Data.ByteString.Short qualified as SBS
import Data.Csv (DefaultOrdered, ToNamedRecord, header, headerOrder, namedRecord, toNamedRecord, (.=)) import Data.Csv (DefaultOrdered, ToNamedRecord, header, headerOrder, namedRecord, toNamedRecord, (.=))
import Data.List (intercalate) import Data.List (intercalate)
import Data.Text (Text, pack) import Data.Text (Text, pack)
import GHC.Generics (Generic)
import Plutarch.Evaluate (evalScript) import Plutarch.Evaluate (evalScript)
import PlutusLedgerApi.V1 ( import PlutusLedgerApi.V1 (
ExBudget (ExBudget), ExBudget (ExBudget),

7
agora-scripts/Main.hs
View file

@ -107,7 +107,12 @@ agoraScripts params =
governorSTAssetClass :: AssetClass governorSTAssetClass :: AssetClass
governorSTAssetClass = governorSTAssetClass =
Value.assetClass (mintingPolicySymbol $ mkMintingPolicy $ governorPolicy governor) "" Value.assetClass
( mintingPolicySymbol $
mkMintingPolicy def $
governorPolicy governor
)
""
proposal :: Proposal proposal :: Proposal
proposal = proposalFromGovernor governor proposal = proposalFromGovernor governor

12
agora-specs/Property/Generator.hs
View file

@ -114,8 +114,10 @@ genInput = do
val <- genSingletonValue val <- genSingletonValue
return $ return $
input $ input $
credential cred mconcat
. withValue val [ credential cred
, withValue val
]
genOutput :: Builder a => Gen a genOutput :: Builder a => Gen a
genOutput = do genOutput = do
@ -123,8 +125,10 @@ genOutput = do
val <- genSingletonValue val <- genSingletonValue
return $ return $
output $ output $
credential cred mconcat
. withValue val [ credential cred
, withValue val
]
genOutRef :: Gen TxOutRef genOutRef :: Gen TxOutRef
genOutRef = do genOutRef = do

8
agora-specs/Property/Governor.hs
View file

@ -157,7 +157,13 @@ governorMintingProperty =
-} -}
gst = assetClassValue govAssetClass 1 gst = assetClassValue govAssetClass 1
mintAmount x = mint . mconcat $ replicate x gst 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 referencedInput = input $ withOutRef gstUTXORef
govDatum :: GovernorDatum govDatum :: GovernorDatum

2
agora-specs/Sample/Effect/GovernorMutation.hs
View file

@ -51,7 +51,7 @@ import Test.Util (datumPair, toDatumHash)
-- | The effect validator instance. -- | The effect validator instance.
effectValidator :: Validator effectValidator :: Validator
effectValidator = mkValidator $ mutateGovernorValidator governor effectValidator = mkValidator def $ mutateGovernorValidator governor
-- | The hash of the validator instance. -- | The hash of the validator instance.
effectValidatorHash :: ValidatorHash effectValidatorHash :: ValidatorHash

3
agora-specs/Sample/Effect/TreasuryWithdrawal.hs
View file

@ -23,6 +23,7 @@ import Agora.Effect.TreasuryWithdrawal (
TreasuryWithdrawalDatum (TreasuryWithdrawalDatum), TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
treasuryWithdrawalValidator, treasuryWithdrawalValidator,
) )
import Data.Default (def)
import Plutarch.Api.V1 (mkValidator, validatorHash) import Plutarch.Api.V1 (mkValidator, validatorHash)
import PlutusLedgerApi.V1 ( import PlutusLedgerApi.V1 (
Address (Address), Address (Address),
@ -147,7 +148,7 @@ buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs _) = f <$> xs
-- | Effect validator instance. -- | Effect validator instance.
validator :: Validator validator :: Validator
validator = mkValidator $ treasuryWithdrawalValidator currSymbol validator = mkValidator def $ treasuryWithdrawalValidator currSymbol
-- | 'TokenName' that represents the hash of the 'Agora.Stake.Stake' validator. -- | 'TokenName' that represents the hash of the 'Agora.Stake.Stake' validator.
validatorHashTN :: TokenName validatorHashTN :: TokenName

26
agora-specs/Sample/Governor/Initialize.hs
View file

@ -114,7 +114,7 @@ govValidatorHash :: ValidatorHash
govValidatorHash = governorValidatorHash governor govValidatorHash = governorValidatorHash governor
govPolicy :: MintingPolicy govPolicy :: MintingPolicy
govPolicy = mkMintingPolicy (governorPolicy governor) govPolicy = mkMintingPolicy def (governorPolicy governor)
govSymbol :: CurrencySymbol govSymbol :: CurrencySymbol
govSymbol = mintingPolicySymbol govPolicy govSymbol = mintingPolicySymbol govPolicy
@ -169,12 +169,16 @@ mintGST ps = builder
then then
mconcat mconcat
[ input $ [ input $
pubKey witnessPubKey mconcat
. withValue witnessValue [ pubKey witnessPubKey
. withOutRef witnessRef , withValue witnessValue
, withOutRef witnessRef
]
, output $ , output $
pubKey witnessPubKey mconcat
. withValue witnessValue [ pubKey witnessPubKey
, withValue witnessValue
]
] ]
else mempty else mempty
@ -184,11 +188,13 @@ mintGST ps = builder
let datum = let datum =
if ps.withGovernorDatum if ps.withGovernorDatum
then withDatum governorOutputDatum then withDatum governorOutputDatum
else id else mempty
in output $ in output $
script govValidatorHash mconcat
. withValue governorValue [ script govValidatorHash
. datum , withValue governorValue
, datum
]
-- --
builder = builder =
mconcat mconcat

36
agora-specs/Sample/Governor/Mutate.hs
View file

@ -49,7 +49,7 @@ import Sample.Shared (
minAda, minAda,
) )
import Test.Specification (SpecificationTree, testValidator) 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 then pubKey $ head pubKeyHashes
else script govValidatorHash else script govValidatorHash
withGSTDatum = withGSTDatum =
withOptional withDatum $ maybe mempty withDatum $
mkGovernorOutputDatum ps.governorOutputDatumValidity mkGovernorOutputDatum ps.governorOutputDatumValidity
in mconcat in mconcat
[ input $ [ input $
script govValidatorHash mconcat
. withDatum governorInputDatum [ script govValidatorHash
. withValue value , withDatum governorInputDatum
. withOutRef governorRef , withValue value
, withOutRef governorRef
]
, output $ , output $
gstOutput mconcat
. withGSTDatum [ gstOutput
. withValue value , withGSTDatum
, withValue value
]
] ]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -162,7 +166,7 @@ mockEffectValidator :: ClosedTerm PValidator
mockEffectValidator = noOpValidator authorityTokenSymbol mockEffectValidator = noOpValidator authorityTokenSymbol
mockEffectValidatorHash :: ValidatorHash mockEffectValidatorHash :: ValidatorHash
mockEffectValidatorHash = validatorHash $ mkValidator mockEffectValidator mockEffectValidatorHash = validatorHash $ mkValidator def mockEffectValidator
mkGATValue :: GATValidity -> Integer -> Value mkGATValue :: GATValidity -> Integer -> Value
mkGATValue NoGAT _ = mempty mkGATValue NoGAT _ = mempty
@ -187,11 +191,15 @@ mkMockEffectBuilder ps =
in mconcat in mconcat
[ mint burnt [ mint burnt
, input $ , input $
script mockEffectValidatorHash mconcat
. withValue inputValue [ script mockEffectValidatorHash
, withValue inputValue
]
, output $ , output $
script mockEffectValidatorHash mconcat
. withValue outputValue [ script mockEffectValidatorHash
, withValue outputValue
]
] ]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

64
agora-specs/Sample/Proposal/Advance.hs
View file

@ -321,14 +321,18 @@ mkProposalBuilder ps =
value = sortValue $ minAda <> pst value = sortValue $ minAda <> pst
in mconcat in mconcat
[ input $ [ input $
script proposalValidatorHash mconcat
. withOutRef proposalRef [ script proposalValidatorHash
. withDatum (mkProposalInputDatum ps) , withOutRef proposalRef
. withValue value , withDatum (mkProposalInputDatum ps)
, withValue value
]
, output $ , output $
script proposalValidatorHash mconcat
. withDatum (mkProposalOutputDatum ps) [ script proposalValidatorHash
. withValue value , withDatum (mkProposalOutputDatum ps)
, withValue value
]
] ]
{- | The proposal redeemer used to spend the proposal UTXO, which is always {- | The proposal redeemer used to spend the proposal UTXO, which is always
@ -400,14 +404,18 @@ mkStakeBuilder ps =
in mconcat in mconcat
[ withSig [ withSig
, input $ , input $
script stakeValidatorHash mconcat
. withOutRef (mkStakeRef idx) [ script stakeValidatorHash
. withValue perStakeValue , withOutRef (mkStakeRef idx)
. withDatum i , withValue perStakeValue
, withDatum i
]
, output $ , output $
script stakeValidatorHash mconcat
. withValue perStakeValue [ script stakeValidatorHash
. withDatum o , withValue perStakeValue
, withDatum o
]
] ]
in mconcat $ in mconcat $
zipWith3 zipWith3
@ -457,15 +465,19 @@ mkGovernorBuilder ps =
value = sortValue $ gst <> minAda value = sortValue $ gst <> minAda
in mconcat in mconcat
[ input $ [ input $
script govValidatorHash mconcat
. withValue value [ script govValidatorHash
. withOutRef governorRef , withValue value
. withDatum governorInputDatum , withOutRef governorRef
, withDatum governorInputDatum
]
, output $ , output $
script govValidatorHash mconcat
. withValue value [ script govValidatorHash
. withOutRef governorRef , withValue value
. withDatum (mkGovernorOutputDatum ps) , withOutRef governorRef
, withDatum (mkGovernorOutputDatum ps)
]
] ]
{- | The proposal redeemer used to spend the governor UTXO, which is always {- | The proposal redeemer used to spend the governor UTXO, which is always
@ -501,9 +513,11 @@ mkAuthorityTokenBuilder (AuthorityTokenParameters es mdt invalidTokenName) =
in mconcat in mconcat
[ mint minted [ mint minted
, output $ , output $
script vh mconcat
. maybe id withDatum mdt [ script vh
. withValue value , maybe mempty withDatum mdt
, withValue value
]
] ]
-- | The redeemer used while running the authority token policy. -- | The redeemer used while running the authority token policy.

40
agora-specs/Sample/Proposal/Cosign.hs
View file

@ -162,15 +162,19 @@ cosign ps = builder
else stakeDatum else stakeDatum
in mconcat in mconcat
[ input $ [ input $
script stakeValidatorHash mconcat
. withValue stakeValue [ script stakeValidatorHash
. withDatum stakeDatum , withValue stakeValue
. withTxId stakeTxRef , withDatum stakeDatum
. withOutRef (mkStakeRef refIdx) , withTxId stakeTxRef
, withOutRef (mkStakeRef refIdx)
]
, output $ , output $
script stakeValidatorHash mconcat
. withValue stakeValue [ script stakeValidatorHash
. withDatum stakeOutputDatum , withValue stakeValue
, withDatum stakeOutputDatum
]
, signedWith stakeDatum.owner , signedWith stakeDatum.owner
] ]
) )
@ -189,15 +193,19 @@ cosign ps = builder
proposalBuilder = proposalBuilder =
mconcat mconcat
[ input $ [ input $
script proposalValidatorHash mconcat
. withValue pst [ script proposalValidatorHash
. withDatum proposalInputDatum , withValue pst
. withTxId proposalTxRef , withDatum proposalInputDatum
. withOutRef proposalRef , withTxId proposalTxRef
, withOutRef proposalRef
]
, output $ , output $
script proposalValidatorHash mconcat
. withValue (sortValue (pst <> minAda)) [ script proposalValidatorHash
. withDatum proposalOutputDatum , withValue (sortValue (pst <> minAda))
, withDatum proposalOutputDatum
]
] ]
validTimeRange :: POSIXTimeRange validTimeRange :: POSIXTimeRange

44
agora-specs/Sample/Proposal/Create.hs
View file

@ -302,29 +302,39 @@ createProposal ps = builder
, --- , ---
timeRange $ mkTimeRange ps timeRange $ mkTimeRange ps
, input $ , input $
script govValidatorHash mconcat
. withValue governorValue [ script govValidatorHash
. withDatum governorInputDatum , withValue governorValue
. withOutRef governorRef , withDatum governorInputDatum
, withOutRef governorRef
]
, output $ , output $
script govValidatorHash mconcat
. withValue governorValue [ script govValidatorHash
. withDatum (mkGovernorOutputDatum ps) , withValue governorValue
, withDatum (mkGovernorOutputDatum ps)
]
, --- , ---
input $ input $
script stakeValidatorHash mconcat
. withValue stakeValue [ script stakeValidatorHash
. withDatum (mkStakeInputDatum ps) , withValue stakeValue
. withOutRef stakeRef , withDatum (mkStakeInputDatum ps)
, withOutRef stakeRef
]
, output $ , output $
script stakeValidatorHash mconcat
. withValue stakeValue [ script stakeValidatorHash
. withDatum (mkStakeOutputDatum ps) , withValue stakeValue
, withDatum (mkStakeOutputDatum ps)
]
, --- , ---
output $ output $
script proposalValidatorHash mconcat
. withValue proposalValue [ script proposalValidatorHash
. withDatum (mkProposalOutputDatum ps) , withValue proposalValue
, withDatum (mkProposalOutputDatum ps)
]
] ]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

36
agora-specs/Sample/Proposal/UnlockStake.hs
View file

@ -257,14 +257,18 @@ unlockStake ps =
( \((i, o), idx) -> ( \((i, o), idx) ->
mconcat mconcat
[ input $ [ input $
script proposalValidatorHash mconcat
. withValue pst [ script proposalValidatorHash
. withDatum i , withValue pst
. withOutRef (mkProposalRef idx) , withDatum i
, withOutRef (mkProposalRef idx)
]
, output $ , output $
script proposalValidatorHash mconcat
. withValue (sortValue $ pst <> minAda) [ script proposalValidatorHash
. withDatum o , withValue (sortValue $ pst <> minAda)
, withDatum o
]
] ]
) )
(zip pIODatums [0 ..]) (zip pIODatums [0 ..])
@ -285,14 +289,18 @@ unlockStake ps =
stakes = stakes =
mconcat mconcat
[ input $ [ input $
script stakeValidatorHash mconcat
. withValue stakeValue [ script stakeValidatorHash
. withDatum sInDatum , withValue stakeValue
. withOutRef stakeRef , withDatum sInDatum
, withOutRef stakeRef
]
, output $ , output $
script stakeValidatorHash mconcat
. withValue stakeValue [ script stakeValidatorHash
. withDatum sOutDatum , withValue stakeValue
, withDatum sOutDatum
]
] ]
builder = builder =

36
agora-specs/Sample/Proposal/Vote.hs
View file

@ -219,23 +219,31 @@ vote params =
, signedWith signer , signedWith signer
, timeRange validTimeRange , timeRange validTimeRange
, input $ , input $
script proposalValidatorHash mconcat
. withValue pst [ script proposalValidatorHash
. withDatum proposalInputDatum , withValue pst
. withOutRef proposalRef , withDatum proposalInputDatum
, withOutRef proposalRef
]
, input $ , input $
script stakeValidatorHash mconcat
. withValue stakeValue [ script stakeValidatorHash
. withDatum stakeInputDatum , withValue stakeValue
. withOutRef stakeRef , withDatum stakeInputDatum
, withOutRef stakeRef
]
, output $ , output $
script proposalValidatorHash mconcat
. withValue pst [ script proposalValidatorHash
. withDatum proposalOutputDatum , withValue pst
, withDatum proposalOutputDatum
]
, output $ , output $
script stakeValidatorHash mconcat
. withValue stakeValue [ script stakeValidatorHash
. withDatum stakeOutputDatum , withValue stakeValue
, withDatum stakeOutputDatum
]
] ]
in builder in builder

8
agora-specs/Sample/Shared.hs
View file

@ -141,10 +141,10 @@ governor = Governor oref gt mc
mc = 20 mc = 20
govPolicy :: MintingPolicy govPolicy :: MintingPolicy
govPolicy = mkMintingPolicy (governorPolicy governor) govPolicy = mkMintingPolicy def (governorPolicy governor)
govValidator :: Validator govValidator :: Validator
govValidator = mkValidator (governorValidator governor) govValidator = mkValidator def (governorValidator governor)
govSymbol :: CurrencySymbol govSymbol :: CurrencySymbol
govSymbol = mintingPolicySymbol govPolicy govSymbol = mintingPolicySymbol govPolicy
@ -239,7 +239,7 @@ gatCs :: CurrencySymbol
gatCs = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" gatCs = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
trValidator :: Validator trValidator :: Validator
trValidator = mkValidator (treasuryValidator gatCs) trValidator = mkValidator def (treasuryValidator gatCs)
-- | `ScriptCredential` used for the dummy treasury validator. -- | `ScriptCredential` used for the dummy treasury validator.
trCredential :: Credential trCredential :: Credential
@ -251,7 +251,7 @@ gatTn = validatorHashToTokenName $ validatorHash mockTrEffect
-- | Mock treasury effect script, used for testing. -- | Mock treasury effect script, used for testing.
mockTrEffect :: Validator mockTrEffect :: Validator
mockTrEffect = mkValidator $ noOpValidator gatCs mockTrEffect = mkValidator def $ noOpValidator gatCs
-- | Mock treasury effect validator hash -- | Mock treasury effect validator hash
mockTrEffectHash :: ValidatorHash mockTrEffectHash :: ValidatorHash

32
agora-specs/Sample/Stake.hs
View file

@ -26,6 +26,7 @@ import Agora.Stake (
StakeDatum (StakeDatum, stakedAmount), StakeDatum (StakeDatum, stakedAmount),
) )
import Agora.Stake.Scripts (stakeValidator) import Agora.Stake.Scripts (stakeValidator)
import Data.Default (def)
import Data.Tagged (Tagged, untag) import Data.Tagged (Tagged, untag)
import Plutarch.Api.V1 (mkValidator, validatorHash) import Plutarch.Api.V1 (mkValidator, validatorHash)
import Plutarch.Context ( import Plutarch.Context (
@ -69,7 +70,10 @@ import Sample.Shared (
-- | 'TokenName' that represents the hash of the 'Stake' validator. -- | 'TokenName' that represents the hash of the 'Stake' validator.
validatorHashTN :: TokenName 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. -- | This script context should be a valid transaction.
stakeCreation :: ScriptContext stakeCreation :: ScriptContext
@ -85,9 +89,11 @@ stakeCreation =
, signedWith signer , signedWith signer
, mint st , mint st
, output $ , output $
script stakeValidatorHash mconcat
. withValue (st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242) [ script stakeValidatorHash
. withDatum datum , withValue (st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242)
, withDatum datum
]
, withMinting stakeSymbol , withMinting stakeSymbol
] ]
in buildMintingUnsafe builder in buildMintingUnsafe builder
@ -143,14 +149,18 @@ stakeDepositWithdraw config =
, signedWith signer , signedWith signer
, mint st , mint st
, input $ , input $
script stakeValidatorHash mconcat
. withValue (st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount)) [ script stakeValidatorHash
. withDatum stakeAfter , withValue (st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount))
. withOutRef stakeRef , withDatum stakeAfter
, withOutRef stakeRef
]
, output $ , output $
script stakeValidatorHash mconcat
. withValue (st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)) [ script stakeValidatorHash
. withDatum stakeAfter , withValue (st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount))
, withDatum stakeAfter
]
, withSpendingOutRef stakeRef , withSpendingOutRef stakeRef
] ]
in buildSpendingUnsafe builder in buildSpendingUnsafe builder

18
agora-specs/Sample/Stake/SetDelegate.hs
View file

@ -129,14 +129,18 @@ setDelegate ps = buildSpendingUnsafe builder
[ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" [ txId "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
, signedWith signer , signedWith signer
, input $ , input $
script stakeValidatorHash mconcat
. withValue stakeValue [ script stakeValidatorHash
. withDatum stakeInput , withValue stakeValue
. withOutRef stakeRef , withDatum stakeInput
, withOutRef stakeRef
]
, output $ , output $
script stakeValidatorHash mconcat
. withValue stakeValue [ script stakeValidatorHash
. withDatum stakeOutput , withValue stakeValue
, withDatum stakeOutput
]
, withSpendingOutRef stakeRef , withSpendingOutRef stakeRef
] ]

28
agora-specs/Sample/Treasury.hs
View file

@ -19,7 +19,6 @@ module Sample.Treasury (
import Plutarch.Context ( import Plutarch.Context (
MintingBuilder, MintingBuilder,
UTXO,
buildMintingUnsafe, buildMintingUnsafe,
credential, credential,
input, input,
@ -57,11 +56,12 @@ import Sample.Shared (
baseCtxBuilder :: MintingBuilder baseCtxBuilder :: MintingBuilder
baseCtxBuilder = baseCtxBuilder =
let treasury :: UTXO -> UTXO let treasury =
treasury = mconcat
credential trCredential [ credential trCredential
. withValue minAda , withValue minAda
. withTxId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" , withTxId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
]
in mconcat in mconcat
[ txId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" [ txId "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
, signedWith signer , signedWith signer
@ -81,9 +81,11 @@ validCtx =
mconcat mconcat
[ baseCtxBuilder [ baseCtxBuilder
, input $ , input $
script mockTrEffectHash mconcat
. withValue (Value.singleton gatCs gatTn 1 <> minAda) [ script mockTrEffectHash
. withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3" , withValue (Value.singleton gatCs gatTn 1 <> minAda)
, withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
]
] ]
in buildMintingUnsafe builder in buildMintingUnsafe builder
@ -122,8 +124,10 @@ trCtxGATNameNotAddress =
mconcat mconcat
[ baseCtxBuilder [ baseCtxBuilder
, input $ , input $
script wrongEffHash mconcat
. withValue (Value.singleton gatCs gatTn 1 <> minAda) [ script wrongEffHash
. withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3" , withValue (Value.singleton gatCs gatTn 1 <> minAda)
, withTxId "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
]
] ]
in buildMintingUnsafe builder in buildMintingUnsafe builder

5
agora-specs/Spec/AuthorityToken.hs
View file

@ -10,7 +10,8 @@ Tests for Authority token functions
module Spec.AuthorityToken (specs) where module Spec.AuthorityToken (specs) where
import Agora.AuthorityToken (singleAuthorityTokenBurned) 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 Plutarch.Unsafe (punsafeCoerce)
import PlutusLedgerApi.V1 ( import PlutusLedgerApi.V1 (
Address (Address), Address (Address),
@ -60,7 +61,7 @@ singleAuthorityTokenBurnedTest mint outs =
actual actual
(popaque (pconstant ())) (popaque (pconstant ()))
perror perror
in compile s in mustCompile s
-- | The SpecificationTree exported by this module. -- | The SpecificationTree exported by this module.
specs :: [SpecificationTree] specs :: [SpecificationTree]

9
agora-testlib/Test/Specification.hs
View file

@ -52,6 +52,7 @@ module Test.Specification (
import Plutarch.Api.V1 (PMintingPolicy, PValidator) import Plutarch.Api.V1 (PMintingPolicy, PValidator)
import Plutarch.Builtin (pforgetData) import Plutarch.Builtin (pforgetData)
import Plutarch.Evaluate (evalScript) import Plutarch.Evaluate (evalScript)
import Plutarch.Extra.Compile (mustCompile)
import Plutarch.Lift (PUnsafeLiftDecl (PLifted)) import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
import PlutusLedgerApi.V1 (Script, ScriptContext) import PlutusLedgerApi.V1 (Script, ScriptContext)
import PlutusTx.IsData qualified as PlutusTx (ToData) import PlutusTx.IsData qualified as PlutusTx (ToData)
@ -164,7 +165,7 @@ policySucceedsWith ::
SpecificationTree SpecificationTree
policySucceedsWith tag policy redeemer scriptContext = policySucceedsWith tag policy redeemer scriptContext =
scriptSucceeds tag $ scriptSucceeds tag $
compile mustCompile
( policy ( policy
# pforgetData (pconstantData redeemer) # pforgetData (pconstantData redeemer)
# pconstant scriptContext # pconstant scriptContext
@ -182,7 +183,7 @@ policyFailsWith ::
SpecificationTree SpecificationTree
policyFailsWith tag policy redeemer scriptContext = policyFailsWith tag policy redeemer scriptContext =
scriptFails tag $ scriptFails tag $
compile mustCompile
( policy ( policy
# pforgetData (pconstantData redeemer) # pforgetData (pconstantData redeemer)
# pconstant scriptContext # pconstant scriptContext
@ -203,7 +204,7 @@ validatorSucceedsWith ::
SpecificationTree SpecificationTree
validatorSucceedsWith tag validator datum redeemer scriptContext = validatorSucceedsWith tag validator datum redeemer scriptContext =
scriptSucceeds tag $ scriptSucceeds tag $
compile mustCompile
( validator ( validator
# pforgetData (pconstantData datum) # pforgetData (pconstantData datum)
# pforgetData (pconstantData redeemer) # pforgetData (pconstantData redeemer)
@ -225,7 +226,7 @@ validatorFailsWith ::
SpecificationTree SpecificationTree
validatorFailsWith tag validator datum redeemer scriptContext = validatorFailsWith tag validator datum redeemer scriptContext =
scriptFails tag $ scriptFails tag $
compile mustCompile
( validator ( validator
# pforgetData (pconstantData datum) # pforgetData (pconstantData datum)
# pforgetData (pconstantData redeemer) # pforgetData (pconstantData redeemer)

11
agora-testlib/Test/Util.hs
View file

@ -19,7 +19,6 @@ module Test.Util (
scriptCredentials, scriptCredentials,
validatorHashes, validatorHashes,
groupsOfN, groupsOfN,
withOptional,
mkSpending, mkSpending,
mkMinting, mkMinting,
CombinableBuilder, CombinableBuilder,
@ -37,7 +36,6 @@ import Data.ByteString.Lazy qualified as ByteString.Lazy
import Data.List (sortOn) import Data.List (sortOn)
import Plutarch.Context ( import Plutarch.Context (
Builder, Builder,
UTXO,
buildMintingUnsafe, buildMintingUnsafe,
buildSpendingUnsafe, buildSpendingUnsafe,
withMinting, 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' {- | Given the builder generator and the parameters, create a 'ScriptContext'
that spends the UTXO that referenced by the given 'TxOutRef'. that spends the UTXO that referenced by the given 'TxOutRef'.
-} -}

11
agora/Agora/AuthorityToken.hs
View file

@ -12,7 +12,6 @@ module Agora.AuthorityToken (
AuthorityToken (..), AuthorityToken (..),
) where ) where
import GHC.Generics qualified as GHC
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
AmountGuarantees, AmountGuarantees,
KeyGuarantees, KeyGuarantees,
@ -53,7 +52,7 @@ newtype AuthorityToken = AuthorityToken
} }
deriving stock deriving stock
( -- | @since 0.1.0 ( -- | @since 0.1.0
GHC.Generic Generic
) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -105,7 +104,7 @@ authorityTokensValidIn = phoistAcyclic $
singleAuthorityTokenBurned :: singleAuthorityTokenBurned ::
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S). forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
Term s PCurrencySymbol -> Term s PCurrencySymbol ->
Term s (PBuiltinList (PAsData PTxInInfo)) -> Term s (PBuiltinList PTxInInfo) ->
Term s (PValue keys amounts) -> Term s (PValue keys amounts) ->
Term s PBool Term s PBool
singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
@ -120,7 +119,7 @@ singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
pall pall
# plam # plam
( \txInInfo' -> unTermCont $ do ( \txInInfo' -> unTermCont $ do
PTxInInfo txInInfo <- pmatchC (pfromData txInInfo') PTxInInfo txInInfo <- pmatchC txInInfo'
let txOut' = pfield @"resolved" # txInInfo let txOut' = pfield @"resolved" # txInInfo
pure $ authorityTokensValidIn # gatCs # pfromData txOut' pure $ authorityTokensValidIn # gatCs # pfromData txOut'
) )
@ -156,9 +155,7 @@ authorityTokenPolicy params =
pguardC "All outputs only emit valid GATs" $ pguardC "All outputs only emit valid GATs" $
pall pall
# plam # plam
( (authorityTokensValidIn # ownSymbol #) (authorityTokensValidIn # ownSymbol #)
. pfromData
)
# txInfo.outputs # txInfo.outputs
pure $ popaque $ pconstant () pure $ popaque $ pconstant ()
) )

4
agora/Agora/Effect.hs
View file

@ -23,7 +23,7 @@ import PlutusLedgerApi.V1.Value (CurrencySymbol)
-} -}
makeEffect :: makeEffect ::
forall (datum :: PType). forall (datum :: PType).
(PIsData datum, PTryFrom PData (PAsData datum)) => (PTryFrom PData datum) =>
CurrencySymbol -> CurrencySymbol ->
(forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) -> (forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
ClosedTerm PValidator ClosedTerm PValidator
@ -34,7 +34,7 @@ makeEffect gatCs' f =
-- convert input datum, PData, into desierable type -- convert input datum, PData, into desierable type
-- the way this conversion is performed should be defined -- the way this conversion is performed should be defined
-- by PTryFrom for each datum in effect script. -- by PTryFrom for each datum in effect script.
(pfromData -> datum', _) <- ptryFromC datum (datum', _) <- ptryFromC datum
-- ensure purpose is Spending. -- ensure purpose is Spending.
PSpending txOutRef <- pmatchC $ pfromData ctx.purpose PSpending txOutRef <- pmatchC $ pfromData ctx.purpose

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

@ -30,8 +30,7 @@ import Agora.Governor.Scripts (
governorSTAssetClassFromGovernor, governorSTAssetClassFromGovernor,
) )
import Agora.Plutarch.Orphans () import Agora.Plutarch.Orphans ()
import GHC.Generics qualified as GHC import Generics.SOP qualified as SOP
import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
PTxOutRef, PTxOutRef,
PValidator, PValidator,
@ -42,7 +41,6 @@ import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (pvalueOf)
import Plutarch.DataRepr ( import Plutarch.DataRepr (
DerivePConstantViaData (..), DerivePConstantViaData (..),
PDataFields, PDataFields,
PIsDataReprInstances (PIsDataReprInstances),
) )
import Plutarch.Extra.Maybe ( import Plutarch.Extra.Maybe (
passertPDJust, passertPDJust,
@ -66,8 +64,16 @@ data MutateGovernorDatum = MutateGovernorDatum
, newDatum :: GovernorDatum , newDatum :: GovernorDatum
-- ^ The new settings for the governor. -- ^ The new settings for the governor.
} }
deriving stock (Show, GHC.Generic) deriving stock
deriving anyclass (Generic) ( -- | @since 0.1.ç
Show
, -- | @since 0.1.ç
Generic
)
deriving anyclass
( -- | @since 0.1.ç
SOP.Generic
)
PlutusTx.makeIsDataIndexed ''MutateGovernorDatum [('MutateGovernorDatum, 0)] PlutusTx.makeIsDataIndexed ''MutateGovernorDatum [('MutateGovernorDatum, 0)]
@ -88,19 +94,13 @@ newtype PMutateGovernorDatum (s :: S)
) )
) )
deriving stock deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic Generic
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
PIsDataRepr SOP.Generic
) , -- | @since 0.1.0
deriving
( -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
@ -109,7 +109,9 @@ newtype PMutateGovernorDatum (s :: S)
, -- | @since 0.1.0 , -- | @since 0.1.0
PEq PEq
) )
via (PIsDataReprInstances PMutateGovernorDatum)
instance DerivePlutusType PMutateGovernorDatum where
type DPTStrat _ = PlutusTypeData
-- | @since 0.1.0 -- | @since 0.1.0
instance PUnsafeLiftDecl PMutateGovernorDatum where type PLifted PMutateGovernorDatum = MutateGovernorDatum 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) deriving via (DerivePConstantViaData MutateGovernorDatum PMutateGovernorDatum) instance (PConstantDecl MutateGovernorDatum)
-- | @since 0.1.0 -- | @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 plength # pfromData txInfoF.outputs #== 1
let govAddress = pfield @"address" #$ govInInfo.resolved let govAddress = pfield @"address" #$ govInInfo.resolved
govOutput' = pfromData $ phead # pfromData txInfoF.outputs govOutput' = phead # pfromData txInfoF.outputs
govOutput <- pletFieldsC @'["address", "value", "datumHash"] govOutput' govOutput <- pletFieldsC @'["address", "value", "datumHash"] govOutput'
@ -208,8 +210,7 @@ mutateGovernorValidator gov = makeEffect (authorityTokenSymbolFromGovernor gov)
let governorOutputDatumHash = let governorOutputDatumHash =
passertPDJust # "Governor output doesn't have datum" # govOutput.datumHash passertPDJust # "Governor output doesn't have datum" # govOutput.datumHash
governorOutputDatum = governorOutputDatum =
pfromData @PGovernorDatum $ passertPJust @PGovernorDatum # "Governor output datum not found"
passertPJust # "Governor output datum not found"
#$ ptryFindDatum # governorOutputDatumHash # txInfoF.datums #$ ptryFindDatum # governorOutputDatumHash # txInfoF.datums
-- Ensure the output governor datum is what we want. -- Ensure the output governor datum is what we want.

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

@ -7,11 +7,9 @@ A dumb effect that only burns its GAT.
-} -}
module Agora.Effect.NoOp (noOpValidator, PNoOp) where module Agora.Effect.NoOp (noOpValidator, PNoOp) where
import Control.Applicative (Const)
import Agora.Effect (makeEffect) import Agora.Effect (makeEffect)
import Agora.Plutarch.Orphans ()
import Plutarch.Api.V1 (PValidator) import Plutarch.Api.V1 (PValidator)
import Plutarch.TryFrom (PTryFrom (..))
import PlutusLedgerApi.V1.Value (CurrencySymbol) import PlutusLedgerApi.V1.Value (CurrencySymbol)
{- | Dummy datum for NoOp effect. {- | Dummy datum for NoOp effect.
@ -19,22 +17,23 @@ import PlutusLedgerApi.V1.Value (CurrencySymbol)
@since 0.1.0 @since 0.1.0
-} -}
newtype PNoOp (s :: S) = PNoOp (Term s PUnit) newtype PNoOp (s :: S) = PNoOp (Term s PUnit)
deriving deriving stock
( -- | @since 0.2.0
Generic
)
deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
) )
via (DerivePNewtype PNoOp PUnit)
-- | @since 0.1.0 -- | @since 0.2.0
instance PTryFrom PData (PAsData PNoOp) where instance DerivePlutusType PNoOp where
type PTryFromExcess PData (PAsData PNoOp) = Const () type DPTStrat _ = PlutusTypeNewtype
ptryFrom' _ cont =
-- JUSTIFICATION: -- | @since 0.2.0
-- We don't care anything about data. instance PTryFrom PData (PAsData PNoOp)
-- It should always be reduced to Unit.
cont (pdata $ pcon $ PNoOp (pconstant ()), ())
{- | Dummy effect which can only burn its GAT. {- | Dummy effect which can only burn its GAT.
@ -42,4 +41,4 @@ instance PTryFrom PData (PAsData PNoOp) where
-} -}
noOpValidator :: CurrencySymbol -> ClosedTerm PValidator noOpValidator :: CurrencySymbol -> ClosedTerm PValidator
noOpValidator curr = makeEffect curr $ noOpValidator curr = makeEffect curr $
\_ (_datum :: Term s PNoOp) _ _ -> popaque (pconstant ()) \_ (_datum :: Term s (PAsData PNoOp)) _ _ -> popaque (pconstant ())

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

@ -15,8 +15,7 @@ module Agora.Effect.TreasuryWithdrawal (
import Agora.Effect (makeEffect) import Agora.Effect (makeEffect)
import Agora.Plutarch.Orphans () import Agora.Plutarch.Orphans ()
import GHC.Generics qualified as GHC import Generics.SOP qualified as SOP
import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
AmountGuarantees (Positive), AmountGuarantees (Positive),
KeyGuarantees (Sorted), KeyGuarantees (Sorted),
@ -31,7 +30,6 @@ import "plutarch" Plutarch.Api.V1.Value (pnormalize)
import Plutarch.DataRepr ( import Plutarch.DataRepr (
DerivePConstantViaData (..), DerivePConstantViaData (..),
PDataFields, PDataFields,
PIsDataReprInstances (..),
) )
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC) import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
@ -57,11 +55,11 @@ data TreasuryWithdrawalDatum = TreasuryWithdrawalDatum
( -- | @since 0.1.0 ( -- | @since 0.1.0
Show Show
, -- | @since 0.1.0 , -- | @since 0.1.0
GHC.Generic Generic
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic SOP.Generic
) )
-- | @since 0.1.0 -- | @since 0.1.0
@ -86,23 +84,21 @@ newtype PTreasuryWithdrawalDatum (s :: S)
) )
deriving stock deriving stock
( -- | @since 0.1.0 ( -- | @since 0.1.0
GHC.Generic Generic
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic SOP.Generic
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsDataRepr
)
deriving
( -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
, -- | @since 0.1.0 , -- | @since 0.1.0
PDataFields PDataFields
) )
via PIsDataReprInstances PTreasuryWithdrawalDatum
instance DerivePlutusType PTreasuryWithdrawalDatum where
type DPTStrat _ = PlutusTypeData
-- | @since 0.1.0 -- | @since 0.1.0
instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where instance PUnsafeLiftDecl PTreasuryWithdrawalDatum where
@ -115,10 +111,7 @@ deriving via
(PConstantDecl TreasuryWithdrawalDatum) (PConstantDecl TreasuryWithdrawalDatum)
-- | @since 0.1.0 -- | @since 0.1.0
deriving via instance PTryFrom PData PTreasuryWithdrawalDatum
PAsData (PIsDataReprInstances PTreasuryWithdrawalDatum)
instance
PTryFrom PData (PAsData PTreasuryWithdrawalDatum)
{- | Withdraws given list of values to specific target addresses. {- | Withdraws given list of values to specific target addresses.
It can be evoked by burning GAT. The transaction should have correct It can be evoked by burning GAT. The transaction should have correct
@ -150,17 +143,17 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
pletC $ pletC $
pmap pmap
# plam # plam
( \(pfromData -> txOut') -> unTermCont $ do ( \txOut' -> unTermCont $ do
txOut <- pletFieldsC @'["address", "value"] $ txOut' txOut <- pletFieldsC @'["address", "value"] $ txOut'
let cred = pfield @"credential" # pfromData txOut.address let cred = pfield @"credential" # pfromData txOut.address
pure . pdata $ ptuple # cred # txOut.value pure . pdata $ ptuple # cred # txOut.value
) )
# txInfo.outputs # pfromData txInfo.outputs
inputValues <- inputValues <-
pletC $ pletC $
pmap pmap
# plam # plam
( \((pfield @"resolved" #) . pfromData -> txOut') -> unTermCont $ do ( \((pfield @"resolved" #) -> txOut') -> unTermCont $ do
txOut <- pletFieldsC @'["address", "value"] $ txOut' txOut <- pletFieldsC @'["address", "value"] $ txOut'
let cred = pfield @"credential" # pfromData txOut.address let cred = pfield @"credential" # pfromData txOut.address
pure . pdata $ ptuple # cred # txOut.value pure . pdata $ ptuple # cred # txOut.value
@ -189,7 +182,7 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
pnot #$ pany pnot #$ pany
# plam # plam
( \x -> ( \x ->
effInput.address #== pfield @"address" # pfromData x effInput.address #== pfield @"address" # x
) )
# pfromData txInfo.outputs # pfromData txInfo.outputs
inputsAreOnlyTreasuriesOrCollateral = inputsAreOnlyTreasuriesOrCollateral =

71
agora/Agora/Governor.hs
View file

@ -40,18 +40,16 @@ import Agora.Proposal.Time (
) )
import Agora.SafeMoney (GTTag) import Agora.SafeMoney (GTTag)
import Data.Tagged (Tagged (..)) import Data.Tagged (Tagged (..))
import GHC.Generics qualified as GHC import Generics.SOP qualified as SOP
import Generics.SOP (Generic, I (I))
import Plutarch.DataRepr ( import Plutarch.DataRepr (
DerivePConstantViaData (..), DerivePConstantViaData (..),
PDataFields, PDataFields,
PIsDataReprInstances (PIsDataReprInstances),
) )
import Plutarch.Extra.IsData ( import Plutarch.Extra.IsData (
DerivePConstantViaEnum (..), DerivePConstantViaEnum (..),
EnumIsData (..), EnumIsData (..),
PlutusTypeEnumData,
) )
import Plutarch.Extra.Other (DerivePNewtype' (..))
import Plutarch.Extra.TermCont (pletFieldsC) import Plutarch.Extra.TermCont (pletFieldsC)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
import PlutusLedgerApi.V1 (TxOutRef) import PlutusLedgerApi.V1 (TxOutRef)
@ -78,7 +76,12 @@ data GovernorDatum = GovernorDatum
-- ^ The maximum number of unfinished proposals that a stake is allowed to be -- ^ The maximum number of unfinished proposals that a stake is allowed to be
-- associated to. -- associated to.
} }
deriving stock (Show, GHC.Generic) deriving stock
( -- | @since 0.1.0
Show
, -- | @since 0.1.0
Generic
)
-- | @since 0.1.0 -- | @since 0.1.0
PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)] PlutusTx.makeIsDataIndexed ''GovernorDatum [('GovernorDatum, 0)]
@ -105,7 +108,7 @@ data GovernorRedeemer
( -- | @since 0.1.0 ( -- | @since 0.1.0
Show Show
, -- | @since 0.1.0 , -- | @since 0.1.0
GHC.Generic Generic
, -- | @since 0.2.0 , -- | @since 0.2.0
Enum Enum
, -- | @since 0.2.0 , -- | @since 0.2.0
@ -113,7 +116,7 @@ data GovernorRedeemer
) )
deriving anyclass deriving anyclass
( -- | @since 0.2.0 ( -- | @since 0.2.0
Generic SOP.Generic
) )
deriving deriving
( -- | @since 0.1.0 ( -- | @since 0.1.0
@ -136,7 +139,12 @@ data Governor = Governor
-- ^ Arbitrary limit for maximum amount of cosigners on a proposal. -- ^ Arbitrary limit for maximum amount of cosigners on a proposal.
-- See `Agora.Proposal.proposalDatumValid`. -- 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 deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic Generic
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
PIsDataRepr SOP.Generic
) )
deriving deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
@ -179,7 +183,10 @@ newtype PGovernorDatum (s :: S) = PGovernorDatum
, -- | @since 0.1.0 , -- | @since 0.1.0
PEq PEq
) )
via PIsDataReprInstances PGovernorDatum
-- | @since 0.2.0
instance DerivePlutusType PGovernorDatum where
type DPTStrat _ = PlutusTypeData
-- | @since 0.1.0 -- | @since 0.1.0
instance PUnsafeLiftDecl PGovernorDatum where type PLifted PGovernorDatum = GovernorDatum 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) deriving via (DerivePConstantViaData GovernorDatum PGovernorDatum) instance (PConstantDecl GovernorDatum)
-- | @since 0.1.0 -- | @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'. {- | Plutarch-level version of 'GovernorRedeemer'.
@since 0.1.0 @since 0.1.0
-} -}
newtype PGovernorRedeemer (s :: S) data PGovernorRedeemer (s :: S)
= PGovernorRedeemer (Term s PInteger) = PCreateProposal
| PMintGATs
| PMutateGovernor
deriving stock deriving stock
( -- | @since 0.1.0 ( -- | @since 0.1.0
GHC.Generic Generic
, -- | @since 0.2.0
Enum
, -- | @since 0.2.0
Bounded
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic SOP.Generic
) , -- | @since 0.1.0
deriving
( -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData 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 -- | @since 0.1.0
instance PUnsafeLiftDecl PGovernorRedeemer where type PLifted PGovernorRedeemer = GovernorRedeemer instance PUnsafeLiftDecl PGovernorRedeemer where type PLifted PGovernorRedeemer = GovernorRedeemer
@ -255,9 +274,9 @@ pisGovernorDatumValid = phoistAcyclic $
foldr1 foldr1
(#&&) (#&&)
[ ptraceIfFalse "thresholds valid" $ [ ptraceIfFalse "thresholds valid" $
pisProposalThresholdsValid # datumF.proposalThresholds pisProposalThresholdsValid # pfromData datumF.proposalThresholds
, ptraceIfFalse "timings valid" $ , ptraceIfFalse "timings valid" $
pisProposalTimingConfigValid # datumF.proposalTimings pisProposalTimingConfigValid # pfromData datumF.proposalTimings
, ptraceIfFalse "time range valid" $ , ptraceIfFalse "time range valid" $
pisMaxTimeRangeWidthValid # datumF.createProposalTimeRangeMaxWidth pisMaxTimeRangeWidthValid # datumF.createProposalTimeRangeMaxWidth
] ]

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

@ -74,6 +74,7 @@ import Agora.Utils (
validatorHashToAddress, validatorHashToAddress,
validatorHashToTokenName, validatorHashToTokenName,
) )
import Data.Default (def)
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
PAddress, PAddress,
PCurrencySymbol, PCurrencySymbol,
@ -93,15 +94,6 @@ import Plutarch.Api.V1.AssetClass (
passetClass, passetClass,
passetClassValueOf, passetClassValueOf,
) )
import Plutarch.Extra.IsData (pmatchEnumFromData)
import Plutarch.Extra.List (pfirstJust)
import Plutarch.Extra.Map (
plookup,
plookup',
)
--------------------------------------------------------------------------------
import Plutarch.Api.V1.ScriptContext ( import Plutarch.Api.V1.ScriptContext (
pfindOutputsToAddress, pfindOutputsToAddress,
pfindTxInByTxOutRef, pfindTxInByTxOutRef,
@ -112,6 +104,12 @@ import Plutarch.Api.V1.ScriptContext (
) )
import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (phasOnlyOneTokenOfCurrencySymbol, psymbolValueOf) import "liqwid-plutarch-extra" Plutarch.Api.V1.Value (phasOnlyOneTokenOfCurrencySymbol, psymbolValueOf)
import Plutarch.Extra.Field (pletAllC) 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.Maybe (passertPDJust, passertPJust, pisDJust)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC) import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC, ptryFromC)
@ -177,12 +175,12 @@ governorPolicy gov =
# "Governor output not found" # "Governor output not found"
#$ pfind #$ pfind
# plam # plam
( \((pfield @"value" #) . pfromData -> value) -> ( \((pfield @"value" #) -> value) ->
psymbolValueOf # ownSymbol # value #== 1 psymbolValueOf # ownSymbol # value #== 1
) )
# pfromData txInfoF.outputs # pfromData txInfoF.outputs
let datumHash = pfield @"datumHash" # pfromData govOutput let datumHash = pfield @"datumHash" # govOutput
datum = mustFindDatum' @PGovernorDatum # datumHash # txInfoF.datums datum = mustFindDatum' @PGovernorDatum # datumHash # txInfoF.datums
pguardC "Governor output datum valid" $ pisGovernorDatumValid # datum pguardC "Governor output datum valid" $ pisGovernorDatumValid # datum
@ -292,7 +290,7 @@ governorValidator gov =
ownInputF <- pletFieldsC @'["address", "value"] ownInput ownInputF <- pletFieldsC @'["address", "value"] ownInput
let ownAddress = pfromData $ ownInputF.address let ownAddress = pfromData $ ownInputF.address
(pfromData -> (oldGovernorDatum :: Term _ PGovernorDatum), _) <- ptryFromC datum' (oldGovernorDatum :: Term _ PGovernorDatum, _) <- ptryFromC datum'
oldGovernorDatumF <- pletAllC oldGovernorDatum oldGovernorDatumF <- pletAllC oldGovernorDatum
-- Check that GST will be returned to the governor. -- Check that GST will be returned to the governor.
@ -314,7 +312,6 @@ governorValidator gov =
passertPDJust # "Governor output doesn't have datum" # ownOutput.datumHash passertPDJust # "Governor output doesn't have datum" # ownOutput.datumHash
newGovernorDatum <- newGovernorDatum <-
pletC $ pletC $
pfromData $
passertPJust # "Ouput governor state datum not found" passertPJust # "Ouput governor state datum not found"
#$ ptryFindDatum # outputGovernorStateDatumHash # txInfoF.datums #$ ptryFindDatum # outputGovernorStateDatumHash # txInfoF.datums
@ -368,9 +365,9 @@ governorValidator gov =
pguardC "Stake input doesn't have datum" $ pguardC "Stake input doesn't have datum" $
pisDJust # stakeInputF.datumHash 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." $ pguardC "Proposals created by the stake must not exceed the number stored in the governor." $
pnumCreatedProposals # stakeInputDatumF.lockedBy pnumCreatedProposals # stakeInputDatumF.lockedBy
@ -400,11 +397,11 @@ governorValidator gov =
proposalOutputDatum' <- proposalOutputDatum' <-
pletC $ pletC $
mustFindDatum' @PProposalDatum mustFindDatum' @(PAsData PProposalDatum)
# outputDatumHash # outputDatumHash
# txInfoF.datums # txInfoF.datums
proposalOutputDatum <- pletAllC proposalOutputDatum' proposalOutputDatum <- pletAllC $ pto $ pfromData proposalOutputDatum'
let expectedStartingTime = let expectedStartingTime =
createProposalStartingTime createProposalStartingTime
@ -462,7 +459,7 @@ governorValidator gov =
#$ ptryFindDatum # stakeOutputDatumHash # txInfoF.datums #$ ptryFindDatum # stakeOutputDatumHash # txInfoF.datums
stakeOutputLocks = stakeOutputLocks =
pfromData $ pfield @"lockedBy" # stakeOutputDatum pfromData $ pfield @"lockedBy" #$ pto $ pfromData stakeOutputDatum
-- The stake should be locked by the newly created proposal. -- The stake should be locked by the newly created proposal.
newLock = newLock =
@ -493,8 +490,7 @@ governorValidator gov =
proposalInputF <- proposalInputF <-
pletFieldsC @'["datumHash"] $ pletFieldsC @'["datumHash"] $
pfield @"resolved" pfield @"resolved"
#$ pfromData #$ passertPJust
$ passertPJust
# "Proposal input not found" # "Proposal input not found"
#$ pfind #$ pfind
# plam # plam
@ -509,13 +505,13 @@ governorValidator gov =
proposalInputDatum <- proposalInputDatum <-
pletC $ pletC $
mustFindDatum' @PProposalDatum mustFindDatum' @(PAsData PProposalDatum)
# proposalInputF.datumHash # proposalInputF.datumHash
# txInfoF.datums # txInfoF.datums
proposalInputDatumF <- proposalInputDatumF <-
pletFieldsC @'["effects", "status", "thresholds", "votes"] pletFieldsC @'["effects", "status", "thresholds", "votes"] $
proposalInputDatum pto $ pfromData proposalInputDatum
-- Check that the proposal state is advanced so that a proposal cannot be executed twice. -- 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" $ pguardC "Output GATs is more than minted GATs" $
plength # outputsWithGAT #== gatCount plength # outputsWithGAT #== gatCount
let gatOutputValidator' :: Term s (PMap _ PValidatorHash PDatumHash :--> PAsData PTxOut :--> PBool) let gatOutputValidator' :: Term s (PMap _ PValidatorHash PDatumHash :--> PTxOut :--> PBool)
gatOutputValidator' = gatOutputValidator' =
phoistAcyclic $ phoistAcyclic $
plam plam
( \effects (pfromData -> output') -> unTermCont $ do ( \effects output' -> unTermCont $ do
output <- pletFieldsC @'["address", "datumHash"] $ output' output <- pletFieldsC @'["address", "datumHash"] output'
let scriptHash = let scriptHash =
passertPJust # "GAT receiver is not a script" passertPJust # "GAT receiver is not a script"
@ -644,7 +640,7 @@ governorSTSymbolFromGovernor :: Governor -> CurrencySymbol
governorSTSymbolFromGovernor gov = mintingPolicySymbol policy governorSTSymbolFromGovernor gov = mintingPolicySymbol policy
where where
policy :: MintingPolicy policy :: MintingPolicy
policy = mkMintingPolicy $ governorPolicy gov policy = mkMintingPolicy def $ governorPolicy gov
{- | Get the 'AssetClass' of GST. {- | Get the 'AssetClass' of GST.
@ -664,7 +660,7 @@ proposalSTSymbolFromGovernor :: Governor -> CurrencySymbol
proposalSTSymbolFromGovernor gov = symbol proposalSTSymbolFromGovernor gov = symbol
where where
gstAC = governorSTAssetClassFromGovernor gov gstAC = governorSTAssetClassFromGovernor gov
policy = mkMintingPolicy $ proposalPolicy gstAC policy = mkMintingPolicy def $ proposalPolicy gstAC
symbol = mintingPolicySymbol policy symbol = mintingPolicySymbol policy
{- | Get the 'AssetClass' of the proposal state token. {- | Get the 'AssetClass' of the proposal state token.
@ -683,7 +679,7 @@ proposalSTAssetClassFromGovernor gov = AssetClass (symbol, "")
stakeSTSymbolFromGovernor :: Governor -> CurrencySymbol stakeSTSymbolFromGovernor :: Governor -> CurrencySymbol
stakeSTSymbolFromGovernor gov = mintingPolicySymbol policy stakeSTSymbolFromGovernor gov = mintingPolicySymbol policy
where where
policy = mkMintingPolicy $ stakePolicy gov.gtClassRef policy = mkMintingPolicy def $ stakePolicy gov.gtClassRef
{- | Get the 'AssetClass' of the stake token. {- | Get the 'AssetClass' of the stake token.
@ -717,7 +713,7 @@ stakeValidatorHashFromGovernor :: Governor -> ValidatorHash
stakeValidatorHashFromGovernor gov = validatorHash validator stakeValidatorHashFromGovernor gov = validatorHash validator
where where
params = stakeFromGovernor gov params = stakeFromGovernor gov
validator = mkValidator $ stakeValidator params validator = mkValidator def $ stakeValidator params
{- | Get the 'Proposal' parameter, given the 'Governor' parameter. {- | Get the 'Proposal' parameter, given the 'Governor' parameter.
@ -738,7 +734,7 @@ proposalValidatorHashFromGovernor :: Governor -> ValidatorHash
proposalValidatorHashFromGovernor gov = validatorHash validator proposalValidatorHashFromGovernor gov = validatorHash validator
where where
params = proposalFromGovernor gov params = proposalFromGovernor gov
validator = mkValidator $ proposalValidator params validator = mkValidator def $ proposalValidator params
{- | Get the hash of 'Agora.Proposal.proposalValidator'. {- | Get the hash of 'Agora.Proposal.proposalValidator'.
@ -747,7 +743,7 @@ proposalValidatorHashFromGovernor gov = validatorHash validator
governorValidatorHash :: Governor -> ValidatorHash governorValidatorHash :: Governor -> ValidatorHash
governorValidatorHash gov = validatorHash validator governorValidatorHash gov = validatorHash validator
where where
validator = mkValidator $ governorValidator gov validator = mkValidator def $ governorValidator gov
{- | Get the 'AuthorityToken' parameter given the 'Governor' parameter. {- | Get the 'AuthorityToken' parameter given the 'Governor' parameter.
@ -763,5 +759,5 @@ authorityTokenFromGovernor gov = AuthorityToken $ governorSTAssetClassFromGovern
authorityTokenSymbolFromGovernor :: Governor -> CurrencySymbol authorityTokenSymbolFromGovernor :: Governor -> CurrencySymbol
authorityTokenSymbolFromGovernor gov = mintingPolicySymbol policy authorityTokenSymbolFromGovernor gov = mintingPolicySymbol policy
where where
policy = mkMintingPolicy $ authorityTokenPolicy params policy = mkMintingPolicy def $ authorityTokenPolicy params
params = authorityTokenFromGovernor gov params = authorityTokenFromGovernor gov

136
agora/Agora/Plutarch/Orphans.hs
View file

@ -1,135 +1,15 @@
{-# OPTIONS_GHC -Wno-orphans #-} {-# 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 module Agora.Plutarch.Orphans () where
import Control.Arrow (first) import Plutarch.Api.V1 (PDatumHash)
import Plutarch.Api.V1 (PAddress, PCredential, PCurrencySymbol, PDatumHash, PMap, PMaybeData, PPOSIXTime, PPubKeyHash, PStakingCredential, PTokenName, PTxId, PTxOutRef, PValidatorHash, PValue) import Plutarch.Builtin (PIsData (..))
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 ((+))
instance Reducible (f x y) => Reducible (Flip f y x) where -- TODO: add checks
type Reduce (Flip f y x) = Reduce (f x y) instance PTryFrom PData (PAsData PDatumHash)
newtype Flip f a b = Flip (f b a) instance PTryFrom PData (PAsData PUnit)
-- | @since 0.1.0 instance (PIsData a) => PIsData (PAsData a) where
instance PTryFrom PData (PAsData b) => PTryFrom PData (PAsData (DerivePNewtype c b)) where pfromDataImpl = pfromData
type pdataImpl = pdataImpl . pfromData
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)

234
agora/Agora/Proposal.hs
View file

@ -39,11 +39,11 @@ module Agora.Proposal (
pisProposalThresholdsValid, pisProposalThresholdsValid,
) where ) where
import Agora.Plutarch.Orphans ()
import Agora.Proposal.Time (PProposalStartingTime, PProposalTimingConfig, ProposalStartingTime, ProposalTimingConfig) import Agora.Proposal.Time (PProposalStartingTime, PProposalTimingConfig, ProposalStartingTime, ProposalTimingConfig)
import Agora.SafeMoney (GTTag) import Agora.SafeMoney (GTTag)
import Data.Tagged (Tagged) import Data.Tagged (Tagged)
import GHC.Generics qualified as GHC import Generics.SOP qualified as SOP
import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
KeyGuarantees (Unsorted), KeyGuarantees (Unsorted),
PDatumHash, PDatumHash,
@ -52,7 +52,7 @@ import Plutarch.Api.V1 (
PValidatorHash, PValidatorHash,
) )
import Plutarch.Api.V1.AssocMap qualified as PAssocMap 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.Comonad (pextract)
import Plutarch.Extra.Field (pletAllC) import Plutarch.Extra.Field (pletAllC)
import Plutarch.Extra.Function (pbuiltinUncurry) import Plutarch.Extra.Function (pbuiltinUncurry)
@ -60,13 +60,13 @@ import Plutarch.Extra.IsData (
DerivePConstantViaDataList (..), DerivePConstantViaDataList (..),
DerivePConstantViaEnum (..), DerivePConstantViaEnum (..),
EnumIsData (..), EnumIsData (..),
PlutusTypeEnumData,
ProductIsData (ProductIsData), ProductIsData (ProductIsData),
) )
import Plutarch.Extra.List (pfirstJust) import Plutarch.Extra.List (pfirstJust)
import Plutarch.Extra.Map qualified as PM import Plutarch.Extra.Map qualified as PM
import Plutarch.Extra.Map.Unsorted qualified as PUM import Plutarch.Extra.Map.Unsorted qualified as PUM
import Plutarch.Extra.Maybe (pfromJust) import Plutarch.Extra.Maybe (pfromJust)
import Plutarch.Extra.Other (DerivePNewtype' (..))
import Plutarch.Extra.TermCont (pguardC, pletC, pmatchC) import Plutarch.Extra.TermCont (pguardC, pletC, pmatchC)
import Plutarch.Lift ( import Plutarch.Lift (
DerivePConstantViaNewtype (..), DerivePConstantViaNewtype (..),
@ -92,6 +92,14 @@ import PlutusTx.AssocMap qualified as AssocMap
@since 0.1.0 @since 0.1.0
-} -}
newtype ProposalId = ProposalId {proposalTag :: Integer} newtype ProposalId = ProposalId {proposalTag :: Integer}
deriving stock
( -- | @since 0.1.0
Eq
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
Generic
)
deriving newtype deriving newtype
( -- | @since 0.1.0 ( -- | @since 0.1.0
PlutusTx.ToData PlutusTx.ToData
@ -100,13 +108,9 @@ newtype ProposalId = ProposalId {proposalTag :: Integer}
, -- | @since 0.1.0 , -- | @since 0.1.0
PlutusTx.UnsafeFromData PlutusTx.UnsafeFromData
) )
deriving stock deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.2.0
Eq SOP.Generic
, -- | @since 0.1.0
Show
, -- | @since 0.1.0
GHC.Generic
) )
{- | Encodes a result. Typically, for a Yes/No proposal, we encode it like this: {- | Encodes a result. Typically, for a Yes/No proposal, we encode it like this:
@ -127,7 +131,7 @@ newtype ResultTag = ResultTag {getResultTag :: Integer}
, -- | @since 0.1.0 , -- | @since 0.1.0
Ord Ord
, -- | @since 0.1.0 , -- | @since 0.1.0
GHC.Generic Generic
) )
deriving newtype deriving newtype
( -- | @since 0.1.0 ( -- | @since 0.1.0
@ -137,6 +141,10 @@ newtype ResultTag = ResultTag {getResultTag :: Integer}
, -- | @since 0.1.0 , -- | @since 0.1.0
PlutusTx.UnsafeFromData PlutusTx.UnsafeFromData
) )
deriving anyclass
( -- | @since 0.2.0
SOP.Generic
)
{- | The "status" of the proposal. This is only useful for state transitions that {- | The "status" of the proposal. This is only useful for state transitions that
need to happen as a result of a transaction as opposed to time-based "periods". need to happen as a result of a transaction as opposed to time-based "periods".
@ -186,7 +194,7 @@ data ProposalStatus
, -- | @since 0.1.0 , -- | @since 0.1.0
Show Show
, -- | @since 0.1.0 , -- | @since 0.1.0
GHC.Generic Generic
, -- | @since 0.2.0 , -- | @since 0.2.0
Enum Enum
, -- | @since 0.2.0 , -- | @since 0.2.0
@ -194,7 +202,7 @@ data ProposalStatus
) )
deriving anyclass deriving anyclass
( -- | @since 0.2.0 ( -- | @since 0.2.0
Generic SOP.Generic
) )
deriving deriving
( -- | @since 0.1.0 ( -- | @since 0.1.0
@ -230,9 +238,9 @@ data ProposalThresholds = ProposalThresholds
, -- | @since 0.1.0 , -- | @since 0.1.0
Show Show
, -- | @since 0.1.0 , -- | @since 0.1.0
GHC.Generic Generic
) )
deriving anyclass (Generic) deriving anyclass (SOP.Generic)
PlutusTx.makeIsDataIndexed 'ProposalThresholds [('ProposalThresholds, 0)] PlutusTx.makeIsDataIndexed 'ProposalThresholds [('ProposalThresholds, 0)]
@ -252,19 +260,23 @@ PlutusTx.makeIsDataIndexed 'ProposalThresholds [('ProposalThresholds, 0)]
newtype ProposalVotes = ProposalVotes newtype ProposalVotes = ProposalVotes
{ getProposalVotes :: AssocMap.Map ResultTag Integer { getProposalVotes :: AssocMap.Map ResultTag Integer
} }
deriving newtype
( -- | @since 0.1.0
PlutusTx.ToData
, -- | @since 0.1.0
PlutusTx.FromData
)
deriving stock deriving stock
( -- | @since 0.1.0 ( -- | @since 0.1.0
Eq Eq
, -- | @since 0.1.0 , -- | @since 0.1.0
Show Show
, -- | @since 0.1.0 , -- | @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. {- | Create a 'ProposalVotes' that has the same shape as the 'effects' field.
@ -307,9 +319,12 @@ data ProposalDatum = ProposalDatum
, -- | @since 0.1.0 , -- | @since 0.1.0
Show Show
, -- | @since 0.1.0 , -- | @since 0.1.0
GHC.Generic Generic
)
deriving anyclass
( -- | @since 0.2.0
SOP.Generic
) )
deriving anyclass (Generic)
deriving deriving
( -- | @since 0.1.0 ( -- | @since 0.1.0
PlutusTx.ToData PlutusTx.ToData
@ -367,7 +382,11 @@ data ProposalRedeemer
, -- | @since 0.1.0 , -- | @since 0.1.0
Show Show
, -- | @since 0.1.0 , -- | @since 0.1.0
GHC.Generic Generic
)
deriving anyclass
( -- | @since 0.2.0
SOP.Generic
) )
-- | @since 0.1.0 -- | @since 0.1.0
@ -395,7 +414,11 @@ data Proposal = Proposal
, -- | @since 0.1.0 , -- | @since 0.1.0
Eq Eq
, -- | @since 0.1.0 , -- | @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 @since 0.1.0
-} -}
newtype PResultTag (s :: S) = PResultTag (Term s PInteger) newtype PResultTag (s :: S) = PResultTag (Term s PInteger)
deriving deriving stock
( -- | @since 0.1.0 ( -- | @since 0.2.0
Generic
)
deriving anyclass
( -- | @since 0.2.0
SOP.Generic
, -- @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
, -- | @since 0.1.0 , -- | @since 0.1.0
PEq PEq
, -- | @since 0.2.0
PPartialOrd
, -- | @since 0.1.0 , -- | @since 0.1.0
POrd POrd
, -- | @since 0.2.0 , -- | @since 0.2.0
PShow 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 -- | @since 0.1.0
instance PUnsafeLiftDecl PResultTag where type PLifted PResultTag = ResultTag instance PUnsafeLiftDecl PResultTag where type PLifted PResultTag = ResultTag
@ -429,36 +466,38 @@ deriving via
instance instance
(PConstantDecl ResultTag) (PConstantDecl ResultTag)
-- | @since 0.1.0
deriving via
PAsData (DerivePNewtype PResultTag PInteger)
instance
PTryFrom PData (PAsData PResultTag)
{- | Plutarch-level version of 'PProposalId'. {- | Plutarch-level version of 'PProposalId'.
@since 0.1.0 @since 0.1.0
-} -}
newtype PProposalId (s :: S) = PProposalId (Term s PInteger) newtype PProposalId (s :: S) = PProposalId (Term s PInteger)
deriving deriving stock
( -- | @since 0.1.0 ( -- | @since 0.2.0
Generic
)
deriving anyclass
( -- | @since 0.2.0
SOP.Generic
, -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
, -- | @since 0.1.0 , -- | @since 0.1.0
PEq PEq
, -- | @since 0.2.0
PPartialOrd
, -- | @since 0.1.0 , -- | @since 0.1.0
POrd POrd
, -- | @since 0.2.0 , -- | @since 0.2.0
PShow PShow
) )
via (DerivePNewtype PProposalId PInteger)
-- | @since 0.2.0
instance DerivePlutusType PProposalId where
type DPTStrat _ = PlutusTypeNewtype
-- | @since 0.1.0 -- | @since 0.1.0
deriving via instance PTryFrom PData (PAsData PProposalId)
PAsData (DerivePNewtype PProposalId PInteger)
instance
PTryFrom PData (PAsData PProposalId)
-- | @since 0.1.0 -- | @since 0.1.0
instance PUnsafeLiftDecl PProposalId where type PLifted PProposalId = ProposalId instance PUnsafeLiftDecl PProposalId where type PLifted PProposalId = ProposalId
@ -473,30 +512,43 @@ deriving via
@since 0.1.0 @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 deriving stock
( -- | @since 0.1.0 ( -- | @since 0.1.0
GHC.Generic Generic
, -- | @since 0.2.0
Bounded
, -- | @since 0.2.0
Enum
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic SOP.Generic
) , -- | @since 0.1.0
deriving
( -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
, -- | @since 0.1.0 , -- | @since 0.1.0
PEq PEq
) )
via (DerivePNewtype' PProposalStatus)
-- | @since 0.2.0
instance DerivePlutusType PProposalStatus where
type DPTStrat _ = PlutusTypeEnumData
-- | @since 0.1.0 -- | @since 0.1.0
instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus instance PUnsafeLiftDecl PProposalStatus where type PLifted PProposalStatus = ProposalStatus
-- | @since 0.1.0 -- | @since 0.1.0
deriving via PAsData (DerivePNewtype' PProposalStatus) instance PTryFrom PData (PAsData PProposalStatus) instance PTryFrom PData (PAsData PProposalStatus)
-- | @since 0.1.0 -- | @since 0.1.0
deriving via (DerivePConstantViaEnum ProposalStatus PProposalStatus) instance (PConstantDecl ProposalStatus) deriving via (DerivePConstantViaEnum ProposalStatus PProposalStatus) instance (PConstantDecl ProposalStatus)
@ -517,32 +569,26 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds
) )
} }
deriving stock deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic Generic
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
PIsDataRepr SOP.Generic
) , -- | @since 0.1.0
deriving
( -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
, -- | @since 0.1.0 , -- | @since 0.1.0
PDataFields PDataFields
) )
via (PIsDataReprInstances PProposalThresholds)
-- | @since 0.2.0
instance DerivePlutusType PProposalThresholds where
type DPTStrat _ = PlutusTypeData
-- | @since 0.1.0 -- | @since 0.1.0
deriving via instance PTryFrom PData PProposalThresholds
PAsData (PIsDataReprInstances PProposalThresholds)
instance
PTryFrom PData (PAsData PProposalThresholds)
-- | @since 0.1.0 -- | @since 0.1.0
instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds instance PUnsafeLiftDecl PProposalThresholds where type PLifted PProposalThresholds = ProposalThresholds
@ -559,19 +605,25 @@ deriving via
-} -}
newtype PProposalVotes (s :: S) newtype PProposalVotes (s :: S)
= PProposalVotes (Term s (PMap 'Unsorted PResultTag PInteger)) = PProposalVotes (Term s (PMap 'Unsorted PResultTag PInteger))
deriving deriving stock
( -- | @since 0.1.0 ( -- | @since 0.2.0
Generic
)
deriving anyclass
( -- | @since 0.2.0
SOP.Generic
, -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
) )
via (DerivePNewtype PProposalVotes (PMap 'Unsorted PResultTag PInteger))
-- | @since 0.2.0
instance DerivePlutusType PProposalVotes where
type DPTStrat _ = PlutusTypeNewtype
-- | @since 0.1.0 -- | @since 0.1.0
deriving via instance PTryFrom PData (PAsData PProposalVotes)
PAsData (DerivePNewtype PProposalVotes (PMap 'Unsorted PResultTag PInteger))
instance
PTryFrom PData (PAsData PProposalVotes)
-- | @since 0.1.0 -- | @since 0.1.0
instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = ProposalVotes instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = ProposalVotes
@ -603,31 +655,25 @@ newtype PProposalDatum (s :: S) = PProposalDatum
) )
} }
deriving stock deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic Generic
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
PIsDataRepr SOP.Generic
) , -- | @since 0.1.0
deriving
( -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
, -- | @since 0.1.0
PDataFields
, -- | @since 0.1.0 , -- | @since 0.1.0
PEq PEq
) )
via (DerivePNewtype' PProposalDatum)
-- | @since 0.1.0 -- | @since 0.2.0
deriving via PAsData (DerivePNewtype' PProposalDatum) instance PTryFrom PData (PAsData PProposalDatum) instance DerivePlutusType PProposalDatum where
type DPTStrat _ = PlutusTypeNewtype
instance PTryFrom PData (PAsData PProposalDatum)
-- | @since 0.1.0 -- | @since 0.1.0
instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum instance PUnsafeLiftDecl PProposalDatum where type PLifted PProposalDatum = ProposalDatum
@ -645,30 +691,24 @@ data PProposalRedeemer (s :: S)
| PUnlock (Term s (PDataRecord '[])) | PUnlock (Term s (PDataRecord '[]))
| PAdvanceProposal (Term s (PDataRecord '[])) | PAdvanceProposal (Term s (PDataRecord '[]))
deriving stock deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic Generic
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
PIsDataRepr SOP.Generic
) , -- | @since 0.1.0
deriving
( -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
) )
via PIsDataReprInstances PProposalRedeemer
-- | @since 0.2.0
instance DerivePlutusType PProposalRedeemer where
type DPTStrat _ = PlutusTypeData
-- | @since 0.1.0 -- | @since 0.1.0
deriving via instance PTryFrom PData PProposalRedeemer
PAsData (PIsDataReprInstances PProposalRedeemer)
instance
PTryFrom PData (PAsData PProposalRedeemer)
-- | @since 0.1.0 -- | @since 0.1.0
instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer instance PUnsafeLiftDecl PProposalRedeemer where type PLifted PProposalRedeemer = ProposalRedeemer

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

@ -174,12 +174,10 @@ proposalValidator proposal =
PJust ((pfield @"resolved" #) -> txOut) <- pmatchC $ pfindTxInByTxOutRef # txOutRef # txInfoF.inputs PJust ((pfield @"resolved" #) -> txOut) <- pmatchC $ pfindTxInByTxOutRef # txOutRef # txInfoF.inputs
txOutF <- pletFieldsC @'["address", "value"] $ txOut txOutF <- pletFieldsC @'["address", "value"] $ txOut
(pfromData -> proposalDatum, _) <- proposalDatum <- pfromData . fst <$> ptryFromC @(PAsData PProposalDatum) datum
ptryFromC @(PAsData PProposalDatum) datum proposalRedeemer <- fst <$> ptryFromC @PProposalRedeemer redeemer
(pfromData -> proposalRedeemer, _) <-
ptryFromC @(PAsData PProposalRedeemer) redeemer
proposalF <- pletAllC proposalDatum proposalF <- pletAllC $ pto proposalDatum
ownAddress <- pletC $ txOutF.address ownAddress <- pletC $ txOutF.address
@ -211,11 +209,12 @@ proposalValidator proposal =
-- TODO: this is highly inefficient: O(n) for every output, -- TODO: this is highly inefficient: O(n) for every output,
-- Maybe we can cache the sorted datum map? -- Maybe we can cache the sorted datum map?
let datum = let datum =
mustFindDatum' @PProposalDatum pfromData $
mustFindDatum' @(PAsData PProposalDatum)
# inputF.datumHash # inputF.datumHash
# txInfoF.datums # txInfoF.datums
proposalId = pfield @"proposalId" # datum proposalId = pfield @"proposalId" # pto datum
pure $ pure $
inputF.address #== ownAddress inputF.address #== ownAddress
@ -226,7 +225,8 @@ proposalValidator proposal =
proposalOut <- proposalOut <-
pletC $ pletC $
mustFindDatum' @PProposalDatum pfromData $
mustFindDatum' @(PAsData PProposalDatum)
# (pfield @"datumHash" # ownOutput) # (pfield @"datumHash" # ownOutput)
# txInfoF.datums # txInfoF.datums
@ -235,12 +235,24 @@ proposalValidator proposal =
proposalOutStatus <- proposalOutStatus <-
pletC $ pletC $
pfromData $ pfromData $
pfield @"status" # proposalOut pfield @"status" # pto proposalOut
onlyStatusChanged <- onlyStatusChanged <-
pletC $ 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.
-- Only the status of proposals is updated. -- Only the status of proposals is updated.
proposalOut proposalOut
#== mkRecordConstr #== mkRecordConstr
@ -263,9 +275,9 @@ proposalValidator proposal =
stakeSTAssetClass <- stakeSTAssetClass <-
pletC $ passetClass # pconstant stakeSym # pconstant stakeTn pletC $ passetClass # pconstant stakeSym # pconstant stakeTn
filterStakeDatumHash :: Term _ (PAsData PTxOut :--> PMaybe (PAsData PDatumHash)) <- filterStakeDatumHash :: Term _ (PTxOut :--> PMaybe (PAsData PDatumHash)) <-
pletC $ pletC $
plam $ \(pfromData -> txOut) -> unTermCont $ do plam $ \txOut -> unTermCont $ do
txOutF <- pletFieldsC @'["value", "datumHash"] txOut txOutF <- pletFieldsC @'["value", "datumHash"] txOut
pure $ pure $
pif pif
@ -333,12 +345,11 @@ proposalValidator proposal =
let stake = let stake =
pfromData $ pfromData $
pfromJust pfromJust
#$ ptryFindDatum #$ ptryFindDatum @(PAsData PStakeDatum)
@(PAsData PStakeDatum)
# pfromData dh # pfromData dh
# txInfoF.datums # txInfoF.datums
stakeF <- pletFieldsC @'["stakedAmount", "owner"] stake stakeF <- pletFieldsC @'["stakedAmount", "owner"] $ pto stake
PPair amount owners <- pmatchC l PPair amount owners <- pmatchC l
@ -369,14 +380,10 @@ proposalValidator proposal =
stakeOutputHash <- pletC $ pfromData $ phead # stakeOutputDatumHashes stakeOutputHash <- pletC $ pfromData $ phead # stakeOutputDatumHashes
stakeIn :: Term _ PStakeDatum <- stakeIn :: Term _ PStakeDatum <-
pletC $ pletC $ pfromData $ pfromJust #$ ptryFindDatum # stakeInputHash # txInfoF.datums
pfromData $
pfromJust #$ ptryFindDatum # stakeInputHash # txInfoF.datums
stakeOut :: Term _ PStakeDatum <- stakeOut :: Term _ PStakeDatum <-
pletC $ pletC $ pfromData $ pfromJust #$ ptryFindDatum # stakeOutputHash # txInfoF.datums
pfromData $
pfromJust #$ ptryFindDatum # stakeOutputHash # txInfoF.datums
stakeUnchanged <- pletC $ stakeInputHash #== stakeOutputHash stakeUnchanged <- pletC $ stakeInputHash #== stakeOutputHash
@ -391,7 +398,7 @@ proposalValidator proposal =
withSingleStake val = withSingleStake val =
withSingleStake' #$ plam $ \stakeIn stakeOut stakeUnchange -> unTermCont $ do withSingleStake' #$ plam $ \stakeIn stakeOut stakeUnchange -> unTermCont $ do
stakeInF <- pletAllC stakeIn stakeInF <- pletAllC $ pto stakeIn
val stakeInF stakeOut stakeUnchange val stakeInF stakeOut stakeUnchange
@ -581,7 +588,7 @@ proposalValidator proposal =
$ ptraceIfFalse "Proposal unchanged" proposalUnchanged $ ptraceIfFalse "Proposal unchanged" proposalUnchanged
-- At last, we ensure that all locks belong to this proposal will be removed. -- 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 = let templateStakeOut =
mkRecordConstr mkRecordConstr
@ -662,13 +669,12 @@ proposalValidator proposal =
pany pany
# plam # plam
( \( (pfield @"value" #) ( \( (pfield @"value" #)
. (pfield @"resolved" #) . (pfield @"resolved" #) ->
. pfromData ->
value value
) -> ) ->
psymbolValueOf # gstSymbol # value #== 1 psymbolValueOf # gstSymbol # value #== 1
) )
# txInfoF.inputs # pfromData txInfoF.inputs
let toFailedState = unTermCont $ do let toFailedState = unTermCont $ do
pguardC "Proposal should fail: not on time" $ pguardC "Proposal should fail: not on time" $

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

@ -30,9 +30,7 @@ module Agora.Proposal.Time (
pisMaxTimeRangeWidthValid, pisMaxTimeRangeWidthValid,
) where ) where
import Agora.Plutarch.Orphans () import Generics.SOP qualified as SOP
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, HasDatatypeInfo, I (I))
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
PExtended (PFinite), PExtended (PFinite),
PInterval (PInterval), PInterval (PInterval),
@ -44,7 +42,6 @@ import Plutarch.Api.V1 (
import Plutarch.DataRepr ( import Plutarch.DataRepr (
DerivePConstantViaData (..), DerivePConstantViaData (..),
PDataFields, PDataFields,
PIsDataReprInstances (..),
) )
import Plutarch.Extra.Field (pletAllC) import Plutarch.Extra.Field (pletAllC)
import Plutarch.Extra.TermCont (pguardC, pmatchC) import Plutarch.Extra.TermCont (pguardC, pmatchC)
@ -53,10 +50,9 @@ import Plutarch.Lift (
PConstantDecl, PConstantDecl,
PUnsafeLiftDecl (..), PUnsafeLiftDecl (..),
) )
import Plutarch.Numeric.Additive (AdditiveSemigroup ((+)))
import PlutusLedgerApi.V1.Time (POSIXTime) import PlutusLedgerApi.V1.Time (POSIXTime)
import PlutusTx qualified import PlutusTx qualified
import Prelude hiding ((+)) import Prelude
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -67,8 +63,22 @@ import Prelude hiding ((+))
newtype ProposalStartingTime = ProposalStartingTime newtype ProposalStartingTime = ProposalStartingTime
{ getProposalStartingTime :: POSIXTime { getProposalStartingTime :: POSIXTime
} }
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) deriving stock
deriving stock (Eq, Show, GHC.Generic) ( -- | @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. {- | Configuration of proposal timings.
@ -92,9 +102,12 @@ data ProposalTimingConfig = ProposalTimingConfig
, -- | @since 0.1.0 , -- | @since 0.1.0
Show Show
, -- | @since 0.1.0 , -- | @since 0.1.0
GHC.Generic Generic
)
deriving anyclass
( -- | @since 0.1.0
SOP.Generic
) )
deriving anyclass (Generic)
PlutusTx.makeIsDataIndexed 'ProposalTimingConfig [('ProposalTimingConfig, 0)] PlutusTx.makeIsDataIndexed 'ProposalTimingConfig [('ProposalTimingConfig, 0)]
@ -108,7 +121,7 @@ newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
, -- | @since 0.1.0 , -- | @since 0.1.0
Ord Ord
, -- | @since 0.1.0 , -- | @since 0.1.0
GHC.Generic Generic
) )
deriving newtype deriving newtype
( -- | @since 0.1.0 ( -- | @since 0.1.0
@ -154,41 +167,47 @@ data PProposalTime (s :: S) = PProposalTime
} }
deriving stock deriving stock
( -- | @since 0.1.0 ( -- | @since 0.1.0
GHC.Generic Generic
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic SOP.Generic
, -- | @since 0.1.0
SOP.HasDatatypeInfo
, -- | @since 0.1.0 , -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0
HasDatatypeInfo
, -- | @since 0.1.0 , -- | @since 0.1.0
PEq PEq
) )
instance DerivePlutusType PProposalTime where
type DPTStrat _ = PlutusTypeScott
-- | Plutarch-level version of 'ProposalStartingTime'. -- | Plutarch-level version of 'ProposalStartingTime'.
newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime) newtype PProposalStartingTime (s :: S) = PProposalStartingTime (Term s PPOSIXTime)
deriving deriving stock
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
SOP.Generic
, -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
, -- | @since 0.1.0 , -- | @since 0.1.0
PEq PEq
, -- | @since 0.1.0
POrd
) )
via (DerivePNewtype PProposalStartingTime PPOSIXTime)
instance DerivePlutusType PProposalStartingTime where
type DPTStrat _ = PlutusTypeNewtype
-- | @since 0.1.0 -- | @since 0.1.0
instance PUnsafeLiftDecl PProposalStartingTime where instance PUnsafeLiftDecl PProposalStartingTime where
type PLifted PProposalStartingTime = ProposalStartingTime type PLifted PProposalStartingTime = ProposalStartingTime
deriving via instance PTryFrom PData (PAsData PProposalStartingTime)
PAsData (DerivePNewtype PProposalStartingTime PPOSIXTime)
instance
PTryFrom PData (PAsData PProposalStartingTime)
-- | @since 0.1.0 -- | @since 0.1.0
deriving via deriving via
@ -213,29 +232,25 @@ newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
) )
} }
deriving stock deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic Generic
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
PIsDataRepr SOP.Generic
) , -- | @since 0.1.0
deriving
( -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
, -- | @since 0.1.0 , -- | @since 0.1.0
PDataFields PDataFields
) )
via (PIsDataReprInstances PProposalTimingConfig)
instance DerivePlutusType PProposalTimingConfig where
type DPTStrat _ = PlutusTypeData
-- | @since 0.1.0 -- | @since 0.1.0
deriving via PAsData (PIsDataReprInstances PProposalTimingConfig) instance PTryFrom PData (PAsData PProposalTimingConfig) instance PTryFrom PData PProposalTimingConfig
-- | @since 0.1.0 -- | @since 0.1.0
instance PUnsafeLiftDecl PProposalTimingConfig where instance PUnsafeLiftDecl PProposalTimingConfig where
@ -250,20 +265,30 @@ deriving via
-- | Plutarch-level version of 'MaxTimeRangeWidth'. -- | Plutarch-level version of 'MaxTimeRangeWidth'.
newtype PMaxTimeRangeWidth (s :: S) newtype PMaxTimeRangeWidth (s :: S)
= PMaxTimeRangeWidth (Term s PPOSIXTime) = PMaxTimeRangeWidth (Term s PPOSIXTime)
deriving deriving stock
( -- | @since 0.1.0 ( -- | @since 0.2.0
Generic
)
deriving anyclass
( -- | @since 0.2.0
SOP.Generic
, -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
, -- | @since 0.1.0 , -- | @since 0.1.0
PEq PEq
, -- | @since 0.2.0
PPartialOrd
, -- | @since 0.1.0 , -- | @since 0.1.0
POrd POrd
) )
via (DerivePNewtype PMaxTimeRangeWidth PPOSIXTime)
instance DerivePlutusType PMaxTimeRangeWidth where
type DPTStrat _ = PlutusTypeNewtype
-- | @since 0.1.0 -- | @since 0.1.0
deriving via PAsData (DerivePNewtype PMaxTimeRangeWidth PPOSIXTime) instance PTryFrom PData (PAsData PMaxTimeRangeWidth) instance PTryFrom PData (PAsData PMaxTimeRangeWidth)
-- | @since 0.1.0 -- | @since 0.1.0
instance PUnsafeLiftDecl PMaxTimeRangeWidth where type PLifted PMaxTimeRangeWidth = MaxTimeRangeWidth instance PUnsafeLiftDecl PMaxTimeRangeWidth where type PLifted PMaxTimeRangeWidth = MaxTimeRangeWidth

121
agora/Agora/Stake.hs
View file

@ -31,20 +31,16 @@ module Agora.Stake (
pisIrrelevant, pisIrrelevant,
) where ) where
import Agora.Plutarch.Orphans ()
import Agora.Proposal (PProposalId, PResultTag, ProposalId (..), ResultTag (..)) import Agora.Proposal (PProposalId, PResultTag, ProposalId (..), ResultTag (..))
import Agora.SafeMoney (GTTag) import Agora.SafeMoney (GTTag)
import Data.Tagged (Tagged (..)) import Data.Tagged (Tagged (..))
import GHC.Generics qualified as GHC import Generics.SOP qualified as SOP
import Generics.SOP (Generic, HasDatatypeInfo, I (I))
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
PMaybeData, PMaybeData,
PPubKeyHash, PPubKeyHash,
) )
import Plutarch.DataRepr ( import Plutarch.DataRepr (
DerivePConstantViaData (..), DerivePConstantViaData (..),
PDataFields,
PIsDataReprInstances (PIsDataReprInstances),
) )
import Plutarch.Extra.Field (pletAll) import Plutarch.Extra.Field (pletAll)
import Plutarch.Extra.IsData ( import Plutarch.Extra.IsData (
@ -52,7 +48,6 @@ import Plutarch.Extra.IsData (
ProductIsData (ProductIsData), ProductIsData (ProductIsData),
) )
import Plutarch.Extra.List (pnotNull) import Plutarch.Extra.List (pnotNull)
import Plutarch.Extra.Other (DerivePNewtype' (..))
import Plutarch.Extra.Sum (PSum (..)) import Plutarch.Extra.Sum (PSum (..))
import Plutarch.Extra.Traversable (pfoldMap) import Plutarch.Extra.Traversable (pfoldMap)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
@ -76,7 +71,7 @@ data Stake = Stake
} }
deriving stock deriving stock
( -- | @since 0.1.0 ( -- | @since 0.1.0
GHC.Generic Generic
) )
{- | Locks that are stored in the stake datums for various purposes. {- | Locks that are stored in the stake datums for various purposes.
@ -133,11 +128,11 @@ data ProposalLock
( -- | @since 0.1.0 ( -- | @since 0.1.0
Show Show
, -- | @since 0.1.0 , -- | @since 0.1.0
GHC.Generic Generic
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic SOP.Generic
) )
PlutusTx.makeIsDataIndexed PlutusTx.makeIsDataIndexed
@ -176,7 +171,12 @@ data StakeRedeemer
DelegateTo PubKeyHash DelegateTo PubKeyHash
| -- | Revoke the existing delegation. | -- | Revoke the existing delegation.
ClearDelegate ClearDelegate
deriving stock (Show, GHC.Generic) deriving stock
( -- | @since 0.1.0
Show
, -- | @since 0.1.0
Generic
)
PlutusTx.makeIsDataIndexed PlutusTx.makeIsDataIndexed
''StakeRedeemer ''StakeRedeemer
@ -208,8 +208,16 @@ data StakeDatum = StakeDatum
-- ^ The current proposals locking this stake. This field must be empty -- ^ The current proposals locking this stake. This field must be empty
-- for the stake to be usable for deposits and withdrawals. -- for the stake to be usable for deposits and withdrawals.
} }
deriving stock (Show, GHC.Generic) deriving stock
deriving anyclass (Generic) ( -- | @since 0.1.0
Show
, -- | @since 0.1.0
Generic
)
deriving anyclass
( -- | @since 0.1.0
SOP.Generic
)
deriving deriving
( -- | @since 0.1.0 ( -- | @since 0.1.0
PlutusTx.ToData PlutusTx.ToData
@ -231,34 +239,28 @@ newtype PStakeDatum (s :: S) = PStakeDatum
( PDataRecord ( PDataRecord
'[ "stakedAmount" ':= PDiscrete GTTag '[ "stakedAmount" ':= PDiscrete GTTag
, "owner" ':= PPubKeyHash , "owner" ':= PPubKeyHash
, "delegatedTo" ':= PMaybeData PPubKeyHash , "delegatedTo" ':= PMaybeData (PAsData PPubKeyHash)
, "lockedBy" ':= PBuiltinList (PAsData PProposalLock) , "lockedBy" ':= PBuiltinList (PAsData PProposalLock)
] ]
) )
} }
deriving stock deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic Generic
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
PIsDataRepr SOP.Generic
) , -- | @since 0.1.0
deriving
( -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
, -- | @since 0.1.0
PDataFields
, -- | @since 0.1.0 , -- | @since 0.1.0
PEq PEq
) )
via (DerivePNewtype' PStakeDatum)
instance DerivePlutusType PStakeDatum where
type DPTStrat _ = PlutusTypeNewtype
-- | @since 0.1.0 -- | @since 0.1.0
instance Plutarch.Lift.PUnsafeLiftDecl PStakeDatum where instance Plutarch.Lift.PUnsafeLiftDecl PStakeDatum where
@ -271,10 +273,7 @@ deriving via
(Plutarch.Lift.PConstantDecl StakeDatum) (Plutarch.Lift.PConstantDecl StakeDatum)
-- | @since 0.1.0 -- | @since 0.1.0
deriving via instance PTryFrom PData (PAsData PStakeDatum)
PAsData (DerivePNewtype' PStakeDatum)
instance
PTryFrom PData (PAsData PStakeDatum)
{- | Plutarch-level redeemer for Stake scripts. {- | Plutarch-level redeemer for Stake scripts.
@ -291,30 +290,23 @@ data PStakeRedeemer (s :: S)
| PDelegateTo (Term s (PDataRecord '["pkh" ':= PPubKeyHash])) | PDelegateTo (Term s (PDataRecord '["pkh" ':= PPubKeyHash]))
| PClearDelegate (Term s (PDataRecord '[])) | PClearDelegate (Term s (PDataRecord '[]))
deriving stock deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic Generic
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
PIsDataRepr SOP.Generic
) , -- | @since 0.1.0
deriving
( -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
) )
via PIsDataReprInstances PStakeRedeemer
instance DerivePlutusType PStakeRedeemer where
type DPTStrat _ = PlutusTypeData
-- | @since 0.1.0 -- | @since 0.1.0
deriving via instance PTryFrom PData PStakeRedeemer
PAsData (PIsDataReprInstances PStakeRedeemer)
instance
PTryFrom PData (PAsData PStakeRedeemer)
-- | @since 0.1.0 -- | @since 0.1.0
instance Plutarch.Lift.PUnsafeLiftDecl PStakeRedeemer where instance Plutarch.Lift.PUnsafeLiftDecl PStakeRedeemer where
@ -331,7 +323,13 @@ deriving via
@since 0.2.0 @since 0.2.0
-} -}
data PProposalLock (s :: S) data PProposalLock (s :: S)
= PCreated (Term s (PDataRecord '["created" ':= PProposalId])) = PCreated
( Term
s
( PDataRecord
'["created" ':= PProposalId]
)
)
| PVoted | PVoted
( Term ( Term
s s
@ -342,34 +340,30 @@ data PProposalLock (s :: S)
) )
) )
deriving stock deriving stock
( -- | @since 0.1.0
GHC.Generic
)
deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic Generic
, -- | @since 0.1.0
HasDatatypeInfo
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
PIsDataRepr SOP.Generic
) , -- | @since 0.1.0
deriving SOP.HasDatatypeInfo
( -- | @since 0.1.0 , -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
, -- | @since 0.1.0 , -- | @since 0.1.0
PEq PEq
) )
via (PIsDataReprInstances PProposalLock)
instance DerivePlutusType PProposalLock where
type DPTStrat _ = PlutusTypeData
-- | @since 0.1.0 -- | @since 0.1.0
deriving via instance PTryFrom PData PProposalLock
PAsData (PIsDataReprInstances PProposalLock)
instance -- | @since 0.2.0
PTryFrom PData (PAsData PProposalLock) instance PTryFrom PData (PAsData PProposalLock)
-- | @since 0.1.0 -- | @since 0.1.0
instance Plutarch.Lift.PUnsafeLiftDecl PProposalLock where instance Plutarch.Lift.PUnsafeLiftDecl PProposalLock where
@ -399,9 +393,7 @@ instance PShow PProposalLock where
pstakeLocked :: forall (s :: S). Term s (PStakeDatum :--> PBool) pstakeLocked :: forall (s :: S). Term s (PStakeDatum :--> PBool)
pstakeLocked = phoistAcyclic $ pstakeLocked = phoistAcyclic $
plam $ \stakeDatum -> plam $ \stakeDatum ->
let locks :: Term _ (PBuiltinList (PAsData PProposalLock)) pnotNull #$ pfield @"lockedBy" @(PBuiltinList _) # pto stakeDatum
locks = pfield @"lockedBy" # stakeDatum
in pnotNull # locks
{- | Get the number of *alive* proposals that were created by the given stake. {- | Get the number of *alive* proposals that were created by the given stake.
@ -439,19 +431,22 @@ data PStakeRole (s :: S)
PIrrelevant PIrrelevant
deriving stock deriving stock
( -- | @since 0.2.0 ( -- | @since 0.2.0
GHC.Generic Generic
) )
deriving anyclass deriving anyclass
( -- | @since 0.2.0 ( -- | @since 0.2.0
Generic SOP.Generic
, -- | @since 0.2.0 , -- | @since 0.2.0
PlutusType PlutusType
, -- | @since 0.2.0 , -- | @since 0.2.0
HasDatatypeInfo SOP.HasDatatypeInfo
, -- | @since 0.2.0 , -- | @since 0.2.0
PEq PEq
) )
instance DerivePlutusType PStakeRole where
type DPTStrat _ = PlutusTypeScott
{- | Retutn true if the stake was used to voted on the proposal. {- | Retutn true if the stake was used to voted on the proposal.
@since 0.2.0 @since 0.2.0

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

@ -19,9 +19,9 @@ import Agora.Utils (
mustFindDatum', mustFindDatum',
pdjust, pdjust,
pdnothing, pdnothing,
pmaybeData,
pvalidatorHashToTokenName, pvalidatorHashToTokenName,
) )
import Data.Default (def)
import Data.Function (on) import Data.Function (on)
import Data.Tagged (Tagged (..), untag) import Data.Tagged (Tagged (..), untag)
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
@ -106,7 +106,11 @@ stakePolicy gtClassRef =
pure $ pure $
pif pif
(psymbolValueOf # ownSymbol # txOutF.value #== 1) (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) in pnot # (pstakeLocked # datum)
) )
(pconstant False) (pconstant False)
@ -146,7 +150,9 @@ stakePolicy gtClassRef =
pletFieldsC @'["value", "address", "datumHash"] scriptOutputWithStakeST pletFieldsC @'["value", "address", "datumHash"] scriptOutputWithStakeST
datumF <- datumF <-
pletFieldsC @'["owner", "stakedAmount"] $ pletFieldsC @'["owner", "stakedAmount"] $
mustFindDatum' @PStakeDatum # outputF.datumHash # txInfoF.datums pto $
pfromData $
mustFindDatum' @(PAsData PStakeDatum) # outputF.datumHash # txInfoF.datums
let hasExpectedStake = let hasExpectedStake =
ptraceIfFalse "Stake ouput has expected amount of stake token" $ ptraceIfFalse "Stake ouput has expected amount of stake token" $
@ -232,12 +238,12 @@ stakeValidator stake =
] ]
txInfo txInfo
(pfromData -> stakeRedeemer, _) <- ptryFromC redeemer stakeRedeemer <- fst <$> ptryFromC redeemer
-- TODO: Use PTryFrom -- TODO: Use PTryFrom
let stakeDatum' :: Term _ PStakeDatum let stakeDatum' :: Term _ PStakeDatum
stakeDatum' = pfromData $ punsafeCoerce datum stakeDatum' = pfromData $ punsafeCoerce datum
stakeDatum <- pletAllC stakeDatum' stakeDatum <- pletAllC $ pto stakeDatum'
PSpending txOutRef <- pmatchC $ pfromData ctx.purpose PSpending txOutRef <- pmatchC $ pfromData ctx.purpose
@ -253,16 +259,16 @@ stakeValidator stake =
ownerSignsTransaction <- pletC $ signedBy # stakeDatum.owner ownerSignsTransaction <- pletC $ signedBy # stakeDatum.owner
delegateSignsTransaction <- delegateSignsTransaction <-
pletC $ pletC $ pconstant False
pmaybeData # pconstant False -- pmaybeData # pconstant False
# plam ((signedBy #) . pdata) -- # plam (signedBy #)
# stakeDatum.delegatedTo -- # stakeDatum.delegatedTo
stCurrencySymbol <- stCurrencySymbol <-
pletC $ pletC $
pconstant $ pconstant $
mintingPolicySymbol $ mintingPolicySymbol $
mkMintingPolicy (stakePolicy stake.gtClassRef) mkMintingPolicy def (stakePolicy stake.gtClassRef)
mintedST <- pletC $ psymbolValueOf # stCurrencySymbol # txInfoF.mint mintedST <- pletC $ psymbolValueOf # stCurrencySymbol # txInfoF.mint
valueSpent <- pletC $ pvalueSpent # txInfoF.inputs valueSpent <- pletC $ pvalueSpent # txInfoF.inputs
spentST <- pletC $ psymbolValueOf # stCurrencySymbol #$ valueSpent spentST <- pletC $ psymbolValueOf # stCurrencySymbol #$ valueSpent
@ -340,10 +346,10 @@ stakeValidator stake =
) )
# pfromData txInfoF.inputs # pfromData txInfoF.inputs
sortTxOuts :: Term _ (PBuiltinList (PAsData PTxOut) :--> PBuiltinList (PAsData PTxOut)) sortTxOuts :: Term _ (PBuiltinList PTxOut :--> PBuiltinList PTxOut)
sortTxOuts = phoistAcyclic $ plam (pmsortBy # plam ((#<) `on` (getDatumHash #)) #) sortTxOuts = phoistAcyclic $ plam (pmsortBy # plam ((#<) `on` (getDatumHash #)) #)
where where
getDatumHash :: Term _ (PAsData PTxOut :--> PDatumHash) getDatumHash :: Term _ (PTxOut :--> PDatumHash)
getDatumHash = phoistAcyclic $ plam ((pfromDJust #) . pfromData . (pfield @"datumHash" #)) getDatumHash = phoistAcyclic $ plam ((pfromDJust #) . pfromData . (pfield @"datumHash" #))
sortedOwnInputs = sortTxOuts # ownInputs sortedOwnInputs = sortTxOuts # ownInputs
@ -360,11 +366,12 @@ stakeValidator stake =
pguardC "ST at inputs must be 1" $ pguardC "ST at inputs must be 1" $
spentST #== 1 spentST #== 1
ownOutput <- pletC $ pfromData $ phead # ownOutputs ownOutput <- pletC $ phead # ownOutputs
stakeOut <- stakeOut <-
pletC $ pletC $
mustFindDatum' @PStakeDatum pfromData $
mustFindDatum' @(PAsData PStakeDatum)
# (pfield @"datumHash" # ownOutput) # (pfield @"datumHash" # ownOutput)
# txInfoF.datums # txInfoF.datums
@ -384,7 +391,7 @@ stakeValidator stake =
( #stakedAmount .= stakeDatum.stakedAmount ( #stakedAmount .= stakeDatum.stakedAmount
.& #owner .= stakeDatum.owner .& #owner .= stakeDatum.owner
.& #delegatedTo .= stakeDatum.delegatedTo .& #delegatedTo .= stakeDatum.delegatedTo
.& #lockedBy .= pfield @"lockedBy" # stakeOut .& #lockedBy .= pfield @"lockedBy" # pto stakeOut
) )
in stakeOut #== templateStakeDatum in stakeOut #== templateStakeDatum
@ -524,7 +531,7 @@ stakeValidator stake =
pguardC "Cannot delegate to the owner" $ pguardC "Cannot delegate to the owner" $
pnot #$ stakeDatum.owner #== pkh pnot #$ stakeDatum.owner #== pkh
pure $ setDelegate #$ pdjust # pkh pure $ setDelegate #$ pdjust # pdata pkh
------------------------------------------------------------ ------------------------------------------------------------
PClearDelegate _ -> PClearDelegate _ ->

32
agora/Agora/Treasury.hs
View file

@ -11,14 +11,16 @@ treasury.
module Agora.Treasury (module Agora.Treasury) where module Agora.Treasury (module Agora.Treasury) where
import Agora.AuthorityToken (singleAuthorityTokenBurned) import Agora.AuthorityToken (singleAuthorityTokenBurned)
import GHC.Generics qualified as GHC import Generics.SOP qualified as SOP
import Generics.SOP (Generic)
import Plutarch.Api.V1 (PValidator) import Plutarch.Api.V1 (PValidator)
import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting)) import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting))
import "plutarch" Plutarch.Api.V1.Value (PValue) import "plutarch" Plutarch.Api.V1.Value (PValue)
import Plutarch.Builtin (pforgetData) import Plutarch.Builtin (pforgetData)
import Plutarch.Extra.IsData (DerivePConstantViaEnum (..), EnumIsData (..)) import Plutarch.Extra.IsData (
import Plutarch.Extra.Other (DerivePNewtype' (..)) DerivePConstantViaEnum (..),
EnumIsData (..),
PlutusTypeEnumData,
)
import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC) import Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC, pmatchC)
import Plutarch.Lift (PConstantDecl (..), PLifted (..), PUnsafeLiftDecl) import Plutarch.Lift (PConstantDecl (..), PLifted (..), PUnsafeLiftDecl)
import Plutarch.TryFrom () import Plutarch.TryFrom ()
@ -38,7 +40,7 @@ data TreasuryRedeemer
, -- | @since 0.1.0 , -- | @since 0.1.0
Show Show
, -- | @since 0.1.0 , -- | @since 0.1.0
GHC.Generic Generic
, -- | @since 0.2.0 , -- | @since 0.2.0
Enum Enum
, -- | @since 0.2.0 , -- | @since 0.2.0
@ -46,7 +48,7 @@ data TreasuryRedeemer
) )
deriving anyclass deriving anyclass
( -- | @since 0.2.0 ( -- | @since 0.2.0
Generic SOP.Generic
) )
deriving deriving
( -- | @since 0.1.0 ( -- | @since 0.1.0
@ -63,23 +65,29 @@ data TreasuryRedeemer
@since 0.1.0 @since 0.1.0
-} -}
newtype PTreasuryRedeemer (s :: S) data PTreasuryRedeemer (s :: S)
= PTreasuryRedeemer (Term s PInteger) = PSpendTreasuryGAT
deriving stock deriving stock
( -- | @since 0.1.0 ( -- | @since 0.1.0
GHC.Generic Generic
, -- | @since 0.2.0
Bounded
, -- | @since 0.2.0
Enum
) )
deriving anyclass deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
Generic SOP.Generic
) )
deriving deriving anyclass
( -- | @since 0.1.0 ( -- | @since 0.1.0
PlutusType PlutusType
, -- | @since 0.1.0 , -- | @since 0.1.0
PIsData PIsData
) )
via (DerivePNewtype' PTreasuryRedeemer)
instance DerivePlutusType PTreasuryRedeemer where
type DPTStrat _ = PlutusTypeEnumData
-- | @since 0.1.0 -- | @since 0.1.0
instance PUnsafeLiftDecl PTreasuryRedeemer where instance PUnsafeLiftDecl PTreasuryRedeemer where

8
agora/Agora/Utils.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE QuantifiedConstraints #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{- | {- |
Module : Agora.Utils Module : Agora.Utils
@ -30,6 +31,7 @@ module Agora.Utils (
pdnothing, pdnothing,
) where ) where
import Data.Default (Default (def))
import Plutarch.Api.V1 ( import Plutarch.Api.V1 (
AmountGuarantees, AmountGuarantees,
KeyGuarantees, KeyGuarantees,
@ -139,7 +141,7 @@ pvalidatorHashToTokenName vh = pcon (PTokenName (pto vh))
@since 0.1.0 @since 0.1.0
-} -}
getMintingPolicySymbol :: ClosedTerm PMintingPolicy -> CurrencySymbol 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. {- | The entire value only contains one token of the given currency symbol.
@ -159,7 +161,7 @@ hasOnlyOneTokenOfCurrencySymbol = phoistAcyclic $
-} -}
mustFindDatum' :: mustFindDatum' ::
forall (datum :: PType). forall (datum :: PType).
(PIsData datum, PTryFrom PData (PAsData datum)) => (PIsData datum, PTryFrom PData datum) =>
forall s. forall s.
Term Term
s s
@ -172,7 +174,7 @@ mustFindDatum' = phoistAcyclic $
let dh = mustBePDJust # "Given TxOut dones't have a datum" # mdh let dh = mustBePDJust # "Given TxOut dones't have a datum" # mdh
dt = mustBePJust # "Datum not found in the transaction" #$ plookupTuple # dh # datums dt = mustBePJust # "Datum not found in the transaction" #$ plookupTuple # dh # datums
(d, _) <- ptryFromC $ pforgetData $ pdata dt (d, _) <- ptryFromC $ pforgetData $ pdata dt
pure $ pfromData d pure d
{- | Extract the value stored in a PMaybe container. {- | Extract the value stored in a PMaybe container.
If there's no value, throw an error with the given message. If there's no value, throw an error with the given message.

1162
bench.csv
View file

File diff suppressed because it is too large Load diff