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

use lpe's AssetClass; fix errors

Browse source
This commit is contained in:
Hongrui Fang 2022-10-19 22:46:57 +08:00
parent 6ae1dcdb40
commit cac856f4eb
24 changed files with 195 additions and 196 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -34,7 +34,7 @@ import Plutarch.Context (
withRef, withRef,
withValue, withValue,
) )
import PlutusLedgerApi.V1.Value (assetClassValue) import Plutarch.Extra.AssetClass (assetClassValue)
import PlutusLedgerApi.V2 ( import PlutusLedgerApi.V2 (
ScriptContext (scriptContextTxInfo), ScriptContext (scriptContextTxInfo),
TxInInfo (txInInfoOutRef), TxInInfo (txInInfoOutRef),

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

@ -16,16 +16,16 @@ import Agora.Effect.GovernorMutation (
) )
import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor)) import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
import Agora.Proposal (ProposalId (..), ProposalThresholds (..)) import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
import Agora.SafeMoney (AuthorityTokenTag)
import Agora.Utils (validatorHashToTokenName) import Agora.Utils (validatorHashToTokenName)
import Data.Default.Class (Default (def)) import Data.Default.Class (Default (def))
import Data.Map import Data.Map ((!))
import Data.Tagged (Tagged (..)) import Data.Tagged (Tagged (..))
import Plutarch.Api.V2 (validatorHash) import Plutarch.Api.V2 (validatorHash)
import Plutarch.Extra.AssetClass (AssetClass (AssetClass), assetClassValue)
import PlutusLedgerApi.V1 qualified as Interval (always) import PlutusLedgerApi.V1 qualified as Interval (always)
import PlutusLedgerApi.V1.Address (scriptHashAddress) import PlutusLedgerApi.V1.Address (scriptHashAddress)
import PlutusLedgerApi.V1.Value (AssetClass, assetClass)
import PlutusLedgerApi.V1.Value qualified as Value ( import PlutusLedgerApi.V1.Value qualified as Value (
assetClassValue,
singleton, singleton,
) )
import PlutusLedgerApi.V2 ( import PlutusLedgerApi.V2 (
@ -66,8 +66,8 @@ effectValidatorAddress :: Address
effectValidatorAddress = scriptHashAddress effectValidatorHash effectValidatorAddress = scriptHashAddress effectValidatorHash
-- | The assetclass of the authority token. -- | The assetclass of the authority token.
atAssetClass :: AssetClass atAssetClass :: Tagged AuthorityTokenTag AssetClass
atAssetClass = assetClass authorityTokenSymbol tokenName atAssetClass = Tagged $ AssetClass authorityTokenSymbol tokenName
where where
tokenName = validatorHashToTokenName effectValidatorHash tokenName = validatorHashToTokenName effectValidatorHash
@ -99,11 +99,11 @@ mkEffectDatum newGovDatum =
-} -}
mkEffectTxInfo :: GovernorDatum -> TxInfo mkEffectTxInfo :: GovernorDatum -> TxInfo
mkEffectTxInfo newGovDatum = mkEffectTxInfo newGovDatum =
let gst = Value.assetClassValue governorAssetClass 1 let gst = assetClassValue governorAssetClass 1
at = Value.assetClassValue atAssetClass 1 at = assetClassValue atAssetClass 1
-- One authority token is burnt in the process. -- One authority token is burnt in the process.
burnt = Value.assetClassValue atAssetClass (-1) burnt = assetClassValue atAssetClass (-1)
-- --

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

@ -32,6 +32,7 @@ import Plutarch.Context (
withRef, withRef,
withValue, withValue,
) )
import Plutarch.Extra.AssetClass (assetClassValue)
import PlutusLedgerApi.V1.Value qualified as Value import PlutusLedgerApi.V1.Value qualified as Value
import PlutusLedgerApi.V2 ( import PlutusLedgerApi.V2 (
CurrencySymbol (CurrencySymbol), CurrencySymbol (CurrencySymbol),
@ -145,7 +146,7 @@ governorRedeemer = MutateGovernor
mkGovernorBuilder :: forall b. CombinableBuilder b => GovernorParameters -> b mkGovernorBuilder :: forall b. CombinableBuilder b => GovernorParameters -> b
mkGovernorBuilder ps = mkGovernorBuilder ps =
let gst = Value.assetClassValue governorAssetClass 1 let gst = assetClassValue governorAssetClass 1
value = sortValue $ gst <> minAda value = sortValue $ gst <> minAda
gstOutput = gstOutput =
if ps.stealGST if ps.stealGST

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

@ -63,6 +63,7 @@ import Agora.Proposal.Time (
votingTime votingTime
), ),
) )
import Agora.SafeMoney (AuthorityTokenTag, GTTag)
import Agora.Stake ( import Agora.Stake (
StakeDatum (..), StakeDatum (..),
) )
@ -73,7 +74,7 @@ import Data.Default (def)
import Data.List (singleton, sort) import Data.List (singleton, sort)
import Data.Map.Strict qualified as StrictMap import Data.Map.Strict qualified as StrictMap
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Tagged (untag) import Data.Tagged (Tagged (Tagged), untag)
import Plutarch.Context ( import Plutarch.Context (
input, input,
mint, mint,
@ -87,9 +88,8 @@ import Plutarch.Context (
withRef, withRef,
withValue, withValue,
) )
import Plutarch.Extra.AssetClass (AssetClass (AssetClass), assetClassValue)
import Plutarch.Lift (PLifted, PUnsafeLiftDecl) import Plutarch.Lift (PLifted, PUnsafeLiftDecl)
import PlutusLedgerApi.V1.Value (AssetClass (..))
import PlutusLedgerApi.V1.Value qualified as Value
import PlutusLedgerApi.V2 ( import PlutusLedgerApi.V2 (
Credential (PubKeyCredential), Credential (PubKeyCredential),
DatumHash, DatumHash,
@ -113,7 +113,7 @@ import Sample.Shared (
governorValidator, governorValidator,
governorValidatorHash, governorValidatorHash,
minAda, minAda,
proposalPolicySymbol, proposalAssetClass,
proposalValidator, proposalValidator,
proposalValidatorHash, proposalValidatorHash,
signer, signer,
@ -217,7 +217,7 @@ data ProposalParameters = ProposalParameters
-- | Everything about the generated stake stuff. -- | Everything about the generated stake stuff.
data StakeParameters = StakeParameters data StakeParameters = StakeParameters
{ numStake :: NumStake { numStake :: NumStake
, perStakeGTs :: Integer , perStakeGTs :: Tagged GTTag Integer
, transactionSignedByOwners :: Bool , transactionSignedByOwners :: Bool
} }
@ -319,7 +319,7 @@ proposalRef = TxOutRef proposalTxRef 1
-} -}
mkProposalBuilder :: forall b. CombinableBuilder b => ProposalParameters -> b mkProposalBuilder :: forall b. CombinableBuilder b => ProposalParameters -> b
mkProposalBuilder ps = mkProposalBuilder ps =
let pst = Value.singleton proposalPolicySymbol "" 1 let pst = assetClassValue proposalAssetClass 1
value = sortValue $ minAda <> pst value = sortValue $ minAda <> pst
in mconcat in mconcat
[ input $ [ input $
@ -356,7 +356,7 @@ mkStakeInputDatums :: StakeParameters -> [StakeDatum]
mkStakeInputDatums ps = mkStakeInputDatums ps =
let template = let template =
StakeDatum StakeDatum
{ stakedAmount = fromInteger ps.perStakeGTs { stakedAmount = ps.perStakeGTs
, owner = PubKeyCredential "" , owner = PubKeyCredential ""
, delegatedTo = Nothing , delegatedTo = Nothing
, lockedBy = [] , lockedBy = []
@ -376,9 +376,9 @@ mkStakeBuilder ps =
let perStakeValue = let perStakeValue =
sortValue $ sortValue $
minAda minAda
<> Value.assetClassValue stakeAssetClass 1 <> assetClassValue stakeAssetClass 1
<> Value.assetClassValue <> assetClassValue
(untag governor.gtClassRef) governor.gtClassRef
ps.perStakeGTs ps.perStakeGTs
perStake idx i = perStake idx i =
let withSig = let withSig =
@ -432,7 +432,7 @@ governorRef = TxOutRef governorTxRef 2
-} -}
mkGovernorBuilder :: forall b. CombinableBuilder b => GovernorParameters -> b mkGovernorBuilder :: forall b. CombinableBuilder b => GovernorParameters -> b
mkGovernorBuilder ps = mkGovernorBuilder ps =
let gst = Value.assetClassValue governorAssetClass 1 let gst = assetClassValue governorAssetClass 1
value = sortValue $ gst <> minAda value = sortValue $ gst <> minAda
in mconcat in mconcat
[ input $ [ input $
@ -476,8 +476,8 @@ mkAuthorityTokenBuilder ps@AuthorityTokenParameters {carryDatum} =
(True, Nothing) -> "deadbeef" (True, Nothing) -> "deadbeef"
(False, Just as) -> scriptHashToTokenName as (False, Just as) -> scriptHashToTokenName as
(False, Nothing) -> "" (False, Nothing) -> ""
ac = AssetClass (authorityTokenSymbol, tn) ac = Tagged @AuthorityTokenTag $ AssetClass authorityTokenSymbol tn
minted = Value.assetClassValue ac 1 minted = assetClassValue ac 1
value = sortValue $ minAda <> minted value = sortValue $ minAda <> minted
in mconcat in mconcat
[ mint minted [ mint minted
@ -678,10 +678,11 @@ getNextState = \case
Finished -> error "Cannot advance 'Finished' proposal" Finished -> error "Cannot advance 'Finished' proposal"
-- | Calculate the number of GTs per stake in order to exceed the minimum limit. -- | Calculate the number of GTs per stake in order to exceed the minimum limit.
compPerStakeGTsForDraft :: NumStake -> Integer compPerStakeGTsForDraft :: NumStake -> Tagged GTTag Integer
compPerStakeGTsForDraft nCosigners = compPerStakeGTsForDraft nCosigners =
untag (def :: ProposalThresholds).toVoting Tagged $
`div` fromIntegral nCosigners + 1 untag (def :: ProposalThresholds).toVoting
`div` fromIntegral nCosigners + 1
dummyDatum :: () dummyDatum :: ()
dummyDatum = () dummyDatum = ()
@ -945,8 +946,9 @@ mkInsufficientCosignsBundle nCosigners nEffects =
} }
where where
insuffcientPerStakeGTs = insuffcientPerStakeGTs =
untag (def :: ProposalThresholds).toVoting Tagged $
`div` fromIntegral nCosigners - 1 untag (def :: ProposalThresholds).toVoting
`div` fromIntegral nCosigners - 1
template = mkValidToNextStateBundle nCosigners nEffects False Draft template = mkValidToNextStateBundle nCosigners nEffects False Draft
-- * From VotingReady -- * From VotingReady

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

@ -48,7 +48,7 @@ import Data.Coerce (coerce)
import Data.Default (def) import Data.Default (def)
import Data.List (sort) import Data.List (sort)
import Data.Map.Strict qualified as StrictMap import Data.Map.Strict qualified as StrictMap
import Data.Tagged (untag) import Data.Tagged (Tagged)
import Plutarch.Context ( import Plutarch.Context (
input, input,
normalizeValue, normalizeValue,
@ -63,8 +63,7 @@ import Plutarch.Context (
withRef, withRef,
withValue, withValue,
) )
import Plutarch.SafeMoney (Discrete (Discrete)) import Plutarch.Extra.AssetClass (assetClassValue)
import PlutusLedgerApi.V1.Value qualified as Value
import PlutusLedgerApi.V2 ( import PlutusLedgerApi.V2 (
Credential (PubKeyCredential), Credential (PubKeyCredential),
POSIXTime (POSIXTime), POSIXTime (POSIXTime),
@ -73,10 +72,9 @@ import PlutusLedgerApi.V2 (
) )
import Sample.Proposal.Shared (proposalTxRef, stakeTxRef) import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
import Sample.Shared ( import Sample.Shared (
fromDiscrete,
governor, governor,
minAda, minAda,
proposalPolicySymbol, proposalAssetClass,
proposalValidator, proposalValidator,
proposalValidatorHash, proposalValidatorHash,
stakeAssetClass, stakeAssetClass,
@ -130,8 +128,8 @@ data Validity = Validity
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
mkStakeAmount :: StakedAmount -> Discrete GTTag mkStakeAmount :: StakedAmount -> Tagged GTTag Integer
mkStakeAmount Sufficient = Discrete $ (def @ProposalThresholds).cosign mkStakeAmount Sufficient = (def @ProposalThresholds).cosign
mkStakeAmount Insufficient = mkStakeAmount Sufficient - 1 mkStakeAmount Insufficient = mkStakeAmount Sufficient - 1
mkStakeOwner :: StakeOwner -> PubKeyHash mkStakeOwner :: StakeOwner -> PubKeyHash
@ -229,8 +227,8 @@ stakeRef = TxOutRef stakeTxRef 0
cosign :: forall b. CombinableBuilder b => ParameterBundle -> b cosign :: forall b. CombinableBuilder b => ParameterBundle -> b
cosign ps = builder cosign ps = builder
where where
pst = Value.singleton proposalPolicySymbol "" 1 pst = assetClassValue proposalAssetClass 1
sst = Value.assetClassValue stakeAssetClass 1 sst = assetClassValue stakeAssetClass 1
---------------------------------------------------------------------------- ----------------------------------------------------------------------------
@ -240,11 +238,9 @@ cosign ps = builder
stakeValue = stakeValue =
normalizeValue $ normalizeValue $
minAda minAda
<> Value.assetClassValue <> assetClassValue
(untag governor.gtClassRef) governor.gtClassRef
( fromDiscrete $ (mkStakeAmount ps.stakeParameters.gtAmount)
mkStakeAmount ps.stakeParameters.gtAmount
)
<> sst <> sst
stakeBuilder = stakeBuilder =

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

@ -47,10 +47,11 @@ import Agora.Stake (
import Data.Coerce (coerce) import Data.Coerce (coerce)
import Data.Default (Default (def)) import Data.Default (Default (def))
import Data.Map.Strict qualified as StrictMap import Data.Map.Strict qualified as StrictMap
import Data.Tagged (untag) import Data.Tagged (Tagged)
import Plutarch.Context ( import Plutarch.Context (
input, input,
mint, mint,
normalizeValue,
output, output,
script, script,
signedWith, signedWith,
@ -60,8 +61,7 @@ import Plutarch.Context (
withRef, withRef,
withValue, withValue,
) )
import Plutarch.SafeMoney (Discrete) import Plutarch.Extra.AssetClass (assetClassValue)
import PlutusLedgerApi.V1.Value qualified as Value
import PlutusLedgerApi.V2 ( import PlutusLedgerApi.V2 (
Credential (PubKeyCredential), Credential (PubKeyCredential),
POSIXTime (POSIXTime), POSIXTime (POSIXTime),
@ -71,12 +71,12 @@ import PlutusLedgerApi.V2 (
) )
import Sample.Proposal.Shared (stakeTxRef) import Sample.Proposal.Shared (stakeTxRef)
import Sample.Shared ( import Sample.Shared (
fromDiscrete,
governor, governor,
governorAssetClass, governorAssetClass,
governorValidator, governorValidator,
governorValidatorHash, governorValidatorHash,
minAda, minAda,
proposalAssetClass,
proposalPolicy, proposalPolicy,
proposalPolicySymbol, proposalPolicySymbol,
proposalStartingTimeFromTimeRange, proposalStartingTimeFromTimeRange,
@ -127,7 +127,7 @@ thisProposalId :: ProposalId
thisProposalId = ProposalId 25 thisProposalId = ProposalId 25
-- | The arbitrary staked amount. Doesn;t really matter in this case. -- | The arbitrary staked amount. Doesn;t really matter in this case.
stakedGTs :: Discrete GTTag stakedGTs :: Tagged GTTag Integer
stakedGTs = 5 stakedGTs = 5
-- | The owner of the stake. -- | The owner of the stake.
@ -282,9 +282,9 @@ governorRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be
createProposal :: forall b. CombinableBuilder b => Parameters -> b createProposal :: forall b. CombinableBuilder b => Parameters -> b
createProposal ps = builder createProposal ps = builder
where where
pst = Value.singleton proposalPolicySymbol "" 1 pst = assetClassValue proposalAssetClass 1
sst = Value.assetClassValue stakeAssetClass 1 sst = assetClassValue stakeAssetClass 1
gst = Value.assetClassValue governorAssetClass 1 gst = assetClassValue governorAssetClass 1
--- ---
@ -292,7 +292,7 @@ createProposal ps = builder
stakeValue = stakeValue =
sortValue $ sortValue $
sst sst
<> Value.assetClassValue (untag governor.gtClassRef) (fromDiscrete stakedGTs) <> assetClassValue governor.gtClassRef stakedGTs
<> minAda <> minAda
proposalValue = sortValue $ pst <> minAda proposalValue = sortValue $ pst <> minAda
@ -314,11 +314,8 @@ createProposal ps = builder
withSig withSig
, --- , ---
mint $ mint $
sortValue $ normalizeValue
pst pst
<>
-- 0 Ada entry, see #174
Value.singleton "" "" 0
, --- , ---
timeRange $ mkTimeRange ps timeRange $ mkTimeRange ps
, input $ , input $

24
agora-specs/Sample/Proposal/Unlock.hs
View file

@ -41,6 +41,7 @@ import Agora.Proposal (
ResultTag (..), ResultTag (..),
) )
import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime), ProposalTimingConfig (..)) import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime), ProposalTimingConfig (..))
import Agora.SafeMoney (GTTag)
import Agora.Stake ( import Agora.Stake (
ProposalLock (..), ProposalLock (..),
StakeDatum (..), StakeDatum (..),
@ -48,7 +49,7 @@ import Agora.Stake (
) )
import Data.Default.Class (Default (def)) import Data.Default.Class (Default (def))
import Data.Map.Strict qualified as StrictMap import Data.Map.Strict qualified as StrictMap
import Data.Tagged (Tagged (Tagged), untag) import Data.Tagged (Tagged, untag)
import Plutarch.Context ( import Plutarch.Context (
input, input,
normalizeValue, normalizeValue,
@ -62,8 +63,7 @@ import Plutarch.Context (
withRef, withRef,
withValue, withValue,
) )
import Plutarch.SafeMoney (Discrete (Discrete)) import Plutarch.Extra.AssetClass (assetClassValue)
import PlutusLedgerApi.V1.Value qualified as Value
import PlutusLedgerApi.V2 ( import PlutusLedgerApi.V2 (
Credential (PubKeyCredential), Credential (PubKeyCredential),
PubKeyHash, PubKeyHash,
@ -73,7 +73,7 @@ import Sample.Proposal.Shared (stakeTxRef)
import Sample.Shared ( import Sample.Shared (
governor, governor,
minAda, minAda,
proposalPolicySymbol, proposalAssetClass,
proposalValidator, proposalValidator,
proposalValidatorHash, proposalValidatorHash,
stakeAssetClass, stakeAssetClass,
@ -106,10 +106,10 @@ defVoteFor :: ResultTag
defVoteFor = ResultTag 0 defVoteFor = ResultTag 0
-- | The default number of GTs the stake will have. -- | The default number of GTs the stake will have.
defStakedGTs :: Integer defStakedGTs :: Tagged GTTag Integer
defStakedGTs = 100000 defStakedGTs = 100000
alteredStakedGTs :: Integer alteredStakedGTs :: Tagged GTTag Integer
alteredStakedGTs = 100 alteredStakedGTs = 100
-- | Default owner of the stakes. -- | Default owner of the stakes.
@ -186,7 +186,7 @@ stakeRedeemer = RetractVotes
mkStakeInputDatum :: StakeParameters -> StakeDatum mkStakeInputDatum :: StakeParameters -> StakeDatum
mkStakeInputDatum ps = mkStakeInputDatum ps =
StakeDatum StakeDatum
{ stakedAmount = Discrete $ Tagged defStakedGTs { stakedAmount = defStakedGTs
, owner = PubKeyCredential defOwner , owner = PubKeyCredential defOwner
, delegatedTo = Just $ PubKeyCredential defDelegatee , delegatedTo = Just $ PubKeyCredential defDelegatee
, lockedBy = stakeLocks , lockedBy = stakeLocks
@ -231,7 +231,7 @@ mkProposalInputDatum sps pps =
updatVotes (ProposalVotes vt) = updatVotes (ProposalVotes vt) =
ProposalVotes $ ProposalVotes $
StrictMap.adjust StrictMap.adjust
(+ sps.numStakes * defStakedGTs) (+ sps.numStakes * untag defStakedGTs)
defVoteFor defVoteFor
vt vt
@ -240,7 +240,7 @@ mkProposalInputDatum sps pps =
unlock :: forall b. CombinableBuilder b => ParameterBundle -> b unlock :: forall b. CombinableBuilder b => ParameterBundle -> b
unlock ps = builder unlock ps = builder
where where
pst = Value.singleton proposalPolicySymbol "" 1 pst = assetClassValue proposalAssetClass 1
proposalInputDatum = proposalInputDatum =
mkProposalInputDatum mkProposalInputDatum
@ -275,7 +275,7 @@ unlock ps = builder
--- ---
sst = Value.assetClassValue stakeAssetClass 1 sst = assetClassValue stakeAssetClass 1
stakeInputDatum = mkStakeInputDatum ps.stakeParameters stakeInputDatum = mkStakeInputDatum ps.stakeParameters
@ -302,8 +302,8 @@ unlock ps = builder
mconcat mconcat
[ minAda [ minAda
, sst , sst
, Value.assetClassValue , assetClassValue
(untag governor.gtClassRef) governor.gtClassRef
gt gt
] ]

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

@ -42,6 +42,7 @@ import Agora.Proposal.Time (
ProposalStartingTime (ProposalStartingTime), ProposalStartingTime (ProposalStartingTime),
ProposalTimingConfig (draftTime, votingTime), ProposalTimingConfig (draftTime, votingTime),
) )
import Agora.SafeMoney (GTTag)
import Agora.Stake ( import Agora.Stake (
ProposalLock (Voted), ProposalLock (Voted),
StakeDatum (..), StakeDatum (..),
@ -50,7 +51,7 @@ import Agora.Stake (
import Data.Default (Default (def)) import Data.Default (Default (def))
import Data.Map.Strict qualified as StrictMap import Data.Map.Strict qualified as StrictMap
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Data.Tagged (untag) import Data.Tagged (Tagged, untag)
import Plutarch.Context ( import Plutarch.Context (
input, input,
mint, mint,
@ -64,14 +65,14 @@ import Plutarch.Context (
withRef, withRef,
withValue, withValue,
) )
import PlutusLedgerApi.V1.Value qualified as Value import Plutarch.Extra.AssetClass (adaClass, assetClassValue)
import PlutusLedgerApi.V2 (Credential (PubKeyCredential), PubKeyHash) import PlutusLedgerApi.V2 (Credential (PubKeyCredential), PubKeyHash)
import PlutusLedgerApi.V2.Contexts (TxOutRef (TxOutRef)) import PlutusLedgerApi.V2.Contexts (TxOutRef (TxOutRef))
import Sample.Proposal.Shared (proposalTxRef) import Sample.Proposal.Shared (proposalTxRef)
import Sample.Shared ( import Sample.Shared (
governor, governor,
minAda, minAda,
proposalPolicySymbol, proposalAssetClass,
proposalValidator, proposalValidator,
proposalValidatorHash, proposalValidatorHash,
stakeAssetClass, stakeAssetClass,
@ -102,7 +103,7 @@ data StakeParameters = StakeParameters
} }
newtype StakeInputParameters = StakeInputParameters newtype StakeInputParameters = StakeInputParameters
{ perStakeGTs :: Integer { perStakeGTs :: Tagged GTTag Integer
} }
data StakeOutputParameters = StakeOutputParameters data StakeOutputParameters = StakeOutputParameters
@ -189,7 +190,7 @@ mkStakeRedeemer params =
mkStakeInputDatum :: StakeInputParameters -> StakeDatum mkStakeInputDatum :: StakeInputParameters -> StakeDatum
mkStakeInputDatum params = mkStakeInputDatum params =
StakeDatum StakeDatum
{ stakedAmount = fromInteger params.perStakeGTs { stakedAmount = params.perStakeGTs
, owner = PubKeyCredential stakeOwner , owner = PubKeyCredential stakeOwner
, delegatedTo = Just (PubKeyCredential delegatee) , delegatedTo = Just (PubKeyCredential delegatee)
, lockedBy = , lockedBy =
@ -205,8 +206,8 @@ mkStakeRef o i = TxOutRef proposalTxRef $ o + i
vote :: forall b. CombinableBuilder b => ParameterBundle -> b vote :: forall b. CombinableBuilder b => ParameterBundle -> b
vote params = vote params =
let pst = Value.singleton proposalPolicySymbol "" 1 let pst = assetClassValue proposalAssetClass 1
sst = Value.assetClassValue stakeAssetClass 1 sst = assetClassValue stakeAssetClass 1
--- ---
@ -217,8 +218,8 @@ vote params =
stakeInputValue = stakeInputValue =
normalizeValue $ normalizeValue $
sst sst
<> Value.assetClassValue <> assetClassValue
(untag governor.gtClassRef) governor.gtClassRef
params.stakeParameters.stakeInputParameters.perStakeGTs params.stakeParameters.stakeInputParameters.perStakeGTs
<> minAda <> minAda
@ -246,11 +247,11 @@ vote params =
10_000_000 10_000_000
in normalizeValue $ in normalizeValue $
sst sst
<> Value.assetClassValue <> assetClassValue
(untag governor.gtClassRef) governor.gtClassRef
gtAmount gtAmount
<> minAda <> minAda
<> Value.singleton "" "" adaAmount <> assetClassValue adaClass adaAmount
stakeRedeemer = stakeRedeemer =
mkStakeRedeemer params.stakeParameters.stakeOutputParameters mkStakeRedeemer params.stakeParameters.stakeOutputParameters
@ -269,7 +270,7 @@ vote params =
, withRef $ mkStakeRef numProposals' i , withRef $ mkStakeRef numProposals' i
] ]
, if params.stakeParameters.stakeOutputParameters.burnStakes , if params.stakeParameters.stakeOutputParameters.burnStakes
then mint $ Value.assetClassValue stakeAssetClass (-1) then mint $ assetClassValue stakeAssetClass (-1)
else else
output $ output $
mconcat mconcat
@ -292,7 +293,7 @@ vote params =
else id else id
) )
. ( + . ( +
params.stakeParameters.stakeInputParameters.perStakeGTs untag params.stakeParameters.stakeInputParameters.perStakeGTs
* params.stakeParameters.numStakes * params.stakeParameters.numStakes
) )
) )

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

@ -14,7 +14,6 @@ module Sample.Shared (
minAda, minAda,
deterministicTracingConfing, deterministicTracingConfing,
mkRedeemer, mkRedeemer,
fromDiscrete,
-- * Agora Scripts -- * Agora Scripts
agoraScripts, agoraScripts,
@ -46,6 +45,7 @@ module Sample.Shared (
proposalValidatorHash, proposalValidatorHash,
proposalValidatorAddress, proposalValidatorAddress,
proposalStartingTimeFromTimeRange, proposalStartingTimeFromTimeRange,
proposalAssetClass,
-- ** Authority -- ** Authority
authorityTokenPolicy, authorityTokenPolicy,
@ -71,10 +71,10 @@ import Agora.Proposal.Time (
ProposalStartingTime (ProposalStartingTime), ProposalStartingTime (ProposalStartingTime),
ProposalTimingConfig (..), ProposalTimingConfig (..),
) )
import Agora.SafeMoney (GovernorSTTag, ProposalSTTag, StakeSTTag)
import Agora.Utils ( import Agora.Utils (
validatorHashToTokenName, validatorHashToTokenName,
) )
import Data.Coerce (coerce)
import Data.Default.Class (Default (..)) import Data.Default.Class (Default (..))
import Data.Map (Map, (!)) import Data.Map (Map, (!))
import Data.Tagged (Tagged (..)) import Data.Tagged (Tagged (..))
@ -85,11 +85,10 @@ import Plutarch.Api.V2 (
mintingPolicySymbol, mintingPolicySymbol,
validatorHash, validatorHash,
) )
import Plutarch.SafeMoney (Discrete (Discrete)) import Plutarch.Extra.AssetClass (AssetClass (AssetClass))
import PlutusLedgerApi.V1.Address (scriptHashAddress) import PlutusLedgerApi.V1.Address (scriptHashAddress)
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass), TokenName, Value) import PlutusLedgerApi.V1.Value (TokenName, Value)
import PlutusLedgerApi.V1.Value qualified as Value ( import PlutusLedgerApi.V1.Value qualified as Value (
assetClass,
singleton, singleton,
) )
import PlutusLedgerApi.V2 ( import PlutusLedgerApi.V2 (
@ -133,7 +132,7 @@ governor = Governor oref gt mc
oref = gstUTXORef oref = gstUTXORef
gt = gt =
Tagged $ Tagged $
Value.assetClass AssetClass
"da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
"LQ" "LQ"
mc = 20 mc = 20
@ -155,8 +154,8 @@ stakePolicy = MintingPolicy $ agoraScripts ! "agora:stakePolicy"
stakeSymbol :: CurrencySymbol stakeSymbol :: CurrencySymbol
stakeSymbol = mintingPolicySymbol stakePolicy stakeSymbol = mintingPolicySymbol stakePolicy
stakeAssetClass :: AssetClass stakeAssetClass :: Tagged StakeSTTag AssetClass
stakeAssetClass = AssetClass (stakeSymbol, validatorHashToTokenName stakeValidatorHash) stakeAssetClass = Tagged $ AssetClass stakeSymbol (validatorHashToTokenName stakeValidatorHash)
stakeValidator :: Validator stakeValidator :: Validator
stakeValidator = Validator $ agoraScripts ! "agora:stakeValidator" stakeValidator = Validator $ agoraScripts ! "agora:stakeValidator"
@ -179,8 +178,8 @@ governorValidator = Validator $ agoraScripts ! "agora:governorValidator"
governorSymbol :: CurrencySymbol governorSymbol :: CurrencySymbol
governorSymbol = mintingPolicySymbol governorPolicy governorSymbol = mintingPolicySymbol governorPolicy
governorAssetClass :: AssetClass governorAssetClass :: Tagged GovernorSTTag AssetClass
governorAssetClass = AssetClass (governorSymbol, "") governorAssetClass = Tagged $ AssetClass governorSymbol ""
governorValidatorHash :: ValidatorHash governorValidatorHash :: ValidatorHash
governorValidatorHash = validatorHash governorValidator governorValidatorHash = validatorHash governorValidator
@ -194,6 +193,9 @@ proposalPolicy = MintingPolicy $ agoraScripts ! "agora:proposalPolicy"
proposalPolicySymbol :: CurrencySymbol proposalPolicySymbol :: CurrencySymbol
proposalPolicySymbol = mintingPolicySymbol proposalPolicy proposalPolicySymbol = mintingPolicySymbol proposalPolicy
proposalAssetClass :: Tagged ProposalSTTag AssetClass
proposalAssetClass = Tagged $ AssetClass proposalPolicySymbol ""
-- | A sample 'PubKeyHash'. -- | A sample 'PubKeyHash'.
signer :: PubKeyHash signer :: PubKeyHash
signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
@ -260,9 +262,6 @@ proposalStartingTimeFromTimeRange _ = error "Given time range should be finite a
mkRedeemer :: forall redeemer. PlutusTx.ToData redeemer => redeemer -> Redeemer mkRedeemer :: forall redeemer. PlutusTx.ToData redeemer => redeemer -> Redeemer
mkRedeemer = Redeemer . toBuiltinData mkRedeemer = Redeemer . toBuiltinData
fromDiscrete :: forall tag. Discrete tag -> Integer
fromDiscrete = coerce
------------------------------------------------------------------ ------------------------------------------------------------------
treasuryOut :: TxOut treasuryOut :: TxOut

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

@ -23,7 +23,7 @@ import Agora.SafeMoney (GTTag)
import Agora.Stake ( import Agora.Stake (
StakeDatum (StakeDatum, stakedAmount), StakeDatum (StakeDatum, stakedAmount),
) )
import Data.Tagged (untag) import Data.Tagged (Tagged)
import Plutarch.Context ( import Plutarch.Context (
MintingBuilder, MintingBuilder,
SpendingBuilder, SpendingBuilder,
@ -41,10 +41,9 @@ import Plutarch.Context (
withSpendingOutRef, withSpendingOutRef,
withValue, withValue,
) )
import Plutarch.SafeMoney (Discrete) import Plutarch.Extra.AssetClass (assetClassValue)
import PlutusLedgerApi.V1.Contexts (TxOutRef (..)) import PlutusLedgerApi.V1.Contexts (TxOutRef (..))
import PlutusLedgerApi.V1.Value qualified as Value ( import PlutusLedgerApi.V1.Value qualified as Value (
assetClassValue,
singleton, singleton,
) )
import PlutusLedgerApi.V2 ( import PlutusLedgerApi.V2 (
@ -57,7 +56,6 @@ import PlutusLedgerApi.V2 (
) )
import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.AssocMap qualified as AssocMap
import Sample.Shared ( import Sample.Shared (
fromDiscrete,
governor, governor,
signer, signer,
stakeAssetClass, stakeAssetClass,
@ -69,7 +67,7 @@ import Test.Util (sortValue)
-- | This script context should be a valid transaction. -- | This script context should be a valid transaction.
stakeCreation :: ScriptContext stakeCreation :: ScriptContext
stakeCreation = stakeCreation =
let st = Value.assetClassValue stakeAssetClass 1 -- Stake ST let st = assetClassValue stakeAssetClass 1 -- Stake ST
datum :: StakeDatum datum :: StakeDatum
datum = StakeDatum 424242424242 (PubKeyCredential signer) Nothing [] datum = StakeDatum 424242424242 (PubKeyCredential signer) Nothing []
@ -114,16 +112,16 @@ stakeCreationUnsigned =
-- | Config for creating a ScriptContext that deposits or withdraws. -- | Config for creating a ScriptContext that deposits or withdraws.
data DepositWithdrawExample = DepositWithdrawExample data DepositWithdrawExample = DepositWithdrawExample
{ startAmount :: Discrete GTTag { startAmount :: Tagged GTTag Integer
-- ^ The amount of GT stored before the transaction. -- ^ The amount of GT stored before the transaction.
, delta :: Discrete GTTag , delta :: Tagged GTTag Integer
-- ^ The amount of GT deposited or withdrawn from the Stake. -- ^ The amount of GT deposited or withdrawn from the Stake.
} }
-- | Create a ScriptContext that deposits or withdraws, given the config for it. -- | Create a ScriptContext that deposits or withdraws, given the config for it.
stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
stakeDepositWithdraw config = stakeDepositWithdraw config =
let st = Value.assetClassValue stakeAssetClass 1 -- Stake ST let st = assetClassValue stakeAssetClass 1 -- Stake ST
stakeBefore :: StakeDatum stakeBefore :: StakeDatum
stakeBefore = StakeDatum config.startAmount (PubKeyCredential signer) Nothing [] stakeBefore = StakeDatum config.startAmount (PubKeyCredential signer) Nothing []
@ -144,7 +142,7 @@ stakeDepositWithdraw config =
, withValue , withValue
( sortValue $ ( sortValue $
st st
<> Value.assetClassValue (untag governor.gtClassRef) (fromDiscrete stakeBefore.stakedAmount) <> assetClassValue governor.gtClassRef stakeBefore.stakedAmount
) )
, withDatum stakeBefore , withDatum stakeBefore
, withRef stakeRef , withRef stakeRef
@ -155,7 +153,7 @@ stakeDepositWithdraw config =
, withValue , withValue
( sortValue $ ( sortValue $
st st
<> Value.assetClassValue (untag governor.gtClassRef) (fromDiscrete stakeAfter.stakedAmount) <> assetClassValue governor.gtClassRef stakeAfter.stakedAmount
) )
, withDatum stakeAfter , withDatum stakeAfter
] ]

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

@ -24,7 +24,6 @@ import Agora.Stake (
StakeDatum (..), StakeDatum (..),
StakeRedeemer (ClearDelegate, DelegateTo), StakeRedeemer (ClearDelegate, DelegateTo),
) )
import Data.Tagged (untag)
import Plutarch.Context ( import Plutarch.Context (
SpendingBuilder, SpendingBuilder,
buildSpending', buildSpending',
@ -38,7 +37,7 @@ import Plutarch.Context (
withSpendingOutRef, withSpendingOutRef,
withValue, withValue,
) )
import PlutusLedgerApi.V1.Value qualified as Value import Plutarch.Extra.AssetClass (assetClassValue)
import PlutusLedgerApi.V2 ( import PlutusLedgerApi.V2 (
Credential (PubKeyCredential), Credential (PubKeyCredential),
PubKeyHash, PubKeyHash,
@ -46,7 +45,6 @@ import PlutusLedgerApi.V2 (
TxOutRef (TxOutRef), TxOutRef (TxOutRef),
) )
import Sample.Shared ( import Sample.Shared (
fromDiscrete,
governor, governor,
minAda, minAda,
signer, signer,
@ -116,14 +114,14 @@ setDelegate ps = buildSpending' builder
_ -> signer2 _ -> signer2
else signer2 else signer2
st = Value.assetClassValue stakeAssetClass 1 -- Stake ST st = assetClassValue stakeAssetClass 1 -- Stake ST
stakeValue = stakeValue =
sortValue $ sortValue $
mconcat mconcat
[ st [ st
, Value.assetClassValue , assetClassValue
(untag governor.gtClassRef) governor.gtClassRef
(fromDiscrete stakeInput.stakedAmount) stakeInput.stakedAmount
, minAda , minAda
] ]

12
agora/Agora/AuthorityToken.hs
View file

@ -28,7 +28,7 @@ import Plutarch.Api.V2 (
PTxInfo (PTxInfo), PTxInfo (PTxInfo),
PTxOut (PTxOut), PTxOut (PTxOut),
) )
import Plutarch.Extra.AssetClass (PAssetClass, passetClass, passetClassValueOf) import Plutarch.Extra.AssetClass (PAssetClassData, ptoScottEncoding)
import "liqwid-plutarch-extra" Plutarch.Extra.List (plookupAssoc) import "liqwid-plutarch-extra" Plutarch.Extra.List (plookupAssoc)
import Plutarch.Extra.ScriptContext (pisTokenSpent) import Plutarch.Extra.ScriptContext (pisTokenSpent)
import Plutarch.Extra.Sum (PSum (PSum)) import Plutarch.Extra.Sum (PSum (PSum))
@ -132,7 +132,7 @@ singleAuthorityTokenBurned gatCs inputs mint = unTermCont $ do
@since 0.1.0 @since 0.1.0
-} -}
authorityTokenPolicy :: ClosedTerm (PAssetClass :--> PMintingPolicy) authorityTokenPolicy :: ClosedTerm (PAssetClassData :--> PMintingPolicy)
authorityTokenPolicy = authorityTokenPolicy =
plam $ \atAssetClass _redeemer ctx' -> plam $ \atAssetClass _redeemer ctx' ->
pmatch ctx' $ \(PScriptContext ctx') -> unTermCont $ do pmatch ctx' $ \(PScriptContext ctx') -> unTermCont $ do
@ -141,12 +141,16 @@ authorityTokenPolicy =
txInfo <- pletFieldsC @'["inputs", "mint", "outputs"] txInfo' txInfo <- pletFieldsC @'["inputs", "mint", "outputs"] txInfo'
let inputs = txInfo.inputs let inputs = txInfo.inputs
mintedValue = pfromData txInfo.mint mintedValue = pfromData txInfo.mint
govTokenSpent = pisTokenSpent # atAssetClass # inputs govTokenSpent = pisTokenSpent # (ptoScottEncoding # atAssetClass) # inputs
PMinting ownSymbol' <- pmatchC $ pfromData ctx.purpose PMinting ownSymbol' <- pmatchC $ pfromData ctx.purpose
let ownSymbol = pfromData $ pfield @"_0" # ownSymbol' let ownSymbol = pfromData $ pfield @"_0" # ownSymbol'
mintedATs = passetClassValueOf # mintedValue # (passetClass # ownSymbol # pconstant "") mintedATs =
psymbolValueOf
# ownSymbol
# mintedValue
pure $ pure $
pif pif
(0 #< mintedATs) (0 #< mintedATs)

5
agora/Agora/Bootstrap.hs
View file

@ -17,15 +17,10 @@ import Agora.Treasury (treasuryValidator)
import Data.Map (fromList) import Data.Map (fromList)
import Data.Text (Text, unpack) import Data.Text (Text, unpack)
import Plutarch (Config) import Plutarch (Config)
import Plutarch.Extra.AssetClass (PAssetClass)
import PlutusLedgerApi.V1.Value (AssetClass)
import Ply (TypedScriptEnvelope) import Ply (TypedScriptEnvelope)
import Ply.Plutarch.Class (PlyArgOf)
import Ply.Plutarch.TypedWriter (TypedWriter, mkEnvelope) import Ply.Plutarch.TypedWriter (TypedWriter, mkEnvelope)
import ScriptExport.ScriptInfo (RawScriptExport (..)) import ScriptExport.ScriptInfo (RawScriptExport (..))
type instance PlyArgOf PAssetClass = AssetClass
{- | Parameterize core scripts, given the 'Agora.Governor.Governor' {- | Parameterize core scripts, given the 'Agora.Governor.Governor'
parameters and plutarch configurations. parameters and plutarch configurations.

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

@ -155,7 +155,7 @@ mutateGovernorValidator =
effectDatumF <- pletAllC effectDatum effectDatumF <- pletAllC effectDatum
txInfoF <- pletFieldsC @'["inputs", "outputs", "datums", "redeemers"] txInfo txInfoF <- pletFieldsC @'["inputs", "outputs", "datums", "redeemers"] txInfo
---------------------------------------------------------------------------- --------------------------------------------------------------------------
scriptInputs <- scriptInputs <-
pletC $ pletC $
@ -184,13 +184,13 @@ mutateGovernorValidator =
isGovernorInput = isGovernorInput =
foldl1 foldl1
(#&&) (#&&)
[ ptraceIfFalse "Can only modify the pinned governor" $ [ ptraceIfFalse "Governor UTxO should carry GST" $
inputF.outRef #== effectDatumF.governorRef
, ptraceIfFalse "Governor UTxO should carry GST" $
psymbolValueOf psymbolValueOf
# gstSymbol # gstSymbol
# (pfield @"value" # inputF.resolved) # (pfield @"value" # inputF.resolved)
#== 1 #== 1
, ptraceIfFalse "Can only modify the pinned governor" $
inputF.outRef #== effectDatumF.governorRef
, ptraceIfFalse "Governor validator run" $ , ptraceIfFalse "Governor validator run" $
pfield @"address" # inputF.resolved pfield @"address" # inputF.resolved
#== governorAddress #== governorAddress

2
agora/Agora/Governor.hs
View file

@ -46,6 +46,7 @@ import Plutarch.DataRepr (
DerivePConstantViaData (DerivePConstantViaData), DerivePConstantViaData (DerivePConstantViaData),
PDataFields, PDataFields,
) )
import Plutarch.Extra.AssetClass (AssetClass)
import Plutarch.Extra.IsData ( import Plutarch.Extra.IsData (
DerivePConstantViaEnum (DerivePConstantEnum), DerivePConstantViaEnum (DerivePConstantEnum),
EnumIsData (EnumIsData), EnumIsData (EnumIsData),
@ -54,7 +55,6 @@ import Plutarch.Extra.IsData (
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletFieldsC) import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletFieldsC)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted)) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
import PlutusLedgerApi.V1 (TxOutRef) import PlutusLedgerApi.V1 (TxOutRef)
import PlutusLedgerApi.V1.Value (AssetClass)
import PlutusTx qualified import PlutusTx qualified
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

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

@ -55,10 +55,10 @@ import Plutarch.Api.V2 (
PTxOutRef, PTxOutRef,
PValidator, PValidator,
) )
import Plutarch.Extra.AssetClass (passetClass, passetClassValueOf) import Plutarch.Extra.AssetClass (passetClass)
import Plutarch.Extra.Field (pletAll, pletAllC) import Plutarch.Extra.Field (pletAll, pletAllC)
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe) import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe)
import Plutarch.Extra.Map (pkeys, ptryLookup) import "liqwid-plutarch-extra" Plutarch.Extra.Map (pkeys, ptryLookup)
import Plutarch.Extra.Maybe (passertPJust, pjust, pmaybe, pmaybeData, pnothing) import Plutarch.Extra.Maybe (passertPJust, pjust, pmaybe, pmaybeData, pnothing)
import Plutarch.Extra.Ord (psort) import Plutarch.Extra.Ord (psort)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
@ -77,7 +77,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
pmatchC, pmatchC,
ptryFromC, ptryFromC,
) )
import Plutarch.Extra.Value (psymbolValueOf) import Plutarch.Extra.Value (passetClassValueOf, psymbolValueOf)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -490,7 +490,7 @@ governorValidator =
proposalInputDatumF.status #== pconstantData Locked proposalInputDatumF.status #== pconstantData Locked
-- Find the highest votes and the corresponding tag. -- Find the highest votes and the corresponding tag.
let quorum = pto $ pto $ pfromData $ pfield @"execute" # proposalInputDatumF.thresholds let quorum = pto $ pfromData $ pfield @"execute" # proposalInputDatumF.thresholds
neutralOption = pneutralOption # proposalInputDatumF.effects neutralOption = pneutralOption # proposalInputDatumF.effects
finalResultTag = pwinner # proposalInputDatumF.votes # quorum # neutralOption finalResultTag = pwinner # proposalInputDatumF.votes # quorum # neutralOption
@ -528,8 +528,8 @@ governorValidator =
gatAssetClass = passetClass # atSymbol # tagToken gatAssetClass = passetClass # atSymbol # tagToken
valueGATCorrect = valueGATCorrect =
passetClassValueOf passetClassValueOf
# outputF.value # gatAssetClass
# gatAssetClass #== 1 # outputF.value #== 1
let hasCorrectDatum = let hasCorrectDatum =
effect.datumHash #== pfromDatumHash # outputF.datum effect.datumHash #== pfromDatumHash # outputF.datum

8
agora/Agora/Linker.hs
View file

@ -8,8 +8,8 @@ import Data.Aeson qualified as Aeson
import Data.Map (fromList) import Data.Map (fromList)
import Data.Tagged (untag) import Data.Tagged (untag)
import Plutarch.Api.V2 (mintingPolicySymbol, validatorHash) import Plutarch.Api.V2 (mintingPolicySymbol, validatorHash)
import Plutarch.Extra.AssetClass (AssetClass (AssetClass))
import PlutusLedgerApi.V1 (Address, CurrencySymbol, TxOutRef, ValidatorHash) import PlutusLedgerApi.V1 (Address, CurrencySymbol, TxOutRef, ValidatorHash)
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
import Ply ( import Ply (
ScriptRole (MintingPolicyRole, ValidatorRole), ScriptRole (MintingPolicyRole, ValidatorRole),
toMintingPolicy, toMintingPolicy,
@ -72,7 +72,7 @@ linker = do
toMintingPolicy toMintingPolicy
govPol' govPol'
gstAssetClass = gstAssetClass =
AssetClass (gstSymbol, "") AssetClass gstSymbol ""
govValHash = validatorHash $ toValidator govVal' govValHash = validatorHash $ toValidator govVal'
at = gstAssetClass at = gstAssetClass
@ -89,14 +89,14 @@ linker = do
propValAddress = propValAddress =
validatorHashToAddress $ validatorHash $ toValidator propVal' validatorHashToAddress $ validatorHash $ toValidator propVal'
pstSymbol = mintingPolicySymbol $ toMintingPolicy propPol' pstSymbol = mintingPolicySymbol $ toMintingPolicy propPol'
pstAssetClass = AssetClass (pstSymbol, "") pstAssetClass = AssetClass pstSymbol ""
stakPol' = stkPol # untag governor.gtClassRef stakPol' = stkPol # untag governor.gtClassRef
stakVal' = stkVal # sstSymbol # pstAssetClass # untag governor.gtClassRef stakVal' = stkVal # sstSymbol # pstAssetClass # untag governor.gtClassRef
sstSymbol = mintingPolicySymbol $ toMintingPolicy stakPol' sstSymbol = mintingPolicySymbol $ toMintingPolicy stakPol'
stakValTokenName = stakValTokenName =
validatorHashToTokenName $ validatorHash $ toValidator stakVal' validatorHashToTokenName $ validatorHash $ toValidator stakVal'
sstAssetClass = AssetClass (sstSymbol, stakValTokenName) sstAssetClass = AssetClass sstSymbol stakValTokenName
treaVal' = treVal # atSymbol treaVal' = treVal # atSymbol

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

@ -8,8 +8,6 @@ import Data.Bifunctor (Bifunctor (bimap))
import Data.Map.Strict qualified as StrictMap import Data.Map.Strict qualified as StrictMap
import Data.Traversable (for) import Data.Traversable (for)
import Plutarch.Api.V1 (KeyGuarantees (Sorted), PMap) import Plutarch.Api.V1 (KeyGuarantees (Sorted), PMap)
import Plutarch.Num (PNum)
import Plutarch.SafeMoney (PDiscrete)
import PlutusTx qualified import PlutusTx qualified
import PlutusTx.AssocMap qualified as AssocMap import PlutusTx.AssocMap qualified as AssocMap
@ -76,6 +74,3 @@ instance
isSorted [] = True isSorted [] = True
isSorted [_] = True isSorted [_] = True
isSorted (x : y : xs) = x < y && isSorted (y : xs) isSorted (x : y : xs) = x < y && isSorted (y : xs)
-- | @since 1.0.0
deriving anyclass instance PNum (PDiscrete tag)

14
agora/Agora/Proposal.hs
View file

@ -78,8 +78,9 @@ import Plutarch.Extra.IsData (
ProductIsData (ProductIsData), ProductIsData (ProductIsData),
) )
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust) import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
import Plutarch.Extra.Map qualified as PM import "liqwid-plutarch-extra" Plutarch.Extra.Map qualified as PM
import Plutarch.Extra.Maybe (pfromJust) import Plutarch.Extra.Maybe (pfromJust)
import Plutarch.Extra.Tagged (PTagged)
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC) import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC)
import Plutarch.Lift ( import Plutarch.Lift (
DerivePConstantViaNewtype (DerivePConstantViaNewtype), DerivePConstantViaNewtype (DerivePConstantViaNewtype),
@ -87,7 +88,6 @@ import Plutarch.Lift (
PUnsafeLiftDecl (type PLifted), PUnsafeLiftDecl (type PLifted),
) )
import Plutarch.Orphans () import Plutarch.Orphans ()
import Plutarch.SafeMoney (PDiscrete)
import PlutusLedgerApi.V2 (Credential, DatumHash, ScriptHash, ValidatorHash) import PlutusLedgerApi.V2 (Credential, DatumHash, ScriptHash, ValidatorHash)
import PlutusTx qualified import PlutusTx qualified
@ -560,11 +560,11 @@ newtype PProposalThresholds (s :: S) = PProposalThresholds
Term Term
s s
( PDataRecord ( PDataRecord
'[ "execute" ':= PDiscrete GTTag '[ "execute" ':= PTagged GTTag PInteger
, "create" ':= PDiscrete GTTag , "create" ':= PTagged GTTag PInteger
, "toVoting" ':= PDiscrete GTTag , "toVoting" ':= PTagged GTTag PInteger
, "vote" ':= PDiscrete GTTag , "vote" ':= PTagged GTTag PInteger
, "cosign" ':= PDiscrete GTTag , "cosign" ':= PTagged GTTag PInteger
] ]
) )
} }

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

@ -50,12 +50,11 @@ import Plutarch.Api.V2 (
PTxOut, PTxOut,
PValidator, PValidator,
) )
import Plutarch.Extra.AssetClass (PAssetClass, passetClass, passetClassValueOf) import Plutarch.Extra.AssetClass (PAssetClassData, passetClass, ptoScottEncoding)
import Plutarch.Extra.Category (PCategory (pidentity)) import Plutarch.Extra.Category (PCategory (pidentity))
import Plutarch.Extra.Comonad (pextract)
import Plutarch.Extra.Field (pletAll, pletAllC) import Plutarch.Extra.Field (pletAll, pletAllC)
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust) import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
import Plutarch.Extra.Map (pupdate) import "plutarch-extra" Plutarch.Extra.Map (pupdate)
import Plutarch.Extra.Maybe ( import Plutarch.Extra.Maybe (
passertPJust, passertPJust,
pisJust, pisJust,
@ -80,8 +79,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
ptryFromC, ptryFromC,
) )
import Plutarch.Extra.Traversable (pfoldMap) import Plutarch.Extra.Traversable (pfoldMap)
import Plutarch.Extra.Value (psymbolValueOf) import Plutarch.Extra.Value (passetClassValueOf, psymbolValueOf)
import Plutarch.SafeMoney (PDiscrete (PDiscrete))
import Plutarch.Unsafe (punsafeCoerce) import Plutarch.Unsafe (punsafeCoerce)
{- | Policy for Proposals. {- | Policy for Proposals.
@ -109,7 +107,7 @@ import Plutarch.Unsafe (punsafeCoerce)
@since 1.0.0 @since 1.0.0
-} -}
proposalPolicy :: ClosedTerm (PAssetClass :--> PMintingPolicy) proposalPolicy :: ClosedTerm (PAssetClassData :--> PMintingPolicy)
proposalPolicy = proposalPolicy =
plam $ \gtAssetClass _redeemer ctx' -> unTermCont $ do plam $ \gtAssetClass _redeemer ctx' -> unTermCont $ do
PScriptContext ctx' <- pmatchC ctx' PScriptContext ctx' <- pmatchC ctx'
@ -120,12 +118,12 @@ proposalPolicy =
PMinting ownSymbol' <- pmatchC $ pfromData ctx.purpose PMinting ownSymbol' <- pmatchC $ pfromData ctx.purpose
let mintedProposalST = let mintedProposalST =
passetClassValueOf passetClassValueOf
# pfromData txInfo.mint
# (passetClass # (pfield @"_0" # ownSymbol') # pconstant "") # (passetClass # (pfield @"_0" # ownSymbol') # pconstant "")
# txInfo.mint
pguardC "Governance state-thread token must move" $ pguardC "Governance state-thread token must move" $
pisTokenSpent pisTokenSpent
# gtAssetClass # (ptoScottEncoding # gtAssetClass)
# txInfo.inputs # txInfo.inputs
pguardC "Minted exactly one proposal ST" $ pguardC "Minted exactly one proposal ST" $
@ -211,7 +209,7 @@ instance DerivePlutusType PStakeInputsContext where
-} -}
proposalValidator :: proposalValidator ::
ClosedTerm ClosedTerm
( PAssetClass ( PAssetClassData
:--> PCurrencySymbol :--> PCurrencySymbol
:--> PCurrencySymbol :--> PCurrencySymbol
:--> PInteger :--> PInteger
@ -304,8 +302,8 @@ proposalValidator =
let isStakeUTxO = let isStakeUTxO =
-- A stake UTxO is a UTxO that carries SST. -- A stake UTxO is a UTxO that carries SST.
passetClassValueOf passetClassValueOf
# (ptoScottEncoding # sstClass)
# txOutF.value # txOutF.value
# sstClass
#== 1 #== 1
stake = stake =
@ -495,9 +493,8 @@ proposalValidator =
PProposalVotes $ PProposalVotes $
pupdate pupdate
# plam # plam
( \votes -> unTermCont $ do ( \votes ->
PDiscrete v <- pmatchC totalStakeAmount pcon $ PJust $ votes + pto totalStakeAmount
pure $ pcon $ PJust $ votes + (pextract # v)
) )
# voteFor # voteFor
# pto (pfromData proposalInputDatumF.votes) # pto (pfromData proposalInputDatumF.votes)
@ -546,9 +543,8 @@ proposalValidator =
pisVoter # stakeRoles pisVoter # stakeRoles
voteCount = voteCount =
pextract pto $
#$ pto pfromData stakeF.stakedAmount
$ pfromData stakeF.stakedAmount
newVotes = newVotes =
pretractVotes pretractVotes

7
agora/Agora/SafeMoney.hs
View file

@ -11,6 +11,7 @@ module Agora.SafeMoney (
GovernorSTTag, GovernorSTTag,
StakeSTTag, StakeSTTag,
ProposalSTTag, ProposalSTTag,
AuthorityTokenTag,
adaRef, adaRef,
) where ) where
@ -47,6 +48,12 @@ data StakeSTTag
-} -}
data ProposalSTTag data ProposalSTTag
{- | Authority token.
@since 1.0.0
-}
data AuthorityTokenTag
{- | Resolves ada tags. {- | Resolves ada tags.
@since 0.1.0 @since 0.1.0

13
agora/Agora/Stake.hs
View file

@ -64,16 +64,15 @@ import Plutarch.DataRepr (
import Plutarch.Extra.Field (pletAll) import Plutarch.Extra.Field (pletAll)
import Plutarch.Extra.IsData ( import Plutarch.Extra.IsData (
DerivePConstantViaDataList (DerivePConstantViaDataList), DerivePConstantViaDataList (DerivePConstantViaDataList),
PlutusTypeDataList,
ProductIsData (ProductIsData), ProductIsData (ProductIsData),
) )
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust) import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
import Plutarch.Extra.Maybe (passertPJust, pjust, pnothing) import Plutarch.Extra.Maybe (passertPJust, pjust, pnothing)
import Plutarch.Extra.Sum (PSum (PSum)) import Plutarch.Extra.Sum (PSum (PSum))
import Plutarch.Extra.Tagged (PTagged)
import Plutarch.Extra.Traversable (pfoldMap) import Plutarch.Extra.Traversable (pfoldMap)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted)) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
import Plutarch.Orphans () import Plutarch.Orphans ()
import Plutarch.SafeMoney (Discrete, PDiscrete)
import PlutusLedgerApi.V2 (Credential) import PlutusLedgerApi.V2 (Credential)
import PlutusTx qualified import PlutusTx qualified
@ -193,7 +192,7 @@ PlutusTx.makeIsDataIndexed
@since 0.1.0 @since 0.1.0
-} -}
data StakeDatum = StakeDatum data StakeDatum = StakeDatum
{ stakedAmount :: Discrete GTTag { stakedAmount :: Tagged GTTag Integer
-- ^ Tracks the amount of governance token staked in the datum. -- ^ Tracks the amount of governance token staked in the datum.
-- This also acts as the voting weight for 'Agora.Proposal.Proposal's. -- This also acts as the voting weight for 'Agora.Proposal.Proposal's.
, owner :: Credential , owner :: Credential
@ -236,7 +235,7 @@ newtype PStakeDatum (s :: S) = PStakeDatum
Term Term
s s
( PDataRecord ( PDataRecord
'[ "stakedAmount" ':= PDiscrete GTTag '[ "stakedAmount" ':= PTagged GTTag PInteger
, "owner" ':= PCredential , "owner" ':= PCredential
, "delegatedTo" ':= PMaybeData (PAsData PCredential) , "delegatedTo" ':= PMaybeData (PAsData PCredential)
, "lockedBy" ':= PBuiltinList (PAsData PProposalLock) , "lockedBy" ':= PBuiltinList (PAsData PProposalLock)
@ -261,7 +260,7 @@ newtype PStakeDatum (s :: S) = PStakeDatum
) )
instance DerivePlutusType PStakeDatum where instance DerivePlutusType PStakeDatum where
type DPTStrat _ = PlutusTypeDataList type DPTStrat _ = PlutusTypeNewtype
-- | @since 1.0.0 -- | @since 1.0.0
instance PUnsafeLiftDecl PStakeDatum where instance PUnsafeLiftDecl PStakeDatum where
@ -282,7 +281,7 @@ instance PTryFrom PData (PAsData PStakeDatum)
-} -}
data PStakeRedeemer (s :: S) data PStakeRedeemer (s :: S)
= -- | Deposit or withdraw a discrete amount of the staked governance token. = -- | Deposit or withdraw a discrete amount of the staked governance token.
PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag])) PDepositWithdraw (Term s (PDataRecord '["delta" ':= PTagged GTTag PInteger]))
| -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets. | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
PDestroy (Term s (PDataRecord '[])) PDestroy (Term s (PDataRecord '[]))
| PPermitVote (Term s (PDataRecord '[])) | PPermitVote (Term s (PDataRecord '[]))
@ -493,7 +492,7 @@ instance DerivePlutusType PSigContext where
-} -}
data PStakeRedeemerContext (s :: S) data PStakeRedeemerContext (s :: S)
= -- | See also 'DepositWithdraw'. = -- | See also 'DepositWithdraw'.
PDepositWithdrawDelta (Term s (PDiscrete GTTag)) PDepositWithdrawDelta (Term s (PTagged GTTag PInteger))
| -- | See also 'DelegateTo'. | -- | See also 'DelegateTo'.
PSetDelegateTo (Term s PCredential) PSetDelegateTo (Term s PCredential)
| PNoMetadata | PNoMetadata

4
agora/Agora/Stake/Redeemers.hs
View file

@ -55,8 +55,6 @@ import Plutarch.Extra.Field (pletAll, pletAllC)
import Plutarch.Extra.Maybe (pdjust, pdnothing, pmaybeData) import Plutarch.Extra.Maybe (pdjust, pdnothing, pmaybeData)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pmatchC) import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pmatchC)
import Plutarch.Numeric.Additive (AdditiveMonoid (zero), AdditiveSemigroup ((+)))
import Prelude hiding (Num ((+)))
-- | A wrapper which ensures that no proposal is presented in the transaction. -- | A wrapper which ensures that no proposal is presented in the transaction.
pwithoutProposal :: pwithoutProposal ::
@ -393,7 +391,7 @@ pdepositWithdraw = phoistAcyclic $
newStakedAmount <- pletC $ stakeInputDatumF.stakedAmount + delta newStakedAmount <- pletC $ stakeInputDatumF.stakedAmount + delta
pguardC "Non-negative staked amount" $ zero #<= newStakedAmount pguardC "Non-negative staked amount" $ 0 #<= newStakedAmount
let expectedDatum = let expectedDatum =
mkRecordConstr mkRecordConstr

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

@ -60,6 +60,7 @@ import Plutarch.Api.V1 (
PTokenName, PTokenName,
) )
import Plutarch.Api.V1.AssocMap (plookup) import Plutarch.Api.V1.AssocMap (plookup)
import Plutarch.Api.V1.Value (pvalueOf)
import Plutarch.Api.V2 ( import Plutarch.Api.V2 (
PMintingPolicy, PMintingPolicy,
PScriptPurpose (PMinting, PSpending), PScriptPurpose (PMinting, PSpending),
@ -69,8 +70,8 @@ import Plutarch.Api.V2 (
) )
import Plutarch.Extra.AssetClass ( import Plutarch.Extra.AssetClass (
PAssetClass, PAssetClass,
passetClassValueOf, PAssetClassData,
pvalueOf, ptoScottEncoding,
) )
import Plutarch.Extra.Field (pletAll) import Plutarch.Extra.Field (pletAll)
import Plutarch.Extra.Functor (PFunctor (pfmap)) import Plutarch.Extra.Functor (PFunctor (pfmap))
@ -98,12 +99,10 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
) )
import Plutarch.Extra.Traversable (pfoldMap) import Plutarch.Extra.Traversable (pfoldMap)
import Plutarch.Extra.Value ( import Plutarch.Extra.Value (
passetClassValueOf,
psymbolValueOf, psymbolValueOf,
) )
import Plutarch.Num (PNum (pnegate)) import Plutarch.Num (PNum (pnegate))
import Plutarch.SafeMoney (
pvalueDiscrete,
)
import Plutarch.Unsafe (punsafeCoerce) import Plutarch.Unsafe (punsafeCoerce)
import Prelude hiding (Num ((+))) import Prelude hiding (Num ((+)))
@ -133,7 +132,7 @@ import Prelude hiding (Num ((+)))
-} -}
stakePolicy :: stakePolicy ::
-- | The (governance) token that a Stake can store. -- | The (governance) token that a Stake can store.
ClosedTerm (PAssetClass :--> PMintingPolicy) ClosedTerm (PAssetClassData :--> PMintingPolicy)
stakePolicy = stakePolicy =
plam $ \gstClass _redeemer ctx' -> unTermCont $ do plam $ \gstClass _redeemer ctx' -> unTermCont $ do
ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' ctx <- pletFieldsC @'["txInfo", "purpose"] ctx'
@ -217,7 +216,8 @@ stakePolicy =
let hasExpectedStake = let hasExpectedStake =
ptraceIfFalse "Stake ouput has expected amount of stake token" $ ptraceIfFalse "Stake ouput has expected amount of stake token" $
pvalueDiscrete # gstClass # outputF.value #== datumF.stakedAmount passetClassValueOf # (ptoScottEncoding # gstClass) # outputF.value
#== pto (pfromData datumF.stakedAmount)
let ownerSignsTransaction = let ownerSignsTransaction =
ptraceIfFalse "Stake Owner should sign the transaction" $ ptraceIfFalse "Stake Owner should sign the transaction" $
pauthorizedBy pauthorizedBy
@ -400,10 +400,13 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
# plam # plam
( \output -> ( \output ->
let validateGT = plam $ \stakeDatum -> let validateGT = plam $ \stakeDatum ->
let expected = pfield @"stakedAmount" # stakeDatum let expected =
pto $
pfromData $
pfield @"stakedAmount" # stakeDatum
actual = actual =
pvalueDiscrete passetClassValueOf
# gstClass # gstClass
# (pfield @"value" # output) # (pfield @"value" # output)
in pif in pif
@ -438,8 +441,8 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
flip pletAll $ \txOutF -> flip pletAll $ \txOutF ->
let isProposalUTxO = let isProposalUTxO =
passetClassValueOf passetClassValueOf
# txOutF.value # pstClass
# pstClass #== 1 # txOutF.value #== 1
proposalDatum = proposalDatum =
pfromData $ pfromData $
pfromOutputDatum @(PAsData PProposalDatum) pfromOutputDatum @(PAsData PProposalDatum)
@ -448,7 +451,7 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
in pif isProposalUTxO (pjust # proposalDatum) pnothing in pif isProposalUTxO (pjust # proposalDatum) pnothing
let pstMinted = let pstMinted =
passetClassValueOf # txInfoF.mint # pstClass #== 1 passetClassValueOf # pstClass # txInfoF.mint #== 1
newProposalContext = newProposalContext =
pcon $ pcon $
@ -601,15 +604,25 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
@since 1.0.0 @since 1.0.0
-} -}
stakeValidator :: ClosedTerm (PCurrencySymbol :--> PAssetClass :--> PAssetClass :--> PValidator) stakeValidator ::
ClosedTerm
( PCurrencySymbol
:--> PAssetClassData
:--> PAssetClassData
:--> PValidator
)
stakeValidator = stakeValidator =
plam $ plam $ \cs pstClass gstClass ->
mkStakeValidator $ mkStakeValidator
StakeRedeemerImpl ( StakeRedeemerImpl
{ onDepositWithdraw = pdepositWithdraw { onDepositWithdraw = pdepositWithdraw
, onDestroy = pdestroy , onDestroy = pdestroy
, onPermitVote = ppermitVote , onPermitVote = ppermitVote
, onRetractVote = pretractVote , onRetractVote = pretractVote
, onDelegateTo = pdelegateTo , onDelegateTo = pdelegateTo
, onClearDelegate = pclearDelegate , onClearDelegate = pclearDelegate
} }
)
cs
(ptoScottEncoding # pstClass)
(ptoScottEncoding # gstClass)