covenant-1.1.0: src/Covenant/Internal/Ledger.hs
module Covenant.Internal.Ledger
( ledgerTypes,
-- For testing
DeclBuilder (Decl),
CtorBuilder (Ctor),
mkDecl,
maybeT,
pair,
list,
tree,
weirderList,
)
where
import Covenant.DeBruijn (DeBruijn (Z))
import Covenant.Index (Count, count0, count1, count2, ix0, ix1)
import Covenant.Internal.Strategy
( DataEncoding (BuiltinStrategy, PlutusData),
InternalStrategy (InternalAssocMapStrat, InternalDataStrat, InternalListStrat, InternalPairStrat),
PlutusDataStrategy (ConstrData, NewtypeData),
)
import Covenant.Internal.Type
( AbstractTy (BoundAt),
BuiltinFlatT (BoolT, ByteStringT, IntegerT),
Constructor (Constructor),
ConstructorName (ConstructorName),
DataDeclaration (DataDeclaration),
TyName (TyName),
ValT (Abstraction, BuiltinFlat, Datatype),
)
import Data.Coerce (coerce)
import Data.Vector qualified as Vector
-- All the ledger types. Just putting them in a list for now but they'll probably end up in some other kind of container eventually
ledgerTypes :: [DataDeclaration AbstractTy]
ledgerTypes =
[ list,
pair,
plutusData,
datum,
redeemer,
scriptHash,
datumHash,
redeemerHash,
credential,
stakingCredential,
pubKeyHash,
address,
maybeT,
posixTime,
interval,
upperBound,
lowerBound,
extended,
ledgerBytes,
assocMap,
currencySymbol,
tokenName,
value,
lovelace,
rational,
mintValue,
txId,
txOutRef,
txOut,
outputDatum,
txInInfo,
dRepCredential,
dRep,
delegatee,
coldCommitteeCredential,
hotCommitteeCredential,
txCert,
voter,
vote,
governanceActionId,
committee,
constitution,
changedParameters,
protocolVersion,
governanceAction,
proposalProcedure,
scriptPurpose,
scriptInfo,
txInfo,
scriptContext
]
-- Builtins. These aren't "real" ADTs and their unique encoding strategies indicate special handling
-- Note (Koz, 11/07/25): This has a Haddock, and is versioned, because
-- Covenant.Test exposes it. If we ever stop doing this, we can remove this
-- Haddock.
-- | The onchain list type.
--
-- @since 1.1.0
list :: DataDeclaration AbstractTy
list =
mkDecl $
Decl
"List"
count1
[ Ctor "Nil" [],
Ctor "Cons" [Abstraction (BoundAt Z ix0), tycon "List" [Abstraction (BoundAt Z ix0)]]
]
(BuiltinStrategy InternalListStrat)
pair :: DataDeclaration AbstractTy
pair = mkDecl $ Decl "Pair" count2 [Ctor "Pair" [a, b]] (BuiltinStrategy InternalPairStrat)
-- Make sure this matches up with chooseData
plutusData :: DataDeclaration AbstractTy
plutusData =
mkDecl $
Decl
"Data"
count0
[ Ctor "Constr" [BuiltinFlat IntegerT, tycon "List" [tycon "Data" []]],
Ctor "Map" [tycon "List" [tycon "Pair" [tycon "Data" [], tycon "Data" []]]],
Ctor "List" [tycon "List" [tycon "Data" []]],
Ctor "I" [BuiltinFlat IntegerT],
Ctor "B" [BuiltinFlat ByteStringT]
]
(BuiltinStrategy InternalDataStrat)
-- Newtypes and Hash Types (from V1)
datum :: DataDeclaration AbstractTy
datum = mkDecl $ Decl "Datum" count0 [Ctor "Datum" [tycon "Data" []]] (PlutusData NewtypeData)
redeemer :: DataDeclaration AbstractTy
redeemer = mkDecl $ Decl "Redeemer" count0 [Ctor "Redeemer" [tycon "Data" []]] (PlutusData NewtypeData)
scriptHash :: DataDeclaration AbstractTy
scriptHash = mkDecl $ Decl "ScriptHash" count0 [Ctor "ScriptHash" [BuiltinFlat ByteStringT]] (PlutusData NewtypeData)
datumHash :: DataDeclaration AbstractTy
datumHash = mkDecl $ Decl "DatumHash" count0 [Ctor "DatumHash" [BuiltinFlat ByteStringT]] (PlutusData NewtypeData)
redeemerHash :: DataDeclaration AbstractTy
redeemerHash = mkDecl $ Decl "RedeemerHash" count0 [Ctor "RedeemerHash" [BuiltinFlat ByteStringT]] (PlutusData NewtypeData)
-- Credential + Staking Credential (from V1)
credential :: DataDeclaration AbstractTy
credential =
mkDecl $
Decl
"Credential"
count0
[ Ctor "PubKeyCredential" [tycon "PubKeyHash" []],
Ctor "ScriptCredential" [tycon "ScriptHash" []]
]
(PlutusData ConstrData)
stakingCredential :: DataDeclaration AbstractTy
stakingCredential =
mkDecl $
Decl
"StakingCredential"
count0
[ Ctor "StakingHash" [tycon "Credential" []],
Ctor "StakingPtr" [BuiltinFlat IntegerT, BuiltinFlat IntegerT, BuiltinFlat IntegerT]
]
(PlutusData ConstrData)
-- PubKeyHash (from V1)
pubKeyHash :: DataDeclaration AbstractTy
pubKeyHash = mkDecl $ Decl "PubKeyHash" count0 [Ctor "PubKeyHash" [BuiltinFlat ByteStringT]] (PlutusData NewtypeData)
-- Address (from V1)
address :: DataDeclaration AbstractTy
address =
mkDecl $
Decl
"Address"
count0
[ Ctor "Address" [tycon "Credential" [], tycon "Maybe" [tycon "StakingCredential" []]]
]
(PlutusData ConstrData)
-- PlutusTX types, from https://github.com/IntersectMBO/plutus/blob/master/plutus-tx/src/PlutusTx/IsData/Instances.hs
maybeT :: DataDeclaration AbstractTy
maybeT =
mkDecl $
Decl
"Maybe"
count1
[ Ctor "Just" [Abstraction (BoundAt Z ix0)],
Ctor "Nothing" []
]
(PlutusData ConstrData)
-- Time & Intervals (V1)
posixTime :: DataDeclaration AbstractTy
posixTime = mkSimpleNewtype "POSIXTime" (BuiltinFlat IntegerT)
interval :: DataDeclaration AbstractTy
interval =
mkDecl $
Decl
"Interval"
count1
[ Ctor
"Interval"
[ tycon "LowerBound" [a],
tycon "UpperBound" [a]
]
]
(PlutusData ConstrData)
upperBound :: DataDeclaration AbstractTy
upperBound =
mkDecl $
Decl
"UpperBound"
count1
[ Ctor "UpperBound" [tycon "Extended" [a], BuiltinFlat BoolT]
]
(PlutusData ConstrData)
lowerBound :: DataDeclaration AbstractTy
lowerBound =
mkDecl $
Decl
"LowerBound"
count1
[ Ctor "LowerBound" [tycon "Extended" [a], BuiltinFlat BoolT]
]
(PlutusData ConstrData)
extended :: DataDeclaration AbstractTy
extended =
mkDecl $
Decl
"Extended"
count1
[ Ctor "NegInf" [],
Ctor "Finite" [a],
Ctor "PosInf" []
]
(PlutusData ConstrData)
-- LedgerBytes (V1)
ledgerBytes :: DataDeclaration AbstractTy
ledgerBytes = mkSimpleNewtype "LedgerBytes" (BuiltinFlat ByteStringT)
-- Value & Friends (should be V1). Also AssocMap (v1)
-- NOTE Sean 5/28: This is "magical" like List/Pair/Data due to the fact that we cannot use an opaque
-- (because opaques do not take type parameters)
assocMap :: DataDeclaration AbstractTy
assocMap =
mkDecl $
Decl
"Map"
count2
[Ctor "Map" [tycon "List" [tycon "Pair" [a, b]]]]
(BuiltinStrategy InternalAssocMapStrat)
currencySymbol :: DataDeclaration AbstractTy
currencySymbol = mkSimpleNewtype "CurrencySymbol" (BuiltinFlat ByteStringT)
tokenName :: DataDeclaration AbstractTy
tokenName = mkSimpleNewtype "TokenName" (BuiltinFlat ByteStringT)
value :: DataDeclaration AbstractTy
value =
mkSimpleNewtype
"Value"
( tycon
"Map"
[ tycon "CurrencySymbol" [],
tycon "Map" [tycon "TokenName" [], BuiltinFlat IntegerT]
]
)
lovelace :: DataDeclaration AbstractTy
lovelace = mkSimpleNewtype "Lovelace" (BuiltinFlat IntegerT)
rational :: DataDeclaration AbstractTy
rational =
mkDecl $
Decl
"Rational"
count0
[ Ctor "Rational" [tycon "Pair" [BuiltinFlat IntegerT, BuiltinFlat IntegerT]]
]
(PlutusData NewtypeData)
-- MintValue (V3)
mintValue :: DataDeclaration AbstractTy
mintValue =
mkDecl $
Decl
"MintValue"
count0
[ Ctor
"UnsafeMintValue"
[ tycon
"Map"
[ tycon "CurrencySymbol" [],
tycon "Map" [tycon "TokenName" [], BuiltinFlat IntegerT]
]
]
]
(PlutusData NewtypeData)
-- TxId (v3)
txId :: DataDeclaration AbstractTy
txId = mkSimpleNewtype "TxId" (BuiltinFlat ByteStringT)
-- TxOutRef (v3)
txOutRef :: DataDeclaration AbstractTy
txOutRef =
mkDecl $
Decl
"TxOutRef"
count0
[ Ctor "TxOutRef" [tycon "TxId" [], BuiltinFlat IntegerT]
]
(PlutusData ConstrData)
-- TxOut (v2)
txOut :: DataDeclaration AbstractTy
txOut =
mkDecl $
Decl
"TxOut"
count0
[ Ctor
"TxOut"
[ tycon "Address" [],
tycon "Value" [],
tycon "OutputDatum" [],
tycon "Maybe" [tycon "ScriptHash" []]
]
]
(PlutusData ConstrData)
-- OutputDatum (v2)
outputDatum :: DataDeclaration AbstractTy
outputDatum =
mkDecl $
Decl
"OutputDatum"
count0
[ Ctor "NoOutputDatum" [],
Ctor "OutputDatumHash" [tycon "DatumHash" []],
Ctor "OutputDatum" [tycon "OutputDatum" []]
]
(PlutusData ConstrData)
-- txInInfo (V3)
txInInfo :: DataDeclaration AbstractTy
txInInfo =
mkDecl $
Decl
"TxInInfo"
count0
[ Ctor
"TxInInfo"
[ tycon "TxOutRef" [],
tycon "TxOut" []
]
]
(PlutusData ConstrData)
-- DRepCredential (v3)
dRepCredential :: DataDeclaration AbstractTy
dRepCredential = mkSimpleNewtype "DRepCredential" (tycon "Credential" [])
-- DRep (v3)
dRep :: DataDeclaration AbstractTy
dRep =
mkDecl $
Decl
"DRep"
count0
[ Ctor "DRep" [tycon "DRepCredential" []],
Ctor "DRepAlwaysAbstain" [],
Ctor "DRepAlwaysNoConfidence" []
]
(PlutusData ConstrData)
-- delegatee (v3)
delegatee :: DataDeclaration AbstractTy
delegatee =
mkDecl $
Decl
"Delegatee"
count0
[ Ctor "DelegStake" [tycon "PubKeyHash" []],
Ctor "DelegVote" [tycon "DRep" []],
Ctor "DelegStakeVoke" [tycon "PubKeyHash" [], tycon "DRep" []]
]
(PlutusData ConstrData)
coldCommitteeCredential :: DataDeclaration AbstractTy
coldCommitteeCredential = mkSimpleNewtype "ColdCommitteeCredential" (tycon "Credential" [])
hotCommitteeCredential :: DataDeclaration AbstractTy
hotCommitteeCredential = mkSimpleNewtype "HotCommitteeCredential" (tycon "Credential" [])
-- txCert (v3)
txCert :: DataDeclaration AbstractTy
txCert =
mkDecl $
Decl
"TxCert"
count0
[ Ctor "TxCertRegStaking" [tycon "Credential" [], tycon "Maybe" [tycon "Lovelace" []]],
Ctor "TxCertUnRegStaking" [tycon "Credential" [], tycon "Maybe" [tycon "Lovelace" []]],
Ctor "TxCertDelegStaking" [tycon "Credential" [], tycon "Delegatee" []],
Ctor "TxCertRegDeleg" [tycon "Credential" [], tycon "Delegatee" [], tycon "Lovelace" []],
Ctor "TxCertRegDRep" [tycon "DRepCredential" [], tycon "Lovelace" []],
Ctor "TxCertUpdateDRep" [tycon "DRepCredential" []],
Ctor "TxCertUnRegDRep" [tycon "DRepCredential" [], tycon "Lovelace" []],
Ctor "TxCertPoolRegister" [tycon "PubKeyHash" [], tycon "PubKeyHash" []],
Ctor "TxCertPoolRetire" [tycon "PubKeyHash" [], BuiltinFlat IntegerT],
Ctor "TxCertAuthHotCommittee" [tycon "ColdCommitteeCredential" [], tycon "HotCommitteeCredential" []],
Ctor "TxCertResignColdCommittee" [tycon "ColdCommitteeCredential" []]
]
(PlutusData ConstrData)
-- voter (v3)
voter :: DataDeclaration AbstractTy
voter =
mkDecl $
Decl
"Voter"
count0
[ Ctor "CommitteeVoter" [tycon "HotCommitteeCredential" []],
Ctor "DRepVoter" [tycon "DRepCredential" []],
Ctor "StakePoolVoter" [tycon "PubKeyHash" []]
]
(PlutusData ConstrData)
-- vote (v3)
vote :: DataDeclaration AbstractTy
vote =
mkDecl $
Decl
"Vote"
count0
[ Ctor "VoteNo" [],
Ctor "VoteYes" [],
Ctor "Abstain" []
]
(PlutusData ConstrData)
-- GovernanceActionID (v3)
governanceActionId :: DataDeclaration AbstractTy
governanceActionId =
mkDecl $
Decl
"GovernanceActionId"
count0
[ Ctor
"GovernanceActionId"
[ tycon "TxId" [],
BuiltinFlat IntegerT
]
]
(PlutusData ConstrData)
-- Committee (v3)
committee :: DataDeclaration AbstractTy
committee =
mkDecl $
Decl
"Committee"
count0
[ Ctor
"Committee"
[ tycon "Map" [tycon "ColdCommitteeCredential" [], BuiltinFlat IntegerT],
tycon "Rational" []
]
]
(PlutusData ConstrData)
-- constitution (V3)
constitution :: DataDeclaration AbstractTy
constitution = mkSimpleNewtype "Constitution" (tycon "Maybe" [tycon "ScriptHash" []])
-- changedParameters (V3)
changedParameters :: DataDeclaration AbstractTy
changedParameters = mkSimpleNewtype "ChangedParameters" (tycon "Data" [])
-- ProtocolVersion (V3)
protocolVersion :: DataDeclaration AbstractTy
protocolVersion =
mkDecl $
Decl
"ProtocolVersion"
count0
[ Ctor "ProtocolVersion" [BuiltinFlat IntegerT, BuiltinFlat IntegerT]
]
(PlutusData ConstrData)
-- GovernanceAction (v3)
governanceAction :: DataDeclaration AbstractTy
governanceAction =
mkDecl $
Decl
"GovernanceAction"
count0
[ Ctor
"ParameterChange"
[ tycon "Maybe" [tycon "GovernanceActionId" []],
tycon "ChangedParameters" [],
tycon "Maybe" [tycon "ScriptHash" []]
],
Ctor
"HardForkInitiation"
[ tycon "Maybe" [tycon "GovernanceActionId" []],
tycon "ProtocolVersion" []
],
Ctor
"TreasuryWithdrawals"
[ tycon "Map" [tycon "Credential" [], tycon "Lovelace" []],
tycon "Maybe" [tycon "ScriptHash" []]
],
Ctor "NoConfidence" [tycon "Maybe" [tycon "GovernanceActionId" []]],
Ctor
"UpdateCommittee"
[ tycon "Maybe" [tycon "GovernanceActionId" []],
tycon "List" [tycon "ColdCommitteeCredential" []],
tycon "Map" [tycon "ColdCommitteeCredential" [], BuiltinFlat IntegerT],
tycon "Rational" []
],
Ctor "NewConstitution" [tycon "Maybe" [tycon "GovernanceActionId" []], tycon "Constitution" []],
Ctor "InfoAction" []
]
(PlutusData ConstrData)
-- ProposalProcedure (v3)
proposalProcedure :: DataDeclaration AbstractTy
proposalProcedure =
mkDecl $
Decl
"ProposalProcedure"
count0
[ Ctor
"ProposalProcedure"
[ tycon "Lovelace" [],
tycon "Credential" [],
tycon "GovernanceAction" []
]
]
(PlutusData ConstrData)
-- scriptPurpose (v3)
scriptPurpose :: DataDeclaration AbstractTy
scriptPurpose =
mkDecl $
Decl
"ScriptPurpose"
count0
[ Ctor "Minting" [tycon "CurrencySymbol" []],
Ctor "Spending" [tycon "TxOutRef" []],
Ctor "Rewarding" [tycon "Credential" []],
Ctor "Certifying" [BuiltinFlat IntegerT, tycon "TxCert" []],
Ctor "Voting" [tycon "Voter" []],
Ctor "Proposing" [BuiltinFlat IntegerT, tycon "ProposalProcedure" []]
]
(PlutusData ConstrData)
-- ScriptInfo (V3)
scriptInfo :: DataDeclaration AbstractTy
scriptInfo =
mkDecl $
Decl
"ScriptInfo"
count0
[ Ctor "MintingScript" [tycon "CurrencySymbol" []],
Ctor "SpendingScript" [tycon "TxOutRef" [], tycon "Maybe" [tycon "Datum" []]],
Ctor "RewardingScript" [tycon "Credential" []],
Ctor "CertifyingScript" [BuiltinFlat IntegerT, tycon "TxCert" []],
Ctor "VotingScript" [tycon "Voter" []],
Ctor "ProposingScript" [BuiltinFlat IntegerT, tycon "ProposalProcedure" []]
]
(PlutusData ConstrData)
-- This is a TypeSyn, so not a declaration, but it's *annoying* to type the ValT version out
posixTimeRange :: ValT AbstractTy
posixTimeRange = tycon "Interval" [tycon "POSIXTime" []]
-- txInfo (v3)
txInfo :: DataDeclaration AbstractTy
txInfo =
mkDecl $
Decl
"TxInfo"
count0
[ Ctor
"TxInfo"
[ tycon "List" [tycon "TxInInfo" []],
tycon "List" [tycon "TxInInfo" []],
tycon "List" [tycon "TxOut" []],
tycon "Lovelace" [],
tycon "MintValue" [],
tycon "List" [tycon "TxCert" []],
tycon "Map" [tycon "Credential" [], tycon "Lovelace" []],
posixTimeRange,
tycon "List" [tycon "PubKeyHash" []],
tycon "Map" [tycon "ScriptPurpose" [], tycon "Redeemer" []],
tycon "Map" [tycon "DatumHash" [], tycon "Datum" []],
tycon "TxId" [],
tycon "Map" [tycon "Voter" [], tycon "Map" [tycon "GovernanceActionId" [], tycon "Vote" []]],
tycon "List" [tycon "ProposalProcedure" []],
tycon "Maybe" [tycon "Lovelace" []],
tycon "Maybe" [tycon "Lovelace" []]
]
]
(PlutusData ConstrData)
-- scriptContext (v3)
scriptContext :: DataDeclaration AbstractTy
scriptContext =
mkDecl $
Decl
"ScriptContext"
count0
[ Ctor
"ScriptContext"
[ tycon "TxInfo" [],
tycon "Redeemer" [],
tycon "ScriptInfo" []
]
]
(PlutusData ConstrData)
-- Helpers
-- Variants of DataDeclaration and Constructor that use Lists to avoid a slew of Vector.fromList cluttering up the module
data DeclBuilder = Decl TyName (Count "tyvar") [CtorBuilder] DataEncoding
data CtorBuilder = Ctor ConstructorName [ValT AbstractTy]
mkDecl :: DeclBuilder -> DataDeclaration AbstractTy
mkDecl (Decl tn cnt ctors enc) = DataDeclaration tn cnt (Vector.fromList . fmap mkCtor $ ctors) enc
where
mkCtor :: CtorBuilder -> Constructor AbstractTy
mkCtor (Ctor cnm fields) = Constructor cnm (Vector.fromList fields)
tycon :: TyName -> [ValT AbstractTy] -> ValT AbstractTy
tycon tn vals = Datatype tn (Vector.fromList vals)
{- This is shorthand for a non-polymorphic newtype (i.e. a single ctor / arg type with a newtype strategy) where
the name of the constructor is the same as the name of the type.
This is a *very* common case and this seems useful to save extra typing.
-}
mkSimpleNewtype :: TyName -> ValT AbstractTy -> DataDeclaration AbstractTy
mkSimpleNewtype tn val = mkDecl $ Decl tn count0 [Ctor (coerce tn) [val]] (PlutusData NewtypeData)
-- obviously should not export these, solely exist to improve readability of declarations.
-- Since everything here is data-encodeable the DB index *should* always be Z & I don't think anything uses more than
-- 2 tyvars
a :: ValT AbstractTy
a = Abstraction (BoundAt Z ix0)
b :: ValT AbstractTy
b = Abstraction (BoundAt Z ix1)
-- For tests, much easier to define this here w/ the helpers
-- Note (Koz, 11/07/25): Same as for `list`.
-- | A datatype equivalent to
--
-- @data Tree a = Bin (Tree a) (Tree a) | Tip a@
--
-- @since 1.1.0
tree :: DataDeclaration AbstractTy
tree =
mkDecl $
Decl
"Tree"
count1
[ Ctor "Bin" [tycon "Tree" [a], tycon "Tree" [a]],
Ctor "Tip" [a]
]
(PlutusData ConstrData)
-- | A datatype equivalent to
--
-- @data WeirderList a = Uncons (Maybe (a, WeirderList a))@
--
-- @since 1.1.0
weirderList :: DataDeclaration AbstractTy
weirderList =
mkDecl $
Decl
"WeirderList"
count1
[ Ctor "Uncons" [tycon "Maybe" [tycon "Pair" [a, tycon "WeirderList" [a]]]]
]
(PlutusData ConstrData)