flake: bump plutarch, fix resulting issues
Collection of things fixed: - `agora-test`: Fix compile resulting from some changes to hackage. - `agora-benchmark`: Switched to `plutarch`-style `evalScript`. - CI: Ported over new flake changes. This is quite a mess.
This commit is contained in:
Emily Martins
parent
0348f72499
commit
5049441dfc
49 changed files with 3487 additions and 3829 deletions
|
|
@ -18,9 +18,9 @@ import Data.Text.Encoding qualified as T
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutus.V1.Ledger.Api qualified as Plutus
|
||||
import Plutus.V1.Ledger.Bytes qualified as Plutus
|
||||
import Plutus.V1.Ledger.Value qualified as Plutus
|
||||
import PlutusLedgerApi.V1 qualified as Plutus
|
||||
import PlutusLedgerApi.V1.Bytes qualified as Plutus
|
||||
import PlutusLedgerApi.V1.Value qualified as Plutus
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -60,7 +60,7 @@ instance (Coercible a Plutus.LedgerBytes) => Aeson.ToJSON (AsBase16Bytes a) wher
|
|||
instance (Coercible Plutus.LedgerBytes a) => Aeson.FromJSON (AsBase16Bytes a) where
|
||||
parseJSON v =
|
||||
Aeson.parseJSON @T.Text v
|
||||
>>= either (Aeson.parserThrowError []) (pure . coerce @_ @(AsBase16Bytes a))
|
||||
>>= either (Aeson.parserThrowError [] . show) (pure . coerce @_ @(AsBase16Bytes a))
|
||||
. Plutus.fromHex
|
||||
. T.encodeUtf8
|
||||
|
||||
|
|
|
|||
|
|
@ -14,6 +14,8 @@ module Agora.AuthorityToken (
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutarch.Api.V1 (
|
||||
AmountGuarantees,
|
||||
KeyGuarantees,
|
||||
PAddress (..),
|
||||
PCredential (..),
|
||||
PCurrencySymbol (..),
|
||||
|
|
@ -28,7 +30,7 @@ import Plutarch.Api.V1.AssetClass (passetClass, passetClassValueOf)
|
|||
import Plutarch.Api.V1.AssocMap (PMap (PMap))
|
||||
import "plutarch" Plutarch.Api.V1.Value (PValue (PValue))
|
||||
import Plutarch.Builtin (pforgetData)
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -100,10 +102,10 @@ authorityTokensValidIn = phoistAcyclic $
|
|||
|
||||
-- | Assert that a single authority token has been burned.
|
||||
singleAuthorityTokenBurned ::
|
||||
forall (s :: S).
|
||||
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
|
||||
Term s PCurrencySymbol ->
|
||||
Term s (PAsData PTxInfo) ->
|
||||
Term s PValue ->
|
||||
Term s (PValue keys amounts) ->
|
||||
Term s PBool
|
||||
singleAuthorityTokenBurned gatCs txInfo mint = unTermCont $ do
|
||||
let gatAmountMinted :: Term _ PInteger
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ import Agora.AuthorityToken (singleAuthorityTokenBurned)
|
|||
import Agora.Utils (tcassert, tclet, tcmatch, tctryFrom)
|
||||
import Plutarch.Api.V1 (PCurrencySymbol, PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator, PValue)
|
||||
import Plutarch.TryFrom ()
|
||||
import Plutus.V1.Ledger.Value (CurrencySymbol)
|
||||
import PlutusLedgerApi.V1.Value (CurrencySymbol)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -43,7 +43,7 @@ makeEffect gatCs' f =
|
|||
|
||||
-- fetch minted values to ensure single GAT is burned
|
||||
txInfo <- tcont $ pletFields @'["mint"] txInfo'
|
||||
let mint :: Term _ PValue
|
||||
let mint :: Term _ (PValue _ _)
|
||||
mint = txInfo.mint
|
||||
|
||||
-- fetch script context
|
||||
|
|
|
|||
|
|
@ -43,8 +43,8 @@ import Plutarch.Unsafe (punsafeCoerce)
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutus.V1.Ledger.Api (TxOutRef)
|
||||
import Plutus.V1.Ledger.Value (AssetClass (..))
|
||||
import PlutusLedgerApi.V1 (TxOutRef)
|
||||
import PlutusLedgerApi.V1.Value (AssetClass (..))
|
||||
import PlutusTx qualified
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -208,7 +208,7 @@ mutateGovernorValidator gov = makeEffect (authorityTokenSymbolFromGovernor gov)
|
|||
return $ popaque $ pconstant ()
|
||||
where
|
||||
-- Get the amount of GST in the a given value.
|
||||
gstValueOf :: Term s (PValue :--> PInteger)
|
||||
gstValueOf :: Term s (PValue _ _ :--> PInteger)
|
||||
gstValueOf = phoistAcyclic $ plam $ \v -> pvalueOf # v # pconstant cs # pconstant tn
|
||||
where
|
||||
AssetClass (cs, tn) = governorSTAssetClassFromGovernor gov
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ import Control.Applicative (Const)
|
|||
import Agora.Effect (makeEffect)
|
||||
import Plutarch.Api.V1 (PValidator)
|
||||
import Plutarch.TryFrom (PTryFrom (..))
|
||||
import Plutus.V1.Ledger.Value (CurrencySymbol)
|
||||
import PlutusLedgerApi.V1.Value (CurrencySymbol)
|
||||
|
||||
-- | Dummy datum for NoOp effect.
|
||||
newtype PNoOp (s :: S) = PNoOp (Term s PUnit)
|
||||
|
|
|
|||
|
|
@ -20,12 +20,15 @@ import Generics.SOP (Generic, I (I))
|
|||
import Agora.Effect (makeEffect)
|
||||
import Agora.Utils (findTxOutByTxOutRef, isPubKey, paddValue, tcassert, tclet, tcmatch)
|
||||
import Plutarch.Api.V1 (
|
||||
AmountGuarantees (Positive),
|
||||
KeyGuarantees (Sorted),
|
||||
PCredential (..),
|
||||
PTuple,
|
||||
PValidator,
|
||||
PValue,
|
||||
ptuple,
|
||||
)
|
||||
import "plutarch" Plutarch.Api.V1.Value (pnormalize)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
|
||||
import Plutarch.DataRepr (
|
||||
|
|
@ -35,8 +38,8 @@ import Plutarch.DataRepr (
|
|||
)
|
||||
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
|
||||
import Plutarch.TryFrom (PTryFrom (..))
|
||||
import Plutus.V1.Ledger.Credential (Credential)
|
||||
import Plutus.V1.Ledger.Value (CurrencySymbol, Value)
|
||||
import PlutusLedgerApi.V1.Credential (Credential)
|
||||
import PlutusLedgerApi.V1.Value (CurrencySymbol, Value)
|
||||
import PlutusTx qualified
|
||||
|
||||
{- | Datum that encodes behavior of Treasury Withdrawal effect.
|
||||
|
|
@ -63,7 +66,7 @@ newtype PTreasuryWithdrawalDatum (s :: S)
|
|||
( Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue))
|
||||
'[ "receivers" ':= PBuiltinList (PAsData (PTuple PCredential (PValue 'Sorted 'Positive)))
|
||||
, "treasuries" ':= PBuiltinList (PAsData PCredential)
|
||||
]
|
||||
)
|
||||
|
|
@ -135,8 +138,8 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
|
|||
# plam (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
|
||||
sumValues =
|
||||
pfoldr
|
||||
# plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
|
||||
# pconstant (mempty :: Value)
|
||||
# plam (\((pfield @"_1" #) . pfromData -> x) ((pnormalize #) -> y) -> paddValue # pfromData x # y)
|
||||
# punsafeCoerce (pconstant (mempty :: Value))
|
||||
treasuryInputValuesSum = sumValues #$ ofTreasury # inputValues
|
||||
treasuryOutputValuesSum = sumValues #$ ofTreasury # outputValues
|
||||
receiverValuesSum = sumValues # datum.receivers
|
||||
|
|
|
|||
|
|
@ -63,8 +63,8 @@ import Plutarch.Unsafe (punsafeCoerce)
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutus.V1.Ledger.Api (TxOutRef)
|
||||
import Plutus.V1.Ledger.Value (AssetClass (..))
|
||||
import PlutusLedgerApi.V1 (TxOutRef)
|
||||
import PlutusLedgerApi.V1.Value (AssetClass (..))
|
||||
import PlutusTx qualified
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -127,15 +127,15 @@ data Governor = Governor
|
|||
-- | Plutarch-level datum for the Governor script.
|
||||
newtype PGovernorDatum (s :: S) = PGovernorDatum
|
||||
{ getGovernorDatum ::
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "proposalThresholds" ':= PProposalThresholds
|
||||
, "nextProposalId" ':= PProposalId
|
||||
, "proposalTimings" ':= PProposalTimingConfig
|
||||
, "createProposalTimeRangeMaxWidth" ':= PMaxTimeRangeWidth
|
||||
]
|
||||
)
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "proposalThresholds" ':= PProposalThresholds
|
||||
, "nextProposalId" ':= PProposalId
|
||||
, "proposalTimings" ':= PProposalTimingConfig
|
||||
, "createProposalTimeRangeMaxWidth" ':= PMaxTimeRangeWidth
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
|
|
|
|||
|
|
@ -125,12 +125,12 @@ import Plutarch.TryFrom ()
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutus.V1.Ledger.Api (
|
||||
import PlutusLedgerApi.V1 (
|
||||
CurrencySymbol (..),
|
||||
MintingPolicy,
|
||||
)
|
||||
import Plutus.V1.Ledger.Scripts (ValidatorHash (..))
|
||||
import Plutus.V1.Ledger.Value (
|
||||
import PlutusLedgerApi.V1.Scripts (ValidatorHash (..))
|
||||
import PlutusLedgerApi.V1.Value (
|
||||
AssetClass (..),
|
||||
)
|
||||
|
||||
|
|
@ -631,7 +631,7 @@ governorValidator gov =
|
|||
tcassert "Output GATs is more than minted GATs" $
|
||||
plength # outputsWithGAT #== gatCount
|
||||
|
||||
let gatOutputValidator' :: Term s (PMap PValidatorHash PDatumHash :--> PAsData PTxOut :--> PBool)
|
||||
let gatOutputValidator' :: Term s (PMap _ PValidatorHash PDatumHash :--> PAsData PTxOut :--> PBool)
|
||||
gatOutputValidator' =
|
||||
phoistAcyclic $
|
||||
plam
|
||||
|
|
@ -679,7 +679,7 @@ governorValidator gov =
|
|||
pure $ popaque $ singleAuthorityTokenBurned patSymbol ctxF.txInfo txInfoF.mint
|
||||
where
|
||||
-- Get th amount of governance tokens in a value.
|
||||
pgtValueOf :: Term s (PValue :--> PDiscrete GTTag)
|
||||
pgtValueOf :: Term s (PValue _ _ :--> PDiscrete GTTag)
|
||||
pgtValueOf = phoistAcyclic $ pvalueDiscrete' gov.gtClassRef
|
||||
|
||||
-- The currency symbol of authority token.
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ import Plutarch.Lift (
|
|||
PUnsafeLiftDecl,
|
||||
)
|
||||
|
||||
import Plutus.V1.Ledger.Crypto (PubKeyHash)
|
||||
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
|
||||
import PlutusTx qualified
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -57,13 +57,13 @@ PlutusTx.unstableMakeIsData ''MultiSig
|
|||
-- | Plutarch-level MultiSig
|
||||
newtype PMultiSig (s :: S) = PMultiSig
|
||||
{ getMultiSig ::
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "keys" ':= PBuiltinList (PAsData PPubKeyHash)
|
||||
, "minSigs" ':= PInteger
|
||||
]
|
||||
)
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "keys" ':= PBuiltinList (PAsData PPubKeyHash)
|
||||
, "minSigs" ':= PInteger
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
|
|
|
|||
|
|
@ -38,6 +38,7 @@ module Agora.Proposal (
|
|||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP (Generic, I (I))
|
||||
import Plutarch.Api.V1 (
|
||||
KeyGuarantees (Unsorted),
|
||||
PDatumHash,
|
||||
PMap,
|
||||
PPubKeyHash,
|
||||
|
|
@ -63,8 +64,8 @@ import Plutarch.Lift (
|
|||
import Plutarch.SafeMoney (PDiscrete)
|
||||
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
import Plutus.V1.Ledger.Api (DatumHash, PubKeyHash, ValidatorHash)
|
||||
import Plutus.V1.Ledger.Value (AssetClass)
|
||||
import PlutusLedgerApi.V1 (DatumHash, PubKeyHash, ValidatorHash)
|
||||
import PlutusLedgerApi.V1.Value (AssetClass)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Haskell-land
|
||||
|
|
@ -322,14 +323,14 @@ deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (P
|
|||
-- | Plutarch-level version of 'ProposalThresholds'.
|
||||
newtype PProposalThresholds (s :: S) = PProposalThresholds
|
||||
{ getProposalThresholds ::
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "execute" ':= PDiscrete GTTag
|
||||
, "draft" ':= PDiscrete GTTag
|
||||
, "vote" ':= PDiscrete GTTag
|
||||
]
|
||||
)
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "execute" ':= PDiscrete GTTag
|
||||
, "draft" ':= PDiscrete GTTag
|
||||
, "vote" ':= PDiscrete GTTag
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
|
|
@ -343,17 +344,17 @@ deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) ins
|
|||
|
||||
-- | Plutarch-level version of 'ProposalVotes'.
|
||||
newtype PProposalVotes (s :: S)
|
||||
= PProposalVotes (Term s (PMap PResultTag PInteger))
|
||||
deriving (PlutusType, PIsData) via (DerivePNewtype PProposalVotes (PMap PResultTag PInteger))
|
||||
= PProposalVotes (Term s (PMap 'Unsorted PResultTag PInteger))
|
||||
deriving (PlutusType, PIsData) via (DerivePNewtype PProposalVotes (PMap 'Unsorted PResultTag PInteger))
|
||||
|
||||
instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = ProposalVotes
|
||||
deriving via
|
||||
(DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap PResultTag PInteger))
|
||||
(DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap 'Unsorted PResultTag PInteger))
|
||||
instance
|
||||
(PConstantDecl ProposalVotes)
|
||||
|
||||
-- | Plutarch-level version of 'emptyVotesFor'.
|
||||
pemptyVotesFor :: forall s a. (PIsData a) => Term s (PMap PResultTag a :--> PProposalVotes)
|
||||
pemptyVotesFor :: forall s a. (PIsData a) => Term s (PMap 'Unsorted PResultTag a :--> PProposalVotes)
|
||||
pemptyVotesFor =
|
||||
phoistAcyclic $
|
||||
plam
|
||||
|
|
@ -365,19 +366,19 @@ pemptyVotesFor =
|
|||
-- | Plutarch-level version of 'ProposalDatum'.
|
||||
newtype PProposalDatum (s :: S) = PProposalDatum
|
||||
{ getProposalDatum ::
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "proposalId" ':= PProposalId
|
||||
, "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash)
|
||||
, "status" ':= PProposalStatus
|
||||
, "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
|
||||
, "thresholds" ':= PProposalThresholds
|
||||
, "votes" ':= PProposalVotes
|
||||
, "timingConfig" ':= PProposalTimingConfig
|
||||
, "startingTime" ':= PProposalStartingTime
|
||||
]
|
||||
)
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "proposalId" ':= PProposalId
|
||||
, "effects" ':= PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
|
||||
, "status" ':= PProposalStatus
|
||||
, "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
|
||||
, "thresholds" ':= PProposalThresholds
|
||||
, "votes" ':= PProposalVotes
|
||||
, "timingConfig" ':= PProposalTimingConfig
|
||||
, "startingTime" ':= PProposalStartingTime
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
|
|
@ -530,7 +531,7 @@ phighestVotes = phoistAcyclic $
|
|||
pneutralOption ::
|
||||
Term
|
||||
s
|
||||
( PMap PResultTag (PMap PValidatorHash PDatumHash)
|
||||
( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
|
||||
:--> PResultTag
|
||||
)
|
||||
pneutralOption = phoistAcyclic $
|
||||
|
|
@ -538,7 +539,7 @@ pneutralOption = phoistAcyclic $
|
|||
let l :: Term _ (PBuiltinList (PBuiltinPair (PAsData PResultTag) _))
|
||||
l = pto effects
|
||||
|
||||
f :: Term _ (PBuiltinPair (PAsData PResultTag) (PAsData (PMap _ _)) :--> PBool)
|
||||
f :: Term _ (PBuiltinPair (PAsData PResultTag) (PAsData (PMap 'Unsorted _ _)) :--> PBool)
|
||||
f = phoistAcyclic $
|
||||
plam $ \((pfromData . (psndBuiltin #) -> el)) ->
|
||||
let el' :: Term _ (PBuiltinList _)
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ import Plutarch.Extra.Map (plookup)
|
|||
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
|
||||
import Plutarch.Extra.TermCont (pmatchC)
|
||||
import Plutarch.SafeMoney (PDiscrete (..))
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
|
||||
|
||||
{- | Policy for Proposals.
|
||||
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@ import Plutarch.Lift (
|
|||
)
|
||||
import Plutarch.Numeric.Additive (AdditiveSemigroup ((+)))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
import Plutus.V1.Ledger.Time (POSIXTime)
|
||||
import PlutusLedgerApi.V1.Time (POSIXTime)
|
||||
import PlutusTx qualified
|
||||
import Prelude hiding ((+))
|
||||
|
||||
|
|
@ -83,7 +83,7 @@ data ProposalTimingConfig = ProposalTimingConfig
|
|||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalTimingConfig [('ProposalTimingConfig, 0)]
|
||||
|
||||
-- | Represents the maximum width of a 'Plutus.V1.Ledger.Time.POSIXTimeRange'.
|
||||
-- | Represents the maximum width of a 'PlutusLedgerApi.V1.Time.POSIXTimeRange'.
|
||||
newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
|
||||
deriving stock (Eq, Show, Ord, GHC.Generic)
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
|
|
@ -106,8 +106,8 @@ newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
|
|||
|
||||
Various functions work simply on 'PProposalTime' and 'ProposalTimingConfig'.
|
||||
In particular, 'currentProposalTime' is useful for extracting the time
|
||||
from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field
|
||||
of 'Plutus.V1.Ledger.Api.TxInfo'.
|
||||
from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field
|
||||
of 'PlutusLedgerApi.V1.TxInfo'.
|
||||
|
||||
We avoid 'PPOSIXTimeRange' where we can in order to save on operations.
|
||||
|
||||
|
|
@ -136,15 +136,15 @@ deriving via
|
|||
-- | Plutarch-level version of 'ProposalTimingConfig'.
|
||||
newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
|
||||
{ getProposalTimingConfig ::
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "draftTime" ':= PPOSIXTime
|
||||
, "votingTime" ':= PPOSIXTime
|
||||
, "lockingTime" ':= PPOSIXTime
|
||||
, "executingTime" ':= PPOSIXTime
|
||||
]
|
||||
)
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "draftTime" ':= PPOSIXTime
|
||||
, "votingTime" ':= PPOSIXTime
|
||||
, "lockingTime" ':= PPOSIXTime
|
||||
, "executingTime" ':= PPOSIXTime
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
|
|
@ -177,7 +177,7 @@ deriving via
|
|||
instance AdditiveSemigroup (Term s PPOSIXTime) where
|
||||
(punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y
|
||||
|
||||
{- | Get the starting time of a proposal, from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field.
|
||||
{- | Get the starting time of a proposal, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
|
||||
For every proposal, this is only meant to run once upon creation. Given time range should be
|
||||
tight enough, meaning that the width of the time range should be less than the maximum value.
|
||||
-}
|
||||
|
|
@ -199,7 +199,7 @@ createProposalStartingTime = phoistAcyclic $
|
|||
|
||||
pure $ pcon $ PProposalStartingTime startingTime
|
||||
|
||||
{- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field.
|
||||
{- | Get the current proposal time, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
|
||||
|
||||
If it's impossible to get a fully-bounded time, (e.g. either end of the 'PPOSIXTimeRange' is
|
||||
an infinity) then we error out.
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ module Agora.SafeMoney (
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
|
||||
|
||||
import Data.Tagged (Tagged (Tagged))
|
||||
|
||||
|
|
|
|||
|
|
@ -19,8 +19,8 @@ import Agora.Aeson.Orphans ()
|
|||
import Data.Aeson qualified as Aeson
|
||||
import GHC.Generics qualified as GHC
|
||||
import Plutarch.Api.V1 (PMintingPolicy, PValidator, mintingPolicySymbol, mkMintingPolicy, mkValidator, validatorHash)
|
||||
import Plutus.V1.Ledger.Api (MintingPolicy, Validator, ValidatorHash)
|
||||
import Plutus.V1.Ledger.Value (CurrencySymbol)
|
||||
import PlutusLedgerApi.V1 (MintingPolicy, Validator, ValidatorHash)
|
||||
import PlutusLedgerApi.V1.Value (CurrencySymbol)
|
||||
|
||||
-- | Bundle containing a 'Validator' and its hash.
|
||||
data ValidatorInfo = ValidatorInfo
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ import Prelude hiding (Num (..))
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutus.V1.Ledger.Api (PubKeyHash)
|
||||
import PlutusLedgerApi.V1 (PubKeyHash)
|
||||
import PlutusTx qualified
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -53,7 +53,7 @@ import Plutarch.DataRepr (
|
|||
)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
|
||||
import Plutus.V1.Ledger.Value (AssetClass)
|
||||
import PlutusLedgerApi.V1.Value (AssetClass)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -175,14 +175,14 @@ PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)]
|
|||
-- | Plutarch-level datum for Stake scripts.
|
||||
newtype PStakeDatum (s :: S) = PStakeDatum
|
||||
{ getStakeDatum ::
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "stakedAmount" ':= PDiscrete GTTag
|
||||
, "owner" ':= PPubKeyHash
|
||||
, "lockedBy" ':= PBuiltinList (PAsData PProposalLock)
|
||||
]
|
||||
)
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "stakedAmount" ':= PDiscrete GTTag
|
||||
, "owner" ':= PPubKeyHash
|
||||
, "lockedBy" ':= PBuiltinList (PAsData PProposalLock)
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
|
|
@ -226,13 +226,13 @@ deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PCo
|
|||
-- | Plutarch-level version of 'ProposalLock'.
|
||||
newtype PProposalLock (s :: S) = PProposalLock
|
||||
{ getProposalLock ::
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "vote" ':= PResultTag
|
||||
, "proposalTag" ':= PProposalId
|
||||
]
|
||||
)
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "vote" ':= PResultTag
|
||||
, "proposalTag" ':= PProposalId
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
|
|
|
|||
|
|
@ -28,12 +28,14 @@ import Agora.Utils (
|
|||
)
|
||||
import Data.Tagged (Tagged (..), untag)
|
||||
import Plutarch.Api.V1 (
|
||||
AmountGuarantees (Positive),
|
||||
PCredential (PPubKeyCredential, PScriptCredential),
|
||||
PMintingPolicy,
|
||||
PScriptPurpose (PMinting, PSpending),
|
||||
PTokenName,
|
||||
PTxInfo,
|
||||
PValidator,
|
||||
PValue,
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
)
|
||||
|
|
@ -45,7 +47,7 @@ import Plutarch.SafeMoney (
|
|||
pdiscreteValue',
|
||||
pvalueDiscrete',
|
||||
)
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
||||
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
|
||||
import Prelude hiding (Num (..))
|
||||
|
||||
{- | Policy for Stake state threads.
|
||||
|
|
@ -57,7 +59,7 @@ import Prelude hiding (Num (..))
|
|||
- Check that exactly one state thread is minted.
|
||||
- Check that an output exists with a state thread and a valid datum.
|
||||
- Check that no state thread is an input.
|
||||
- assert @'Plutus.V1.Ledger.Api.TokenName' == 'Plutus.V1.Ledger.Api.ValidatorHash'@
|
||||
- assert @'PlutusLedgerApi.V1.TokenName' == 'PlutusLedgerApi.V1.ValidatorHash'@
|
||||
of the script that we pay to.
|
||||
|
||||
=== For burning:
|
||||
|
|
@ -226,7 +228,8 @@ stakeValidator stake =
|
|||
|
||||
PJust txInInfo <- tcmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfoF.inputs
|
||||
ownAddress <- tclet $ pfield @"address" #$ pfield @"resolved" # txInInfo
|
||||
let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo
|
||||
let continuingValue :: Term _ (PValue _ _)
|
||||
continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo
|
||||
|
||||
-- Whether the owner signs this transaction or not.
|
||||
ownerSignsTransaction <- tclet $ ptxSignedBy # txInfoF.signatories # stakeDatum.owner
|
||||
|
|
@ -413,8 +416,11 @@ stakeValidator stake =
|
|||
)
|
||||
datumCorrect = stakeOut #== expectedDatum
|
||||
|
||||
let expectedValue =
|
||||
paddValue # continuingValue # (pdiscreteValue' stake.gtClassRef # delta)
|
||||
let valueDelta :: Term _ (PValue _ 'Positive)
|
||||
valueDelta = pdiscreteValue' stake.gtClassRef # delta
|
||||
|
||||
expectedValue =
|
||||
paddValue # continuingValue # valueDelta
|
||||
|
||||
valueCorrect =
|
||||
foldr1
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ import Plutarch.DataRepr (
|
|||
)
|
||||
import Plutarch.Lift (PConstantDecl (..), PLifted (..), PUnsafeLiftDecl)
|
||||
import Plutarch.TryFrom ()
|
||||
import Plutus.V1.Ledger.Value (CurrencySymbol)
|
||||
import PlutusLedgerApi.V1.Value (CurrencySymbol)
|
||||
import PlutusTx qualified
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -90,7 +90,7 @@ treasuryValidator gatCs' = plam $ \_datum redeemer ctx' -> unTermCont $ do
|
|||
-- Get the minted value from txInfo.
|
||||
txInfo' <- tclet ctx.txInfo
|
||||
txInfo <- tcont $ pletFields @'["mint"] txInfo'
|
||||
let mint :: Term _ PValue
|
||||
let mint :: Term _ (PValue _ _)
|
||||
mint = txInfo.mint
|
||||
|
||||
gatCs <- tclet $ pconstant gatCs'
|
||||
|
|
|
|||
|
|
@ -65,18 +65,20 @@ module Agora.Utils (
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutus.V1.Ledger.Api (
|
||||
import PlutusLedgerApi.V1 (
|
||||
Address (..),
|
||||
Credential (..),
|
||||
CurrencySymbol,
|
||||
TokenName (..),
|
||||
ValidatorHash (..),
|
||||
)
|
||||
import Plutus.V1.Ledger.Value (AssetClass (..))
|
||||
import PlutusLedgerApi.V1.Value (AssetClass (..))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutarch.Api.V1 (
|
||||
AmountGuarantees (NoGuarantees, NonZero, Positive),
|
||||
KeyGuarantees (Sorted, Unsorted),
|
||||
PAddress,
|
||||
PCredential (PScriptCredential),
|
||||
PCurrencySymbol,
|
||||
|
|
@ -103,6 +105,7 @@ import Plutarch.Builtin (pforgetData, ppairDataBuiltin)
|
|||
import Plutarch.Extra.Map (pkeys)
|
||||
import Plutarch.Reducible (Reducible (Reduce))
|
||||
import Plutarch.TryFrom (PTryFrom (PTryFromExcess))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- TermCont-based combinators. Some of these will live in plutarch eventually.
|
||||
|
|
@ -222,7 +225,9 @@ pisJust = phoistAcyclic $
|
|||
PNothing -> pconstant False
|
||||
|
||||
-- | Get the sum of all values belonging to a particular CurrencySymbol.
|
||||
psymbolValueOf :: Term s (PCurrencySymbol :--> PValue :--> PInteger)
|
||||
psymbolValueOf ::
|
||||
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
|
||||
Term s (PCurrencySymbol :--> PValue keys amounts :--> PInteger)
|
||||
psymbolValueOf =
|
||||
phoistAcyclic $
|
||||
plam $ \sym value'' -> unTermCont $ do
|
||||
|
|
@ -233,33 +238,46 @@ psymbolValueOf =
|
|||
pure $ pfoldr # plam (\x v -> pfromData (psndBuiltin # x) + v) # 0 # m
|
||||
|
||||
-- | Extract amount from PValue belonging to a Haskell-level AssetClass.
|
||||
passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger)
|
||||
passetClassValueOf' ::
|
||||
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
|
||||
AssetClass ->
|
||||
Term s (PValue keys amounts :--> PInteger)
|
||||
passetClassValueOf' (AssetClass (sym, token)) =
|
||||
phoistAcyclic $ plam $ \value -> pvalueOf # value # pconstant sym # pconstant token
|
||||
|
||||
-- | Return '>=' on two values comparing by only a particular AssetClass.
|
||||
pgeqByClass :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PValue :--> PBool)
|
||||
pgeqByClass ::
|
||||
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
|
||||
Term s (PCurrencySymbol :--> PTokenName :--> PValue keys amounts :--> PValue keys amounts :--> PBool)
|
||||
pgeqByClass =
|
||||
phoistAcyclic $
|
||||
plam $ \cs tn a b ->
|
||||
pvalueOf # b # cs # tn #<= pvalueOf # a # cs # tn
|
||||
|
||||
-- | Return '>=' on two values comparing by only a particular CurrencySymbol.
|
||||
pgeqBySymbol :: Term s (PCurrencySymbol :--> PValue :--> PValue :--> PBool)
|
||||
pgeqBySymbol ::
|
||||
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
|
||||
Term s (PCurrencySymbol :--> PValue keys amounts :--> PValue keys amounts :--> PBool)
|
||||
pgeqBySymbol =
|
||||
phoistAcyclic $
|
||||
plam $ \cs a b ->
|
||||
psymbolValueOf # cs # b #<= psymbolValueOf # cs # a
|
||||
|
||||
-- | Return '>=' on two values comparing by only a particular Haskell-level AssetClass.
|
||||
pgeqByClass' :: AssetClass -> Term s (PValue :--> PValue :--> PBool)
|
||||
pgeqByClass' ::
|
||||
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
|
||||
AssetClass ->
|
||||
Term s (PValue keys amounts :--> PValue keys amounts :--> PBool)
|
||||
pgeqByClass' ac =
|
||||
phoistAcyclic $
|
||||
plam $ \a b ->
|
||||
passetClassValueOf' ac # b #<= passetClassValueOf' ac # a
|
||||
|
||||
-- | Union two maps using a merge function on collisions.
|
||||
pmapUnionWith :: forall k v s. PIsData v => Term s ((v :--> v :--> v) :--> PMap k v :--> PMap k v :--> PMap k v)
|
||||
pmapUnionWith ::
|
||||
forall (k :: PType) (v :: PType) (keys :: KeyGuarantees) (s :: S).
|
||||
PIsData v =>
|
||||
Term s ((v :--> v :--> v) :--> PMap keys k v :--> PMap keys k v :--> PMap keys k v)
|
||||
pmapUnionWith = phoistAcyclic $
|
||||
-- TODO: this function is kinda suspect. I feel like a lot of optimizations could be done here
|
||||
plam $ \f xs' ys' -> unTermCont $ do
|
||||
|
|
@ -301,7 +319,10 @@ pmapMaybe = phoistAcyclic $
|
|||
_ -> self # f # xs
|
||||
|
||||
-- | / O(n) /. Update the value at a given key in a `PMap`, have the same functionalities as 'Data.Map.update'.
|
||||
pupdate :: forall s k v. (PIsData k, PIsData v) => Term s ((v :--> PMaybe v) :--> k :--> PMap k v :--> PMap k v)
|
||||
pupdate ::
|
||||
forall (k :: PType) (v :: PType) (keys :: KeyGuarantees) (s :: S).
|
||||
(PIsData k, PIsData v) =>
|
||||
Term s ((v :--> PMaybe v) :--> k :--> PMap keys k v :--> PMap keys k v)
|
||||
pupdate = phoistAcyclic $
|
||||
plam $ \f (pdata -> tk) (pto -> (ps :: Term _ (PBuiltinList _))) ->
|
||||
pcon $
|
||||
|
|
@ -324,7 +345,10 @@ pupdate = phoistAcyclic $
|
|||
# ps
|
||||
|
||||
-- | / O(n) /. Map a function over all values in a 'PMap'.
|
||||
pmapMap :: forall s k a b. (PIsData k, PIsData a, PIsData b) => Term s ((a :--> b) :--> PMap k a :--> PMap k b)
|
||||
pmapMap ::
|
||||
forall (k :: PType) (a :: PType) (b :: PType) (keys :: KeyGuarantees) (s :: S).
|
||||
(PIsData k, PIsData a, PIsData b) =>
|
||||
Term s ((a :--> b) :--> PMap keys k a :--> PMap keys k b)
|
||||
pmapMap = phoistAcyclic $
|
||||
plam $ \f (pto -> (ps :: Term _ (PBuiltinList _))) ->
|
||||
pcon $
|
||||
|
|
@ -340,8 +364,15 @@ pmapMap = phoistAcyclic $
|
|||
)
|
||||
# ps
|
||||
|
||||
-- | Compute the guarantees known after adding two values.
|
||||
type family AddGuarantees (a :: AmountGuarantees) (b :: AmountGuarantees) where
|
||||
AddGuarantees 'Positive 'Positive = 'Positive
|
||||
AddGuarantees _ _ = 'NoGuarantees
|
||||
|
||||
-- | Add two 'PValue's together.
|
||||
paddValue :: forall s. Term s (PValue :--> PValue :--> PValue)
|
||||
paddValue ::
|
||||
forall (keys :: KeyGuarantees) (as :: AmountGuarantees) (bs :: AmountGuarantees) (s :: S).
|
||||
Term s (PValue keys as :--> PValue keys bs :--> PValue keys (AddGuarantees as bs))
|
||||
paddValue = phoistAcyclic $
|
||||
plam $ \a' b' -> unTermCont $ do
|
||||
PValue a <- tcmatch a'
|
||||
|
|
@ -353,7 +384,9 @@ paddValue = phoistAcyclic $
|
|||
)
|
||||
|
||||
-- | Sum of all value at input.
|
||||
pvalueSpent :: Term s (PBuiltinList (PAsData PTxInInfo) :--> PValue)
|
||||
pvalueSpent ::
|
||||
forall (s :: S).
|
||||
Term s (PBuiltinList (PAsData PTxInInfo) :--> PValue 'Sorted 'Positive)
|
||||
pvalueSpent = phoistAcyclic $
|
||||
plam $ \inputs ->
|
||||
pfoldr
|
||||
|
|
@ -368,7 +401,8 @@ pvalueSpent = phoistAcyclic $
|
|||
(\(PTxOut o) -> pfromData $ pfield @"value" # o)
|
||||
# v
|
||||
)
|
||||
# pconstant mempty
|
||||
-- TODO: This should be possible without coercions, but I can't figure out the types atm.
|
||||
# punsafeCoerce (pconstant mempty :: Term _ (PValue 'Unsorted 'NonZero))
|
||||
# inputs
|
||||
|
||||
-- | Find the TxInInfo by a TxOutRef.
|
||||
|
|
@ -415,7 +449,10 @@ ptokenSpent =
|
|||
{- | True if both maps have exactly the same keys.
|
||||
Using @'#=='@ is not sufficient, because keys returned are not ordered.
|
||||
-}
|
||||
pkeysEqual :: (POrd k, PIsData k) => forall (s :: S) a b. Term s (PMap k a :--> PMap k b :--> PBool)
|
||||
pkeysEqual ::
|
||||
forall (k :: PType) (a :: PType) (b :: PType) (keys :: KeyGuarantees) (s :: S).
|
||||
(POrd k, PIsData k) =>
|
||||
Term s (PMap keys k a :--> PMap keys k b :--> PBool)
|
||||
pkeysEqual = phoistAcyclic $
|
||||
plam $ \p q -> unTermCont $ do
|
||||
pks <- tclet $ pkeys # p
|
||||
|
|
@ -575,7 +612,9 @@ phalve = phoistAcyclic $ plam $ \l -> go # l # l
|
|||
-}
|
||||
|
||||
-- | Create a value with a single asset class.
|
||||
psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue)
|
||||
psingletonValue ::
|
||||
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
|
||||
Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue keys amounts)
|
||||
psingletonValue = phoistAcyclic $
|
||||
plam $ \sym tok int ->
|
||||
let innerTup = pcon $ PMap $ psingleton #$ ppairDataBuiltin # pdata tok # pdata int
|
||||
|
|
@ -645,7 +684,9 @@ getMintingPolicySymbol :: ClosedTerm PMintingPolicy -> CurrencySymbol
|
|||
getMintingPolicySymbol v = mintingPolicySymbol $ mkMintingPolicy v
|
||||
|
||||
-- | The entire value only contains one token of the given currency symbol.
|
||||
hasOnlyOneTokenOfCurrencySymbol :: Term s (PCurrencySymbol :--> PValue :--> PBool)
|
||||
hasOnlyOneTokenOfCurrencySymbol ::
|
||||
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
|
||||
Term s (PCurrencySymbol :--> PValue keys amounts :--> PBool)
|
||||
hasOnlyOneTokenOfCurrencySymbol = phoistAcyclic $
|
||||
plam $ \cs vs -> P.do
|
||||
psymbolValueOf # cs # vs #== 1
|
||||
|
|
@ -687,6 +728,6 @@ mustBePDJust = phoistAcyclic $
|
|||
PDJust ((pfield @"_0" #) -> v) -> v
|
||||
_ -> ptraceError emsg
|
||||
|
||||
-- | Create an 'Address' from a given 'ValidatorHash' with no 'Plutus.V1.Ledger.Credential.StakingCredential'.
|
||||
-- | Create an 'Address' from a given 'ValidatorHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'.
|
||||
validatorHashToAddress :: ValidatorHash -> Address
|
||||
validatorHashToAddress vh = Address (ScriptCredential vh) Nothing
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue