fix compilation errors
This commit is contained in:
Hongrui Fang
parent
d921927a2f
commit
6da4e7286d
21 changed files with 279 additions and 677 deletions
|
|
@ -11,10 +11,6 @@ module Agora.AuthorityToken (
|
|||
singleAuthorityTokenBurned,
|
||||
) where
|
||||
|
||||
import Agora.Utils (
|
||||
passert,
|
||||
psymbolValueOf',
|
||||
)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential (..),
|
||||
PCurrencySymbol (..),
|
||||
|
|
@ -33,6 +29,7 @@ import Plutarch.Api.V2 (
|
|||
PTxOut (PTxOut),
|
||||
)
|
||||
import Plutarch.Extra.AssetClass (PAssetClassData, ptoScottEncoding)
|
||||
import Plutarch.Extra.Bool (passert)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (plookupAssoc)
|
||||
import Plutarch.Extra.Maybe (pfromJust)
|
||||
import Plutarch.Extra.ScriptContext (pisTokenSpent)
|
||||
|
|
@ -44,7 +41,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
|||
pmatchC,
|
||||
)
|
||||
import Plutarch.Extra.Traversable (pfoldMap)
|
||||
import Plutarch.Extra.Value (psymbolValueOf)
|
||||
import Plutarch.Extra.Value (psymbolValueOf, psymbolValueOf')
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -26,7 +26,6 @@ import Agora.Governor (
|
|||
PGovernorRedeemer,
|
||||
)
|
||||
import Agora.Plutarch.Orphans ()
|
||||
import Agora.Utils (pfromSingleton, ptryFromRedeemer)
|
||||
import Plutarch.Api.V1 (PCurrencySymbol, PValidatorHash)
|
||||
import Plutarch.Api.V2 (
|
||||
PScriptPurpose (PSpending),
|
||||
|
|
@ -38,9 +37,15 @@ import Plutarch.DataRepr (
|
|||
PDataFields,
|
||||
)
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (ptryFromSingleton)
|
||||
import Plutarch.Extra.Maybe (passertPJust, pdnothing)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.=))
|
||||
import Plutarch.Extra.ScriptContext (paddressFromValidatorHash, pfromOutputDatum, pisScriptAddress)
|
||||
import Plutarch.Extra.ScriptContext (
|
||||
paddressFromValidatorHash,
|
||||
pisScriptAddress,
|
||||
ptryFromOutputDatum,
|
||||
ptryFromRedeemer,
|
||||
)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC)
|
||||
import Plutarch.Extra.Value (psymbolValueOf)
|
||||
import Plutarch.Lift (PConstantDecl, PLifted, PUnsafeLiftDecl)
|
||||
|
|
@ -216,11 +221,11 @@ mutateGovernorValidator =
|
|||
|
||||
let governorOutput =
|
||||
ptrace "Only governor output is allowed" $
|
||||
pfromSingleton # pfromData txInfoF.outputs
|
||||
ptryFromSingleton # pfromData txInfoF.outputs
|
||||
|
||||
governorOutputDatum =
|
||||
ptrace "Resolve governor outoput datum" $
|
||||
pfromOutputDatum @PGovernorDatum
|
||||
ptryFromOutputDatum @PGovernorDatum
|
||||
# (pfield @"datum" # governorOutput)
|
||||
# txInfoF.datums
|
||||
|
||||
|
|
|
|||
|
|
@ -15,7 +15,6 @@ module Agora.Effect.TreasuryWithdrawal (
|
|||
|
||||
import Agora.Effect (makeEffect)
|
||||
import Agora.Plutarch.Orphans ()
|
||||
import Agora.Utils (pdelete)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential,
|
||||
PCurrencySymbol,
|
||||
|
|
@ -35,6 +34,7 @@ import Plutarch.DataRepr (
|
|||
PDataFields,
|
||||
)
|
||||
import Plutarch.Extra.Field (pletAllC)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pdeleteFirst)
|
||||
import Plutarch.Extra.ScriptContext (pisPubKey)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC)
|
||||
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
|
||||
|
|
@ -178,7 +178,7 @@ treasuryWithdrawalValidator = plam $
|
|||
(ptraceError "Invalid receiver")
|
||||
|
||||
pure $
|
||||
pmatch (pdelete # credValue # receivers) $ \case
|
||||
pmatch (pdeleteFirst # credValue # receivers) $ \case
|
||||
PJust updatedReceivers ->
|
||||
ptrace "Receiver output" updatedReceivers
|
||||
PNothing ->
|
||||
|
|
|
|||
|
|
@ -40,10 +40,6 @@ import Agora.Stake (
|
|||
pnumCreatedProposals,
|
||||
presolveStakeInputDatum,
|
||||
)
|
||||
import Agora.Utils (
|
||||
plistEqualsBy,
|
||||
pscriptHashToTokenName,
|
||||
)
|
||||
import Plutarch.Api.V1 (PCurrencySymbol)
|
||||
import Plutarch.Api.V1.AssocMap (plookup)
|
||||
import Plutarch.Api.V1.AssocMap qualified as AssocMap
|
||||
|
|
@ -57,17 +53,18 @@ import Plutarch.Api.V2 (
|
|||
)
|
||||
import Plutarch.Extra.AssetClass (PAssetClassData, passetClass, ptoScottEncoding)
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, plistEqualsBy, pmapMaybe)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.Map (pkeys, ptryLookup)
|
||||
import Plutarch.Extra.Maybe (passertPJust, pjust, pmaybe, pmaybeData, pnothing)
|
||||
import Plutarch.Extra.Ord (psort)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
|
||||
import Plutarch.Extra.ScriptContext (
|
||||
pfindTxInByTxOutRef,
|
||||
pfromDatumHash,
|
||||
pfromOutputDatum,
|
||||
pisUTXOSpent,
|
||||
pscriptHashFromAddress,
|
||||
pscriptHashToTokenName,
|
||||
ptryFromDatumHash,
|
||||
ptryFromOutputDatum,
|
||||
pvalueSpent,
|
||||
)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
||||
|
|
@ -153,7 +150,7 @@ governorPolicy =
|
|||
|
||||
governorDatum =
|
||||
ptrace "Resolve governor datum" $
|
||||
pfromOutputDatum @PGovernorDatum
|
||||
ptryFromOutputDatum @PGovernorDatum
|
||||
# txOutF.datum
|
||||
# txInfoF.datums
|
||||
in pif isGovernorUTxO (pjust # governorDatum) pnothing
|
||||
|
|
@ -323,7 +320,7 @@ governorValidator =
|
|||
|
||||
datum =
|
||||
ptrace "Resolve governor datum" $
|
||||
pfromOutputDatum @PGovernorDatum
|
||||
ptryFromOutputDatum @PGovernorDatum
|
||||
# outputF.datum
|
||||
# txInfoF.datums
|
||||
in pif
|
||||
|
|
@ -350,7 +347,7 @@ governorValidator =
|
|||
proposalDatum =
|
||||
ptrace "Resolve proposal output datum" $
|
||||
pfromData $
|
||||
pfromOutputDatum
|
||||
ptryFromOutputDatum
|
||||
# txOutF.datum
|
||||
# txInfoF.datums
|
||||
in pif isProposalUTxO (pjust # proposalDatum) pnothing
|
||||
|
|
@ -546,7 +543,7 @@ governorValidator =
|
|||
#== 1
|
||||
|
||||
let hasCorrectDatum =
|
||||
effect.datumHash #== pfromDatumHash # outputF.datum
|
||||
effect.datumHash #== ptryFromDatumHash # outputF.datum
|
||||
|
||||
pguardC "Authority output valid" $
|
||||
foldr1
|
||||
|
|
@ -568,7 +565,7 @@ governorValidator =
|
|||
-- The sorted hashes of all the GAT receivers.
|
||||
actualReceivers =
|
||||
psort
|
||||
#$ pmapMaybe
|
||||
#$ pmapMaybe @PList
|
||||
# getReceiverScriptHash
|
||||
# pfromData txInfoF.outputs
|
||||
|
||||
|
|
|
|||
|
|
@ -3,12 +3,13 @@
|
|||
module Agora.Linker (linker, AgoraScriptInfo (..)) where
|
||||
|
||||
import Agora.Governor (Governor (gstOutRef, gtClassRef, maximumCosigners))
|
||||
import Agora.Utils (validatorHashToAddress, validatorHashToTokenName)
|
||||
import Agora.Utils (validatorHashToAddress)
|
||||
import Data.Aeson qualified as Aeson
|
||||
import Data.Map (fromList)
|
||||
import Data.Tagged (untag)
|
||||
import Plutarch.Api.V2 (mintingPolicySymbol, validatorHash)
|
||||
import Plutarch.Extra.AssetClass (AssetClass (AssetClass))
|
||||
import Plutarch.Extra.ScriptContext (validatorHashToTokenName)
|
||||
import PlutusLedgerApi.V1 (Address, CurrencySymbol, TxOutRef, ValidatorHash)
|
||||
import Ply (
|
||||
ScriptRole (MintingPolicyRole, ValidatorRole),
|
||||
|
|
|
|||
|
|
@ -35,13 +35,6 @@ import Agora.Stake (
|
|||
pisVoter,
|
||||
presolveStakeInputDatum,
|
||||
)
|
||||
import Agora.Utils (
|
||||
pfromSingleton,
|
||||
pinsertUniqueBy,
|
||||
plistEqualsBy,
|
||||
pmapMaybe,
|
||||
ptryFromRedeemer,
|
||||
)
|
||||
import Plutarch.Api.V1 (PCredential, PCurrencySymbol)
|
||||
import Plutarch.Api.V1.AssocMap (plookup)
|
||||
import Plutarch.Api.V2 (
|
||||
|
|
@ -56,7 +49,12 @@ import Plutarch.Extra.AssetClass (
|
|||
)
|
||||
import Plutarch.Extra.Category (PCategory (pidentity))
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (
|
||||
pfindJust,
|
||||
plistEqualsBy,
|
||||
pmapMaybe,
|
||||
ptryFromSingleton,
|
||||
)
|
||||
import "plutarch-extra" Plutarch.Extra.Map (pupdate)
|
||||
import Plutarch.Extra.Maybe (
|
||||
passertPJust,
|
||||
|
|
@ -66,11 +64,12 @@ import Plutarch.Extra.Maybe (
|
|||
pmaybe,
|
||||
pnothing,
|
||||
)
|
||||
import Plutarch.Extra.Ord (pfromOrdBy, psort)
|
||||
import Plutarch.Extra.Ord (pfromOrdBy, pinsertUniqueBy, psort)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
|
||||
import Plutarch.Extra.ScriptContext (
|
||||
pfindTxInByTxOutRef,
|
||||
pfromOutputDatum,
|
||||
ptryFromOutputDatum,
|
||||
ptryFromRedeemer,
|
||||
)
|
||||
import Plutarch.Extra.Sum (PSum (PSum))
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
||||
|
|
@ -309,7 +308,7 @@ proposalValidator =
|
|||
-- Using inline datum to avoid O(n^2) lookup.
|
||||
pfromData $
|
||||
ptrace "Resolve proposal datum" $
|
||||
pfromOutputDatum @(PAsData PProposalDatum)
|
||||
ptryFromOutputDatum @(PAsData PProposalDatum)
|
||||
# outputF.datum
|
||||
# txInfoF.datums
|
||||
in pif
|
||||
|
|
@ -348,7 +347,7 @@ proposalValidator =
|
|||
pletC $
|
||||
plam $
|
||||
let stakeInputs =
|
||||
pmapMaybe
|
||||
pmapMaybe @PList
|
||||
# resolveStakeInputDatum
|
||||
# pfromData txInfoF.inputs
|
||||
|
||||
|
|
@ -439,7 +438,7 @@ proposalValidator =
|
|||
stakeF <-
|
||||
pletFieldsC @'["owner", "stakedAmount"] $
|
||||
ptrace "Exactly one stake input" $
|
||||
pfromSingleton # sctxF.inputStakes
|
||||
ptryFromSingleton # sctxF.inputStakes
|
||||
|
||||
let newCosigner = stakeF.owner
|
||||
|
||||
|
|
|
|||
|
|
@ -30,7 +30,6 @@ module Agora.Proposal.Time (
|
|||
pisWithin,
|
||||
) where
|
||||
|
||||
import Agora.Utils (pcurrentTimeDuration)
|
||||
import Control.Composition ((.*))
|
||||
import Data.Functor ((<&>))
|
||||
import Plutarch.Api.V1 (
|
||||
|
|
@ -52,6 +51,7 @@ import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing)
|
|||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletC, pmatchC)
|
||||
import Plutarch.Extra.Time (
|
||||
PCurrentTime (PCurrentTime),
|
||||
pcurrentTimeDuration,
|
||||
pisWithinCurrentTime,
|
||||
)
|
||||
import Plutarch.Lift (
|
||||
|
|
|
|||
|
|
@ -50,7 +50,6 @@ import Agora.Proposal (
|
|||
ResultTag,
|
||||
)
|
||||
import Agora.SafeMoney (GTTag)
|
||||
import Agora.Utils (pmapMaybe, ppureIf)
|
||||
import Data.Tagged (Tagged)
|
||||
import Generics.SOP qualified as SOP
|
||||
import Plutarch.Api.V1 (PCredential)
|
||||
|
|
@ -67,15 +66,16 @@ import Plutarch.DataRepr (
|
|||
DerivePConstantViaData (DerivePConstantViaData),
|
||||
PDataFields,
|
||||
)
|
||||
import Plutarch.Extra.Applicative (ppureIf)
|
||||
import Plutarch.Extra.AssetClass (PAssetClass)
|
||||
import Plutarch.Extra.Field (pletAll)
|
||||
import Plutarch.Extra.IsData (
|
||||
DerivePConstantViaDataList (DerivePConstantViaDataList),
|
||||
ProductIsData (ProductIsData),
|
||||
)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe)
|
||||
import Plutarch.Extra.Maybe (passertPJust, pjust, pnothing)
|
||||
import Plutarch.Extra.ScriptContext (pfromOutputDatum)
|
||||
import Plutarch.Extra.ScriptContext (ptryFromOutputDatum)
|
||||
import Plutarch.Extra.Sum (PSum (PSum))
|
||||
import Plutarch.Extra.Tagged (PTagged)
|
||||
import Plutarch.Extra.Traversable (pfoldMap)
|
||||
|
|
@ -734,7 +734,7 @@ presolveStakeInputDatum = phoistAcyclic $
|
|||
datum =
|
||||
ptrace "Resolve stake datum" $
|
||||
pfromData $
|
||||
pfromOutputDatum @(PAsData PStakeDatum)
|
||||
ptryFromOutputDatum @(PAsData PStakeDatum)
|
||||
# txOutF.datum
|
||||
# datums
|
||||
in pif
|
||||
|
|
|
|||
|
|
@ -48,10 +48,10 @@ import Agora.Stake (
|
|||
),
|
||||
pstakeLocked,
|
||||
)
|
||||
import Agora.Utils (pfromSingleton, pisSingleton, pmustDeleteBy)
|
||||
import Plutarch.Api.V1.Address (PCredential)
|
||||
import Plutarch.Api.V2 (PMaybeData)
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pisSingleton, ptryDeleteFirstBy, ptryFromSingleton)
|
||||
import Plutarch.Extra.Maybe (pdjust, pdnothing, pmaybeData)
|
||||
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pmatchC)
|
||||
|
|
@ -87,7 +87,7 @@ pbatchUpdateInputs = phoistAcyclic $
|
|||
plam $ \f -> flip pmatch $ \ctxF ->
|
||||
pnull
|
||||
#$ pfoldr
|
||||
# (pmustDeleteBy # f)
|
||||
# plam (\x -> ptryDeleteFirstBy # (f # x))
|
||||
# ctxF.stakeOutputDatums
|
||||
# ctxF.stakeInputDatums
|
||||
|
||||
|
|
@ -387,12 +387,12 @@ pdepositWithdraw = phoistAcyclic $
|
|||
stakeInputDatum <-
|
||||
pletC $
|
||||
ptrace "Single stake input" $
|
||||
pfromSingleton # ctxF.stakeInputDatums
|
||||
ptryFromSingleton # ctxF.stakeInputDatums
|
||||
stakeInputDatumF <- pletAllC stakeInputDatum
|
||||
|
||||
let stakeOutputDatum =
|
||||
ptrace "Single stake output" $
|
||||
pfromSingleton # ctxF.stakeOutputDatums
|
||||
ptryFromSingleton # ctxF.stakeOutputDatums
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -52,13 +52,7 @@ import Agora.Stake.Redeemers (
|
|||
ppermitVote,
|
||||
pretractVote,
|
||||
)
|
||||
import Agora.Utils (
|
||||
passert,
|
||||
pisDNothing,
|
||||
pmapMaybe,
|
||||
psymbolValueOf',
|
||||
pvalidatorHashToTokenName,
|
||||
)
|
||||
import Agora.Utils (pisDNothing)
|
||||
import Plutarch.Api.V1 (
|
||||
PCredential (PPubKeyCredential, PScriptCredential),
|
||||
PCurrencySymbol,
|
||||
|
|
@ -79,9 +73,10 @@ import Plutarch.Extra.AssetClass (
|
|||
passetClass,
|
||||
ptoScottEncoding,
|
||||
)
|
||||
import Plutarch.Extra.Bool (passert)
|
||||
import Plutarch.Extra.Field (pletAll, pletAllC)
|
||||
import Plutarch.Extra.Functor (PFunctor (pfmap))
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe)
|
||||
import Plutarch.Extra.Maybe (
|
||||
passertPJust,
|
||||
pfromJust,
|
||||
|
|
@ -93,7 +88,8 @@ import Plutarch.Extra.Maybe (
|
|||
import Plutarch.Extra.Ord (POrdering (PEQ, PGT, PLT), pcompareBy, pfromOrd)
|
||||
import Plutarch.Extra.ScriptContext (
|
||||
pfindTxInByTxOutRef,
|
||||
pfromOutputDatum,
|
||||
ptryFromOutputDatum,
|
||||
pvalidatorHashToTokenName,
|
||||
pvalueSpent,
|
||||
)
|
||||
import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
||||
|
|
@ -106,6 +102,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
|
|||
import Plutarch.Extra.Value (
|
||||
passetClassValueOf,
|
||||
psymbolValueOf,
|
||||
psymbolValueOf',
|
||||
)
|
||||
import Plutarch.Num (PNum (pnegate))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
|
|
@ -197,7 +194,7 @@ stakePolicy =
|
|||
datumF <-
|
||||
pletAllC $
|
||||
pfromData $
|
||||
pfromOutputDatum @(PAsData PStakeDatum)
|
||||
ptryFromOutputDatum @(PAsData PStakeDatum)
|
||||
# outputF.datum
|
||||
# txInfoF.datums
|
||||
|
||||
|
|
@ -277,10 +274,11 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
|
|||
#$ pfield @"address"
|
||||
# validatedInput
|
||||
|
||||
let sstName = pvalidatorHashToTokenName #$ pmatch stakeValidatorCredential $
|
||||
\case
|
||||
PScriptCredential r -> pfield @"_0" # r
|
||||
_ -> perror
|
||||
let sstName = pvalidatorHashToTokenName $
|
||||
pmatch stakeValidatorCredential $
|
||||
\case
|
||||
PScriptCredential r -> pfield @"_0" # r
|
||||
_ -> perror
|
||||
|
||||
sstClass <- pletC $ passetClass # sstSymbol # sstName
|
||||
|
||||
|
|
@ -310,7 +308,7 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
|
|||
datum =
|
||||
ptrace "Resolve stake datum" $
|
||||
pfromData $
|
||||
pfromOutputDatum @(PAsData PStakeDatum)
|
||||
ptryFromOutputDatum @(PAsData PStakeDatum)
|
||||
# txOutF.datum
|
||||
# txInfoF.datums
|
||||
in passert
|
||||
|
|
@ -439,7 +437,7 @@ mkStakeValidator impl sstSymbol pstClass gstClass =
|
|||
#== 1
|
||||
proposalDatum =
|
||||
pfromData $
|
||||
pfromOutputDatum @(PAsData PProposalDatum)
|
||||
ptryFromOutputDatum @(PAsData PProposalDatum)
|
||||
# txOutF.datum
|
||||
# txInfoF.datums
|
||||
in pif isProposalUTxO (pjust # proposalDatum) pnothing
|
||||
|
|
|
|||
|
|
@ -8,101 +8,22 @@ Description: Plutarch utility functions that should be upstreamed or don't belon
|
|||
Plutarch utility functions that should be upstreamed or don't belong anywhere else.
|
||||
-}
|
||||
module Agora.Utils (
|
||||
validatorHashToTokenName,
|
||||
validatorHashToAddress,
|
||||
pltAsData,
|
||||
withBuiltinPairAsData,
|
||||
pvalidatorHashToTokenName,
|
||||
pscriptHashToTokenName,
|
||||
scriptHashToTokenName,
|
||||
plistEqualsBy,
|
||||
pstringIntercalate,
|
||||
punwords,
|
||||
pcurrentTimeDuration,
|
||||
pdelete,
|
||||
pdeleteBy,
|
||||
pmustDeleteBy,
|
||||
pisSingleton,
|
||||
pfromSingleton,
|
||||
pmapMaybe,
|
||||
PAlternative (..),
|
||||
ppureIf,
|
||||
pltBy,
|
||||
pinsertUniqueBy,
|
||||
ptryFromRedeemer,
|
||||
passert,
|
||||
pisNothing,
|
||||
pisDNothing,
|
||||
psymbolValueOf',
|
||||
) where
|
||||
|
||||
import Plutarch.Api.V1 (
|
||||
KeyGuarantees (Unsorted),
|
||||
PPOSIXTime,
|
||||
PRedeemer,
|
||||
PValidatorHash,
|
||||
)
|
||||
import Plutarch.Api.V1.AssocMap (PMap, plookup)
|
||||
import Plutarch.Api.V2 (
|
||||
AmountGuarantees,
|
||||
PCurrencySymbol,
|
||||
PMaybeData (PDNothing),
|
||||
PScriptHash,
|
||||
PScriptPurpose,
|
||||
PTokenName,
|
||||
PValue,
|
||||
)
|
||||
import Plutarch.Extra.Applicative (PApplicative (ppure))
|
||||
import Plutarch.Extra.Category (PCategory (pidentity))
|
||||
import Plutarch.Extra.Functor (PFunctor (PSubcategory, pfmap))
|
||||
import Plutarch.Extra.Maybe (pjust, pnothing)
|
||||
import Plutarch.Extra.Ord (PComparator, POrdering (PLT), pcompareBy, pequateBy)
|
||||
import Plutarch.Extra.Time (PCurrentTime (PCurrentTime))
|
||||
import Plutarch.Unsafe (punsafeCoerce)
|
||||
import PlutusLedgerApi.V2 (
|
||||
Address (Address),
|
||||
Credential (ScriptCredential),
|
||||
ScriptHash (ScriptHash),
|
||||
TokenName (TokenName),
|
||||
ValidatorHash (ValidatorHash),
|
||||
ValidatorHash,
|
||||
)
|
||||
|
||||
{- Functions which should (probably) not be upstreamed
|
||||
All of these functions are quite inefficient.
|
||||
-}
|
||||
|
||||
{- | Safely convert a 'ValidatorHash' into a 'TokenName'. This can be useful for tagging
|
||||
tokens for extra safety.
|
||||
|
||||
@since 0.1.0
|
||||
-}
|
||||
validatorHashToTokenName :: ValidatorHash -> TokenName
|
||||
validatorHashToTokenName (ValidatorHash hash) = TokenName hash
|
||||
|
||||
{- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging
|
||||
tokens for extra safety.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pvalidatorHashToTokenName :: forall (s :: S). Term s (PValidatorHash :--> PTokenName)
|
||||
pvalidatorHashToTokenName = phoistAcyclic $ plam punsafeCoerce
|
||||
|
||||
{- | Safely convert a 'PScriptHash' into a 'PTokenName'. This can be useful for tagging
|
||||
tokens for extra safety.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
scriptHashToTokenName :: ScriptHash -> TokenName
|
||||
scriptHashToTokenName (ScriptHash hash) = TokenName hash
|
||||
|
||||
{- | Safely convert a 'PScriptHash' into a 'PTokenName'. This can be useful for tagging
|
||||
tokens for extra safety.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pscriptHashToTokenName :: forall (s :: S). Term s PScriptHash -> Term s PTokenName
|
||||
pscriptHashToTokenName = punsafeCoerce
|
||||
|
||||
{- | Create an 'Address' from a given 'ValidatorHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'.
|
||||
|
||||
@since 0.1.0
|
||||
|
|
@ -110,62 +31,6 @@ pscriptHashToTokenName = punsafeCoerce
|
|||
validatorHashToAddress :: ValidatorHash -> Address
|
||||
validatorHashToAddress vh = Address (ScriptCredential vh) Nothing
|
||||
|
||||
{- | Compare two 'PAsData' value, return true if the first one is less than the second one.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
pltAsData ::
|
||||
forall (a :: PType) (s :: S).
|
||||
(POrd a, PIsData a) =>
|
||||
Term s (PAsData a :--> PAsData a :--> PBool)
|
||||
pltAsData = phoistAcyclic $
|
||||
plam $
|
||||
\(pfromData -> l) (pfromData -> r) -> l #< r
|
||||
|
||||
{- | Extract data stored in a 'PBuiltinPair' and call a function to process it.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
withBuiltinPairAsData ::
|
||||
forall (a :: PType) (b :: PType) (c :: PType) (s :: S).
|
||||
(PIsData a, PIsData b) =>
|
||||
(Term s a -> Term s b -> Term s c) ->
|
||||
Term
|
||||
s
|
||||
(PBuiltinPair (PAsData a) (PAsData b)) ->
|
||||
Term s c
|
||||
withBuiltinPairAsData f p =
|
||||
let a = pfromData $ pfstBuiltin # p
|
||||
b = pfromData $ psndBuiltin # p
|
||||
in f a b
|
||||
|
||||
-- | @since 1.0.0
|
||||
plistEqualsBy ::
|
||||
forall
|
||||
(list1 :: PType -> PType)
|
||||
(list2 :: PType -> PType)
|
||||
(a :: PType)
|
||||
(b :: PType)
|
||||
(s :: S).
|
||||
(PIsListLike list1 a, PIsListLike list2 b) =>
|
||||
Term s ((a :--> b :--> PBool) :--> list1 a :--> list2 b :--> PBool)
|
||||
plistEqualsBy = phoistAcyclic $
|
||||
plam $ \eq -> pfix #$ plam $ \self l1 l2 ->
|
||||
pelimList
|
||||
( \x xs ->
|
||||
pelimList
|
||||
( \y ys ->
|
||||
-- Avoid comparison if two lists have different length.
|
||||
self # xs # ys #&& eq # x # y
|
||||
)
|
||||
-- l2 is empty, but l1 is not.
|
||||
(pconstant False)
|
||||
l2
|
||||
)
|
||||
-- l1 is empty, so l2 should be empty as well.
|
||||
(pnull # l2)
|
||||
l1
|
||||
|
||||
-- | @since 1.0.0
|
||||
pstringIntercalate ::
|
||||
forall (s :: S).
|
||||
|
|
@ -183,225 +48,6 @@ punwords ::
|
|||
Term s PString
|
||||
punwords = pstringIntercalate " "
|
||||
|
||||
-- | @since 1.0.0
|
||||
pcurrentTimeDuration ::
|
||||
forall (s :: S).
|
||||
Term
|
||||
s
|
||||
( PCurrentTime
|
||||
:--> PPOSIXTime
|
||||
)
|
||||
pcurrentTimeDuration = phoistAcyclic $
|
||||
plam $
|
||||
flip pmatch $
|
||||
\(PCurrentTime lb ub) -> ub - lb
|
||||
|
||||
{- | / O(n) /. Remove the first occurance of a value from the given list.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pdelete ::
|
||||
forall (a :: PType) (list :: PType -> PType) (s :: S).
|
||||
(PEq a, PIsListLike list a) =>
|
||||
Term s (a :--> list a :--> PMaybe (list a))
|
||||
pdelete = phoistAcyclic $ pdeleteBy # plam (#==)
|
||||
|
||||
-- | @since 1.0.0
|
||||
pdeleteBy ::
|
||||
forall (a :: PType) (list :: PType -> PType) (s :: S).
|
||||
(PIsListLike list a) =>
|
||||
Term s ((a :--> a :--> PBool) :--> a :--> list a :--> PMaybe (list a))
|
||||
pdeleteBy = phoistAcyclic $
|
||||
plam $ \f' x -> plet (f' # x) $ \f ->
|
||||
precList
|
||||
( \self h t ->
|
||||
pif
|
||||
(f # h)
|
||||
(pjust # t)
|
||||
(pfmap # (pcons # h) # (self # t))
|
||||
)
|
||||
(const pnothing)
|
||||
|
||||
-- | @since 1.0.0
|
||||
pmustDeleteBy ::
|
||||
forall (a :: PType) (list :: PType -> PType) (s :: S).
|
||||
(PIsListLike list a) =>
|
||||
Term s ((a :--> a :--> PBool) :--> a :--> list a :--> list a)
|
||||
pmustDeleteBy = phoistAcyclic $
|
||||
plam $ \f' x -> plet (f' # x) $ \f ->
|
||||
precList
|
||||
( \self h t ->
|
||||
pif
|
||||
(f # h)
|
||||
t
|
||||
(pcons # h #$ self # t)
|
||||
)
|
||||
(const $ ptraceError "Cannot delete element")
|
||||
|
||||
{- | / O(1) /.Return true if the given list has only one element.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pisSingleton ::
|
||||
forall (a :: PType) (list :: PType -> PType) (s :: S).
|
||||
(PIsListLike list a) =>
|
||||
Term s (list a :--> PBool)
|
||||
pisSingleton =
|
||||
phoistAcyclic $
|
||||
precList
|
||||
(\_ _ t -> pnull # t)
|
||||
(const $ pconstant False)
|
||||
|
||||
{- Throws an error if the given list contains zero or more than one elements.
|
||||
Otherwise returns the only element.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pfromSingleton ::
|
||||
forall (a :: PType) (list :: PType -> PType) (s :: S).
|
||||
(PIsListLike list a) =>
|
||||
Term s (list a :--> a)
|
||||
pfromSingleton =
|
||||
phoistAcyclic $
|
||||
precList
|
||||
( \_ h t ->
|
||||
pif
|
||||
(pnull # t)
|
||||
h
|
||||
(ptraceError "More than one element")
|
||||
)
|
||||
(const $ ptraceError "Empty list")
|
||||
|
||||
{- | A version of 'pmap' which can throw out elements and change the list type
|
||||
along the way.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
pmapMaybe ::
|
||||
forall
|
||||
(listO :: PType -> PType)
|
||||
(b :: PType)
|
||||
(listI :: PType -> PType)
|
||||
(a :: PType)
|
||||
(s :: S).
|
||||
(PIsListLike listI a, PIsListLike listO b) =>
|
||||
Term s ((a :--> PMaybe b) :--> listI a :--> listO b)
|
||||
pmapMaybe = phoistAcyclic $
|
||||
plam $ \f ->
|
||||
precList
|
||||
( \self h t ->
|
||||
pmatch
|
||||
(f # h)
|
||||
( \case
|
||||
PJust x -> pcons # x
|
||||
PNothing -> pidentity
|
||||
)
|
||||
# (self # t)
|
||||
)
|
||||
(const pnil)
|
||||
|
||||
infixl 3 #<|>
|
||||
|
||||
-- | @since 1.0.0
|
||||
class (PApplicative f) => PAlternative (f :: PType -> PType) where
|
||||
(#<|>) ::
|
||||
forall (a :: PType) (s :: S).
|
||||
(PSubcategory f a) =>
|
||||
Term s (f a :--> f a :--> f a)
|
||||
pempty ::
|
||||
forall (a :: PType) (s :: S).
|
||||
(PSubcategory f a) =>
|
||||
Term s (f a)
|
||||
|
||||
-- | @since 1.0.0
|
||||
instance PAlternative PMaybe where
|
||||
(#<|>) = phoistAcyclic $
|
||||
plam $ \a b -> pmatch a $ \case
|
||||
PNothing -> b
|
||||
PJust _ -> a
|
||||
pempty = pnothing
|
||||
|
||||
-- | @since 1.0.0
|
||||
ppureIf ::
|
||||
forall
|
||||
(f :: PType -> PType)
|
||||
(a :: PType)
|
||||
(s :: S).
|
||||
(PAlternative f, PSubcategory f a) =>
|
||||
Term s (PBool :--> a :--> f a)
|
||||
ppureIf = phoistAcyclic $
|
||||
plam $ \cond x ->
|
||||
pif
|
||||
cond
|
||||
(ppure # x)
|
||||
pempty
|
||||
|
||||
{- | Less then check using a `PComparator`.
|
||||
|
||||
@ since 1.0.0
|
||||
-}
|
||||
pltBy ::
|
||||
forall (a :: PType) (s :: S).
|
||||
Term
|
||||
s
|
||||
( PComparator a
|
||||
:--> a
|
||||
:--> a
|
||||
:--> PBool
|
||||
)
|
||||
pltBy = phoistAcyclic $
|
||||
plam $ \c x y ->
|
||||
pcompareBy # c # x # y #== pcon PLT
|
||||
|
||||
-- | @since 1.0.0
|
||||
pinsertUniqueBy ::
|
||||
forall (list :: PType -> PType) (a :: PType) (s :: S).
|
||||
(PIsListLike list a) =>
|
||||
Term s (PComparator a :--> a :--> list a :--> list a)
|
||||
pinsertUniqueBy = phoistAcyclic $
|
||||
plam $ \c x ->
|
||||
let lt = pltBy # c
|
||||
eq = pequateBy # c
|
||||
in precList
|
||||
( \self h t ->
|
||||
let ensureUniqueness =
|
||||
pif
|
||||
(eq # x # h)
|
||||
(ptraceError "inserted value already exists")
|
||||
next =
|
||||
pif
|
||||
(lt # x # h)
|
||||
(pcons # x #$ pcons # h # t)
|
||||
(pcons # h #$ self # t)
|
||||
in ensureUniqueness next
|
||||
)
|
||||
(const $ psingleton # x)
|
||||
|
||||
-- | @since 1.0.0
|
||||
ptryFromRedeemer ::
|
||||
forall (r :: PType) (s :: S).
|
||||
(PTryFrom PData r) =>
|
||||
Term
|
||||
s
|
||||
( PScriptPurpose
|
||||
:--> PMap 'Unsorted PScriptPurpose PRedeemer
|
||||
:--> PMaybe r
|
||||
)
|
||||
ptryFromRedeemer = phoistAcyclic $
|
||||
plam $ \p m ->
|
||||
pfmap
|
||||
# plam (flip ptryFrom fst . pto)
|
||||
# (plookup # p # m)
|
||||
|
||||
-- | @since 1.0.0
|
||||
passert ::
|
||||
forall (a :: PType) (s :: S).
|
||||
Term s PString ->
|
||||
Term s PBool ->
|
||||
Term s a ->
|
||||
Term s a
|
||||
passert msg cond x = pif cond x $ ptraceError msg
|
||||
|
||||
-- | @since 1.0.0
|
||||
pisNothing ::
|
||||
forall (a :: PType) (s :: S).
|
||||
|
|
@ -421,46 +67,3 @@ pisDNothing = phoistAcyclic $
|
|||
flip pmatch $ \case
|
||||
PDNothing _ -> pconstant True
|
||||
_ -> pconstant False
|
||||
|
||||
{- | Get the negative and positive amount of a particular 'CurrencySymbol', and
|
||||
return nothing if it doesn't exist in the value.
|
||||
|
||||
@since 1.0.0
|
||||
-}
|
||||
psymbolValueOf' ::
|
||||
forall
|
||||
(keys :: KeyGuarantees)
|
||||
(amounts :: AmountGuarantees)
|
||||
(s :: S).
|
||||
Term
|
||||
s
|
||||
( PCurrencySymbol
|
||||
:--> PValue keys amounts
|
||||
:--> PMaybe
|
||||
( PPair
|
||||
-- Positive amount
|
||||
PInteger
|
||||
-- Negative amount
|
||||
PInteger
|
||||
)
|
||||
)
|
||||
psymbolValueOf' = phoistAcyclic $
|
||||
plam $ \sym value ->
|
||||
let tnMap = plookup # sym # pto value
|
||||
f =
|
||||
plam $
|
||||
( pfoldr
|
||||
# plam
|
||||
( \x r ->
|
||||
let q = pfromData $ psndBuiltin # x
|
||||
in pmatch r $ \(PPair p n) ->
|
||||
pif
|
||||
(0 #< q)
|
||||
(pcon $ PPair (p + q) n)
|
||||
(pcon $ PPair p (n + q))
|
||||
)
|
||||
# pcon (PPair 0 0)
|
||||
#
|
||||
)
|
||||
. pto
|
||||
in pfmap # f # tnMap
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue