From c1c9ad5bfb0fa8c821bbf7340bbb49f58e24fa9a Mon Sep 17 00:00:00 2001 From: Ana Pantilie <45069775+ana-pantilie@users.noreply.github.com> Date: Tue, 17 Dec 2024 15:18:41 +0200 Subject: [PATCH] Fully Data-backed V3.ScriptContext (#6700) --- .../PlutusBenchmark/Data/ScriptContexts.hs | 132 +- .../9.6/checkScriptContext1-20.budget.golden | 4 +- .../9.6/checkScriptContext1-4.budget.golden | 4 +- .../Data/9.6/checkScriptContext1.pir.golden | 1406 ++--------------- .../Data/9.6/checkScriptContext1.size.golden | 2 +- .../9.6/checkScriptContext2-20.budget.golden | 4 +- .../9.6/checkScriptContext2-4.budget.golden | 4 +- .../Data/9.6/checkScriptContext2.pir.golden | 1309 +-------------- .../Data/9.6/checkScriptContext2.size.golden | 2 +- ...ScriptContextEqualityData-20.budget.golden | 4 +- ...ptContextEqualityOverhead-20.budget.golden | 4 +- ...319_ana.pantilie95_fully_data_backed_sc.md | 8 + plutus-ledger-api/plutus-ledger-api.cabal | 6 +- .../src/PlutusLedgerApi/Data/V1.hs | 143 +- .../src/PlutusLedgerApi/Data/V2.hs | 119 +- .../src/PlutusLedgerApi/Data/V3.hs | 231 ++- .../src/PlutusLedgerApi/V1/Data/Address.hs | 109 ++ .../src/PlutusLedgerApi/V1/Data/Contexts.hs | 380 +++-- .../src/PlutusLedgerApi/V1/Data/Credential.hs | 116 ++ .../src/PlutusLedgerApi/V1/Data/Interval.hs | 592 +++++++ .../src/PlutusLedgerApi/V1/Data/Time.hs | 100 ++ .../src/PlutusLedgerApi/V1/Data/Tx.hs | 183 ++- .../src/PlutusLedgerApi/V1/Data/Value.hs | 658 ++++---- .../src/PlutusLedgerApi/V2/Data/Contexts.hs | 318 ++-- .../src/PlutusLedgerApi/V2/Data/Tx.hs | 173 +- .../src/PlutusLedgerApi/V3/Data/Contexts.hs | 661 ++++---- .../src/PlutusLedgerApi/V3/Data/Tx.hs | 98 ++ plutus-ledger-api/test/Spec.hs | 197 ++- .../test/Spec/Data/ContextDecoding.hs | 28 - 29 files changed, 3024 insertions(+), 3971 deletions(-) create mode 100644 plutus-ledger-api/changelog.d/20241212_191319_ana.pantilie95_fully_data_backed_sc.md create mode 100644 plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Address.hs create mode 100644 plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Credential.hs create mode 100644 plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Interval.hs create mode 100644 plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Time.hs create mode 100644 plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Tx.hs delete mode 100644 plutus-ledger-api/test/Spec/Data/ContextDecoding.hs diff --git a/plutus-benchmark/script-contexts/src/PlutusBenchmark/Data/ScriptContexts.hs b/plutus-benchmark/script-contexts/src/PlutusBenchmark/Data/ScriptContexts.hs index 35dd2562d29..c0162bf9161 100644 --- a/plutus-benchmark/script-contexts/src/PlutusBenchmark/Data/ScriptContexts.hs +++ b/plutus-benchmark/script-contexts/src/PlutusBenchmark/Data/ScriptContexts.hs @@ -1,14 +1,23 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} module PlutusBenchmark.Data.ScriptContexts where -import PlutusLedgerApi.Data.V3 (OutputDatum (NoOutputDatum), PubKeyHash (..), Redeemer (..), - ScriptContext (..), ScriptInfo (SpendingScript), TxId (..), - TxInfo (..), TxOut (..), TxOutRef (..), always) -import PlutusLedgerApi.V1.Address +import PlutusLedgerApi.Data.V1 qualified as PlutusTx +import PlutusLedgerApi.Data.V3 (PubKeyHash (..), Redeemer (..), ScriptContext, TxId (..), TxInfo, + TxOut, always, pattern NoOutputDatum, pattern ScriptContext, + pattern SpendingScript, pattern TxInfo, pattern TxOut, + pattern TxOutRef, txInfoCurrentTreasuryAmount, txInfoData, + txInfoFee, txInfoId, txInfoInputs, txInfoMint, txInfoOutputs, + txInfoProposalProcedures, txInfoRedeemers, txInfoReferenceInputs, + txInfoSignatories, txInfoTreasuryDonation, txInfoTxCerts, + txInfoValidRange, txInfoVotes, txInfoWdrl, txOutAddress, txOutDatum, + txOutReferenceScript, txOutValue) +import PlutusLedgerApi.V1.Data.Address import PlutusLedgerApi.V1.Data.Value import PlutusTx qualified import PlutusTx.Builtins qualified as PlutusTx @@ -17,8 +26,9 @@ import PlutusTx.Data.List qualified as Data.List import PlutusTx.Plugin () import PlutusTx.Prelude qualified as PlutusTx --- | A very crude deterministic generator for 'ScriptContext's with size --- approximately proportional to the input integer. +{-| A very crude deterministic generator for 'ScriptContext's with size +approximately proportional to the input integer. +-} mkScriptContext :: Integer -> ScriptContext mkScriptContext i = ScriptContext @@ -26,34 +36,35 @@ mkScriptContext i = (Redeemer (PlutusTx.toBuiltinData (1 :: Integer))) (SpendingScript (TxOutRef (TxId "") 0) Nothing) - mkTxInfo :: Integer -> TxInfo -mkTxInfo i = TxInfo { - txInfoInputs=mempty, - txInfoReferenceInputs=mempty, - txInfoOutputs=Data.List.map mkTxOut (Data.List.fromSOP ([1..i] :: [Integer])), - txInfoFee=10000, - txInfoMint=mempty, - txInfoTxCerts=mempty, - txInfoWdrl=Map.empty, - txInfoValidRange=always, - txInfoSignatories=mempty, - txInfoRedeemers=Map.empty, - txInfoData=Map.empty, - txInfoId=TxId "", - txInfoVotes=Map.empty, - txInfoProposalProcedures=mempty, - txInfoCurrentTreasuryAmount=Nothing, - txInfoTreasuryDonation=Nothing - } +mkTxInfo i = + TxInfo + { txInfoInputs = mempty + , txInfoReferenceInputs = mempty + , txInfoOutputs = Data.List.map mkTxOut (Data.List.fromSOP ([1 .. i] :: [Integer])) + , txInfoFee = 10000 + , txInfoMint = mempty + , txInfoTxCerts = mempty + , txInfoWdrl = Map.empty + , txInfoValidRange = always + , txInfoSignatories = mempty + , txInfoRedeemers = Map.empty + , txInfoData = Map.empty + , txInfoId = TxId "" + , txInfoVotes = Map.empty + , txInfoProposalProcedures = mempty + , txInfoCurrentTreasuryAmount = Nothing + , txInfoTreasuryDonation = Nothing + } mkTxOut :: Integer -> TxOut -mkTxOut i = TxOut { - txOutAddress=pubKeyHashAddress (PubKeyHash ""), - txOutValue=mkValue i, - txOutDatum=NoOutputDatum, - txOutReferenceScript=Nothing - } +mkTxOut i = + TxOut + { txOutAddress = pubKeyHashAddress (PubKeyHash "") + , txOutValue = mkValue i + , txOutDatum = NoOutputDatum + , txOutReferenceScript = Nothing + } mkValue :: Integer -> Value mkValue i = assetClassValue (assetClass adaSymbol adaToken) i @@ -68,19 +79,16 @@ checkScriptContext1 d = -- since we do use it later let !sc = PlutusTx.unsafeFromBuiltinData d ScriptContext txi _ _ = sc - in - if Data.List.length (txInfoOutputs txi) `PlutusTx.modInteger` 2 PlutusTx.== 0 - then () - else PlutusTx.traceError "Odd number of outputs" -{-# INLINABLE checkScriptContext1 #-} + in if Data.List.length (txInfoOutputs txi) `PlutusTx.modInteger` 2 PlutusTx.== 0 + then () + else PlutusTx.traceError "Odd number of outputs" +{-# INLINEABLE checkScriptContext1 #-} mkCheckScriptContext1Code :: ScriptContext -> PlutusTx.CompiledCode () mkCheckScriptContext1Code sc = let d = PlutusTx.toBuiltinData sc - in - $$(PlutusTx.compile [|| checkScriptContext1 ||]) - `PlutusTx.unsafeApplyCode` - PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||checkScriptContext1||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d -- This example aims to *force* the decoding of the script context and then ignore it entirely. -- This corresponds to the unfortunate case where the decoding "wrapper" around a script forces @@ -88,23 +96,21 @@ mkCheckScriptContext1Code sc = checkScriptContext2 :: PlutusTx.BuiltinData -> () checkScriptContext2 d = let (sc :: ScriptContext) = PlutusTx.unsafeFromBuiltinData d - -- Just using a bang pattern was not enough to stop GHC from getting - -- rid of the dead binding before we even hit the plugin, this works - -- for now! - in case sc of - !_ -> - if 48 PlutusTx.* 9900 PlutusTx.== (475200 :: Integer) - then () - else PlutusTx.traceError "Got my sums wrong" -{-# INLINABLE checkScriptContext2 #-} + in -- Just using a bang pattern was not enough to stop GHC from getting + -- rid of the dead binding before we even hit the plugin, this works + -- for now! + case sc of + !_ -> + if 48 PlutusTx.* 9900 PlutusTx.== (475200 :: Integer) + then () + else PlutusTx.traceError "Got my sums wrong" +{-# INLINEABLE checkScriptContext2 #-} mkCheckScriptContext2Code :: ScriptContext -> PlutusTx.CompiledCode () mkCheckScriptContext2Code sc = let d = PlutusTx.toBuiltinData sc - in - $$(PlutusTx.compile [|| checkScriptContext2 ||]) - `PlutusTx.unsafeApplyCode` - PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||checkScriptContext2||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d {- Note [Redundant arguments to equality benchmarks] The arguments for the benchmarks are passed as terms created with `liftCodeDef`. @@ -124,26 +130,26 @@ scriptContextEqualityData :: ScriptContext -> PlutusTx.BuiltinData -> () -- See Note [Redundant arguments to equality benchmarks] scriptContextEqualityData _ d = if PlutusTx.equalsData d d - then () - else PlutusTx.traceError "The argument is not equal to itself" -{-# INLINABLE scriptContextEqualityData #-} + then () + else PlutusTx.traceError "The argument is not equal to itself" +{-# INLINEABLE scriptContextEqualityData #-} mkScriptContextEqualityDataCode :: ScriptContext -> PlutusTx.CompiledCode () mkScriptContextEqualityDataCode sc = let d = PlutusTx.toBuiltinData sc - in $$(PlutusTx.compile [|| scriptContextEqualityData ||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||scriptContextEqualityData||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d -- This example is just the overhead from the previous two -- See Note [Redundant arguments to equality benchmarks] scriptContextEqualityOverhead :: ScriptContext -> PlutusTx.BuiltinData -> () scriptContextEqualityOverhead _ _ = () -{-# INLINABLE scriptContextEqualityOverhead #-} +{-# INLINEABLE scriptContextEqualityOverhead #-} mkScriptContextEqualityOverheadCode :: ScriptContext -> PlutusTx.CompiledCode () mkScriptContextEqualityOverheadCode sc = let d = PlutusTx.toBuiltinData sc - in $$(PlutusTx.compile [|| scriptContextEqualityOverhead ||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc - `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d + in $$(PlutusTx.compile [||scriptContextEqualityOverhead||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc + `PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d diff --git a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext1-20.budget.golden b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext1-20.budget.golden index ee8a15856eb..9e48a1922b4 100644 --- a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext1-20.budget.golden +++ b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext1-20.budget.golden @@ -1,2 +1,2 @@ -({cpu: 50148035 -| mem: 195889}) \ No newline at end of file +({cpu: 33072854 +| mem: 126955}) \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext1-4.budget.golden b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext1-4.budget.golden index 0aa434b9b71..72e3fa449b7 100644 --- a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext1-4.budget.golden +++ b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext1-4.budget.golden @@ -1,2 +1,2 @@ -({cpu: 31987795 -| mem: 120721}) \ No newline at end of file +({cpu: 16448614 +| mem: 61387}) \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext1.pir.golden b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext1.pir.golden index 5a3f11f798f..abb5184d0ac 100644 --- a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext1.pir.golden +++ b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext1.pir.golden @@ -16,176 +16,9 @@ addInteger 1 (go t eta)) in let - data GovernanceActionId | GovernanceActionId_match where - GovernanceActionId : bytestring -> integer -> GovernanceActionId data Bool | Bool_match where True : Bool False : Bool - data Unit | Unit_match where - Unit : Unit - !traceError : all a. string -> a - = /\a -> - \(str : string) -> let !x : Unit = trace {Unit} str Unit in error {a} - !`$fUnsafeFromDataGovernanceAction_$cunsafeFromBuiltinData` : - data -> GovernanceActionId - = \(d : data) -> - let - !tup : pair integer (list data) = unConstrData d - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. GovernanceActionId} - (/\dead -> - GovernanceActionId - (unBData (headList {data} args)) - (unIData (headList {data} (tailList {data} args)))) - (/\dead -> traceError {GovernanceActionId} "PT1") - {all dead. dead} - data (Tuple2 :: * -> * -> *) a b | Tuple2_match where - Tuple2 : a -> b -> Tuple2 a b - data Credential | Credential_match where - PubKeyCredential : bytestring -> Credential - ScriptCredential : bytestring -> Credential - !`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` : data -> Credential - = \(d : data) -> - let - !tup : pair integer (list data) = unConstrData d - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. Credential} - (/\dead -> PubKeyCredential (unBData (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 1 index) True False) - {all dead. Credential} - (/\dead -> ScriptCredential (unBData (headList {data} args))) - (/\dead -> traceError {Credential} "PT1") - {all dead. dead}) - {all dead. dead} - data DRep | DRep_match where - DRep : Credential -> DRep - DRepAlwaysAbstain : DRep - DRepAlwaysNoConfidence : DRep - !`$fUnsafeFromDataDRep_$cunsafeFromBuiltinData` : data -> DRep - = \(d : data) -> - let - !tup : pair integer (list data) = unConstrData d - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. DRep} - (/\dead -> - DRep - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 1 index) True False) - {all dead. DRep} - (/\dead -> DRepAlwaysAbstain) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 2 index) True False) - {all dead. DRep} - (/\dead -> DRepAlwaysNoConfidence) - (/\dead -> traceError {DRep} "PT1") - {all dead. dead}) - {all dead. dead}) - {all dead. dead} - data Delegatee | Delegatee_match where - DelegStake : bytestring -> Delegatee - DelegStakeVote : bytestring -> DRep -> Delegatee - DelegVote : DRep -> Delegatee - !`$fUnsafeFromDataDelegatee_$cunsafeFromBuiltinData` : data -> Delegatee - = \(d : data) -> - let - !tup : pair integer (list data) = unConstrData d - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. Delegatee} - (/\dead -> DelegStake (unBData (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 1 index) True False) - {all dead. Delegatee} - (/\dead -> - DelegVote - (`$fUnsafeFromDataDRep_$cunsafeFromBuiltinData` - (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 2 index) True False) - {all dead. Delegatee} - (/\dead -> - DelegStakeVote - (unBData (headList {data} args)) - (`$fUnsafeFromDataDRep_$cunsafeFromBuiltinData` - (headList {data} (tailList {data} args)))) - (/\dead -> traceError {Delegatee} "PT1") - {all dead. dead}) - {all dead. dead}) - {all dead. dead} - !`$fUnsafeFromDataBool_$cunsafeFromBuiltinData` : data -> Bool - = \(d : data) -> - let - !tup : pair integer (list data) = unConstrData d - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. Bool} - (/\dead -> False) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 1 index) True False) - {all dead. Bool} - (/\dead -> True) - (/\dead -> traceError {Bool} "PT1") - {all dead. dead}) - {all dead. dead} - data (Extended :: * -> *) a | Extended_match where - Finite : a -> Extended a - NegInf : Extended a - PosInf : Extended a - !`$fUnsafeFromDataExtended_$cunsafeFromBuiltinData` : - all a. (\a -> data -> a) a -> data -> Extended a - = /\a -> - \(`$dUnsafeFromData` : (\a -> data -> a) a) (d : data) -> - let - !tup : pair integer (list data) = unConstrData d - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. Extended a} - (/\dead -> NegInf {a}) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 1 index) True False) - {all dead. Extended a} - (/\dead -> - Finite {a} (`$dUnsafeFromData` (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 2 index) True False) - {all dead. Extended a} - (/\dead -> PosInf {a}) - (/\dead -> traceError {Extended a} "PT1") - {all dead. dead}) - {all dead. dead}) - {all dead. dead} data (Maybe :: * -> *) a | Maybe_match where Just : a -> Maybe a Nothing : Maybe a @@ -208,1094 +41,50 @@ {all dead. Maybe a} (/\dead -> Just {a} (`$dUnsafeFromData` (headList {data} args))) - (/\dead -> traceError {Maybe a} "PT1") + (/\dead -> error {Maybe a}) {all dead. dead}) {all dead. dead} - data ProtocolVersion | ProtocolVersion_match where - ProtocolVersion : integer -> integer -> ProtocolVersion - data Rational | Rational_match where - Rational : integer -> integer -> Rational - data GovernanceAction | GovernanceAction_match where - HardForkInitiation : - Maybe GovernanceActionId -> ProtocolVersion -> GovernanceAction - InfoAction : GovernanceAction - NewConstitution : - Maybe GovernanceActionId -> Maybe bytestring -> GovernanceAction - NoConfidence : Maybe GovernanceActionId -> GovernanceAction - ParameterChange : - Maybe GovernanceActionId -> data -> Maybe bytestring -> GovernanceAction - TreasuryWithdrawals : - (\k a -> list (pair data data)) Credential integer -> - Maybe bytestring -> - GovernanceAction - UpdateCommittee : - Maybe GovernanceActionId -> - (\a -> list data) Credential -> - (\k a -> list (pair data data)) Credential integer -> - Rational -> - GovernanceAction - data ProposalProcedure | ProposalProcedure_match where - ProposalProcedure : - integer -> Credential -> GovernanceAction -> ProposalProcedure - data TxCert | TxCert_match where - TxCertAuthHotCommittee : Credential -> Credential -> TxCert - TxCertDelegStaking : Credential -> Delegatee -> TxCert - TxCertPoolRegister : bytestring -> bytestring -> TxCert - TxCertPoolRetire : bytestring -> integer -> TxCert - TxCertRegDRep : Credential -> integer -> TxCert - TxCertRegDeleg : Credential -> Delegatee -> integer -> TxCert - TxCertRegStaking : Credential -> Maybe integer -> TxCert - TxCertResignColdCommittee : Credential -> TxCert - TxCertUnRegDRep : Credential -> integer -> TxCert - TxCertUnRegStaking : Credential -> Maybe integer -> TxCert - TxCertUpdateDRep : Credential -> TxCert - data TxOutRef | TxOutRef_match where - TxOutRef : bytestring -> integer -> TxOutRef - data Voter | Voter_match where - CommitteeVoter : Credential -> Voter - DRepVoter : Credential -> Voter - StakePoolVoter : bytestring -> Voter - data ScriptInfo | ScriptInfo_match where - CertifyingScript : integer -> TxCert -> ScriptInfo - MintingScript : bytestring -> ScriptInfo - ProposingScript : integer -> ProposalProcedure -> ScriptInfo - RewardingScript : Credential -> ScriptInfo - SpendingScript : TxOutRef -> Maybe data -> ScriptInfo - VotingScript : Voter -> ScriptInfo - data (LowerBound :: * -> *) a | LowerBound_match where - LowerBound : Extended a -> Bool -> LowerBound a - data (UpperBound :: * -> *) a | UpperBound_match where - UpperBound : Extended a -> Bool -> UpperBound a - data (Interval :: * -> *) a | Interval_match where - Interval : LowerBound a -> UpperBound a -> Interval a - in - letrec - !euclid : integer -> integer -> integer - = \(x : integer) (y : integer) -> - Bool_match - (ifThenElse {Bool} (equalsInteger 0 y) True False) - {all dead. integer} - (/\dead -> x) - (/\dead -> euclid y (modInteger x y)) - {all dead. dead} - in - letrec - !unsafeRatio : integer -> integer -> Rational - = \(n : integer) (d : integer) -> - Bool_match - (ifThenElse {Bool} (equalsInteger 0 d) True False) - {all dead. Rational} - (/\dead -> traceError {Rational} "PT3") - (/\dead -> - Bool_match - (ifThenElse {Bool} (lessThanInteger d 0) True False) - {all dead. Rational} - (/\dead -> - unsafeRatio (subtractInteger 0 n) (subtractInteger 0 d)) - (/\dead -> - let - !gcd' : integer = euclid n d - in - Rational (quotientInteger n gcd') (quotientInteger d gcd')) - {all dead. dead}) - {all dead. dead} - in - let - Vote = all a. a -> a - TxOut = all a. a -> a - TxInInfo = all a. a -> a - ScriptPurpose = all a. a -> a - data TxInfo | TxInfo_match where - TxInfo : - (\a -> list data) TxInInfo -> - (\a -> list data) TxInInfo -> - (\a -> list data) TxOut -> - integer -> - (\k a -> list (pair data data)) - bytestring - ((\k a -> list (pair data data)) bytestring integer) -> - (\a -> list data) TxCert -> - (\k a -> list (pair data data)) Credential integer -> - Interval integer -> - (\a -> list data) bytestring -> - (\k a -> list (pair data data)) ScriptPurpose data -> - (\k a -> list (pair data data)) bytestring data -> - bytestring -> - (\k a -> list (pair data data)) - Voter - ((\k a -> list (pair data data)) GovernanceActionId Vote) -> - (\a -> list data) ProposalProcedure -> - Maybe integer -> - Maybe integer -> - TxInfo - data ScriptContext | ScriptContext_match where - ScriptContext : TxInfo -> data -> ScriptInfo -> ScriptContext + data (Solo :: * -> *) a | Solo_match where + MkSolo : a -> Solo a + data Unit | Unit_match where + Unit : Unit in \(d : data) -> - ScriptContext_match - (let - !tup : pair integer (list data) = unConstrData d - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. ScriptContext} - (/\dead -> + Solo_match + {data} + ((let + r = Solo data + in + \(scrut : data) + (cont : data -> data -> data -> r) + (fail : unit -> r) -> let - !l : list data = tailList {data} args + !tup : pair integer (list data) = unConstrData scrut in - ScriptContext - (let - !tup : pair integer (list data) - = unConstrData (headList {data} args) - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. TxInfo} - (/\dead -> - let - !l : list data = tailList {data} args - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - in - TxInfo - (unListData (headList {data} args)) - (unListData (headList {data} l)) - (unListData (headList {data} l)) - (unIData (headList {data} l)) - (unMapData (headList {data} l)) - (unListData (headList {data} l)) - (unMapData (headList {data} l)) - (let - !tup : pair integer (list data) - = unConstrData (headList {data} l) - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. Interval integer} - (/\dead -> - Interval - {integer} - (let - !tup : pair integer (list data) - = unConstrData (headList {data} args) - !index : integer - = fstPair {integer} {list data} tup - !args : list data - = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger 0 index) - True - False) - {all dead. LowerBound integer} - (/\dead -> - LowerBound - {integer} - (`$fUnsafeFromDataExtended_$cunsafeFromBuiltinData` - {integer} - unIData - (headList {data} args)) - (`$fUnsafeFromDataBool_$cunsafeFromBuiltinData` - (headList {data} (tailList {data} args)))) - (/\dead -> traceError {LowerBound integer} "PT1") - {all dead. dead}) - (let - !tup : pair integer (list data) - = unConstrData - (headList {data} (tailList {data} args)) - !index : integer - = fstPair {integer} {list data} tup - !args : list data - = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger 0 index) - True - False) - {all dead. UpperBound integer} - (/\dead -> - UpperBound - {integer} - (`$fUnsafeFromDataExtended_$cunsafeFromBuiltinData` - {integer} - unIData - (headList {data} args)) - (`$fUnsafeFromDataBool_$cunsafeFromBuiltinData` - (headList {data} (tailList {data} args)))) - (/\dead -> traceError {UpperBound integer} "PT1") - {all dead. dead})) - (/\dead -> traceError {Interval integer} "PT1") - {all dead. dead}) - (unListData (headList {data} l)) - (unMapData (headList {data} l)) - (unMapData (headList {data} l)) - (unBData (headList {data} l)) - (unMapData (headList {data} l)) - (unListData (headList {data} l)) - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {integer} - unIData - (headList {data} l)) - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {integer} - unIData - (headList {data} (tailList {data} l)))) - (/\dead -> traceError {TxInfo} "PT1") - {all dead. dead}) - (headList {data} l) - (let - !tup : pair integer (list data) - = unConstrData (headList {data} (tailList {data} l)) - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. ScriptInfo} - (/\dead -> MintingScript (unBData (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 1 index) True False) - {all dead. ScriptInfo} - (/\dead -> - SpendingScript - (let - !tup : pair integer (list data) - = unConstrData (headList {data} args) - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger 0 index) - True - False) - {all dead. TxOutRef} - (/\dead -> - TxOutRef - (unBData (headList {data} args)) - (unIData - (headList {data} (tailList {data} args)))) - (/\dead -> traceError {TxOutRef} "PT1") - {all dead. dead}) - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {data} - (\(d : data) -> d) - (headList {data} (tailList {data} args)))) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 2 index) True False) - {all dead. ScriptInfo} - (/\dead -> - RewardingScript - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 3 index) - True - False) - {all dead. ScriptInfo} - (/\dead -> - CertifyingScript - (unIData (headList {data} args)) - (let - !tup : pair integer (list data) - = unConstrData - (headList - {data} - (tailList {data} args)) - !index : integer - = fstPair {integer} {list data} tup - !args : list data - = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger 0 index) - True - False) - {all dead. TxCert} - (/\dead -> - TxCertRegStaking - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList {data} args)) - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {integer} - unIData - (headList - {data} - (tailList {data} args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 1 index) - True - False) - {all dead. TxCert} - (/\dead -> - TxCertUnRegStaking - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList {data} args)) - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {integer} - unIData - (headList - {data} - (tailList {data} args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 2 index) - True - False) - {all dead. TxCert} - (/\dead -> - TxCertDelegStaking - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList {data} args)) - (`$fUnsafeFromDataDelegatee_$cunsafeFromBuiltinData` - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 3 index) - True - False) - {all dead. TxCert} - (/\dead -> - let - !l : list data - = tailList - {data} - args - in - TxCertRegDeleg - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList - {data} - args)) - (`$fUnsafeFromDataDelegatee_$cunsafeFromBuiltinData` - (headList {data} l)) - (unIData - (headList - {data} - (tailList - {data} - l)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 4 - index) - True - False) - {all dead. TxCert} - (/\dead -> - TxCertRegDRep - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList - {data} - args)) - (unIData - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 5 - index) - True - False) - {all dead. TxCert} - (/\dead -> - TxCertUpdateDRep - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList - {data} - args))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 6 - index) - True - False) - {all dead. - TxCert} - (/\dead -> - TxCertUnRegDRep - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList - {data} - args)) - (unIData - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 7 - index) - True - False) - {all dead. - TxCert} - (/\dead -> - TxCertPoolRegister - (unBData - (headList - {data} - args)) - (unBData - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 8 - index) - True - False) - {all dead. - TxCert} - (/\dead -> - TxCertPoolRetire - (unBData - (headList - {data} - args)) - (unIData - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 9 - index) - True - False) - {all dead. - TxCert} - (/\dead -> - TxCertAuthHotCommittee - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList - {data} - args)) - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 10 - index) - True - False) - {all dead. - TxCert} - (/\dead -> - TxCertResignColdCommittee - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList - {data} - args))) - (/\dead -> - traceError - {TxCert} - "PT1") - {all dead. - dead}) - {all dead. - dead}) - {all dead. - dead}) - {all dead. - dead}) - {all dead. - dead}) - {all dead. dead}) - {all dead. dead}) - {all dead. dead}) - {all dead. dead}) - {all dead. dead}) - {all dead. dead})) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 4 index) - True - False) - {all dead. ScriptInfo} - (/\dead -> - VotingScript - (let - !tup : pair integer (list data) - = unConstrData - (headList {data} args) - !index : integer - = fstPair {integer} {list data} tup - !args : list data - = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger 0 index) - True - False) - {all dead. Voter} - (/\dead -> - CommitteeVoter - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 1 index) - True - False) - {all dead. Voter} - (/\dead -> - DRepVoter - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 2 index) - True - False) - {all dead. Voter} - (/\dead -> - StakePoolVoter - (unBData - (headList - {data} - args))) - (/\dead -> - traceError {Voter} "PT1") - {all dead. dead}) - {all dead. dead}) - {all dead. dead})) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 5 index) - True - False) - {all dead. ScriptInfo} - (/\dead -> - ProposingScript - (unIData (headList {data} args)) - (let - !tup : pair integer (list data) - = unConstrData - (headList - {data} - (tailList {data} args)) - !index : integer - = fstPair - {integer} - {list data} - tup - !args : list data - = sndPair - {integer} - {list data} - tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger 0 index) - True - False) - {all dead. ProposalProcedure} - (/\dead -> - let - !l : list data - = tailList {data} args - in - ProposalProcedure - (unIData - (headList {data} args)) - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList {data} l)) - (let - !tup : - pair - integer - (list data) - = unConstrData - (headList - {data} - (tailList - {data} - l)) - !index : integer - = fstPair - {integer} - {list data} - tup - !args : list data - = sndPair - {integer} - {list data} - tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger 0 index) - True - False) - {all dead. - GovernanceAction} - (/\dead -> - let - !l : list data - = tailList - {data} - args - in - ParameterChange - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {GovernanceActionId} - `$fUnsafeFromDataGovernanceAction_$cunsafeFromBuiltinData` - (headList - {data} - args)) - (headList {data} l) - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {bytestring} - unBData - (headList - {data} - (tailList - {data} - l)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 1 - index) - True - False) - {all dead. - GovernanceAction} - (/\dead -> - HardForkInitiation - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {GovernanceActionId} - `$fUnsafeFromDataGovernanceAction_$cunsafeFromBuiltinData` - (headList - {data} - args)) - (let - !tup : - pair - integer - (list - data) - = unConstrData - (headList - {data} - (tailList - {data} - args)) - !index : - integer - = fstPair - {integer} - {list - data} - tup - !args : - list data - = sndPair - {integer} - {list - data} - tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 0 - index) - True - False) - {all dead. - ProtocolVersion} - (/\dead -> - ProtocolVersion - (unIData - (headList - {data} - args)) - (unIData - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - traceError - {ProtocolVersion} - "PT1") - {all dead. - dead})) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 2 - index) - True - False) - {all dead. - GovernanceAction} - (/\dead -> - TreasuryWithdrawals - (unMapData - (headList - {data} - args)) - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {bytestring} - unBData - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 3 - index) - True - False) - {all dead. - GovernanceAction} - (/\dead -> - NoConfidence - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {GovernanceActionId} - `$fUnsafeFromDataGovernanceAction_$cunsafeFromBuiltinData` - (headList - {data} - args))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 4 - index) - True - False) - {all dead. - GovernanceAction} - (/\dead -> - let - !l : - list - data - = tailList - {data} - args - !l : - list - data - = tailList - {data} - l - in - UpdateCommittee - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {GovernanceActionId} - `$fUnsafeFromDataGovernanceAction_$cunsafeFromBuiltinData` - (headList - {data} - args)) - (unListData - (headList - {data} - l)) - (unMapData - (headList - {data} - l)) - (let - !x : - data - = headList - {data} - (tailList - {data} - l) - in - Tuple2_match - {integer} - {integer} - (let - !tup : - pair - integer - (list - data) - = unConstrData - x - !index : - integer - = fstPair - {integer} - {list - data} - tup - !args : - list - data - = sndPair - {integer} - {list - data} - tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 0 - index) - True - False) - {all dead. - Tuple2 - integer - integer} - (/\dead -> - Tuple2 - {integer} - {integer} - (unIData - (headList - {data} - args)) - (unIData - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - traceError - {Tuple2 - integer - integer} - "PT1") - {all dead. - dead}) - {Rational} - (\(a : - integer) - (b : - integer) -> - unsafeRatio - a - b))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 5 - index) - True - False) - {all dead. - GovernanceAction} - (/\dead -> - NewConstitution - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {GovernanceActionId} - `$fUnsafeFromDataGovernanceAction_$cunsafeFromBuiltinData` - (headList - {data} - args)) - (let - !tup : - pair - integer - (list - data) - = unConstrData - (headList - {data} - (tailList - {data} - args)) - !index : - integer - = fstPair - {integer} - {list - data} - tup - !args : - list - data - = sndPair - {integer} - {list - data} - tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 0 - index) - True - False) - {all dead. - Maybe - bytestring} - (/\dead -> - `$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {bytestring} - unBData - (headList - {data} - args)) - (/\dead -> - traceError - {Maybe - bytestring} - "PT1") - {all dead. - dead})) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 6 - index) - True - False) - {all dead. - GovernanceAction} - (/\dead -> - InfoAction) - (/\dead -> - traceError - {GovernanceAction} - "PT1") - {all dead. - dead}) - {all dead. - dead}) - {all dead. - dead}) - {all dead. - dead}) - {all dead. - dead}) - {all dead. dead}) - {all dead. dead})) - (/\dead -> - traceError - {ProposalProcedure} - "PT1") - {all dead. dead})) - (/\dead -> - traceError {ScriptInfo} "PT1") - {all dead. dead}) - {all dead. dead}) - {all dead. dead}) - {all dead. dead}) - {all dead. dead}) - {all dead. dead})) - (/\dead -> traceError {ScriptContext} "PT1") - {all dead. dead}) + Bool_match + (ifThenElse + {Bool} + (equalsInteger 0 (fstPair {integer} {list data} tup)) + True + False) + {all dead. r} + (/\dead -> + let + !l : list data = sndPair {integer} {list data} tup + !l : list data = tailList {data} l + in + cont + (headList {data} l) + (headList {data} l) + (headList {data} (tailList {data} l))) + (/\dead -> fail ()) + {all dead. dead}) + d + (\(txi : data) (ds : data) (ds : data) -> MkSolo {data} txi) + (\(void : unit) -> + Unit_match (error {Unit}) {Solo data} (error {Solo data}))) {Unit} - (\(ipv : TxInfo) (ipv : data) (ipv : ScriptInfo) -> + (\(ipv : data) -> Bool_match (ifThenElse {Bool} @@ -1303,13 +92,100 @@ 0 (modInteger (let - !ds : (\a -> list data) TxOut - = TxInfo_match + !ds : + (\a -> list data) data + = (let + r = (\a -> list data) data + in + \(scrut : data) + (cont : + (\a -> list data) data -> + (\a -> list data) data -> + (\a -> list data) data -> + integer -> + (\k a -> list (pair data data)) + bytestring + ((\k a -> list (pair data data)) + bytestring + integer) -> + (\a -> list data) data -> + (\k a -> list (pair data data)) data integer -> + (\a -> data) integer -> + (\a -> list data) bytestring -> + (\k a -> list (pair data data)) data data -> + (\k a -> list (pair data data)) + bytestring + data -> + bytestring -> + (\k a -> list (pair data data)) + data + ((\k a -> list (pair data data)) data data) -> + (\a -> list data) data -> + Maybe integer -> + Maybe integer -> + r) + (fail : unit -> r) -> + let + !tup : pair integer (list data) + = unConstrData scrut + in + Bool_match + (ifThenElse + {Bool} + (equalsInteger + 0 + (fstPair {integer} {list data} tup)) + True + False) + {all dead. r} + (/\dead -> + let + !l : list data + = sndPair {integer} {list data} tup + !l : list data = tailList {data} l + !l : list data = tailList {data} l + !l : list data = tailList {data} l + !l : list data = tailList {data} l + !l : list data = tailList {data} l + !l : list data = tailList {data} l + !l : list data = tailList {data} l + !l : list data = tailList {data} l + !l : list data = tailList {data} l + !l : list data = tailList {data} l + !l : list data = tailList {data} l + !l : list data = tailList {data} l + !l : list data = tailList {data} l + !l : list data = tailList {data} l + in + cont + (unListData (headList {data} l)) + (unListData (headList {data} l)) + (unListData (headList {data} l)) + (unIData (headList {data} l)) + (unMapData (headList {data} l)) + (unListData (headList {data} l)) + (unMapData (headList {data} l)) + (headList {data} l) + (unListData (headList {data} l)) + (unMapData (headList {data} l)) + (unMapData (headList {data} l)) + (unBData (headList {data} l)) + (unMapData (headList {data} l)) + (unListData (headList {data} l)) + (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` + {integer} + unIData + (headList {data} l)) + (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` + {integer} + unIData + (headList {data} (tailList {data} l)))) + (/\dead -> fail ()) + {all dead. dead}) ipv - {(\a -> list data) TxOut} - (\(ds : (\a -> list data) TxInInfo) - (ds : (\a -> list data) TxInInfo) - (ds : (\a -> list data) TxOut) + (\(ds : (\a -> list data) data) + (ds : (\a -> list data) data) + (ds : (\a -> list data) data) (ds : integer) (ds : (\k a -> list (pair data data)) @@ -1317,17 +193,12 @@ ((\k a -> list (pair data data)) bytestring integer)) - (ds : (\a -> list data) TxCert) + (ds : (\a -> list data) data) (ds : - (\k a -> list (pair data data)) - Credential - integer) - (ds : Interval integer) + (\k a -> list (pair data data)) data integer) + (ds : (\a -> data) integer) (ds : (\a -> list data) bytestring) - (ds : - (\k a -> list (pair data data)) - ScriptPurpose - data) + (ds : (\k a -> list (pair data data)) data data) (ds : (\k a -> list (pair data data)) bytestring @@ -1335,14 +206,13 @@ (ds : bytestring) (ds : (\k a -> list (pair data data)) - Voter - ((\k a -> list (pair data data)) - GovernanceActionId - Vote)) - (ds : (\a -> list data) ProposalProcedure) + data + ((\k a -> list (pair data data)) data data)) + (ds : (\a -> list data) data) (ds : Maybe integer) (ds : Maybe integer) -> ds) + (\(void : unit) -> error {(\a -> list data) data}) in go ds 0) 2)) diff --git a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext1.size.golden b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext1.size.golden index 05cfb717b9b..7d4983b9898 100644 --- a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext1.size.golden +++ b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext1.size.golden @@ -1 +1 @@ -2385 \ No newline at end of file +458 \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext2-20.budget.golden b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext2-20.budget.golden index 34fe369a997..a0079bcaedc 100644 --- a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext2-20.budget.golden +++ b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext2-20.budget.golden @@ -1,2 +1,2 @@ -({cpu: 25806429 -| mem: 94094}) \ No newline at end of file +({cpu: 64100 +| mem: 500}) \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext2-4.budget.golden b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext2-4.budget.golden index 34fe369a997..a0079bcaedc 100644 --- a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext2-4.budget.golden +++ b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext2-4.budget.golden @@ -1,2 +1,2 @@ -({cpu: 25806429 -| mem: 94094}) \ No newline at end of file +({cpu: 64100 +| mem: 500}) \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext2.pir.golden b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext2.pir.golden index 8060438d0bf..6bdcb3a1669 100644 --- a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext2.pir.golden +++ b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext2.pir.golden @@ -1,1314 +1,11 @@ (let - data GovernanceActionId | GovernanceActionId_match where - GovernanceActionId : bytestring -> integer -> GovernanceActionId + data Unit | Unit_match where + Unit : Unit data Bool | Bool_match where True : Bool False : Bool - data Unit | Unit_match where - Unit : Unit - !traceError : all a. string -> a - = /\a -> - \(str : string) -> let !x : Unit = trace {Unit} str Unit in error {a} - !`$fUnsafeFromDataGovernanceAction_$cunsafeFromBuiltinData` : - data -> GovernanceActionId - = \(d : data) -> - let - !tup : pair integer (list data) = unConstrData d - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. GovernanceActionId} - (/\dead -> - GovernanceActionId - (unBData (headList {data} args)) - (unIData (headList {data} (tailList {data} args)))) - (/\dead -> traceError {GovernanceActionId} "PT1") - {all dead. dead} - data (Tuple2 :: * -> * -> *) a b | Tuple2_match where - Tuple2 : a -> b -> Tuple2 a b - data Credential | Credential_match where - PubKeyCredential : bytestring -> Credential - ScriptCredential : bytestring -> Credential - !`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` : data -> Credential - = \(d : data) -> - let - !tup : pair integer (list data) = unConstrData d - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. Credential} - (/\dead -> PubKeyCredential (unBData (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 1 index) True False) - {all dead. Credential} - (/\dead -> ScriptCredential (unBData (headList {data} args))) - (/\dead -> traceError {Credential} "PT1") - {all dead. dead}) - {all dead. dead} - data DRep | DRep_match where - DRep : Credential -> DRep - DRepAlwaysAbstain : DRep - DRepAlwaysNoConfidence : DRep - !`$fUnsafeFromDataDRep_$cunsafeFromBuiltinData` : data -> DRep - = \(d : data) -> - let - !tup : pair integer (list data) = unConstrData d - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. DRep} - (/\dead -> - DRep - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 1 index) True False) - {all dead. DRep} - (/\dead -> DRepAlwaysAbstain) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 2 index) True False) - {all dead. DRep} - (/\dead -> DRepAlwaysNoConfidence) - (/\dead -> traceError {DRep} "PT1") - {all dead. dead}) - {all dead. dead}) - {all dead. dead} - data Delegatee | Delegatee_match where - DelegStake : bytestring -> Delegatee - DelegStakeVote : bytestring -> DRep -> Delegatee - DelegVote : DRep -> Delegatee - !`$fUnsafeFromDataDelegatee_$cunsafeFromBuiltinData` : data -> Delegatee - = \(d : data) -> - let - !tup : pair integer (list data) = unConstrData d - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. Delegatee} - (/\dead -> DelegStake (unBData (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 1 index) True False) - {all dead. Delegatee} - (/\dead -> - DelegVote - (`$fUnsafeFromDataDRep_$cunsafeFromBuiltinData` - (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 2 index) True False) - {all dead. Delegatee} - (/\dead -> - DelegStakeVote - (unBData (headList {data} args)) - (`$fUnsafeFromDataDRep_$cunsafeFromBuiltinData` - (headList {data} (tailList {data} args)))) - (/\dead -> traceError {Delegatee} "PT1") - {all dead. dead}) - {all dead. dead}) - {all dead. dead} - !`$fUnsafeFromDataBool_$cunsafeFromBuiltinData` : data -> Bool - = \(d : data) -> - let - !tup : pair integer (list data) = unConstrData d - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. Bool} - (/\dead -> False) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 1 index) True False) - {all dead. Bool} - (/\dead -> True) - (/\dead -> traceError {Bool} "PT1") - {all dead. dead}) - {all dead. dead} - data (Extended :: * -> *) a | Extended_match where - Finite : a -> Extended a - NegInf : Extended a - PosInf : Extended a - !`$fUnsafeFromDataExtended_$cunsafeFromBuiltinData` : - all a. (\a -> data -> a) a -> data -> Extended a - = /\a -> - \(`$dUnsafeFromData` : (\a -> data -> a) a) (d : data) -> - let - !tup : pair integer (list data) = unConstrData d - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. Extended a} - (/\dead -> NegInf {a}) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 1 index) True False) - {all dead. Extended a} - (/\dead -> - Finite {a} (`$dUnsafeFromData` (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 2 index) True False) - {all dead. Extended a} - (/\dead -> PosInf {a}) - (/\dead -> traceError {Extended a} "PT1") - {all dead. dead}) - {all dead. dead}) - {all dead. dead} - data (Maybe :: * -> *) a | Maybe_match where - Just : a -> Maybe a - Nothing : Maybe a - !`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` : - all a. (\a -> data -> a) a -> data -> Maybe a - = /\a -> - \(`$dUnsafeFromData` : (\a -> data -> a) a) (d : data) -> - let - !tup : pair integer (list data) = unConstrData d - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 1 index) True False) - {all dead. Maybe a} - (/\dead -> Nothing {a}) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. Maybe a} - (/\dead -> - Just {a} (`$dUnsafeFromData` (headList {data} args))) - (/\dead -> traceError {Maybe a} "PT1") - {all dead. dead}) - {all dead. dead} - data ProtocolVersion | ProtocolVersion_match where - ProtocolVersion : integer -> integer -> ProtocolVersion - data Rational | Rational_match where - Rational : integer -> integer -> Rational - data GovernanceAction | GovernanceAction_match where - HardForkInitiation : - Maybe GovernanceActionId -> ProtocolVersion -> GovernanceAction - InfoAction : GovernanceAction - NewConstitution : - Maybe GovernanceActionId -> Maybe bytestring -> GovernanceAction - NoConfidence : Maybe GovernanceActionId -> GovernanceAction - ParameterChange : - Maybe GovernanceActionId -> data -> Maybe bytestring -> GovernanceAction - TreasuryWithdrawals : - (\k a -> list (pair data data)) Credential integer -> - Maybe bytestring -> - GovernanceAction - UpdateCommittee : - Maybe GovernanceActionId -> - (\a -> list data) Credential -> - (\k a -> list (pair data data)) Credential integer -> - Rational -> - GovernanceAction - data ProposalProcedure | ProposalProcedure_match where - ProposalProcedure : - integer -> Credential -> GovernanceAction -> ProposalProcedure - data TxCert | TxCert_match where - TxCertAuthHotCommittee : Credential -> Credential -> TxCert - TxCertDelegStaking : Credential -> Delegatee -> TxCert - TxCertPoolRegister : bytestring -> bytestring -> TxCert - TxCertPoolRetire : bytestring -> integer -> TxCert - TxCertRegDRep : Credential -> integer -> TxCert - TxCertRegDeleg : Credential -> Delegatee -> integer -> TxCert - TxCertRegStaking : Credential -> Maybe integer -> TxCert - TxCertResignColdCommittee : Credential -> TxCert - TxCertUnRegDRep : Credential -> integer -> TxCert - TxCertUnRegStaking : Credential -> Maybe integer -> TxCert - TxCertUpdateDRep : Credential -> TxCert - data TxOutRef | TxOutRef_match where - TxOutRef : bytestring -> integer -> TxOutRef - data Voter | Voter_match where - CommitteeVoter : Credential -> Voter - DRepVoter : Credential -> Voter - StakePoolVoter : bytestring -> Voter - data ScriptInfo | ScriptInfo_match where - CertifyingScript : integer -> TxCert -> ScriptInfo - MintingScript : bytestring -> ScriptInfo - ProposingScript : integer -> ProposalProcedure -> ScriptInfo - RewardingScript : Credential -> ScriptInfo - SpendingScript : TxOutRef -> Maybe data -> ScriptInfo - VotingScript : Voter -> ScriptInfo - data (LowerBound :: * -> *) a | LowerBound_match where - LowerBound : Extended a -> Bool -> LowerBound a - data (UpperBound :: * -> *) a | UpperBound_match where - UpperBound : Extended a -> Bool -> UpperBound a - data (Interval :: * -> *) a | Interval_match where - Interval : LowerBound a -> UpperBound a -> Interval a - in - letrec - !euclid : integer -> integer -> integer - = \(x : integer) (y : integer) -> - Bool_match - (ifThenElse {Bool} (equalsInteger 0 y) True False) - {all dead. integer} - (/\dead -> x) - (/\dead -> euclid y (modInteger x y)) - {all dead. dead} - in - letrec - !unsafeRatio : integer -> integer -> Rational - = \(n : integer) (d : integer) -> - Bool_match - (ifThenElse {Bool} (equalsInteger 0 d) True False) - {all dead. Rational} - (/\dead -> traceError {Rational} "PT3") - (/\dead -> - Bool_match - (ifThenElse {Bool} (lessThanInteger d 0) True False) - {all dead. Rational} - (/\dead -> - unsafeRatio (subtractInteger 0 n) (subtractInteger 0 d)) - (/\dead -> - let - !gcd' : integer = euclid n d - in - Rational (quotientInteger n gcd') (quotientInteger d gcd')) - {all dead. dead}) - {all dead. dead} - in - let - Vote = all a. a -> a - TxOut = all a. a -> a - TxInInfo = all a. a -> a - ScriptPurpose = all a. a -> a - data TxInfo | TxInfo_match where - TxInfo : - (\a -> list data) TxInInfo -> - (\a -> list data) TxInInfo -> - (\a -> list data) TxOut -> - integer -> - (\k a -> list (pair data data)) - bytestring - ((\k a -> list (pair data data)) bytestring integer) -> - (\a -> list data) TxCert -> - (\k a -> list (pair data data)) Credential integer -> - Interval integer -> - (\a -> list data) bytestring -> - (\k a -> list (pair data data)) ScriptPurpose data -> - (\k a -> list (pair data data)) bytestring data -> - bytestring -> - (\k a -> list (pair data data)) - Voter - ((\k a -> list (pair data data)) GovernanceActionId Vote) -> - (\a -> list data) ProposalProcedure -> - Maybe integer -> - Maybe integer -> - TxInfo - data ScriptContext | ScriptContext_match where - ScriptContext : TxInfo -> data -> ScriptInfo -> ScriptContext in - \(d : data) -> - let - !ds : - ScriptContext - = let - !tup : pair integer (list data) = unConstrData d - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. ScriptContext} - (/\dead -> - let - !l : list data = tailList {data} args - in - ScriptContext - (let - !tup : pair integer (list data) - = unConstrData (headList {data} args) - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. TxInfo} - (/\dead -> - let - !l : list data = tailList {data} args - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - !l : list data = tailList {data} l - in - TxInfo - (unListData (headList {data} args)) - (unListData (headList {data} l)) - (unListData (headList {data} l)) - (unIData (headList {data} l)) - (unMapData (headList {data} l)) - (unListData (headList {data} l)) - (unMapData (headList {data} l)) - (let - !tup : pair integer (list data) - = unConstrData (headList {data} l) - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. Interval integer} - (/\dead -> - Interval - {integer} - (let - !tup : pair integer (list data) - = unConstrData (headList {data} args) - !index : integer - = fstPair {integer} {list data} tup - !args : list data - = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger 0 index) - True - False) - {all dead. LowerBound integer} - (/\dead -> - LowerBound - {integer} - (`$fUnsafeFromDataExtended_$cunsafeFromBuiltinData` - {integer} - unIData - (headList {data} args)) - (`$fUnsafeFromDataBool_$cunsafeFromBuiltinData` - (headList - {data} - (tailList {data} args)))) - (/\dead -> traceError {LowerBound integer} "PT1") - {all dead. dead}) - (let - !tup : pair integer (list data) - = unConstrData - (headList {data} (tailList {data} args)) - !index : integer - = fstPair {integer} {list data} tup - !args : list data - = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger 0 index) - True - False) - {all dead. UpperBound integer} - (/\dead -> - UpperBound - {integer} - (`$fUnsafeFromDataExtended_$cunsafeFromBuiltinData` - {integer} - unIData - (headList {data} args)) - (`$fUnsafeFromDataBool_$cunsafeFromBuiltinData` - (headList - {data} - (tailList {data} args)))) - (/\dead -> traceError {UpperBound integer} "PT1") - {all dead. dead})) - (/\dead -> traceError {Interval integer} "PT1") - {all dead. dead}) - (unListData (headList {data} l)) - (unMapData (headList {data} l)) - (unMapData (headList {data} l)) - (unBData (headList {data} l)) - (unMapData (headList {data} l)) - (unListData (headList {data} l)) - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {integer} - unIData - (headList {data} l)) - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {integer} - unIData - (headList {data} (tailList {data} l)))) - (/\dead -> traceError {TxInfo} "PT1") - {all dead. dead}) - (headList {data} l) - (let - !tup : pair integer (list data) - = unConstrData (headList {data} (tailList {data} l)) - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse {Bool} (equalsInteger 0 index) True False) - {all dead. ScriptInfo} - (/\dead -> MintingScript (unBData (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse {Bool} (equalsInteger 1 index) True False) - {all dead. ScriptInfo} - (/\dead -> - SpendingScript - (let - !tup : pair integer (list data) - = unConstrData (headList {data} args) - !index : integer - = fstPair {integer} {list data} tup - !args : list data - = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger 0 index) - True - False) - {all dead. TxOutRef} - (/\dead -> - TxOutRef - (unBData (headList {data} args)) - (unIData - (headList {data} (tailList {data} args)))) - (/\dead -> traceError {TxOutRef} "PT1") - {all dead. dead}) - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {data} - (\(d : data) -> d) - (headList {data} (tailList {data} args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 2 index) - True - False) - {all dead. ScriptInfo} - (/\dead -> - RewardingScript - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 3 index) - True - False) - {all dead. ScriptInfo} - (/\dead -> - CertifyingScript - (unIData (headList {data} args)) - (let - !tup : pair integer (list data) - = unConstrData - (headList - {data} - (tailList {data} args)) - !index : integer - = fstPair {integer} {list data} tup - !args : list data - = sndPair {integer} {list data} tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger 0 index) - True - False) - {all dead. TxCert} - (/\dead -> - TxCertRegStaking - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList {data} args)) - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {integer} - unIData - (headList - {data} - (tailList {data} args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 1 index) - True - False) - {all dead. TxCert} - (/\dead -> - TxCertUnRegStaking - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList {data} args)) - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {integer} - unIData - (headList - {data} - (tailList {data} args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 2 index) - True - False) - {all dead. TxCert} - (/\dead -> - TxCertDelegStaking - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList {data} args)) - (`$fUnsafeFromDataDelegatee_$cunsafeFromBuiltinData` - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 3 index) - True - False) - {all dead. TxCert} - (/\dead -> - let - !l : list data - = tailList - {data} - args - in - TxCertRegDeleg - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList - {data} - args)) - (`$fUnsafeFromDataDelegatee_$cunsafeFromBuiltinData` - (headList - {data} - l)) - (unIData - (headList - {data} - (tailList - {data} - l)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 4 - index) - True - False) - {all dead. TxCert} - (/\dead -> - TxCertRegDRep - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList - {data} - args)) - (unIData - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 5 - index) - True - False) - {all dead. - TxCert} - (/\dead -> - TxCertUpdateDRep - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList - {data} - args))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 6 - index) - True - False) - {all dead. - TxCert} - (/\dead -> - TxCertUnRegDRep - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList - {data} - args)) - (unIData - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 7 - index) - True - False) - {all dead. - TxCert} - (/\dead -> - TxCertPoolRegister - (unBData - (headList - {data} - args)) - (unBData - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 8 - index) - True - False) - {all dead. - TxCert} - (/\dead -> - TxCertPoolRetire - (unBData - (headList - {data} - args)) - (unIData - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 9 - index) - True - False) - {all dead. - TxCert} - (/\dead -> - TxCertAuthHotCommittee - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList - {data} - args)) - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 10 - index) - True - False) - {all dead. - TxCert} - (/\dead -> - TxCertResignColdCommittee - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList - {data} - args))) - (/\dead -> - traceError - {TxCert} - "PT1") - {all dead. - dead}) - {all dead. - dead}) - {all dead. - dead}) - {all dead. - dead}) - {all dead. - dead}) - {all dead. - dead}) - {all dead. dead}) - {all dead. dead}) - {all dead. dead}) - {all dead. dead}) - {all dead. dead})) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 4 index) - True - False) - {all dead. ScriptInfo} - (/\dead -> - VotingScript - (let - !tup : pair integer (list data) - = unConstrData - (headList {data} args) - !index : integer - = fstPair - {integer} - {list data} - tup - !args : list data - = sndPair - {integer} - {list data} - tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger 0 index) - True - False) - {all dead. Voter} - (/\dead -> - CommitteeVoter - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList {data} args))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 1 index) - True - False) - {all dead. Voter} - (/\dead -> - DRepVoter - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList - {data} - args))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 2 index) - True - False) - {all dead. Voter} - (/\dead -> - StakePoolVoter - (unBData - (headList - {data} - args))) - (/\dead -> - traceError - {Voter} - "PT1") - {all dead. dead}) - {all dead. dead}) - {all dead. dead})) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger 5 index) - True - False) - {all dead. ScriptInfo} - (/\dead -> - ProposingScript - (unIData (headList {data} args)) - (let - !tup : pair integer (list data) - = unConstrData - (headList - {data} - (tailList - {data} - args)) - !index : integer - = fstPair - {integer} - {list data} - tup - !args : list data - = sndPair - {integer} - {list data} - tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger 0 index) - True - False) - {all dead. ProposalProcedure} - (/\dead -> - let - !l : list data - = tailList {data} args - in - ProposalProcedure - (unIData - (headList {data} args)) - (`$fUnsafeFromDataCredential_$cunsafeFromBuiltinData` - (headList {data} l)) - (let - !tup : - pair - integer - (list data) - = unConstrData - (headList - {data} - (tailList - {data} - l)) - !index : integer - = fstPair - {integer} - {list data} - tup - !args : list data - = sndPair - {integer} - {list data} - tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 0 - index) - True - False) - {all dead. - GovernanceAction} - (/\dead -> - let - !l : list data - = tailList - {data} - args - in - ParameterChange - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {GovernanceActionId} - `$fUnsafeFromDataGovernanceAction_$cunsafeFromBuiltinData` - (headList - {data} - args)) - (headList {data} l) - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {bytestring} - unBData - (headList - {data} - (tailList - {data} - l)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 1 - index) - True - False) - {all dead. - GovernanceAction} - (/\dead -> - HardForkInitiation - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {GovernanceActionId} - `$fUnsafeFromDataGovernanceAction_$cunsafeFromBuiltinData` - (headList - {data} - args)) - (let - !tup : - pair - integer - (list - data) - = unConstrData - (headList - {data} - (tailList - {data} - args)) - !index : - integer - = fstPair - {integer} - {list - data} - tup - !args : - list data - = sndPair - {integer} - {list - data} - tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 0 - index) - True - False) - {all dead. - ProtocolVersion} - (/\dead -> - ProtocolVersion - (unIData - (headList - {data} - args)) - (unIData - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - traceError - {ProtocolVersion} - "PT1") - {all dead. - dead})) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 2 - index) - True - False) - {all dead. - GovernanceAction} - (/\dead -> - TreasuryWithdrawals - (unMapData - (headList - {data} - args)) - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {bytestring} - unBData - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 3 - index) - True - False) - {all dead. - GovernanceAction} - (/\dead -> - NoConfidence - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {GovernanceActionId} - `$fUnsafeFromDataGovernanceAction_$cunsafeFromBuiltinData` - (headList - {data} - args))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 4 - index) - True - False) - {all dead. - GovernanceAction} - (/\dead -> - let - !l : - list - data - = tailList - {data} - args - !l : - list - data - = tailList - {data} - l - in - UpdateCommittee - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {GovernanceActionId} - `$fUnsafeFromDataGovernanceAction_$cunsafeFromBuiltinData` - (headList - {data} - args)) - (unListData - (headList - {data} - l)) - (unMapData - (headList - {data} - l)) - (let - !x : - data - = headList - {data} - (tailList - {data} - l) - in - Tuple2_match - {integer} - {integer} - (let - !tup : - pair - integer - (list - data) - = unConstrData - x - !index : - integer - = fstPair - {integer} - {list - data} - tup - !args : - list - data - = sndPair - {integer} - {list - data} - tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 0 - index) - True - False) - {all dead. - Tuple2 - integer - integer} - (/\dead -> - Tuple2 - {integer} - {integer} - (unIData - (headList - {data} - args)) - (unIData - (headList - {data} - (tailList - {data} - args)))) - (/\dead -> - traceError - {Tuple2 - integer - integer} - "PT1") - {all dead. - dead}) - {Rational} - (\(a : - integer) - (b : - integer) -> - unsafeRatio - a - b))) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 5 - index) - True - False) - {all dead. - GovernanceAction} - (/\dead -> - NewConstitution - (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {GovernanceActionId} - `$fUnsafeFromDataGovernanceAction_$cunsafeFromBuiltinData` - (headList - {data} - args)) - (let - !tup : - pair - integer - (list - data) - = unConstrData - (headList - {data} - (tailList - {data} - args)) - !index : - integer - = fstPair - {integer} - {list - data} - tup - !args : - list - data - = sndPair - {integer} - {list - data} - tup - in - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 0 - index) - True - False) - {all dead. - Maybe - bytestring} - (/\dead -> - `$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` - {bytestring} - unBData - (headList - {data} - args)) - (/\dead -> - traceError - {Maybe - bytestring} - "PT1") - {all dead. - dead})) - (/\dead -> - Bool_match - (ifThenElse - {Bool} - (equalsInteger - 6 - index) - True - False) - {all dead. - GovernanceAction} - (/\dead -> - InfoAction) - (/\dead -> - traceError - {GovernanceAction} - "PT1") - {all dead. - dead}) - {all dead. - dead}) - {all dead. - dead}) - {all dead. - dead}) - {all dead. - dead}) - {all dead. dead}) - {all dead. dead})) - (/\dead -> - traceError - {ProposalProcedure} - "PT1") - {all dead. dead})) - (/\dead -> - traceError {ScriptInfo} "PT1") - {all dead. dead}) - {all dead. dead}) - {all dead. dead}) - {all dead. dead}) - {all dead. dead}) - {all dead. dead})) - (/\dead -> traceError {ScriptContext} "PT1") - {all dead. dead} - in - Unit) + \(d : data) -> Unit) (Constr 0 [ Constr 0 [ List [] diff --git a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext2.size.golden b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext2.size.golden index cf04c8c6daa..bf0d87ab1b2 100644 --- a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext2.size.golden +++ b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContext2.size.golden @@ -1 +1 @@ -2285 \ No newline at end of file +4 \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContextEqualityData-20.budget.golden b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContextEqualityData-20.budget.golden index 3cedc2457c8..8db993b6233 100644 --- a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContextEqualityData-20.budget.golden +++ b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContextEqualityData-20.budget.golden @@ -1,2 +1,2 @@ -({cpu: 37218332 -| mem: 28002}) \ No newline at end of file +({cpu: 33106332 +| mem: 2302}) \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContextEqualityOverhead-20.budget.golden b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContextEqualityOverhead-20.budget.golden index d6a220283f2..5538712881b 100644 --- a/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContextEqualityOverhead-20.budget.golden +++ b/plutus-benchmark/script-contexts/test/Data/9.6/checkScriptContextEqualityOverhead-20.budget.golden @@ -1,2 +1,2 @@ -({cpu: 4224100 -| mem: 26500}) \ No newline at end of file +({cpu: 112100 +| mem: 800}) \ No newline at end of file diff --git a/plutus-ledger-api/changelog.d/20241212_191319_ana.pantilie95_fully_data_backed_sc.md b/plutus-ledger-api/changelog.d/20241212_191319_ana.pantilie95_fully_data_backed_sc.md new file mode 100644 index 00000000000..8abfa4bb1ea --- /dev/null +++ b/plutus-ledger-api/changelog.d/20241212_191319_ana.pantilie95_fully_data_backed_sc.md @@ -0,0 +1,8 @@ +### Added + +- New data-backed versions of multiple types in the ledger-api. These can be found in the `.../Data/` directories. + +### Changed + +- The `ScriptContext` type from `PlutusLedgerApi.Data.V3` is now fully data-backed. +- All types contained in the data-backed version of the `ScriptContext` are also now data-backed, except `Maybe` and `Bool`. diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal index a6271509f7c..5c320bf26d3 100644 --- a/plutus-ledger-api/plutus-ledger-api.cabal +++ b/plutus-ledger-api/plutus-ledger-api.cabal @@ -67,7 +67,11 @@ library PlutusLedgerApi.V1.Contexts PlutusLedgerApi.V1.Credential PlutusLedgerApi.V1.Crypto + PlutusLedgerApi.V1.Data.Address PlutusLedgerApi.V1.Data.Contexts + PlutusLedgerApi.V1.Data.Credential + PlutusLedgerApi.V1.Data.Interval + PlutusLedgerApi.V1.Data.Time PlutusLedgerApi.V1.Data.Tx PlutusLedgerApi.V1.Data.Value PlutusLedgerApi.V1.DCert @@ -88,6 +92,7 @@ library PlutusLedgerApi.V3 PlutusLedgerApi.V3.Contexts PlutusLedgerApi.V3.Data.Contexts + PlutusLedgerApi.V3.Data.Tx PlutusLedgerApi.V3.EvaluationContext PlutusLedgerApi.V3.MintValue PlutusLedgerApi.V3.ParamName @@ -162,7 +167,6 @@ test-suite plutus-ledger-api-test Spec.CBOR.DeserialiseFailureInfo Spec.ContextDecoding Spec.CostModelParams - Spec.Data.ContextDecoding Spec.Data.CostModelParams Spec.Data.Eval Spec.Data.Versions diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Data/V1.hs b/plutus-ledger-api/src/PlutusLedgerApi/Data/V1.hs index 655c5289922..72fc669e20e 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Data/V1.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Data/V1.hs @@ -1,4 +1,4 @@ --- editorconfig-checker-disable-file +{-# LANGUAGE PatternSynonyms #-} -- | The interface to Plutus V1 for the ledger. module PlutusLedgerApi.Data.V1 ( @@ -57,8 +57,12 @@ module PlutusLedgerApi.Data.V1 ( DCert (..), -- *** Credentials - StakingCredential (..), - Credential (..), + StakingCredential, + pattern StakingHash, + pattern StakingPtr, + Credential, + pattern PubKeyCredential, + pattern ScriptCredential, -- *** Value Value (..), @@ -75,7 +79,10 @@ module PlutusLedgerApi.Data.V1 ( POSIXTimeRange, -- *** Types for representing transactions - Address (..), + Address, + pattern Address, + addressCredential, + addressStakingCredential, PubKeyHash (..), TxId (..), TxInfo (..), @@ -84,11 +91,19 @@ module PlutusLedgerApi.Data.V1 ( TxInInfo (..), -- *** Intervals - Interval (..), - Extended (..), + Interval, + pattern Interval, + ivFrom, + ivTo, + Extended, + pattern NegInf, + pattern PosInf, + pattern Finite, Closure, - UpperBound (..), - LowerBound (..), + UpperBound, + pattern UpperBound, + LowerBound, + pattern LowerBound, always, from, to, @@ -127,93 +142,95 @@ import PlutusLedgerApi.Common as Common hiding (deserialiseScript, evaluateScrip evaluateScriptRestricting) import PlutusLedgerApi.Common qualified as Common (deserialiseScript, evaluateScriptCounting, evaluateScriptRestricting) -import PlutusLedgerApi.V1.Address import PlutusLedgerApi.V1.Bytes -import PlutusLedgerApi.V1.Credential import PlutusLedgerApi.V1.Crypto +import PlutusLedgerApi.V1.Data.Address import PlutusLedgerApi.V1.Data.Contexts +import PlutusLedgerApi.V1.Data.Credential +import PlutusLedgerApi.V1.Data.Interval hiding (singleton) +import PlutusLedgerApi.V1.Data.Time import PlutusLedgerApi.V1.Data.Value import PlutusLedgerApi.V1.DCert import PlutusLedgerApi.V1.EvaluationContext -import PlutusLedgerApi.V1.Interval hiding (singleton) import PlutusLedgerApi.V1.ParamName import PlutusLedgerApi.V1.Scripts as Scripts -import PlutusLedgerApi.V1.Time -{- | An alias to the Plutus ledger language this module exposes at runtime. +{-| An alias to the Plutus ledger language this module exposes at runtime. MAYBE: Use CPP '__FILE__' + some TH to automate this. -} thisLedgerLanguage :: PlutusLedgerLanguage thisLedgerLanguage = PlutusV1 {- Note [Abstract types in the ledger API] -We need to support old versions of the ledger API as we update the code that it depends on. You -might think that we should therefore make the types that we expose abstract, and only expose -specific functions for constructing and working with them. However the situation is slightly -different for us. - -Normally, when you are in this situation, you want to retain the same *interface* as the old version, -but with the new types and functions underneath. Abstraction lets you do this easily. But we actually -want to keep the old *implementation*, because things really have to work the same, bug-for-bug. And -the types have to translate into Plutus Core in exactly the same way, and so on. - -So we're going to end up with multiple versions of the types and functions that we expose here, even -internally. That means we don't lose anything by exposing all the details: we're never going to remove -anything, we're just going to create new versions. +We need to support old versions of the ledger API as we update the code that +it depends on. You might think that we should therefore make the types that +we expose abstract, and only expose specific functions for constructing and +working with them. However the situation is slightly different for us. + +Normally, when you are in this situation, you want to retain the same *interface* +as the old version, but with the new types and functions underneath. Abstraction +lets you do this easily. But we actually want to keep the old *implementation*, +because things really have to work the same, bug-for-bug. And the types have to +translate into Plutus Core in exactly the same way, and so on. + +So we're going to end up with multiple versions of the types and functions that +we expose here, even internally. That means we don't lose anything by exposing +all the details: we're never going to remove anything, we're just going to create +new versions. -} -{- | The deserialization from a serialised script into a `ScriptForEvaluation`, +{-| The deserialization from a serialised script into a `ScriptForEvaluation`, ready to be evaluated on-chain. Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). -} -deserialiseScript :: - forall m. - (MonadError ScriptDecodeError m) => - -- | which major protocol version the script was submitted in. - MajorProtocolVersion -> - -- | the script to deserialise. - SerialisedScript -> - m ScriptForEvaluation +deserialiseScript + :: forall m + . (MonadError ScriptDecodeError m) + => MajorProtocolVersion + -- ^ which major protocol version the script was submitted in. + -> SerialisedScript + -- ^ the script to deserialise. + -> m ScriptForEvaluation deserialiseScript = Common.deserialiseScript thisLedgerLanguage -{- | Evaluates a script, returning the minimum budget that the script would need +{-| Evaluates a script, returning the minimum budget that the script would need to evaluate successfully. lalaThis will take as long as the script takes, if you need to limit the execution time of the script also, you can use 'evaluateScriptRestricting', which also returns the used budget. -} -evaluateScriptCounting :: - -- | Which major protocol version to run the operation in - MajorProtocolVersion -> - -- | Whether to produce log output - VerboseMode -> - -- | Includes the cost model to use for tallying up the execution costs - EvaluationContext -> - -- | The script to evaluate - ScriptForEvaluation -> - -- | The arguments to the script - [PLC.Data] -> - (LogOutput, Either EvaluationError ExBudget) +evaluateScriptCounting + :: MajorProtocolVersion + -- ^ Which major protocol version to run the operation in + -> VerboseMode + -- ^ Whether to produce log output + -> EvaluationContext + -- ^ Includes the cost model to use for tallying up the execution costs + -> ScriptForEvaluation + -- ^ The script to evaluate + -> [PLC.Data] + -- ^ The arguments to the script + -> (LogOutput, Either EvaluationError ExBudget) evaluateScriptCounting = Common.evaluateScriptCounting thisLedgerLanguage -{- | Evaluates a script, with a cost model and a budget that restricts how many +{-| Evaluates a script, with a cost model and a budget that restricts how many resources it can use according to the cost model. Also returns the budget that was actually used. Can be used to calculate budgets for scripts, but even in this case you must give a limit to guard against scripts that run for a long time or loop. -} -evaluateScriptRestricting :: - -- | Which major protocol version to run the operation in - MajorProtocolVersion -> - -- | Whether to produce log output - VerboseMode -> - -- | Includes the cost model to use for tallying up the execution costs - EvaluationContext -> - -- | The resource budget which must not be exceeded during evaluation - ExBudget -> - -- | The script to evaluate - ScriptForEvaluation -> - -- | The arguments to the script - [PLC.Data] -> - (LogOutput, Either EvaluationError ExBudget) +evaluateScriptRestricting + :: MajorProtocolVersion + -- ^ Which major protocol version to run the operation in + -> VerboseMode + -- ^ Whether to produce log output + -> EvaluationContext + -- ^ Includes the cost model to use for tallying up the execution costs + -> ExBudget + -- ^ The resource budget which must not be exceeded during evaluation + -> ScriptForEvaluation + -- ^ The script to evaluate + -> [PLC.Data] + -- ^ The arguments to the script + -> (LogOutput, Either EvaluationError ExBudget) evaluateScriptRestricting = Common.evaluateScriptRestricting thisLedgerLanguage diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Data/V2.hs b/plutus-ledger-api/src/PlutusLedgerApi/Data/V2.hs index 5e0bd2757b9..aacfd15b1c6 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Data/V2.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Data/V2.hs @@ -1,4 +1,4 @@ --- editorconfig-checker-disable-file +{-# LANGUAGE PatternSynonyms #-} -- | The interface to Plutus V2 for the ledger. module PlutusLedgerApi.Data.V2 ( @@ -59,8 +59,12 @@ module PlutusLedgerApi.Data.V2 ( V1.DCert (..), -- *** Credentials - V1.StakingCredential (..), - V1.Credential (..), + V1.StakingCredential, + pattern V1.StakingHash, + pattern V1.StakingPtr, + V1.Credential, + pattern V1.PubKeyCredential, + pattern V1.ScriptCredential, -- *** Value V1.Value (..), @@ -77,21 +81,40 @@ module PlutusLedgerApi.Data.V2 ( V1.POSIXTimeRange, -- *** Types for representing transactions - V1.Address (..), + V1.Address, + pattern V1.Address, + V1.addressCredential, + V1.addressStakingCredential, V1.PubKeyHash (..), Tx.TxId (..), Contexts.TxInfo (..), - Tx.TxOut (..), + Tx.TxOut, + pattern Tx.TxOut, + Tx.txOutAddress, + Tx.txOutValue, + Tx.txOutDatum, + Tx.txOutReferenceScript, Tx.TxOutRef (..), Contexts.TxInInfo (..), - Tx.OutputDatum (..), + Tx.OutputDatum, + pattern Tx.NoOutputDatum, + pattern Tx.OutputDatum, + pattern Tx.OutputDatumHash, -- *** Intervals - V1.Interval (..), - V1.Extended (..), + V1.Interval, + pattern V1.Interval, + V1.ivFrom, + V1.ivTo, + V1.Extended, + pattern V1.NegInf, + pattern V1.PosInf, + pattern V1.Finite, V1.Closure, - V1.UpperBound (..), - V1.LowerBound (..), + V1.UpperBound, + pattern V1.UpperBound, + V1.LowerBound, + pattern V1.LowerBound, V1.always, V1.from, V1.to, @@ -138,64 +161,64 @@ import PlutusLedgerApi.V2.ParamName qualified as ParamName import PlutusTx.Data.AssocMap (Map, unsafeFromList) -{- | An alias to the Plutus ledger language this module exposes at runtime. +{-| An alias to the Plutus ledger language this module exposes at runtime. MAYBE: Use CPP '__FILE__' + some TH to automate this. -} thisLedgerLanguage :: Common.PlutusLedgerLanguage thisLedgerLanguage = Common.PlutusV2 -{- | The deserialization from a serialised script into a `ScriptForEvaluation`, +{-| The deserialization from a serialised script into a `ScriptForEvaluation`, ready to be evaluated on-chain. Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). -} -deserialiseScript :: - forall m. - (Common.MonadError Common.ScriptDecodeError m) => - -- | which major protocol version the script was submitted in. - Common.MajorProtocolVersion -> - -- | the script to deserialise. - Common.SerialisedScript -> - m Common.ScriptForEvaluation +deserialiseScript + :: forall m + . (Common.MonadError Common.ScriptDecodeError m) + => Common.MajorProtocolVersion + -- ^ which major protocol version the script was submitted in. + -> Common.SerialisedScript + -- ^ the script to deserialise. + -> m Common.ScriptForEvaluation deserialiseScript = Common.deserialiseScript thisLedgerLanguage -{- | Evaluates a script, returning the minimum budget that the script would need +{-| Evaluates a script, returning the minimum budget that the script would need to evaluate successfully. This will take as long as the script takes, if you need to limit the execution time of the script also, you can use 'evaluateScriptRestricting', which also returns the used budget. -} -evaluateScriptCounting :: - -- | Which major protocol version to run the operation in - Common.MajorProtocolVersion -> - -- | Whether to produce log output - Common.VerboseMode -> - -- | Includes the cost model to use for tallying up the execution costs - Common.EvaluationContext -> - -- | The script to evaluate - Common.ScriptForEvaluation -> - -- | The arguments to the script - [Common.Data] -> - (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) +evaluateScriptCounting + :: Common.MajorProtocolVersion + -- ^ Which major protocol version to run the operation in + -> Common.VerboseMode + -- ^ Whether to produce log output + -> Common.EvaluationContext + -- ^ Includes the cost model to use for tallying up the execution costs + -> Common.ScriptForEvaluation + -- ^ The script to evaluate + -> [Common.Data] + -- ^ The arguments to the script + -> (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) evaluateScriptCounting = Common.evaluateScriptCounting thisLedgerLanguage -{- | Evaluates a script, with a cost model and a budget that restricts how many +{-| Evaluates a script, with a cost model and a budget that restricts how many resources it can use according to the cost model. Also returns the budget that was actually used. Can be used to calculate budgets for scripts, but even in this case you must give a limit to guard against scripts that run for a long time or loop. -} -evaluateScriptRestricting :: - -- | Which major protocol version to run the operation in - Common.MajorProtocolVersion -> - -- | Whether to produce log output - Common.VerboseMode -> - -- | Includes the cost model to use for tallying up the execution costs - Common.EvaluationContext -> - -- | The resource budget which must not be exceeded during evaluation - Common.ExBudget -> - -- | The script to evaluate - Common.ScriptForEvaluation -> - -- | The arguments to the script - [Common.Data] -> - (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) +evaluateScriptRestricting + :: Common.MajorProtocolVersion + -- ^ Which major protocol version to run the operation in + -> Common.VerboseMode + -- ^ Whether to produce log output + -> Common.EvaluationContext + -- ^ Includes the cost model to use for tallying up the execution costs + -> Common.ExBudget + -- ^ The resource budget which must not be exceeded during evaluation + -> Common.ScriptForEvaluation + -- ^ The script to evaluate + -> [Common.Data] + -- ^ The arguments to the script + -> (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) evaluateScriptRestricting = Common.evaluateScriptRestricting thisLedgerLanguage diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Data/V3.hs b/plutus-ledger-api/src/PlutusLedgerApi/Data/V3.hs index 9787706542a..ccba45f4205 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Data/V3.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Data/V3.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + -- | The interface to Plutus V3 for the ledger. module PlutusLedgerApi.Data.V3 ( -- * Scripts @@ -18,18 +20,60 @@ module PlutusLedgerApi.Data.V3 ( Contexts.ColdCommitteeCredential (..), Contexts.HotCommitteeCredential (..), Contexts.DRepCredential (..), - Contexts.DRep (..), - Contexts.Delegatee (..), - Contexts.TxCert (..), - Contexts.Voter (..), - Contexts.Vote (..), - Contexts.GovernanceActionId (..), - Contexts.Committee (..), + Contexts.DRep, + pattern Contexts.DRep, + pattern Contexts.DRepAlwaysAbstain, + pattern Contexts.DRepAlwaysNoConfidence, + Contexts.Delegatee, + pattern Contexts.DelegStake, + pattern Contexts.DelegVote, + pattern Contexts.DelegStakeVote, + Contexts.TxCert, + pattern Contexts.TxCertRegStaking, + pattern Contexts.TxCertUnRegStaking, + pattern Contexts.TxCertDelegStaking, + pattern Contexts.TxCertRegDeleg, + pattern Contexts.TxCertRegDRep, + pattern Contexts.TxCertUpdateDRep, + pattern Contexts.TxCertUnRegDRep, + pattern Contexts.TxCertPoolRegister, + pattern Contexts.TxCertPoolRetire, + pattern Contexts.TxCertAuthHotCommittee, + pattern Contexts.TxCertResignColdCommittee, + Contexts.Voter, + pattern Contexts.CommitteeVoter, + pattern Contexts.DRepVoter, + pattern Contexts.StakePoolVoter, + Contexts.Vote, + pattern Contexts.VoteNo, + pattern Contexts.VoteYes, + pattern Contexts.Abstain, + Contexts.GovernanceActionId, + Contexts.gaidTxId, + Contexts.gaidGovActionIx, + Contexts.Committee, + pattern Contexts.Committee, + Contexts.committeeMembers, + Contexts.committeeQuorum, Contexts.Constitution (..), - Contexts.ProtocolVersion (..), - Contexts.GovernanceAction (..), + Contexts.ProtocolVersion, + pattern Contexts.ProtocolVersion, + Contexts.pvMajor, + Contexts.pvMinor, + Contexts.GovernanceAction, + pattern Contexts.ParameterChange, + pattern Contexts.HardForkInitiation, + pattern Contexts.TreasuryWithdrawals, + pattern Contexts.NoConfidence, + pattern Contexts.UpdateCommittee, + pattern Contexts.NewConstitution, + pattern Contexts.InfoAction, Contexts.ChangedParameters (..), - Contexts.ProposalProcedure (..), + Contexts.ProposalProcedure, + pattern Contexts.ProposalProcedure, + Contexts.ppDeposit, + Contexts.ppReturnAddr, + Contexts.ppGovernanceAction, -- ** Protocol version Common.MajorProtocolVersion (..), @@ -54,9 +98,22 @@ module PlutusLedgerApi.Data.V3 ( EvaluationContext.assertWellFormedCostModelParams, -- * Context types - Contexts.ScriptContext (..), - Contexts.ScriptPurpose (..), - Contexts.ScriptInfo (..), + Contexts.ScriptContext, + pattern Contexts.ScriptContext, + Contexts.ScriptPurpose, + pattern Contexts.Minting, + pattern Contexts.Spending, + pattern Contexts.Rewarding, + pattern Contexts.Certifying, + pattern Contexts.Voting, + pattern Contexts.Proposing, + Contexts.ScriptInfo, + pattern Contexts.MintingScript, + pattern Contexts.SpendingScript, + pattern Contexts.RewardingScript, + pattern Contexts.CertifyingScript, + pattern Contexts.VotingScript, + pattern Contexts.ProposingScript, -- ** Supporting types used in the context types @@ -72,8 +129,12 @@ module PlutusLedgerApi.Data.V3 ( V2.fromBytes, -- *** Credentials - V2.StakingCredential (..), - V2.Credential (..), + V2.StakingCredential, + pattern V2.StakingHash, + pattern V2.StakingPtr, + V2.Credential, + pattern V2.PubKeyCredential, + pattern V2.ScriptCredential, -- *** Value V2.Value (..), @@ -90,21 +151,63 @@ module PlutusLedgerApi.Data.V3 ( V2.POSIXTimeRange, -- *** Types for representing transactions - V2.Address (..), + V2.Address, + pattern V2.Address, + V2.addressCredential, + V2.addressStakingCredential, V2.PubKeyHash (..), Tx.TxId (..), - Contexts.TxInfo (..), - V2.TxOut (..), - Tx.TxOutRef (..), - Contexts.TxInInfo (..), - V2.OutputDatum (..), + Contexts.TxInfo, + pattern Contexts.TxInfo, + Contexts.txInfoInputs, + Contexts.txInfoReferenceInputs, + Contexts.txInfoOutputs, + Contexts.txInfoFee, + Contexts.txInfoMint, + Contexts.txInfoTxCerts, + Contexts.txInfoWdrl, + Contexts.txInfoValidRange, + Contexts.txInfoSignatories, + Contexts.txInfoRedeemers, + Contexts.txInfoData, + Contexts.txInfoId, + Contexts.txInfoVotes, + Contexts.txInfoProposalProcedures, + Contexts.txInfoCurrentTreasuryAmount, + Contexts.txInfoTreasuryDonation, + V2.TxOut, + pattern V2.TxOut, + V2.txOutAddress, + V2.txOutValue, + V2.txOutDatum, + V2.txOutReferenceScript, + Tx.TxOutRef, + pattern Tx.TxOutRef, + Tx.txOutRefId, + Tx.txOutRefIdx, + Contexts.TxInInfo, + pattern Contexts.TxInInfo, + Contexts.txInInfoOutRef, + Contexts.txInInfoResolved, + V2.OutputDatum, + pattern V2.NoOutputDatum, + pattern V2.OutputDatum, + pattern V2.OutputDatumHash, -- *** Intervals - V2.Interval (..), - V2.Extended (..), + V2.Interval, + pattern V2.Interval, + V2.ivFrom, + V2.ivTo, + V2.Extended, + pattern V2.NegInf, + pattern V2.PosInf, + pattern V2.Finite, V2.Closure, - V2.UpperBound (..), - V2.LowerBound (..), + V2.UpperBound, + pattern V2.UpperBound, + V2.LowerBound, + pattern V2.LowerBound, V2.always, V2.from, V2.to, @@ -151,71 +254,71 @@ module PlutusLedgerApi.Data.V3 ( import PlutusLedgerApi.Common qualified as Common import PlutusLedgerApi.Data.V2 qualified as V2 import PlutusLedgerApi.V3.Data.Contexts qualified as Contexts +import PlutusLedgerApi.V3.Data.Tx qualified as Tx import PlutusLedgerApi.V3.EvaluationContext qualified as EvaluationContext import PlutusLedgerApi.V3.ParamName qualified as ParamName -import PlutusLedgerApi.V3.Tx qualified as Tx import PlutusTx.Ratio qualified as Ratio -{- | An alias to the Plutus ledger language this module exposes at runtime. +{-| An alias to the Plutus ledger language this module exposes at runtime. MAYBE: Use CPP '__FILE__' + some TH to automate this. -} thisLedgerLanguage :: Common.PlutusLedgerLanguage thisLedgerLanguage = Common.PlutusV3 -{- | The deserialization from a serialised script into a `ScriptForEvaluation`, +{-| The deserialization from a serialised script into a `ScriptForEvaluation`, ready to be evaluated on-chain. Called inside phase-1 validation (i.e., deserialisation error is a phase-1 error). -} -deserialiseScript :: - forall m. - (Common.MonadError Common.ScriptDecodeError m) => - -- | which major protocol version the script was submitted in. - Common.MajorProtocolVersion -> - -- | the script to deserialise. - Common.SerialisedScript -> - m Common.ScriptForEvaluation +deserialiseScript + :: forall m + . (Common.MonadError Common.ScriptDecodeError m) + => Common.MajorProtocolVersion + -- ^ which major protocol version the script was submitted in. + -> Common.SerialisedScript + -- ^ the script to deserialise. + -> m Common.ScriptForEvaluation deserialiseScript = Common.deserialiseScript thisLedgerLanguage -{- | Evaluates a script, returning the minimum budget that the script would need +{-| Evaluates a script, returning the minimum budget that the script would need to evaluate successfully. This will take as long as the script takes, if you need to limit the execution time of the script also, you can use 'evaluateScriptRestricting', which also returns the used budget. -} -evaluateScriptCounting :: - -- | Which protocol version to run the operation in - Common.MajorProtocolVersion -> - -- | Whether to produce log output - Common.VerboseMode -> - -- | Includes the cost model to use for tallying up the execution costs - EvaluationContext.EvaluationContext -> - -- | The script to evaluate - Common.ScriptForEvaluation -> - -- | The @ScriptContext@ argument to the script - Common.Data -> - (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) +evaluateScriptCounting + :: Common.MajorProtocolVersion + -- ^ Which protocol version to run the operation in + -> Common.VerboseMode + -- ^ Whether to produce log output + -> EvaluationContext.EvaluationContext + -- ^ Includes the cost model to use for tallying up the execution costs + -> Common.ScriptForEvaluation + -- ^ The script to evaluate + -> Common.Data + -- ^ The @ScriptContext@ argument to the script + -> (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) evaluateScriptCounting mpv verbose ec s arg = Common.evaluateScriptCounting thisLedgerLanguage mpv verbose ec s [arg] -{- | Evaluates a script, with a cost model and a budget that restricts how many +{-| Evaluates a script, with a cost model and a budget that restricts how many resources it can use according to the cost model. Also returns the budget that was actually used. Can be used to calculate budgets for scripts, but even in this case you must give a limit to guard against scripts that run for a long time or loop. -} -evaluateScriptRestricting :: - -- | Which protocol version to run the operation in - Common.MajorProtocolVersion -> - -- | Whether to produce log output - Common.VerboseMode -> - -- | Includes the cost model to use for tallying up the execution costs - EvaluationContext.EvaluationContext -> - -- | The resource budget which must not be exceeded during evaluation - Common.ExBudget -> - -- | The script to evaluate - Common.ScriptForEvaluation -> - -- | The @ScriptContext@ argument to the script - Common.Data -> - (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) +evaluateScriptRestricting + :: Common.MajorProtocolVersion + -- ^ Which protocol version to run the operation in + -> Common.VerboseMode + -- ^ Whether to produce log output + -> EvaluationContext.EvaluationContext + -- ^ Includes the cost model to use for tallying up the execution costs + -> Common.ExBudget + -- ^ The resource budget which must not be exceeded during evaluation + -> Common.ScriptForEvaluation + -- ^ The script to evaluate + -> Common.Data + -- ^ The @ScriptContext@ argument to the script + -> (Common.LogOutput, Either Common.EvaluationError Common.ExBudget) evaluateScriptRestricting mpv verbose ec budget s arg = Common.evaluateScriptRestricting thisLedgerLanguage mpv verbose ec budget s [arg] diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Address.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Address.hs new file mode 100644 index 00000000000..ac1a0f3bed6 --- /dev/null +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Address.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-specialise #-} + +module PlutusLedgerApi.V1.Data.Address ( + Address, + pattern Address, + addressCredential, + addressStakingCredential, + pubKeyHashAddress, + toPubKeyHash, + toScriptHash, + scriptHashAddress, + stakingCredential, +) where + +import Control.DeepSeq (NFData) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import PlutusLedgerApi.V1.Crypto (PubKeyHash) +import PlutusLedgerApi.V1.Data.Credential (Credential, StakingCredential, pattern PubKeyCredential, + pattern ScriptCredential) +import PlutusLedgerApi.V1.Scripts (ScriptHash) +import PlutusTx qualified +import PlutusTx.AsData qualified as PlutusTx +import PlutusTx.Blueprint.Definition (HasBlueprintDefinition) +import PlutusTx.Bool qualified as PlutusTx +import PlutusTx.Eq qualified as PlutusTx +import Prettyprinter (Pretty (pretty), parens, (<+>)) + +{-| An address may contain two credentials, +the payment credential and optionally a 'StakingCredential'. +-} +PlutusTx.asData + [d| + data Address = Address + { addressCredential :: Credential + , -- \^ the payment credential + addressStakingCredential :: Maybe StakingCredential + } + -- \^ the staking credential + + deriving stock (Eq, Ord, Show, Generic, Typeable) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + deriving anyclass (NFData, HasBlueprintDefinition) + |] + +instance Pretty Address where + pretty (Address cred stakingCred) = + let staking = maybe "no staking credential" pretty stakingCred + in pretty cred <+> parens staking + +instance PlutusTx.Eq Address where + {-# INLINEABLE (==) #-} + Address cred stakingCred == Address cred' stakingCred' = + cred + PlutusTx.== cred' + PlutusTx.&& stakingCred + PlutusTx.== stakingCred' + +{-# INLINEABLE pubKeyHashAddress #-} + +{-| The address that should be targeted by a transaction output +locked by the public key with the given hash. +-} +pubKeyHashAddress :: PubKeyHash -> Address +pubKeyHashAddress pkh = Address (PubKeyCredential pkh) Nothing + +{-# INLINEABLE toPubKeyHash #-} + +-- | The PubKeyHash of the address, if any +toPubKeyHash :: Address -> Maybe PubKeyHash +toPubKeyHash (Address (PubKeyCredential k) _) = Just k +toPubKeyHash _ = Nothing + +{-# INLINEABLE toScriptHash #-} + +-- | The validator hash of the address, if any +toScriptHash :: Address -> Maybe ScriptHash +toScriptHash (Address (ScriptCredential k) _) = Just k +toScriptHash _ = Nothing + +{-# INLINEABLE scriptHashAddress #-} + +{-| The address that should be used by a transaction output +locked by the given validator script hash. +-} +scriptHashAddress :: ScriptHash -> Address +scriptHashAddress vh = Address (ScriptCredential vh) Nothing + +{-# INLINEABLE stakingCredential #-} + +-- | The staking credential of an address (if any) +stakingCredential :: Address -> Maybe StakingCredential +stakingCredential (Address _ s) = s + +---------------------------------------------------------------------------------------------------- +-- TH Splices -------------------------------------------------------------------------------------- + +$(PlutusTx.makeLift ''Address) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Contexts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Contexts.hs index 25f2dae5f1b..a28bd4be42b 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Contexts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Contexts.hs @@ -1,40 +1,39 @@ --- editorconfig-checker-disable-file {-# LANGUAGE DerivingVia #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} - {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} -{-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-specialise #-} -module PlutusLedgerApi.V1.Data.Contexts - ( - -- * Pending transactions and related types - TxInfo(..) - , ScriptContext(..) - , ScriptPurpose(..) - , TxId (..) - , TxOut(..) - , TxOutRef(..) - , TxInInfo(..) - , findOwnInput - , findDatum - , findDatumHash - , findTxInByTxOutRef - , findContinuingOutputs - , getContinuingOutputs - -- * Validator functions - , pubKeyOutputsAt - , valuePaidTo - , spendsOutput - , txSignedBy - , valueSpent - , valueProduced - , ownCurrencySymbol - ) where +module PlutusLedgerApi.V1.Data.Contexts ( + -- * Pending transactions and related types + TxInfo (..), + ScriptContext (..), + ScriptPurpose (..), + TxId (..), + TxOut (..), + TxOutRef (..), + TxInInfo (..), + findOwnInput, + findDatum, + findDatumHash, + findTxInByTxOutRef, + findContinuingOutputs, + getContinuingOutputs, + + -- * Validator functions + pubKeyOutputsAt, + valuePaidTo, + spendsOutput, + txSignedBy, + valueSpent, + valueProduced, + ownCurrencySymbol, +) where import GHC.Generics (Generic) import PlutusTx @@ -44,9 +43,9 @@ import PlutusTx.Prelude import Prettyprinter import Prettyprinter.Extras -import PlutusLedgerApi.V1.Address (Address (..)) -import PlutusLedgerApi.V1.Credential (Credential (..), StakingCredential) import PlutusLedgerApi.V1.Crypto (PubKeyHash (..)) +import PlutusLedgerApi.V1.Data.Address (pattern Address) +import PlutusLedgerApi.V1.Data.Credential (StakingCredential, pattern PubKeyCredential) import PlutusLedgerApi.V1.Data.Tx (TxId (..), TxOut (..), TxOutRef (..)) import PlutusLedgerApi.V1.Data.Value (CurrencySymbol (..), Value) import PlutusLedgerApi.V1.DCert (DCert (..)) @@ -67,148 +66,231 @@ redeemer and data scripts of all of its inputs and outputs. -- | An input of a pending transaction. data TxInInfo = TxInInfo - { txInInfoOutRef :: TxOutRef - , txInInfoResolved :: TxOut - } deriving stock (Generic, Haskell.Show, Haskell.Eq) + { txInInfoOutRef :: TxOutRef + , txInInfoResolved :: TxOut + } + deriving stock (Generic, Haskell.Show, Haskell.Eq) makeLift ''TxInInfo -makeIsDataIndexed ''TxInInfo [('TxInInfo,0)] +makeIsDataIndexed ''TxInInfo [('TxInInfo, 0)] instance Eq TxInInfo where - TxInInfo ref res == TxInInfo ref' res' = ref == ref' && res == res' + TxInInfo ref res == TxInInfo ref' res' = ref == ref' && res == res' instance Pretty TxInInfo where - pretty TxInInfo{txInInfoOutRef, txInInfoResolved} = - pretty txInInfoOutRef <+> "->" <+> pretty txInInfoResolved + pretty TxInInfo{txInInfoOutRef, txInInfoResolved} = + pretty txInInfoOutRef <+> "->" <+> pretty txInInfoResolved -- | Purpose of the script that is currently running data ScriptPurpose - = Minting CurrencySymbol - | Spending TxOutRef - | Rewarding StakingCredential - | Certifying DCert - deriving stock (Generic, Haskell.Show, Haskell.Eq) - deriving Pretty via (PrettyShow ScriptPurpose) + = Minting CurrencySymbol + | Spending TxOutRef + | Rewarding StakingCredential + | Certifying DCert + deriving stock (Generic, Haskell.Show, Haskell.Eq) + deriving Pretty via (PrettyShow ScriptPurpose) makeLift ''ScriptPurpose -makeIsDataIndexed ''ScriptPurpose - [ ('Minting,0) - , ('Spending,1) - , ('Rewarding,2) - , ('Certifying,3) - ] +makeIsDataIndexed + ''ScriptPurpose + [ ('Minting, 0) + , ('Spending, 1) + , ('Rewarding, 2) + , ('Certifying, 3) + ] instance Eq ScriptPurpose where - {-# INLINABLE (==) #-} - Minting cs == Minting cs' = cs == cs' - Spending ref == Spending ref' = ref == ref' - Rewarding sc == Rewarding sc' = sc == sc' - Certifying cert == Certifying cert' = cert == cert' - _ == _ = False - --- | A pending transaction. This is the view as seen by validator scripts, so some details are stripped out. + {-# INLINEABLE (==) #-} + Minting cs == Minting cs' = cs == cs' + Spending ref == Spending ref' = ref == ref' + Rewarding sc == Rewarding sc' = sc == sc' + Certifying cert == Certifying cert' = cert == cert' + _ == _ = False + +{-| A pending transaction. This is the view as seen by validator scripts, +so some details are stripped out. +-} data TxInfo = TxInfo - { txInfoInputs :: List TxInInfo -- ^ Transaction inputs; cannot be an empty list - , txInfoOutputs :: List TxOut -- ^ Transaction outputs - , txInfoFee :: Value -- ^ The fee paid by this transaction. - , txInfoMint :: Value -- ^ The 'Value' minted by this transaction. - , txInfoDCert :: List DCert -- ^ Digests of certificates included in this transaction - -- TODO: is this a map? is this a list? - , txInfoWdrl :: [(StakingCredential, Integer)] -- ^ Withdrawals - , txInfoValidRange :: POSIXTimeRange -- ^ The valid range for the transaction. - , txInfoSignatories :: List PubKeyHash -- ^ Signatures provided with the transaction, attested that they all signed the tx - -- TODO: is this a map? is this a list? - , txInfoData :: [(DatumHash, Datum)] -- ^ The lookup table of datums attached to the transaction - , txInfoId :: TxId -- ^ Hash of the pending transaction body (i.e. transaction excluding witnesses) - } deriving stock (Generic, Haskell.Show, Haskell.Eq) + { txInfoInputs :: List TxInInfo + -- ^ Transaction inputs; cannot be an empty list + , txInfoOutputs :: List TxOut + -- ^ Transaction outputs + , txInfoFee :: Value + -- ^ The fee paid by this transaction. + , txInfoMint :: Value + -- ^ The 'Value' minted by this transaction. + , txInfoDCert :: List DCert + -- ^ Digests of certificates included in this transaction + -- TODO: is this a map? is this a list? + , txInfoWdrl :: [(StakingCredential, Integer)] + -- ^ Withdrawals + , txInfoValidRange :: POSIXTimeRange + -- ^ The valid range for the transaction. + , txInfoSignatories :: List PubKeyHash + -- ^ Signatures provided with the transaction, attested that they all signed the tx + -- TODO: is this a map? is this a list? + , txInfoData :: [(DatumHash, Datum)] + -- ^ The lookup table of datums attached to the transaction + , txInfoId :: TxId + -- ^ Hash of the pending transaction body (i.e. transaction excluding witnesses) + } + deriving stock (Generic, Haskell.Show, Haskell.Eq) makeLift ''TxInfo -makeIsDataIndexed ''TxInfo [('TxInfo,0)] +makeIsDataIndexed ''TxInfo [('TxInfo, 0)] instance Eq TxInfo where - {-# INLINABLE (==) #-} - TxInfo i o f m c w r s d tid == TxInfo i' o' f' m' c' w' r' s' d' tid' = - i == i' && o == o' && f == f' && m == m' && c == c' && w == w' && r == r' && s == s' && d == d' && tid == tid' + {-# INLINEABLE (==) #-} + TxInfo i o f m c w r s d tid == TxInfo i' o' f' m' c' w' r' s' d' tid' = + i + == i' + && o + == o' + && f + == f' + && m + == m' + && c + == c' + && w + == w' + && r + == r' + && s + == s' + && d + == d' + && tid + == tid' instance Pretty TxInfo where - pretty TxInfo{txInfoInputs, txInfoOutputs, txInfoFee, txInfoMint, txInfoDCert, txInfoWdrl, txInfoValidRange, txInfoSignatories, txInfoData, txInfoId} = - vsep - [ "TxId:" <+> pretty txInfoId - , "Inputs:" <+> pretty txInfoInputs - , "Outputs:" <+> pretty txInfoOutputs - , "Fee:" <+> pretty txInfoFee - , "Value minted:" <+> pretty txInfoMint - , "DCerts:" <+> pretty txInfoDCert - , "Wdrl:" <+> pretty txInfoWdrl - , "Valid range:" <+> pretty txInfoValidRange - , "Signatories:" <+> pretty txInfoSignatories - , "Datums:" <+> pretty txInfoData - ] + pretty + TxInfo + { txInfoInputs + , txInfoOutputs + , txInfoFee + , txInfoMint + , txInfoDCert + , txInfoWdrl + , txInfoValidRange + , txInfoSignatories + , txInfoData + , txInfoId + } = + vsep + [ "TxId:" <+> pretty txInfoId + , "Inputs:" <+> pretty txInfoInputs + , "Outputs:" <+> pretty txInfoOutputs + , "Fee:" <+> pretty txInfoFee + , "Value minted:" <+> pretty txInfoMint + , "DCerts:" <+> pretty txInfoDCert + , "Wdrl:" <+> pretty txInfoWdrl + , "Valid range:" <+> pretty txInfoValidRange + , "Signatories:" <+> pretty txInfoSignatories + , "Datums:" <+> pretty txInfoData + ] -- | The context that the currently-executing script can access. data ScriptContext = ScriptContext - { scriptContextTxInfo :: TxInfo -- ^ information about the transaction the currently-executing script is included in - , scriptContextPurpose :: ScriptPurpose -- ^ the purpose of the currently-executing script - } - deriving stock (Generic, Haskell.Eq, Haskell.Show) + { scriptContextTxInfo :: TxInfo + -- ^ information about the transaction the currently-executing script is included in + , scriptContextPurpose :: ScriptPurpose + -- ^ the purpose of the currently-executing script + } + deriving stock (Generic, Haskell.Eq, Haskell.Show) makeLift ''ScriptContext -makeIsDataIndexed ''ScriptContext [('ScriptContext,0)] +makeIsDataIndexed ''ScriptContext [('ScriptContext, 0)] instance Eq ScriptContext where - {-# INLINABLE (==) #-} - ScriptContext info purpose == ScriptContext info' purpose' = info == info' && purpose == purpose' + {-# INLINEABLE (==) #-} + ScriptContext info purpose == ScriptContext info' purpose' = info == info' && purpose == purpose' instance Pretty ScriptContext where - pretty ScriptContext{scriptContextTxInfo, scriptContextPurpose} = - vsep - [ "Purpose:" <+> pretty scriptContextPurpose - , nest 2 $ vsep ["TxInfo:", pretty scriptContextTxInfo] - ] + pretty ScriptContext{scriptContextTxInfo, scriptContextPurpose} = + vsep + [ "Purpose:" <+> pretty scriptContextPurpose + , nest 2 $ vsep ["TxInfo:", pretty scriptContextTxInfo] + ] -- | Find the input currently being validated. findOwnInput :: ScriptContext -> Maybe TxInInfo -findOwnInput ScriptContext{scriptContextTxInfo=TxInfo{txInfoInputs}, scriptContextPurpose=Spending txOutRef} = - Data.List.find (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == txOutRef) txInfoInputs +findOwnInput + ScriptContext + { scriptContextTxInfo = TxInfo{txInfoInputs} + , scriptContextPurpose = Spending txOutRef + } = + Data.List.find + (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == txOutRef) + txInfoInputs findOwnInput _ = Nothing -{-# INLINABLE findOwnInput #-} +{-# INLINEABLE findOwnInput #-} -- | Find the data corresponding to a data hash, if there is one findDatum :: DatumHash -> TxInfo -> Maybe Datum findDatum dsh TxInfo{txInfoData} = snd <$> find f txInfoData - where - f (dsh', _) = dsh' == dsh -{-# INLINABLE findDatum #-} + where + f (dsh', _) = dsh' == dsh +{-# INLINEABLE findDatum #-} --- | Find the hash of a datum, if it is part of the pending transaction's --- hashes +{-| Find the hash of a datum, if it is part of the pending transaction's + hashes +-} findDatumHash :: Datum -> TxInfo -> Maybe DatumHash findDatumHash ds TxInfo{txInfoData} = fst <$> find f txInfoData - where - f (_, ds') = ds' == ds -{-# INLINABLE findDatumHash #-} + where + f (_, ds') = ds' == ds +{-# INLINEABLE findDatumHash #-} --- | Given a UTXO reference and a transaction (`TxInfo`), resolve it to one of the transaction's inputs (`TxInInfo`). +{-| Given a UTXO reference and a transaction (`TxInfo`), resolve it to one of +the transaction's inputs (`TxInInfo`). +-} findTxInByTxOutRef :: TxOutRef -> TxInfo -> Maybe TxInInfo findTxInByTxOutRef outRef TxInfo{txInfoInputs} = - Data.List.find (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == outRef) txInfoInputs -{-# INLINABLE findTxInByTxOutRef #-} + Data.List.find + (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == outRef) + txInfoInputs +{-# INLINEABLE findTxInByTxOutRef #-} --- | Finds all the outputs that pay to the same script address that we are currently spending from, if any. +{-| Finds all the outputs that pay to the same script address that we are +currently spending from, if any. +-} findContinuingOutputs :: ScriptContext -> List Integer -findContinuingOutputs ctx | Just TxInInfo{txInInfoResolved=TxOut{txOutAddress}} <- findOwnInput ctx = Data.List.findIndices (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx) - where - f addr TxOut{txOutAddress=otherAddress} = addr == otherAddress -findContinuingOutputs _ = traceError "Le" -- "Can't find any continuing outputs" -{-# INLINABLE findContinuingOutputs #-} - --- | Get all the outputs that pay to the same script address we are currently spending from, if any. +findContinuingOutputs ctx + | Just + TxInInfo + { txInInfoResolved = TxOut{txOutAddress} + } <- + findOwnInput ctx = + Data.List.findIndices + (f txOutAddress) + (txInfoOutputs $ scriptContextTxInfo ctx) + where + f addr TxOut{txOutAddress = otherAddress} = + addr == otherAddress +findContinuingOutputs _ = + traceError "Le" -- "Can't find any continuing outputs" +{-# INLINEABLE findContinuingOutputs #-} + +{-| Get all the outputs that pay to the same script address we are currently +spending from, if any. +-} getContinuingOutputs :: ScriptContext -> List TxOut -getContinuingOutputs ctx | Just TxInInfo{txInInfoResolved=TxOut{txOutAddress}} <- findOwnInput ctx = Data.List.filter (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx) - where - f addr TxOut{txOutAddress=otherAddress} = addr == otherAddress -getContinuingOutputs _ = traceError "Lf" -- "Can't get any continuing outputs" -{-# INLINABLE getContinuingOutputs #-} +getContinuingOutputs ctx + | Just + TxInInfo + { txInInfoResolved = TxOut{txOutAddress} + } <- + findOwnInput ctx = + Data.List.filter + (f txOutAddress) + (txInfoOutputs $ scriptContextTxInfo ctx) + where + f addr TxOut{txOutAddress = otherAddress} = + addr == otherAddress +getContinuingOutputs _ = + traceError "Lf" -- "Can't get any continuing outputs" +{-# INLINEABLE getContinuingOutputs #-} {- Note [Hashes in validator scripts] @@ -236,49 +318,57 @@ them from the correct types in Haskell, and for comparing them (in -- | Check if a transaction was signed by the given public key. txSignedBy :: TxInfo -> PubKeyHash -> Bool -txSignedBy TxInfo{txInfoSignatories} k = case Data.List.find ((==) k) txInfoSignatories of +txSignedBy TxInfo{txInfoSignatories} k = + case Data.List.find ((==) k) txInfoSignatories of Just _ -> True Nothing -> False -{-# INLINABLE txSignedBy #-} +{-# INLINEABLE txSignedBy #-} -- | Get the values paid to a public key address by a pending transaction. pubKeyOutputsAt :: PubKeyHash -> TxInfo -> List Value pubKeyOutputsAt pk p = - let flt TxOut{txOutAddress = Address (PubKeyCredential pk') _, txOutValue} | pk == pk' = Just txOutValue - flt _ = Nothing - in Data.List.mapMaybe flt (txInfoOutputs p) -{-# INLINABLE pubKeyOutputsAt #-} + let flt + TxOut + { txOutAddress = Address (PubKeyCredential pk') _ + , txOutValue + } | pk == pk' = Just txOutValue + flt _ = Nothing + in Data.List.mapMaybe flt (txInfoOutputs p) +{-# INLINEABLE pubKeyOutputsAt #-} -- | Get the total value paid to a public key address by a pending transaction. valuePaidTo :: TxInfo -> PubKeyHash -> Value valuePaidTo ptx pkh = Data.List.mconcat (pubKeyOutputsAt pkh ptx) -{-# INLINABLE valuePaidTo #-} +{-# INLINEABLE valuePaidTo #-} -- | Get the total value of inputs spent by this transaction. valueSpent :: TxInfo -> Value valueSpent = Data.List.foldMap (txOutValue . txInInfoResolved) . txInfoInputs -{-# INLINABLE valueSpent #-} +{-# INLINEABLE valueSpent #-} -- | Get the total value of outputs produced by this transaction. valueProduced :: TxInfo -> Value valueProduced = Data.List.foldMap txOutValue . txInfoOutputs -{-# INLINABLE valueProduced #-} +{-# INLINEABLE valueProduced #-} -- | The 'CurrencySymbol' of the current validator script. ownCurrencySymbol :: ScriptContext -> CurrencySymbol -ownCurrencySymbol ScriptContext{scriptContextPurpose=Minting cs} = cs -ownCurrencySymbol _ = traceError "Lh" -- "Can't get currency symbol of the current validator script" -{-# INLINABLE ownCurrencySymbol #-} +ownCurrencySymbol ScriptContext{scriptContextPurpose = Minting cs} = cs +ownCurrencySymbol _ = + traceError "Lh" -- "Can't get currency symbol of the current validator script" +{-# INLINEABLE ownCurrencySymbol #-} -{- | Check if the pending transaction spends a specific transaction output +{-| Check if the pending transaction spends a specific transaction output (identified by the hash of a transaction and an index into that transactions' outputs) -} spendsOutput :: TxInfo -> TxId -> Integer -> Bool spendsOutput p h i = - let spendsOutRef inp = - let outRef = txInInfoOutRef inp - in h == txOutRefId outRef - && i == txOutRefIdx outRef - in Data.List.any spendsOutRef (txInfoInputs p) -{-# INLINABLE spendsOutput #-} + let spendsOutRef inp = + let outRef = txInInfoOutRef inp + in h + == txOutRefId outRef + && i + == txOutRefIdx outRef + in Data.List.any spendsOutRef (txInfoInputs p) +{-# INLINEABLE spendsOutput #-} diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Credential.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Credential.hs new file mode 100644 index 00000000000..e8fb95d2f00 --- /dev/null +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Credential.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-specialise #-} + +-- | Address and staking address credentials for outputs. +module PlutusLedgerApi.V1.Data.Credential ( + StakingCredential, + pattern StakingHash, + pattern StakingPtr, + Credential, + pattern PubKeyCredential, + pattern ScriptCredential, +) where + +import Control.DeepSeq (NFData) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import PlutusLedgerApi.V1.Crypto (PubKeyHash) +import PlutusLedgerApi.V1.Scripts (ScriptHash) +import PlutusTx qualified +import PlutusTx.AsData qualified as PlutusTx +import PlutusTx.Blueprint (HasBlueprintDefinition) +import PlutusTx.Bool qualified as PlutusTx +import PlutusTx.Eq qualified as PlutusTx +import PlutusTx.Show (deriveShow) +import Prettyprinter (Pretty (..), (<+>)) + +{-| Credentials required to unlock a transaction output. + +The 'PubKeyCredential' constructor represents the transaction that +spends this output and must be signed by the private key. +See `Crypto.PubKeyHash`. + +The 'ScriptCredential' constructor represents the transaction that spends +this output must include the validator script and +be accepted by the validator. See `ScriptHash`. +-} +PlutusTx.asData + [d| + data Credential + = PubKeyCredential PubKeyHash + | ScriptCredential ScriptHash + deriving stock (Eq, Ord, Show, Generic, Typeable) + deriving anyclass (NFData, HasBlueprintDefinition) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + |] + +instance Pretty Credential where + pretty (PubKeyCredential pkh) = "PubKeyCredential:" <+> pretty pkh + pretty (ScriptCredential val) = "ScriptCredential:" <+> pretty val + +instance PlutusTx.Eq Credential where + {-# INLINEABLE (==) #-} + PubKeyCredential l == PubKeyCredential r = l PlutusTx.== r + ScriptCredential a == ScriptCredential a' = a PlutusTx.== a' + _ == _ = False + +{-| Staking credential used to assign rewards. + +The staking hash constructor is the `Credential` required to unlock a +transaction output. Either a public key credential (`Crypto.PubKeyHash`) or +a script credential (`ScriptHash`). Both are hashed with /BLAKE2b-244/. 28 byte. + +The 'StakingPtr' constructor is the certificate pointer, constructed by the given +slot number, transaction and certificate indices. +NB: The fields should really be all `Word64`, as they are implemented in `Word64`, +but 'Integer' is our only integral type so we need to use it instead. +-} +PlutusTx.asData + [d| + data StakingCredential + = StakingHash Credential + | StakingPtr + Integer + -- \^ the slot number + Integer + -- \^ the transaction index (within the block) + Integer + -- \^ the certificate index (within the transaction) + deriving stock (Eq, Ord, Show, Generic, Typeable) + deriving anyclass (NFData, HasBlueprintDefinition) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + |] + +instance Pretty StakingCredential where + pretty (StakingHash h) = "StakingHash" <+> pretty h + pretty (StakingPtr a b c) = "StakingPtr:" <+> pretty a <+> pretty b <+> pretty c + +instance PlutusTx.Eq StakingCredential where + {-# INLINEABLE (==) #-} + StakingHash l == StakingHash r = l PlutusTx.== r + StakingPtr a b c == StakingPtr a' b' c' = + a + PlutusTx.== a' + PlutusTx.&& b + PlutusTx.== b' + PlutusTx.&& c + PlutusTx.== c' + _ == _ = False + +---------------------------------------------------------------------------------------------------- +-- TH Splices -------------------------------------------------------------------------------------- + +PlutusTx.makeLift ''Credential +PlutusTx.makeLift ''StakingCredential + +deriveShow ''Credential +deriveShow ''StakingCredential diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Interval.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Interval.hs new file mode 100644 index 00000000000..076d28b3f2b --- /dev/null +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Interval.hs @@ -0,0 +1,592 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-specialise #-} + +-- | A type for intervals and associated functions. +module PlutusLedgerApi.V1.Data.Interval ( + Interval, + pattern Interval, + ivFrom, + ivTo, + UpperBound, + pattern UpperBound, + LowerBound, + pattern LowerBound, + Extended, + pattern NegInf, + pattern Finite, + pattern PosInf, + Closure, + member, + interval, + from, + to, + always, + never, + singleton, + hull, + intersection, + overlaps, + contains, + isEmpty, + before, + after, + lowerBound, + upperBound, + strictLowerBound, + strictUpperBound, + mapInterval, +) where + +import Control.DeepSeq (NFData) +import GHC.Generics (Generic) +import Prelude qualified as Haskell +import Prettyprinter (Pretty (pretty), comma, (<+>)) + +import PlutusTx qualified +import PlutusTx.AsData qualified as PlutusTx +import PlutusTx.Blueprint (ConstructorSchema (..), Schema (..)) +import PlutusTx.Blueprint.Class (HasBlueprintSchema (schema)) +import PlutusTx.Blueprint.Definition (HasBlueprintDefinition (..), HasSchemaDefinition, Unrolled, + definitionIdFromTypeK, definitionRef) +import PlutusTx.Blueprint.Definition.TF (Nub, type (++)) +import PlutusTx.Blueprint.Schema.Annotation (SchemaInfo (..), emptySchemaInfo) +import PlutusTx.Eq as PlutusTx +import PlutusTx.Lift (makeLift) +import PlutusTx.Ord as PlutusTx +import PlutusTx.Prelude + +-- See Note [Enumerable Intervals] + +-- | Whether a bound is inclusive or not. +type Closure = Bool + +-- | A set extended with a positive and negative infinity. +PlutusTx.asData + [d| + data Extended a = NegInf | Finite a | PosInf + deriving stock (Haskell.Show, Generic) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + deriving anyclass (NFData) + |] + +-- | The upper bound of an interval. +PlutusTx.asData + [d| + data UpperBound a = UpperBound (Extended a) Closure + deriving stock (Haskell.Show, Generic) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + deriving anyclass (NFData) + |] + +-- | The lower bound of an interval. +PlutusTx.asData + [d| + data LowerBound a = LowerBound (Extended a) Closure + deriving stock (Haskell.Show, Generic) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + deriving anyclass (NFData) + |] + +-- See Note [Enumerable Intervals] + +{-| An interval of @a@s. + +The interval may be either closed or open at either end, meaning +that the endpoints may or may not be included in the interval. + +The interval can also be unbounded on either side. + +The 'Eq' instance gives equality of the intervals, not structural equality. +There is no 'Ord' instance, but 'contains' gives a partial order. + +Note that some of the functions on `Interval` rely on `Enum` in order to +handle non-inclusive endpoints. For this reason, it may not be safe to +use `Interval`s with non-inclusive endpoints on types whose `Enum` +instances have partial methods. +-} +PlutusTx.asData + [d| + data Interval a = Interval {ivFrom :: LowerBound a, ivTo :: UpperBound a} + deriving stock (Haskell.Show, Generic) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + deriving anyclass (NFData) + |] + +instance (HasBlueprintDefinition a) => HasBlueprintDefinition (Interval a) where + type + Unroll (Interval a) = + Nub (Interval a ': (Unrolled (LowerBound a) ++ Unrolled (UpperBound a))) + definitionId = definitionIdFromTypeK @_ @Interval Haskell.<> definitionId @a + +instance + ( HasBlueprintDefinition a + , HasSchemaDefinition (LowerBound a) referencedTypes + , HasSchemaDefinition (UpperBound a) referencedTypes + ) + => HasBlueprintSchema (Interval a) referencedTypes + where + {-# INLINEABLE schema #-} + schema = + SchemaConstructor + (MkSchemaInfo Nothing Nothing Nothing) + ( MkConstructorSchema + 0 + [ definitionRef @(LowerBound a) @referencedTypes + , definitionRef @(UpperBound a) @referencedTypes + ] + ) + +mapInterval + :: ( PlutusTx.ToData a1 + , PlutusTx.ToData a2 + , PlutusTx.UnsafeFromData a1 + , PlutusTx.UnsafeFromData a2 + ) + => (a1 -> a2) + -> Interval a1 + -> Interval a2 +mapInterval f (Interval fromA toA) = Interval (mapLowerBound f fromA) (mapUpperBound f toA) + +instance (Pretty a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Pretty (Interval a) where + pretty (Interval l h) = pretty l <+> comma <+> pretty h + +instance (HasBlueprintDefinition a) => HasBlueprintDefinition (Extended a) where + type Unroll (Extended a) = Extended a ': Unrolled a + definitionId = definitionIdFromTypeK @_ @Extended Haskell.<> definitionId @a + +mapExtended + :: (PlutusTx.ToData t, PlutusTx.ToData a, PlutusTx.UnsafeFromData t, PlutusTx.UnsafeFromData a) + => (t -> a) -> Extended t -> Extended a +mapExtended _ NegInf = NegInf +mapExtended f (Finite a) = Finite (f a) +mapExtended _ PosInf = PosInf + +instance (Pretty a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Pretty (Extended a) where + pretty NegInf = pretty "-∞" + pretty PosInf = pretty "+∞" + pretty (Finite a) = pretty a + +instance (HasBlueprintDefinition (Extended a)) => HasBlueprintDefinition (UpperBound a) where + type Unroll (UpperBound a) = UpperBound a ': (Unrolled Closure ++ Unrolled (Extended a)) + definitionId = definitionIdFromTypeK @_ @UpperBound Haskell.<> definitionId @(Extended a) + +instance + ( HasSchemaDefinition a referencedTypes + , HasBlueprintDefinition a + , HasSchemaDefinition (Extended a) referencedTypes + , HasSchemaDefinition Closure referencedTypes + ) + => HasBlueprintSchema (UpperBound a) referencedTypes + where + {-# INLINEABLE schema #-} + schema = + SchemaConstructor + emptySchemaInfo{title = Just "UpperBound"} + ( MkConstructorSchema + 0 + [ definitionRef @(Extended a) @referencedTypes + , definitionRef @Closure @referencedTypes + ] + ) + +{-| For an enumerable type, turn an upper bound into a single inclusive +bounding value. + +Since the type is enumerable, non-inclusive bounds are equivalent +to inclusive bounds on the predecessor. + +See Note [Enumerable Intervals] +-} +inclusiveUpperBound + :: (Enum a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => UpperBound a -> Extended a +-- already inclusive +inclusiveUpperBound (UpperBound v True) = v +-- take pred +inclusiveUpperBound (UpperBound (Finite x) False) = Finite $ pred x +-- an infinity: inclusive/non-inclusive makes no difference +inclusiveUpperBound (UpperBound v False) = v + +mapUpperBound + :: ( PlutusTx.ToData a1 + , PlutusTx.ToData a2 + , PlutusTx.UnsafeFromData a1 + , PlutusTx.UnsafeFromData a2 + ) + => (a1 -> a2) -> UpperBound a1 -> UpperBound a2 +mapUpperBound f (UpperBound e c) = UpperBound (mapExtended f e) c + +instance (Pretty a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Pretty (UpperBound a) where + pretty (UpperBound PosInf _) = pretty "+∞)" + pretty (UpperBound NegInf _) = pretty "-∞)" + pretty (UpperBound a True) = pretty a <+> pretty "]" + pretty (UpperBound a False) = pretty a <+> pretty ")" + +instance (HasBlueprintDefinition (Extended a)) => HasBlueprintDefinition (LowerBound a) where + type Unroll (LowerBound a) = LowerBound a ': (Unrolled Closure ++ Unrolled (Extended a)) + definitionId = definitionIdFromTypeK @_ @LowerBound Haskell.<> definitionId @(Extended a) + +instance + ( HasSchemaDefinition a referencedTypes + , HasBlueprintDefinition a + , HasSchemaDefinition (Extended a) referencedTypes + , HasSchemaDefinition Closure referencedTypes + ) + => HasBlueprintSchema (LowerBound a) referencedTypes + where + {-# INLINEABLE schema #-} + schema = + SchemaConstructor + emptySchemaInfo{title = Just "LowerBound"} + ( MkConstructorSchema + 0 + [ definitionRef @(Extended a) @referencedTypes + , definitionRef @Closure @referencedTypes + ] + ) + +{-| For an enumerable type, turn an lower bound into a single inclusive +bounding value. + +Since the type is enumerable, non-inclusive bounds are equivalent +to inclusive bounds on the successor. + +See Note [Enumerable Intervals] +-} +inclusiveLowerBound + :: (Enum a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => LowerBound a -> Extended a +-- already inclusive +inclusiveLowerBound (LowerBound v True) = v +-- take succ +inclusiveLowerBound (LowerBound (Finite x) False) = Finite $ succ x +-- an infinity: inclusive/non-inclusive makes no difference +inclusiveLowerBound (LowerBound v False) = v + +mapLowerBound + :: ( PlutusTx.ToData a1 + , PlutusTx.ToData a2 + , PlutusTx.UnsafeFromData a1 + , PlutusTx.UnsafeFromData a2 + ) + => (a1 -> a2) -> LowerBound a1 -> LowerBound a2 +mapLowerBound f (LowerBound e c) = LowerBound (mapExtended f e) c + +instance (Pretty a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Pretty (LowerBound a) where + pretty (LowerBound PosInf _) = pretty "(+∞" + pretty (LowerBound NegInf _) = pretty "(-∞" + pretty (LowerBound a True) = pretty "[" <+> pretty a + pretty (LowerBound a False) = pretty "(" <+> pretty a + +instance (Eq a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Eq (Extended a) where + {-# INLINEABLE (==) #-} + NegInf == NegInf = True + PosInf == PosInf = True + Finite l == Finite r = l == r + _ == _ = False + +instance (Eq a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Haskell.Eq (Extended a) where + (==) = (PlutusTx.==) + +instance (Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Ord (Extended a) where + {-# INLINEABLE compare #-} + NegInf `compare` NegInf = EQ + NegInf `compare` _ = LT + _ `compare` NegInf = GT + PosInf `compare` PosInf = EQ + _ `compare` PosInf = LT + PosInf `compare` _ = GT + Finite l `compare` Finite r = l `compare` r + +instance (Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Haskell.Ord (Extended a) where + compare = PlutusTx.compare + +-- See Note [Enumerable Intervals] +instance (Enum a, Eq a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Eq (UpperBound a) where + {-# INLINEABLE (==) #-} + b1 == b2 = inclusiveUpperBound b1 == inclusiveUpperBound b2 + +instance + (Enum a, Eq a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => Haskell.Eq (UpperBound a) + where + (==) = (PlutusTx.==) + +-- See Note [Enumerable Intervals] +instance + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => Ord (UpperBound a) + where + {-# INLINEABLE compare #-} + b1 `compare` b2 = inclusiveUpperBound b1 `compare` inclusiveUpperBound b2 + +instance + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => Haskell.Ord (UpperBound a) + where + compare = PlutusTx.compare + +-- See Note [Enumerable Intervals] +instance + (Enum a, Eq a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => Eq (LowerBound a) + where + {-# INLINEABLE (==) #-} + b1 == b2 = inclusiveLowerBound b1 == inclusiveLowerBound b2 + +instance + (Enum a, Eq a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => Haskell.Eq (LowerBound a) + where + (==) = (PlutusTx.==) + +-- See Note [Enumerable Intervals] +instance + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => Ord (LowerBound a) + where + {-# INLINEABLE compare #-} + b1 `compare` b2 = inclusiveLowerBound b1 `compare` inclusiveLowerBound b2 + +instance + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => Haskell.Ord (LowerBound a) + where + compare = PlutusTx.compare + +{-| Construct a strict upper bound from a value. +The resulting bound includes all values that are (strictly) smaller than the input value. +-} +strictUpperBound :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => a -> UpperBound a +strictUpperBound a = UpperBound (Finite a) False +{-# INLINEABLE strictUpperBound #-} + +{-| Construct a strict lower bound from a value. +The resulting bound includes all values that are (strictly) greater than the input value. +-} +strictLowerBound :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => a -> LowerBound a +strictLowerBound a = LowerBound (Finite a) False +{-# INLINEABLE strictLowerBound #-} + +{-| Construct a lower bound from a value. +The resulting bound includes all values that are equal or greater than the input value. +-} +lowerBound :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => a -> LowerBound a +lowerBound a = LowerBound (Finite a) True +{-# INLINEABLE lowerBound #-} + +{-| Construct an upper bound from a value. +The resulting bound includes all values that are equal or smaller than the input value. +-} +upperBound :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => a -> UpperBound a +upperBound a = UpperBound (Finite a) True +{-# INLINEABLE upperBound #-} + +-- See Note [Enumerable Intervals] +instance + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => JoinSemiLattice (Interval a) + where + {-# INLINEABLE (\/) #-} + (\/) = hull + +-- See Note [Enumerable Intervals] +instance + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => BoundedJoinSemiLattice (Interval a) + where + {-# INLINEABLE bottom #-} + bottom = never + +-- See Note [Enumerable Intervals] +instance + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => MeetSemiLattice (Interval a) + where + {-# INLINEABLE (/\) #-} + (/\) = intersection + +-- See Note [Enumerable Intervals] +instance + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => BoundedMeetSemiLattice (Interval a) + where + {-# INLINEABLE top #-} + top = always + +-- See Note [Enumerable Intervals] +instance + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => Eq (Interval a) + where + {-# INLINEABLE (==) #-} + -- Degenerate case: both the intervals are empty. + -- There can be many empty intervals, so we check for this case + -- explicitly + iv1 == iv2 | isEmpty iv1 && isEmpty iv2 = True + (Interval lb1 ub1) == (Interval lb2 ub2) = lb1 == lb2 && ub1 == ub2 + +instance + (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => Haskell.Eq (Interval a) + where + {-# INLINEABLE (==) #-} + (==) = (PlutusTx.==) + +{-| @interval a b@ includes all values that are greater than or equal to @a@ +and smaller than or equal to @b@. Therefore it includes @a@ and @b@. In math. notation: [a,b] +-} +interval :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => a -> a -> Interval a +interval s s' = Interval (lowerBound s) (upperBound s') +{-# INLINEABLE interval #-} + +{-| Create an interval that includes just a single concrete point @a@, +i.e. having the same non-strict lower and upper bounds. In math.notation: [a,a] +-} +singleton :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => a -> Interval a +singleton s = interval s s +{-# INLINEABLE singleton #-} + +{-| @from a@ is an 'Interval' that includes all values that are + greater than or equal to @a@. In math. notation: [a,+∞] +-} +from :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => a -> Interval a +from s = Interval (lowerBound s) (UpperBound PosInf True) +{-# INLINEABLE from #-} + +{-| @to a@ is an 'Interval' that includes all values that are + smaller than or equal to @a@. In math. notation: [-∞,a] +-} +to :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => a -> Interval a +to s = Interval (LowerBound NegInf True) (upperBound s) +{-# INLINEABLE to #-} + +-- | An 'Interval' that covers every slot. In math. notation [-∞,+∞] +always :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Interval a +always = Interval (LowerBound NegInf True) (UpperBound PosInf True) +{-# INLINEABLE always #-} + +{-| An 'Interval' that is empty. +There can be many empty intervals, see `isEmpty`. +The empty interval `never` is arbitrarily set to [+∞,-∞]. +-} +never :: (PlutusTx.ToData a, PlutusTx.UnsafeFromData a) => Interval a +never = Interval (LowerBound PosInf True) (UpperBound NegInf True) +{-# INLINEABLE never #-} + +-- | Check whether a value is in an interval. +member + :: (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => a -> Interval a -> Bool +member a i = i `contains` singleton a +{-# INLINEABLE member #-} + +{-| Check whether two intervals overlap, that is, whether there is a value that + is a member of both intervals. +-} +overlaps + :: (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => Interval a -> Interval a -> Bool +overlaps l r = not $ isEmpty (l `intersection` r) +{-# INLINEABLE overlaps #-} + +{-| 'intersection a b' is the largest interval that is contained in 'a' and in + 'b', if it exists. +-} +intersection + :: (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => Interval a -> Interval a -> Interval a +intersection (Interval l1 h1) (Interval l2 h2) = Interval (max l1 l2) (min h1 h2) +{-# INLINEABLE intersection #-} + +-- | 'hull a b' is the smallest interval containing 'a' and 'b'. +hull + :: (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => Interval a -> Interval a -> Interval a +hull (Interval l1 h1) (Interval l2 h2) = Interval (min l1 l2) (max h1 h2) +{-# INLINEABLE hull #-} + +{-| @a `contains` b@ is true if the 'Interval' @b@ is entirely contained in +@a@. That is, @a `contains` b@ if for every entry @s@, if @member s b@ then +@member s a@. +-} +contains + :: (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => Interval a -> Interval a -> Bool +-- Everything contains the empty interval +contains _ i2 | isEmpty i2 = True +-- Nothing is contained in the empty interval (except the empty interval, +-- which is already handled) +contains i1 _ | isEmpty i1 = False +-- Otherwise we check the endpoints. This doesn't work for empty intervals, +-- hence the cases above. +contains (Interval l1 h1) (Interval l2 h2) = l1 <= l2 && h2 <= h1 +{-# INLINEABLE contains #-} + +-- | Check if an 'Interval' is empty. +isEmpty + :: (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => Interval a -> Bool +isEmpty (Interval lb ub) = case inclusiveLowerBound lb `compare` inclusiveUpperBound ub of + -- We have at least two possible values, the lower bound and the upper bound + LT -> False + -- We have one possible value, the lower bound/upper bound + EQ -> False + -- We have no possible values + GT -> True +{-# INLINEABLE isEmpty #-} + +-- | Check if a value is earlier than the beginning of an 'Interval'. +before + :: (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => a -> Interval a -> Bool +before h (Interval f _) = lowerBound h < f +{-# INLINEABLE before #-} + +-- | Check if a value is later than the end of an 'Interval'. +after + :: (Enum a, Ord a, PlutusTx.ToData a, PlutusTx.UnsafeFromData a) + => a -> Interval a -> Bool +after h (Interval _ t) = upperBound h > t +{-# INLINEABLE after #-} + +{- Note [Enumerable Intervals] +The 'Interval' type is set up to handle open intervals, where we have non-inclusive +bounds. These are only meaningful for orders where there do not exist (computable) +joins and meets over all elements greater or less than an element. + +If those do exist, we can eliminate non-inclusive bounds in favour of inclusive bounds. +For example, in the integers, (x, y) is equivalent to [x+1, y-1], because +x+1 = sup { z | z > x} and y-1 = inf { z | z < y }. + +Checking equality, containment etc. of intervals with non-inclusive bounds is +tricky. For example, to know if (x, y) is empty, we need to know if there is a +value between x and y. We don't have a typeclass for that! + +In practice, most of the intervals we care about are enumerable (have 'Enum' +instances). We assume that `pred` and `succ` calculate the infima/suprema described +above, and so we can turn non-inclusive bounds into inclusive bounds, which +makes things much easier. The downside is that some of the `Enum` instances have +partial implementations, which means that, e.g. `isEmpty (False, True]` will +throw. + +The upshot of this is that many functions in this module require 'Enum'. +-} + +---------------------------------------------------------------------------------------------------- +-- TH Splices -------------------------------------------------------------------------------------- + +$(makeLift ''Extended) +$(makeLift ''LowerBound) +$(makeLift ''UpperBound) +$(makeLift ''Interval) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Time.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Time.hs new file mode 100644 index 00000000000..3caaf97216a --- /dev/null +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Time.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +-- Otherwise we get a complaint about the 'fromIntegral' +-- call in the generated instance of 'Integral' for 'Ada' +{-# OPTIONS_GHC -Wno-identities #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + +-- | UTCTime and UTCTime ranges. +module PlutusLedgerApi.V1.Data.Time ( + POSIXTime (..), + POSIXTimeRange, + DiffMilliSeconds (..), + fromMilliSeconds, +) where + +import PlutusTx.Prelude +import Prelude qualified as Haskell + +import Control.DeepSeq (NFData) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import PlutusLedgerApi.V1.Data.Interval (Interval) +import PlutusTx qualified +import PlutusTx.Blueprint.Class (HasBlueprintSchema (..)) +import PlutusTx.Blueprint.Definition (HasBlueprintDefinition) +import PlutusTx.Blueprint.Schema (Schema (SchemaInteger), emptyIntegerSchema) +import PlutusTx.Blueprint.Schema.Annotation (SchemaInfo (..), emptySchemaInfo) +import PlutusTx.Lift (makeLift) +import Prettyprinter (Pretty (pretty), (<+>)) + +-- | This is a length of time, as measured by a number of milliseconds. +newtype DiffMilliSeconds = DiffMilliSeconds Integer + deriving stock (Haskell.Eq, Haskell.Ord, Haskell.Show, Generic, Typeable) + deriving anyclass (NFData, HasBlueprintDefinition) + deriving newtype + ( Haskell.Num + , AdditiveSemigroup + , AdditiveMonoid + , AdditiveGroup + , Haskell.Enum + , Eq + , Ord + , Haskell.Real + , Haskell.Integral + , PlutusTx.ToData + , PlutusTx.FromData + , PlutusTx.UnsafeFromData + ) + +instance HasBlueprintSchema DiffMilliSeconds referencedTypes where + schema = SchemaInteger emptySchemaInfo{title = Just "DiffMilliSeconds"} emptyIntegerSchema + +{-| POSIX time is measured as the number of /milliseconds/ since 1970-01-01T00:00:00Z. +This is not the same as Haskell's `Data.Time.Clock.POSIX.POSIXTime` +-} +newtype POSIXTime = POSIXTime {getPOSIXTime :: Integer} + deriving stock (Haskell.Eq, Haskell.Ord, Haskell.Show, Generic, Typeable) + deriving anyclass (NFData, HasBlueprintDefinition) + deriving newtype + ( AdditiveSemigroup + , AdditiveMonoid + , AdditiveGroup + , Eq + , Ord + , Enum + , PlutusTx.ToData + , PlutusTx.FromData + , PlutusTx.UnsafeFromData + , Haskell.Num + , Haskell.Enum + , Haskell.Real + , Haskell.Integral + ) + +instance HasBlueprintSchema POSIXTime referencedTypes where + schema = SchemaInteger emptySchemaInfo{title = Just "POSIXTime"} emptyIntegerSchema + +instance Pretty POSIXTime where + pretty (POSIXTime i) = "POSIXTime" <+> pretty i + +-- | An 'Interval' of 'POSIXTime's. +type POSIXTimeRange = Interval POSIXTime + +-- | Simple conversion from 'DiffMilliSeconds' to 'POSIXTime'. +fromMilliSeconds :: DiffMilliSeconds -> POSIXTime +fromMilliSeconds (DiffMilliSeconds s) = POSIXTime s +{-# INLINEABLE fromMilliSeconds #-} + +---------------------------------------------------------------------------------------------------- +-- TH Splices -------------------------------------------------------------------------------------- + +$(makeLift ''DiffMilliSeconds) +$(makeLift ''POSIXTime) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Tx.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Tx.hs index 6e9717e72b5..cdc2e7a634f 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Tx.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Tx.hs @@ -1,4 +1,3 @@ --- editorconfig-checker-disable-file {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE LambdaCase #-} @@ -6,29 +5,28 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -module PlutusLedgerApi.V1.Data.Tx - ( - -- * Transactions - TxId (..) - , ScriptTag (..) - , RedeemerPtr (..) - , Redeemers - -- * Transaction outputs - , TxOut(..) - , TxOutRef(..) - , isPubKeyOut - , isPayToScriptOut - , outAddress - , outValue - , txOutPubKey - , txOutDatum - , pubKeyHashTxOut - ) where +module PlutusLedgerApi.V1.Data.Tx ( + -- * Transactions + TxId (..), + ScriptTag (..), + RedeemerPtr (..), + Redeemers, + + -- * Transaction outputs + TxOut (..), + TxOutRef (..), + isPubKeyOut, + isPayToScriptOut, + outAddress, + outValue, + txOutPubKey, + txOutDatum, + pubKeyHashTxOut, +) where import Control.DeepSeq (NFData) import Control.Lens @@ -44,81 +42,97 @@ import PlutusTx.Builtins qualified as PlutusTx import PlutusTx.Eq qualified as PlutusTx import PlutusTx.Ord qualified as PlutusTx -import PlutusLedgerApi.V1.Address import PlutusLedgerApi.V1.Bytes import PlutusLedgerApi.V1.Crypto +import PlutusLedgerApi.V1.Data.Address import PlutusLedgerApi.V1.Data.Value import PlutusLedgerApi.V1.Scripts -{- | A transaction ID, i.e. the hash of a transaction. Hashed with BLAKE2b-256. 32 byte. + +{-| A transaction ID, i.e. the hash of a transaction. Hashed with BLAKE2b-256. 32 byte. This is a simple type without any validation, __use with caution__. You may want to add checks for its invariants. See the - [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). + [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). -- editorconfig-checker-disable-file +-} +newtype TxId = TxId {getTxId :: PlutusTx.BuiltinByteString} + deriving stock (Eq, Ord, Generic) + deriving anyclass (NFData) + deriving newtype (PlutusTx.Eq, PlutusTx.Ord) + deriving + ( IsString + -- ^ from hex encoding + , Show + -- ^ using hex encoding + , Pretty + -- ^ using hex encoding + ) + via LedgerBytes + +{-| A tag indicating the type of script that we are pointing to. + +See also 'PlutusLedgerApi.V1.ScriptPurpose' -} -newtype TxId = TxId { getTxId :: PlutusTx.BuiltinByteString } - deriving stock (Eq, Ord, Generic) - deriving anyclass (NFData) - deriving newtype (PlutusTx.Eq, PlutusTx.Ord) - deriving - (IsString -- ^ from hex encoding - , Show -- ^ using hex encoding - , Pretty -- ^ using hex encoding - ) via LedgerBytes - --- | A tag indicating the type of script that we are pointing to. --- --- See also 'PlutusLedgerApi.V1.ScriptPurpose' data ScriptTag = Spend | Mint | Cert | Reward - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) --- | A redeemer pointer is a pair of a script type tag ('ScriptTag') `t` and an index `i`, --- picking out the i-th script of type `t` in the transaction. +{-| A redeemer pointer is a pair of a script type tag ('ScriptTag') `t` and an index `i`, +picking out the i-th script of type `t` in the transaction. +-} data RedeemerPtr = RedeemerPtr ScriptTag Integer - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) -- | Redeemers is a `Map` of redeemer pointer ('RedeemerPtr') and its 'Redeemer'. type Redeemers = Map RedeemerPtr Redeemer --- | A reference to a transaction output. This is a --- pair of a transaction ID (`TxId`), and an index indicating which of the outputs --- of that transaction we are referring to. -data TxOutRef = TxOutRef { - txOutRefId :: TxId, -- ^ The transaction ID. - txOutRefIdx :: Integer -- ^ Index into the referenced transaction's outputs - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData) +{-| A reference to a transaction output. This is a +pair of a transaction ID (`TxId`), and an index indicating which of the outputs +of that transaction we are referring to. +-} +data TxOutRef = TxOutRef + { txOutRefId :: TxId + -- ^ The transaction ID. + , txOutRefIdx :: Integer + -- ^ Index into the referenced transaction's outputs + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) instance Pretty TxOutRef where - pretty TxOutRef{txOutRefId, txOutRefIdx} = pretty txOutRefId <> "!" <> pretty txOutRefIdx + pretty TxOutRef{txOutRefId, txOutRefIdx} = pretty txOutRefId <> "!" <> pretty txOutRefIdx instance PlutusTx.Eq TxOutRef where - {-# INLINABLE (==) #-} - l == r = - txOutRefId l PlutusTx.== txOutRefId r - PlutusTx.&& txOutRefIdx l PlutusTx.== txOutRefIdx r - --- | A transaction output, consisting of a target address ('Address'), a value ('Value'), --- and optionally a datum hash ('DatumHash'). -data TxOut = TxOut { - txOutAddress :: Address, - txOutValue :: Value, - txOutDatumHash :: Maybe DatumHash - } - deriving stock (Show, Eq, Generic) + {-# INLINEABLE (==) #-} + l == r = + txOutRefId l + PlutusTx.== txOutRefId r + PlutusTx.&& txOutRefIdx l + PlutusTx.== txOutRefIdx r + +{-| A transaction output, consisting of a target address ('Address'), a value ('Value'), +and optionally a datum hash ('DatumHash'). +-} +data TxOut = TxOut + { txOutAddress :: Address + , txOutValue :: Value + , txOutDatumHash :: Maybe DatumHash + } + deriving stock (Show, Eq, Generic) instance Pretty TxOut where - pretty TxOut{txOutAddress, txOutValue} = - hang 2 $ vsep ["-" <+> pretty txOutValue <+> "addressed to", pretty txOutAddress] + pretty TxOut{txOutAddress, txOutValue} = + hang 2 $ vsep ["-" <+> pretty txOutValue <+> "addressed to", pretty txOutAddress] instance PlutusTx.Eq TxOut where - {-# INLINABLE (==) #-} - l == r = - txOutAddress l PlutusTx.== txOutAddress r - PlutusTx.&& txOutValue l PlutusTx.== txOutValue r - PlutusTx.&& txOutDatumHash l PlutusTx.== txOutDatumHash r + {-# INLINEABLE (==) #-} + l == r = + txOutAddress l + PlutusTx.== txOutAddress r + PlutusTx.&& txOutValue l + PlutusTx.== txOutValue r + PlutusTx.&& txOutDatumHash l + PlutusTx.== txOutDatumHash r -- | The datum attached to a 'TxOut', if there is one. txOutDatum :: TxOut -> Maybe DatumHash @@ -134,14 +148,17 @@ txOutScriptHash TxOut{txOutAddress} = toScriptHash txOutAddress -- | The address of a transaction output. outAddress :: Lens' TxOut Address -outAddress = lens txOutAddress s where - s tx a = tx { txOutAddress = a } +outAddress = lens txOutAddress s + where + s tx a = tx{txOutAddress = a} --- | The value of a transaction output. --- | TODO: Compute address again +{-| The value of a transaction output. +| TODO: Compute address again +-} outValue :: Lens' TxOut Value -outValue = lens txOutValue s where - s tx v = tx { txOutValue = v } +outValue = lens txOutValue s + where + s tx v = tx{txOutValue = v} -- | Whether the output is a pay-to-pubkey output. isPubKeyOut :: TxOut -> Bool @@ -156,10 +173,10 @@ pubKeyHashTxOut :: Value -> PubKeyHash -> TxOut pubKeyHashTxOut v pkh = TxOut (pubKeyHashAddress pkh) v Nothing PlutusTx.makeLift ''TxId -PlutusTx.makeIsDataIndexed ''TxId [('TxId,0)] +PlutusTx.makeIsDataIndexed ''TxId [('TxId, 0)] -PlutusTx.makeIsDataIndexed ''TxOut [('TxOut,0)] +PlutusTx.makeIsDataIndexed ''TxOut [('TxOut, 0)] PlutusTx.makeLift ''TxOut -PlutusTx.makeIsDataIndexed ''TxOutRef [('TxOutRef,0)] +PlutusTx.makeIsDataIndexed ''TxOutRef [('TxOutRef, 0)] PlutusTx.makeLift ''TxOutRef diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs index 3b413c41c31..5e9d1f57cb7 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -1,8 +1,5 @@ -- TODO: this module adds a copy of the 'Value' type -- in which the underlying maps are 'Data.AssocMap'. --- !!WARNING!!: this is currently experimental so do not use in production code! - --- editorconfig-checker-disable-file {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} @@ -16,54 +13,58 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} - +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} -- Prevent unboxing, which the plugin can't deal with {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-spec-constr #-} {-# OPTIONS_GHC -fno-specialise #-} -{-# OPTIONS_GHC -fexpose-all-unfoldings #-} -- We need -fexpose-all-unfoldings to compile the Marlowe validator with GHC 9.6.2. -- TODO. Look into this more closely: see https://github.com/IntersectMBO/plutus/issues/6172. -- | Functions for working with 'Value'. module PlutusLedgerApi.V1.Data.Value ( - -- ** Currency symbols - CurrencySymbol(..) - , currencySymbol - , adaSymbol - -- ** Token names - , TokenName(..) - , tokenName - , toString - , adaToken - -- * Asset classes - , AssetClass(..) - , assetClass - , assetClassValue - , assetClassValueOf - -- ** Value - , Value(..) - , singleton - , valueOf - , withCurrencySymbol - , currencySymbolValueOf - , lovelaceValue - , lovelaceValueOf - , scale - , symbols - -- * Partial order operations - , geq - , gt - , leq - , lt - -- * Etc. - , isZero - , split - , unionWith - , flattenValue - , Lovelace (..) - ) where + -- ** Currency symbols + CurrencySymbol (..), + currencySymbol, + adaSymbol, + + -- ** Token names + TokenName (..), + tokenName, + toString, + adaToken, + + -- * Asset classes + AssetClass (..), + assetClass, + assetClassValue, + assetClassValueOf, + + -- ** Value + Value (..), + singleton, + valueOf, + withCurrencySymbol, + currencySymbolValueOf, + lovelaceValue, + lovelaceValueOf, + scale, + symbols, + + -- * Partial order operations + geq, + gt, + leq, + lt, + + -- * Etc. + isZero, + split, + unionWith, + flattenValue, + Lovelace (..), +) where import Prelude qualified as Haskell @@ -97,25 +98,25 @@ import PlutusTx.These (These (..)) import Prettyprinter (Pretty, (<>)) import Prettyprinter.Extras (PrettyShow (PrettyShow)) -{- | ByteString representing the currency, hashed with /BLAKE2b-224/. +{-| ByteString representing the currency, hashed with /BLAKE2b-224/. It is empty for `Ada`, 28 bytes for `MintingPolicyHash`. Forms an `AssetClass` along with `TokenName`. A `Value` is a map from `CurrencySymbol`'s to a map from `TokenName` to an `Integer`. This is a simple type without any validation, __use with caution__. You may want to add checks for its invariants. See the - [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). + [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). -- editorconfig-checker-disable-file -} newtype CurrencySymbol = CurrencySymbol { unCurrencySymbol :: PlutusTx.BuiltinByteString } deriving - ( -- | from hex encoding - IsString - , -- | using hex encoding - Haskell.Show - , -- | using hex encoding - Pretty + ( IsString + -- ^ from hex encoding + , Haskell.Show + -- ^ using hex encoding + , Pretty + -- ^ using hex encoding ) via LedgerBytes deriving stock (Generic, Data, Typeable) @@ -131,24 +132,25 @@ newtype CurrencySymbol = CurrencySymbol deriving anyclass (NFData, HasBlueprintDefinition) instance HasBlueprintSchema CurrencySymbol referencedTypes where - {-# INLINABLE schema #-} - schema = schema @PlutusTx.BuiltinByteString - & withSchemaInfo \info -> - info { title = Just "CurrencySymbol" } + {-# INLINEABLE schema #-} + schema = + schema @PlutusTx.BuiltinByteString + & withSchemaInfo \info -> + info{title = Just "CurrencySymbol"} -- | Creates `CurrencySymbol` from raw `ByteString`. currencySymbol :: BS.ByteString -> CurrencySymbol currencySymbol = CurrencySymbol . PlutusTx.toBuiltin -{-# INLINABLE currencySymbol #-} +{-# INLINEABLE currencySymbol #-} -{- | ByteString of a name of a token. +{-| ByteString of a name of a token. Shown as UTF-8 string when possible. Should be no longer than 32 bytes, empty for Ada. Forms an `AssetClass` along with a `CurrencySymbol`. This is a simple type without any validation, __use with caution__. You may want to add checks for its invariants. See the - [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). + [Shelley ledger specification](https://github.com/IntersectMBO/cardano-ledger/releases/download/cardano-ledger-spec-2023-04-03/shelley-ledger.pdf). -- editorconfig-checker-disable-file -} newtype TokenName = TokenName {unTokenName :: PlutusTx.BuiltinByteString} deriving stock (Generic, Data, Typeable) @@ -166,26 +168,27 @@ newtype TokenName = TokenName {unTokenName :: PlutusTx.BuiltinByteString} -- | UTF-8 encoding. Doesn't verify length. instance IsString TokenName where - fromString = fromText . Text.pack + fromString = fromText . Text.pack instance HasBlueprintSchema TokenName referencedTypes where - {-# INLINABLE schema #-} - schema = schema @PlutusTx.BuiltinByteString - & withSchemaInfo \info -> - info { title = Just "TokenName" } + {-# INLINEABLE schema #-} + schema = + schema @PlutusTx.BuiltinByteString + & withSchemaInfo \info -> + info{title = Just "TokenName"} -- | Creates `TokenName` from raw `BS.ByteString`. tokenName :: BS.ByteString -> TokenName tokenName = TokenName . PlutusTx.toBuiltin -{-# INLINABLE tokenName #-} +{-# INLINEABLE tokenName #-} fromText :: Text -> TokenName fromText = tokenName . E.encodeUtf8 fromTokenName :: (BS.ByteString -> r) -> (Text -> r) -> TokenName -> r fromTokenName handleBytestring handleText (TokenName bs) = - either (\_ -> handleBytestring $ PlutusTx.fromBuiltin bs) handleText $ - E.decodeUtf8' (PlutusTx.fromBuiltin bs) + either (\_ -> handleBytestring $ PlutusTx.fromBuiltin bs) handleText + $ E.decodeUtf8' (PlutusTx.fromBuiltin bs) -- | Encode a `ByteString` to a hex `Text`. asBase16 :: BS.ByteString -> Text @@ -195,7 +198,7 @@ asBase16 bs = Text.concat ["0x", encodeByteString bs] quoted :: Text -> Text quoted s = Text.concat ["\"", s, "\""] -{- | Turn a TokenName to a hex-encoded 'String' +{-| Turn a TokenName to a hex-encoded 'String' Compared to `show` , it will not surround the string with double-quotes. -} @@ -203,17 +206,17 @@ toString :: TokenName -> Haskell.String toString = Text.unpack . fromTokenName asBase16 id instance Haskell.Show TokenName where - show = Text.unpack . fromTokenName asBase16 quoted + show = Text.unpack . fromTokenName asBase16 quoted -- | The 'CurrencySymbol' of the 'Ada' currency. adaSymbol :: CurrencySymbol adaSymbol = CurrencySymbol emptyByteString -{-# INLINABLE adaSymbol #-} +{-# INLINEABLE adaSymbol #-} -- | The 'TokenName' of the 'Ada' currency. adaToken :: TokenName adaToken = TokenName emptyByteString -{-# INLINABLE adaToken #-} +{-# INLINEABLE adaToken #-} -- | An asset class, identified by a `CurrencySymbol` and a `TokenName`. newtype AssetClass = AssetClass {unAssetClass :: (CurrencySymbol, TokenName)} @@ -232,10 +235,10 @@ newtype AssetClass = AssetClass {unAssetClass :: (CurrencySymbol, TokenName)} deriving (Pretty) via (PrettyShow (CurrencySymbol, TokenName)) instance HasBlueprintSchema AssetClass referencedTypes where - {-# INLINABLE schema #-} + {-# INLINEABLE schema #-} schema = - SchemaBuiltInPair emptySchemaInfo $ - MkPairSchema + SchemaBuiltInPair emptySchemaInfo + $ MkPairSchema { left = schema @CurrencySymbol , right = schema @TokenName } @@ -243,7 +246,7 @@ instance HasBlueprintSchema AssetClass referencedTypes where -- | The curried version of 'AssetClass' constructor assetClass :: CurrencySymbol -> TokenName -> AssetClass assetClass s t = AssetClass (s, t) -{-# INLINABLE assetClass #-} +{-# INLINEABLE assetClass #-} {- Note [Value vs value] We call two completely different things "values": the 'Value' type and a value within a key-value @@ -268,7 +271,8 @@ See https://github.com/IntersectMBO/plutus/pull/5779 for details on the experime -- See Note [Value vs value]. -- See Note [Optimising Value]. -{- | The 'Value' type represents a collection of amounts of different currencies. + +{-| The 'Value' type represents a collection of amounts of different currencies. We can think of 'Value' as a vector space whose dimensions are currencies. Operations on currencies are usually implemented /pointwise/. That is, @@ -284,87 +288,91 @@ taken to be zero. There is no 'Ord Value' instance since 'Value' is only a partial order, so 'compare' can't do the right thing in some cases. - -} -newtype Value = Value { getValue :: Map CurrencySymbol (Map TokenName Integer) } - deriving stock (Generic, Typeable, Haskell.Show) - deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) - deriving Pretty via (PrettyShow Value) +-} +newtype Value = Value {getValue :: Map CurrencySymbol (Map TokenName Integer)} + deriving stock (Generic, Typeable, Haskell.Show) + deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) + deriving Pretty via (PrettyShow Value) instance HasBlueprintDefinition Value where type Unroll Value = '[Value, CurrencySymbol, TokenName, Integer] definitionId = definitionIdFromType @Value instance HasBlueprintSchema Value referencedTypes where - {-# INLINABLE schema #-} + {-# INLINEABLE schema #-} schema = SchemaMap emptySchemaInfo - { title = Just "Value" } + { title = Just "Value" + } MkMapSchema { keySchema = definitionRef @CurrencySymbol , valueSchema = - SchemaMap emptySchemaInfo MkMapSchema - { keySchema = definitionRef @TokenName - , valueSchema = definitionRef @Integer - , minItems = Nothing - , maxItems = Nothing - } + SchemaMap + emptySchemaInfo + MkMapSchema + { keySchema = definitionRef @TokenName + , valueSchema = definitionRef @Integer + , minItems = Nothing + , maxItems = Nothing + } , minItems = Nothing , maxItems = Nothing } instance Haskell.Eq Value where - (==) = eq + (==) = eq instance Eq Value where - {-# INLINABLE (==) #-} - (==) = eq + {-# INLINEABLE (==) #-} + (==) = eq instance Haskell.Semigroup Value where - (<>) = unionWith (+) + (<>) = unionWith (+) instance Semigroup Value where - {-# INLINABLE (<>) #-} - (<>) = unionWith (+) + {-# INLINEABLE (<>) #-} + (<>) = unionWith (+) instance Haskell.Monoid Value where - mempty = Value Map.empty + mempty = Value Map.empty instance Monoid Value where - {-# INLINABLE mempty #-} - mempty = Value Map.empty + {-# INLINEABLE mempty #-} + mempty = Value Map.empty instance Group Value where - {-# INLINABLE inv #-} - inv = scale @Integer @Value (-1) + {-# INLINEABLE inv #-} + inv = scale @Integer @Value (-1) deriving via (Additive Value) instance AdditiveSemigroup Value deriving via (Additive Value) instance AdditiveMonoid Value deriving via (Additive Value) instance AdditiveGroup Value instance Module Integer Value where - {-# INLINABLE scale #-} - scale i (Value xs) = Value (Map.map (Map.map (\i' -> i * i')) xs) + {-# INLINEABLE scale #-} + scale i (Value xs) = Value (Map.map (Map.map (\i' -> i * i')) xs) instance JoinSemiLattice Value where - {-# INLINABLE (\/) #-} - (\/) = unionWith Ord.max + {-# INLINEABLE (\/) #-} + (\/) = unionWith Ord.max instance MeetSemiLattice Value where - {-# INLINABLE (/\) #-} - (/\) = unionWith Ord.min + {-# INLINEABLE (/\) #-} + (/\) = unionWith Ord.min --- | Get the quantity of the given currency in the 'Value'. --- Assumes that the underlying map doesn't contain duplicate keys. +{-| Get the quantity of the given currency in the 'Value'. +Assumes that the underlying map doesn't contain duplicate keys. +-} valueOf :: Value -> CurrencySymbol -> TokenName -> Integer valueOf value cur tn = withCurrencySymbol cur value 0 \tokens -> case Map.lookup tn tokens of - Nothing -> 0 - Just v -> v -{-# INLINABLE valueOf #-} + Nothing -> 0 + Just v -> v +{-# INLINEABLE valueOf #-} -{- | Apply a continuation function to the token quantities of the given currency +{-| Apply a continuation function to the token quantities of the given currency symbol in the value or return a default value if the currency symbol is not present in the value. -} @@ -373,9 +381,9 @@ withCurrencySymbol currency value def k = case Map.lookup currency (getValue value) of Nothing -> def Just tokenQuantities -> k tokenQuantities -{-# INLINABLE withCurrencySymbol #-} +{-# INLINEABLE withCurrencySymbol #-} -{- | Get the total value of the currency symbol in the 'Value' map. +{-| Get the total value of the currency symbol in the 'Value' map. Assumes that the underlying map doesn't contain duplicate keys. Note that each token of the currency symbol may have a value that is positive, @@ -383,154 +391,167 @@ zero or negative. -} currencySymbolValueOf :: Value -> CurrencySymbol -> Integer currencySymbolValueOf value cur = withCurrencySymbol cur value 0 \tokens -> - -- This is more efficient than `PlutusTx.sum (Map.elems tokens)`, because - -- the latter materializes the intermediate result of `Map.elems tokens`. - Map.foldr (\amt acc -> amt + acc) 0 tokens -{-# INLINABLE currencySymbolValueOf #-} + -- This is more efficient than `PlutusTx.sum (Map.elems tokens)`, because + -- the latter materializes the intermediate result of `Map.elems tokens`. + Map.foldr (\amt acc -> amt + acc) 0 tokens +{-# INLINEABLE currencySymbolValueOf #-} -- | The list of 'CurrencySymbol's of a 'Value'. symbols :: Value -> BuiltinList BuiltinData symbols (Value mp) = Map.keys mp -{-# INLINABLE symbols #-} +{-# INLINEABLE symbols #-} -- | Make a 'Value' containing only the given quantity of the given currency. singleton :: CurrencySymbol -> TokenName -> Integer -> Value singleton c tn i = Value (Map.singleton c (Map.singleton tn i)) -{-# INLINABLE singleton #-} +{-# INLINEABLE singleton #-} -- | A 'Value' containing the given quantity of Lovelace. lovelaceValue :: Lovelace -> Value lovelaceValue = singleton adaSymbol adaToken . getLovelace -{-# INLINABLE lovelaceValue #-} +{-# INLINEABLE lovelaceValue #-} -- | Get the quantity of Lovelace in the 'Value'. lovelaceValueOf :: Value -> Lovelace lovelaceValueOf v = Lovelace (valueOf v adaSymbol adaToken) -{-# INLINABLE lovelaceValueOf #-} +{-# INLINEABLE lovelaceValueOf #-} -- | A 'Value' containing the given amount of the asset class. assetClassValue :: AssetClass -> Integer -> Value assetClassValue (AssetClass (c, t)) = singleton c t -{-# INLINABLE assetClassValue #-} +{-# INLINEABLE assetClassValue #-} -- | Get the quantity of the given 'AssetClass' class in the 'Value'. assetClassValueOf :: Value -> AssetClass -> Integer assetClassValueOf v (AssetClass (c, t)) = valueOf v c t -{-# INLINABLE assetClassValueOf #-} +{-# INLINEABLE assetClassValueOf #-} -- | Combine two 'Value' maps, assumes the well-definedness of the two maps. unionVal :: Value -> Value -> Map CurrencySymbol (Map TokenName (These Integer Integer)) unionVal (Value l) (Value r) = - let - combined = Map.union l r - unThese k = case k of - This a -> Map.map This a - That b -> Map.map That b - These a b -> Map.union a b - in Map.map unThese combined -{-# INLINABLE unionVal #-} - --- | Combine two 'Value' maps with the argument function. --- Assumes the well-definedness of the two maps. + let + combined = Map.union l r + unThese k = case k of + This a -> Map.map This a + That b -> Map.map That b + These a b -> Map.union a b + in + Map.map unThese combined +{-# INLINEABLE unionVal #-} + +{-| Combine two 'Value' maps with the argument function. +Assumes the well-definedness of the two maps. +-} unionWith :: (Integer -> Integer -> Integer) -> Value -> Value -> Value unionWith f ls rs = - let - combined = unionVal ls rs - unThese k' = case k' of - This a -> f a 0 - That b -> f 0 b - These a b -> f a b - in Value (Map.map (Map.map unThese) combined) -{-# INLINABLE unionWith #-} - --- | Convert a 'Value' to a simple list, keeping only the non-zero amounts. --- Note that the result isn't sorted, meaning @v1 == v2@ doesn't generally imply --- @flattenValue v1 == flattenValue v2@. --- Also assumes that there are no duplicate keys in the 'Value' 'Map'. + let + combined = unionVal ls rs + unThese k' = case k' of + This a -> f a 0 + That b -> f 0 b + These a b -> f a b + in + Value (Map.map (Map.map unThese) combined) +{-# INLINEABLE unionWith #-} + +{-| Convert a 'Value' to a simple list, keeping only the non-zero amounts. +Note that the result isn't sorted, meaning @v1 == v2@ doesn't generally imply +@flattenValue v1 == flattenValue v2@. +Also assumes that there are no duplicate keys in the 'Value' 'Map'. +-} flattenValue :: Value -> [(CurrencySymbol, TokenName, Integer)] flattenValue v = goOuter [] (Map.toList $ getValue v) - where - goOuter acc [] = acc - goOuter acc ((cs, m) : tl) = goOuter (goInner cs acc (Map.toList m)) tl + where + goOuter acc [] = acc + goOuter acc ((cs, m) : tl) = goOuter (goInner cs acc (Map.toList m)) tl - goInner _ acc [] = acc - goInner cs acc ((tn, a) : tl) - | a /= 0 = goInner cs ((cs, tn, a) : acc) tl - | otherwise = goInner cs acc tl -{-# INLINABLE flattenValue #-} + goInner _ acc [] = acc + goInner cs acc ((tn, a) : tl) + | a /= 0 = goInner cs ((cs, tn, a) : acc) tl + | otherwise = goInner cs acc tl +{-# INLINEABLE flattenValue #-} -- Num operations -- | Check whether a 'Value' is zero. isZero :: Value -> Bool isZero (Value xs) = Map.all (Map.all (\i -> 0 == i)) xs -{-# INLINABLE isZero #-} +{-# INLINEABLE isZero #-} --- | Checks whether a predicate holds for all the values in a 'Value' --- union. Assumes the well-definedness of the two underlying 'Map's. +{-| Checks whether a predicate holds for all the values in a 'Value' +union. Assumes the well-definedness of the two underlying 'Map's. +-} checkPred :: (These Integer Integer -> Bool) -> Value -> Value -> Bool checkPred f l r = - let - inner :: Map TokenName (These Integer Integer) -> Bool - inner = Map.all f - in - Map.all inner (unionVal l r) -{-# INLINABLE checkPred #-} - --- | Check whether a binary relation holds for value pairs of two 'Value' maps, --- supplying 0 where a key is only present in one of them. + let + inner :: Map TokenName (These Integer Integer) -> Bool + inner = Map.all f + in + Map.all inner (unionVal l r) +{-# INLINEABLE checkPred #-} + +{-| Check whether a binary relation holds for value pairs of two 'Value' maps, + supplying 0 where a key is only present in one of them. +-} checkBinRel :: (Integer -> Integer -> Bool) -> Value -> Value -> Bool checkBinRel f l r = - let - unThese k' = case k' of - This a -> f a 0 - That b -> f 0 b - These a b -> f a b - in checkPred unThese l r -{-# INLINABLE checkBinRel #-} - --- | Check whether one 'Value' is greater than or equal to another. See 'Value' for an explanation --- of how operations on 'Value's work. + let + unThese k' = case k' of + This a -> f a 0 + That b -> f 0 b + These a b -> f a b + in + checkPred unThese l r +{-# INLINEABLE checkBinRel #-} + +{-| Check whether one 'Value' is greater than or equal to another. See 'Value' for an explanation +of how operations on 'Value's work. +-} geq :: Value -> Value -> Bool -- If both are zero then checkBinRel will be vacuously true, but this is fine. geq = checkBinRel (>=) -{-# INLINABLE geq #-} +{-# INLINEABLE geq #-} --- | Check whether one 'Value' is less than or equal to another. See 'Value' for an explanation of --- how operations on 'Value's work. +{-| Check whether one 'Value' is less than or equal to another. See 'Value' for an explanation of +how operations on 'Value's work. +-} leq :: Value -> Value -> Bool -- If both are zero then checkBinRel will be vacuously true, but this is fine. leq = checkBinRel (<=) -{-# INLINABLE leq #-} +{-# INLINEABLE leq #-} --- | Check whether one 'Value' is strictly greater than another. --- This is *not* a pointwise operation. @gt l r@ means @geq l r && not (eq l r)@. +{-| Check whether one 'Value' is strictly greater than another. +This is *not* a pointwise operation. @gt l r@ means @geq l r && not (eq l r)@. +-} gt :: Value -> Value -> Bool gt l r = geq l r && not (eq l r) -{-# INLINABLE gt #-} +{-# INLINEABLE gt #-} --- | Check whether one 'Value' is strictly less than another. --- This is *not* a pointwise operation. @lt l r@ means @leq l r && not (eq l r)@. +{-| Check whether one 'Value' is strictly less than another. +This is *not* a pointwise operation. @lt l r@ means @leq l r && not (eq l r)@. +-} lt :: Value -> Value -> Bool lt l r = leq l r && not (eq l r) -{-# INLINABLE lt #-} - --- | Split a 'Value' into its positive and negative parts. The first element of --- the tuple contains the negative parts of the 'Value', the second element --- contains the positive parts. --- --- @negate (fst (split a)) `plus` (snd (split a)) == a@ --- +{-# INLINEABLE lt #-} + +{-| Split a 'Value' into its positive and negative parts. The first element of + the tuple contains the negative parts of the 'Value', the second element + contains the positive parts. + + @negate (fst (split a)) `plus` (snd (split a)) == a@ +-} split :: Value -> (Value, Value) -split (Value mp) = (negate (Value neg), Value pos) where +split (Value mp) = (negate (Value neg), Value pos) + where (neg, pos) = Map.mapThese splitIntl mp splitIntl :: Map TokenName Integer -> These (Map TokenName Integer) (Map TokenName Integer) - splitIntl mp' = These l r where + splitIntl mp' = These l r + where (l, r) = Map.mapThese (\i -> if i <= 0 then This i else That i) mp' -{-# INLINABLE split #-} +{-# INLINEABLE split #-} -{- | Check equality of two lists of distinct key-value pairs, each value being uniquely +{-| Check equality of two lists of distinct key-value pairs, each value being uniquely identified by a key, given a function checking whether a 'Value' is zero and a function checking equality of values. Note that the caller must ensure that the two lists are well-defined in this sense. This is not checked or enforced in `unordEqWith`, and therefore @@ -563,142 +584,145 @@ The algorithm we use here is very similar, if not identical, to @valueEqualsValu https://github.com/IntersectMBO/plutus/issues/5135 -} unordEqWith - :: (BuiltinData -> Bool) - -> (BuiltinData -> BuiltinData -> Bool) - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) + :: (BuiltinData -> Bool) + -> (BuiltinData -> BuiltinData -> Bool) + -> BuiltinList (BuiltinPair BuiltinData BuiltinData) + -> BuiltinList (BuiltinPair BuiltinData BuiltinData) + -> Bool +unordEqWith is0 eqV = goBoth + where + goBoth + :: BuiltinList (BuiltinPair BuiltinData BuiltinData) -> BuiltinList (BuiltinPair BuiltinData BuiltinData) -> Bool -unordEqWith is0 eqV = goBoth where - goBoth - :: BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> Bool - goBoth l1 l2 = - B.matchList - l1 - -- null l1 case - ( \() -> - B.matchList - l2 - -- null l2 case - (\() -> True) - -- non-null l2 case - (\ _ _ -> Map.all is0 (Map.unsafeFromBuiltinList l2 :: Map BuiltinData BuiltinData)) - ) - -- non-null l1 case - ( \hd1 tl1 -> - B.matchList - l2 - -- null l2 case - (\() -> Map.all is0 (Map.unsafeFromBuiltinList l1 :: Map BuiltinData BuiltinData)) - -- non-null l2 case - ( \hd2 tl2 -> - let - k1 = BI.fst hd1 - v1 = BI.snd hd1 - k2 = BI.fst hd2 - v2 = BI.snd hd2 - in - if k1 == k2 - then - if eqV v1 v2 - then goBoth tl1 tl2 - else False - else - if is0 v1 - then goBoth tl1 l2 - else + goBoth l1 l2 = + B.matchList + l1 + -- null l1 case + ( \() -> + B.matchList + l2 + -- null l2 case + (\() -> True) + -- non-null l2 case + (\_ _ -> Map.all is0 (Map.unsafeFromBuiltinList l2 :: Map BuiltinData BuiltinData)) + ) + -- non-null l1 case + ( \hd1 tl1 -> + B.matchList + l2 + -- null l2 case + (\() -> Map.all is0 (Map.unsafeFromBuiltinList l1 :: Map BuiltinData BuiltinData)) + -- non-null l2 case + ( \hd2 tl2 -> + let + k1 = BI.fst hd1 + v1 = BI.snd hd1 + k2 = BI.fst hd2 + v2 = BI.snd hd2 + in + if k1 == k2 + then + if eqV v1 v2 + then goBoth tl1 tl2 + else False + else + if is0 v1 + then goBoth tl1 l2 + else + let + goRight + :: BuiltinList (BuiltinPair BuiltinData BuiltinData) + -> BuiltinList (BuiltinPair BuiltinData BuiltinData) + -> Bool + goRight acc l = + B.matchList + l + -- null l case + (\() -> False) + -- non-null l case + ( \hd tl -> let - goRight - :: BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> Bool - goRight acc l = - B.matchList - l - -- null l case - (\() -> False) - -- non-null l case - ( \hd tl -> - let - k = BI.fst hd - v = BI.snd hd - in - if is0 v - then goRight acc tl - else - if k == k1 - then - if eqV v1 v - then goBoth tl1 (revAppend' acc tl) - else False - else goRight (hd `BI.mkCons` acc) tl - ) - in - goRight - ( if is0 v2 - then BI.mkNilPairData BI.unitval - else hd2 `BI.mkCons` BI.mkNilPairData BI.unitval - ) - tl2 - ) + k = BI.fst hd + v = BI.snd hd + in + if is0 v + then goRight acc tl + else + if k == k1 + then + if eqV v1 v + then goBoth tl1 (revAppend' acc tl) + else False + else goRight (hd `BI.mkCons` acc) tl + ) + in + goRight + ( if is0 v2 + then BI.mkNilPairData BI.unitval + else hd2 `BI.mkCons` BI.mkNilPairData BI.unitval + ) + tl2 ) - - revAppend' = rev - where - rev l acc = - B.matchList - l - (\() -> acc) - ( \hd tl -> - rev tl (hd `BI.mkCons` acc) - ) -{-# INLINABLE unordEqWith #-} - + ) + + revAppend' = rev + where + rev l acc = + B.matchList + l + (\() -> acc) + ( \hd tl -> + rev tl (hd `BI.mkCons` acc) + ) +{-# INLINEABLE unordEqWith #-} -- | Check equality of two maps of maps indexed by 'CurrencySymbol's, + --- given a function checking whether a value is zero and a function -- checking equality of values. eqMapOfMapsWith - :: (Map TokenName Integer -> Bool) - -> (Map TokenName Integer -> Map TokenName Integer -> Bool) - -> Map CurrencySymbol (Map TokenName Integer) - -> Map CurrencySymbol (Map TokenName Integer) - -> Bool + :: (Map TokenName Integer -> Bool) + -> (Map TokenName Integer -> Map TokenName Integer -> Bool) + -> Map CurrencySymbol (Map TokenName Integer) + -> Map CurrencySymbol (Map TokenName Integer) + -> Bool eqMapOfMapsWith is0 eqV map1 map2 = - let xs1 = Map.toBuiltinList map1 - xs2 = Map.toBuiltinList map2 - is0' v = is0 (unsafeFromBuiltinData v) - eqV' v1 v2 = eqV (unsafeFromBuiltinData v1) (unsafeFromBuiltinData v2) - in unordEqWith is0' eqV' xs1 xs2 -{-# INLINABLE eqMapOfMapsWith #-} - --- | Check equality of two 'Map Token Integer's given a function checking whether a value is zero and a function --- checking equality of values. + let xs1 = Map.toBuiltinList map1 + xs2 = Map.toBuiltinList map2 + is0' v = is0 (unsafeFromBuiltinData v) + eqV' v1 v2 = eqV (unsafeFromBuiltinData v1) (unsafeFromBuiltinData v2) + in unordEqWith is0' eqV' xs1 xs2 +{-# INLINEABLE eqMapOfMapsWith #-} + +{-| Check equality of two 'Map Token Integer's given a function checking whether a value is zero and a function +checking equality of values. +-} eqMapWith - :: (Integer -> Bool) - -> (Integer -> Integer -> Bool) - -> Map TokenName Integer - -> Map TokenName Integer - -> Bool + :: (Integer -> Bool) + -> (Integer -> Integer -> Bool) + -> Map TokenName Integer + -> Map TokenName Integer + -> Bool eqMapWith is0 eqV map1 map2 = - let xs1 = Map.toBuiltinList map1 - xs2 = Map.toBuiltinList map2 - is0' v = is0 (unsafeFromBuiltinData v) - eqV' v1 v2 = eqV (unsafeFromBuiltinData v1) (unsafeFromBuiltinData v2) - in unordEqWith is0' eqV' xs1 xs2 -{-# INLINABLE eqMapWith #-} - --- | Check equality of two 'Value's. Does not assume orderness of lists within a 'Value' or a lack --- of empty values (such as a token whose quantity is zero or a currency that has a bunch of such --- tokens or no tokens at all), but does assume that no currencies or tokens within a single --- currency have multiple entries. + let xs1 = Map.toBuiltinList map1 + xs2 = Map.toBuiltinList map2 + is0' v = is0 (unsafeFromBuiltinData v) + eqV' v1 v2 = eqV (unsafeFromBuiltinData v1) (unsafeFromBuiltinData v2) + in unordEqWith is0' eqV' xs1 xs2 +{-# INLINEABLE eqMapWith #-} + +{-| Check equality of two 'Value's. Does not assume orderness of lists within a 'Value' or a lack +of empty values (such as a token whose quantity is zero or a currency that has a bunch of such +tokens or no tokens at all), but does assume that no currencies or tokens within a single +currency have multiple entries. +-} eq :: Value -> Value -> Bool eq (Value currs1) (Value currs2) = - eqMapOfMapsWith (Map.all (0 ==)) (eqMapWith (0 ==) (==)) currs1 currs2 -{-# INLINABLE eq #-} + eqMapOfMapsWith (Map.all (0 ==)) (eqMapWith (0 ==) (==)) currs1 currs2 +{-# INLINEABLE eq #-} -newtype Lovelace = Lovelace { getLovelace :: Integer } +newtype Lovelace = Lovelace {getLovelace :: Integer} deriving stock (Generic, Typeable) deriving (Pretty) via (PrettyShow Lovelace) deriving anyclass (HasBlueprintDefinition) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Contexts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Contexts.hs index 2fab9aa1d47..28bcc8a8111 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Contexts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Contexts.hs @@ -1,41 +1,45 @@ --- editorconfig-checker-disable-file {-# LANGUAGE DerivingVia #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} - {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} -{-# OPTIONS_GHC -fno-strictness #-} -{-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} -module PlutusLedgerApi.V2.Data.Contexts - ( - -- * Pending transactions and related types - TxInfo(..) - , ScriptContext(..) - , ScriptPurpose(..) - , TxId (..) - , TxOut(..) - , TxOutRef(..) - , TxInInfo(..) - , findOwnInput - , findDatum - , findDatumHash - , findTxInByTxOutRef - , findContinuingOutputs - , getContinuingOutputs - -- * Validator functions - , pubKeyOutputsAt - , valuePaidTo - , spendsOutput - , txSignedBy - , valueSpent - , valueProduced - , ownCurrencySymbol - ) where +module PlutusLedgerApi.V2.Data.Contexts ( + -- * Pending transactions and related types + TxInfo (..), + ScriptContext (..), + ScriptPurpose (..), + TxId (..), + TxOut, + pattern TxOut, + txOutAddress, + txOutValue, + txOutDatum, + txOutReferenceScript, + TxOutRef (..), + TxInInfo (..), + findOwnInput, + findDatum, + findDatumHash, + findTxInByTxOutRef, + findContinuingOutputs, + getContinuingOutputs, + + -- * Validator functions + pubKeyOutputsAt, + valuePaidTo, + spendsOutput, + txSignedBy, + valueSpent, + valueProduced, + ownCurrencySymbol, +) where import GHC.Generics (Generic) import PlutusTx @@ -45,178 +49,246 @@ import PlutusTx.Data.List qualified as Data.List import PlutusTx.Prelude hiding (toList) import Prettyprinter (Pretty (..), nest, vsep, (<+>)) -import PlutusLedgerApi.V1.Address (Address (..)) -import PlutusLedgerApi.V1.Credential (Credential (..), StakingCredential) import PlutusLedgerApi.V1.Crypto (PubKeyHash (..)) +import PlutusLedgerApi.V1.Data.Address (pattern Address) import PlutusLedgerApi.V1.Data.Contexts (ScriptPurpose (..)) +import PlutusLedgerApi.V1.Data.Credential (StakingCredential, pattern PubKeyCredential) import PlutusLedgerApi.V1.Data.Value (CurrencySymbol, Value) import PlutusLedgerApi.V1.DCert (DCert (..)) import PlutusLedgerApi.V1.Scripts import PlutusLedgerApi.V1.Time (POSIXTimeRange) -import PlutusLedgerApi.V2.Data.Tx (TxId (..), TxOut (..), TxOutRef (..)) +import PlutusLedgerApi.V2.Data.Tx (TxId (..), TxOut, TxOutRef (..), pattern TxOut, txOutAddress, + txOutDatum, txOutReferenceScript, txOutValue) import Prelude qualified as Haskell -- | An input of a pending transaction. data TxInInfo = TxInInfo - { txInInfoOutRef :: TxOutRef - , txInInfoResolved :: TxOut - } deriving stock (Generic, Haskell.Show, Haskell.Eq) + { txInInfoOutRef :: TxOutRef + , txInInfoResolved :: TxOut + } + deriving stock (Generic, Haskell.Show, Haskell.Eq) makeLift ''TxInInfo -makeIsDataIndexed ''TxInInfo [('TxInInfo,0)] +makeIsDataIndexed ''TxInInfo [('TxInInfo, 0)] instance Eq TxInInfo where - TxInInfo ref res == TxInInfo ref' res' = ref == ref' && res == res' + TxInInfo ref res == TxInInfo ref' res' = ref == ref' && res == res' instance Pretty TxInInfo where - pretty TxInInfo{txInInfoOutRef, txInInfoResolved} = - pretty txInInfoOutRef <+> "->" <+> pretty txInInfoResolved + pretty TxInInfo{txInInfoOutRef, txInInfoResolved} = + pretty txInInfoOutRef <+> "->" <+> pretty txInInfoResolved --- | A pending transaction. This is the view as seen by validator scripts, so some details are stripped out. +{-| A pending transaction. This is the view as seen by validator scripts, +so some details are stripped out. +-} data TxInfo = TxInfo - { txInfoInputs :: List TxInInfo -- ^ Transaction inputs; cannot be an empty list - , txInfoReferenceInputs :: List TxInInfo -- ^ /Added in V2:/ Transaction reference inputs - , txInfoOutputs :: List TxOut -- ^ Transaction outputs - , txInfoFee :: Value -- ^ The fee paid by this transaction. - , txInfoMint :: Value -- ^ The 'Value' minted by this transaction. - , txInfoDCert :: List DCert -- ^ Digests of certificates included in this transaction - , txInfoWdrl :: Map StakingCredential Integer -- ^ Withdrawals - -- /V1->V2/: changed from assoc list to a 'PlutusTx.AssocMap' - , txInfoValidRange :: POSIXTimeRange -- ^ The valid range for the transaction. - , txInfoSignatories :: List PubKeyHash -- ^ Signatures provided with the transaction, attested that they all signed the tx - , txInfoRedeemers :: Map ScriptPurpose Redeemer -- ^ /Added in V2:/ a table of redeemers attached to the transaction - , txInfoData :: Map DatumHash Datum -- ^ The lookup table of datums attached to the transaction - -- /V1->V2/: changed from assoc list to a 'PlutusTx.AssocMap' - , txInfoId :: TxId -- ^ Hash of the pending transaction body (i.e. transaction excluding witnesses) - } deriving stock (Generic, Haskell.Show) + { txInfoInputs :: List TxInInfo + -- ^ Transaction inputs; cannot be an empty list + , txInfoReferenceInputs :: List TxInInfo + -- ^ /Added in V2:/ Transaction reference inputs + , txInfoOutputs :: List TxOut + -- ^ Transaction outputs + , txInfoFee :: Value + -- ^ The fee paid by this transaction. + , txInfoMint :: Value + -- ^ The 'Value' minted by this transaction. + , txInfoDCert :: List DCert + -- ^ Digests of certificates included in this transaction + , txInfoWdrl :: Map StakingCredential Integer + -- ^ Withdrawals + -- /V1->V2/: changed from assoc list to a 'PlutusTx.AssocMap' + , txInfoValidRange :: POSIXTimeRange + -- ^ The valid range for the transaction. + , txInfoSignatories :: List PubKeyHash + -- ^ Signatures provided with the transaction, attested that they all signed the tx + , txInfoRedeemers :: Map ScriptPurpose Redeemer + -- ^ /Added in V2:/ a table of redeemers attached to the transaction + , txInfoData :: Map DatumHash Datum + -- ^ The lookup table of datums attached to the transaction + -- /V1->V2/: changed from assoc list to a 'PlutusTx.AssocMap' + , txInfoId :: TxId + -- ^ Hash of the pending transaction body (i.e. transaction excluding witnesses) + } + deriving stock (Generic, Haskell.Show) makeLift ''TxInfo -makeIsDataIndexed ''TxInfo [('TxInfo,0)] +makeIsDataIndexed ''TxInfo [('TxInfo, 0)] instance Pretty TxInfo where - pretty TxInfo{txInfoInputs, txInfoReferenceInputs, txInfoOutputs, txInfoFee, txInfoMint, txInfoDCert, txInfoWdrl, txInfoValidRange, txInfoSignatories, txInfoRedeemers, txInfoData, txInfoId} = - vsep - [ "TxId:" <+> pretty txInfoId - , "Inputs:" <+> pretty txInfoInputs - , "Reference inputs:" <+> pretty txInfoReferenceInputs - , "Outputs:" <+> pretty txInfoOutputs - , "Fee:" <+> pretty txInfoFee - , "Value minted:" <+> pretty txInfoMint - , "DCerts:" <+> pretty txInfoDCert - , "Wdrl:" <+> pretty txInfoWdrl - , "Valid range:" <+> pretty txInfoValidRange - , "Signatories:" <+> pretty txInfoSignatories - , "Redeemers:" <+> pretty txInfoRedeemers - , "Datums:" <+> pretty txInfoData - ] + pretty + TxInfo + { txInfoInputs + , txInfoReferenceInputs + , txInfoOutputs + , txInfoFee + , txInfoMint + , txInfoDCert + , txInfoWdrl + , txInfoValidRange + , txInfoSignatories + , txInfoRedeemers + , txInfoData + , txInfoId + } = + vsep + [ "TxId:" <+> pretty txInfoId + , "Inputs:" <+> pretty txInfoInputs + , "Reference inputs:" <+> pretty txInfoReferenceInputs + , "Outputs:" <+> pretty txInfoOutputs + , "Fee:" <+> pretty txInfoFee + , "Value minted:" <+> pretty txInfoMint + , "DCerts:" <+> pretty txInfoDCert + , "Wdrl:" <+> pretty txInfoWdrl + , "Valid range:" <+> pretty txInfoValidRange + , "Signatories:" <+> pretty txInfoSignatories + , "Redeemers:" <+> pretty txInfoRedeemers + , "Datums:" <+> pretty txInfoData + ] -- | The context that the currently-executing script can access. data ScriptContext = ScriptContext - { scriptContextTxInfo :: TxInfo -- ^ information about the transaction the currently-executing script is included in - , scriptContextPurpose :: ScriptPurpose -- ^ the purpose of the currently-executing script - } - deriving stock (Generic, Haskell.Show) + { scriptContextTxInfo :: TxInfo + -- ^ information about the transaction the currently-executing script is included in + , scriptContextPurpose :: ScriptPurpose + -- ^ the purpose of the currently-executing script + } + deriving stock (Generic, Haskell.Show) makeLift ''ScriptContext -makeIsDataIndexed ''ScriptContext [('ScriptContext,0)] +makeIsDataIndexed ''ScriptContext [('ScriptContext, 0)] instance Pretty ScriptContext where - pretty ScriptContext{scriptContextTxInfo, scriptContextPurpose} = - vsep - [ "Purpose:" <+> pretty scriptContextPurpose - , nest 2 $ vsep ["TxInfo:", pretty scriptContextTxInfo] - ] + pretty ScriptContext{scriptContextTxInfo, scriptContextPurpose} = + vsep + [ "Purpose:" <+> pretty scriptContextPurpose + , nest 2 $ vsep ["TxInfo:", pretty scriptContextTxInfo] + ] -- | Find the input currently being validated. findOwnInput :: ScriptContext -> Maybe TxInInfo -findOwnInput ScriptContext{scriptContextTxInfo=TxInfo{txInfoInputs}, scriptContextPurpose=Spending txOutRef} = - Data.List.find (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == txOutRef) txInfoInputs +findOwnInput + ScriptContext + { scriptContextTxInfo = TxInfo{txInfoInputs} + , scriptContextPurpose = Spending txOutRef + } = + Data.List.find + (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == txOutRef) + txInfoInputs findOwnInput _ = Nothing -{-# INLINABLE findOwnInput #-} +{-# INLINEABLE findOwnInput #-} -- | Find the data corresponding to a data hash, if there is one findDatum :: DatumHash -> TxInfo -> Maybe Datum findDatum dsh TxInfo{txInfoData} = lookup dsh txInfoData -{-# INLINABLE findDatum #-} +{-# INLINEABLE findDatum #-} --- | Find the hash of a datum, if it is part of the pending transaction's --- hashes +{-| Find the hash of a datum, if it is part of the pending transaction's +hashes +-} findDatumHash :: Datum -> TxInfo -> Maybe DatumHash findDatumHash ds TxInfo{txInfoData} = fst <$> find f (toList txInfoData) - where - f (_, ds') = ds' == ds -{-# INLINABLE findDatumHash #-} + where + f (_, ds') = ds' == ds +{-# INLINEABLE findDatumHash #-} -{-| Given a UTXO reference and a transaction (`TxInfo`), resolve it to one of the transaction's inputs (`TxInInfo`). -Note: this only searches the true transaction inputs and not the referenced transaction inputs. +{-| Given a UTXO reference and a transaction (`TxInfo`), resolve it to one +of the transaction's inputs (`TxInInfo`). +Note: this only searches the true transaction inputs and not the referenced +transaction inputs. -} findTxInByTxOutRef :: TxOutRef -> TxInfo -> Maybe TxInInfo findTxInByTxOutRef outRef TxInfo{txInfoInputs} = - Data.List.find (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == outRef) txInfoInputs -{-# INLINABLE findTxInByTxOutRef #-} + Data.List.find + (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == outRef) + txInfoInputs +{-# INLINEABLE findTxInByTxOutRef #-} --- | Find the indices of all the outputs that pay to the same script address we are currently spending from, if any. +{-| Find the indices of all the outputs that pay to the same script address +we are currently spending from, if any. +-} findContinuingOutputs :: ScriptContext -> List Integer -findContinuingOutputs ctx | Just TxInInfo{txInInfoResolved=TxOut{txOutAddress}} <- findOwnInput ctx = Data.List.findIndices (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx) - where - f addr TxOut{txOutAddress=otherAddress} = addr == otherAddress +findContinuingOutputs ctx + | Just + TxInInfo + { txInInfoResolved = TxOut{txOutAddress = addr} + } <- + findOwnInput ctx = + Data.List.findIndices (f addr) (txInfoOutputs $ scriptContextTxInfo ctx) + where + f addr TxOut{txOutAddress = otherAddress} = addr == otherAddress findContinuingOutputs _ = traceError "Le" -- "Can't find any continuing outputs" -{-# INLINABLE findContinuingOutputs #-} +{-# INLINEABLE findContinuingOutputs #-} --- | Get all the outputs that pay to the same script address we are currently spending from, if any. +{-| Get all the outputs that pay to the same script address we are currently spending +from, if any. +-} getContinuingOutputs :: ScriptContext -> List TxOut -getContinuingOutputs ctx | Just TxInInfo{txInInfoResolved=TxOut{txOutAddress}} <- findOwnInput ctx = Data.List.filter (f txOutAddress) (txInfoOutputs $ scriptContextTxInfo ctx) - where - f addr TxOut{txOutAddress=otherAddress} = addr == otherAddress +getContinuingOutputs ctx + | Just + TxInInfo + { txInInfoResolved = TxOut{txOutAddress = addr} + } <- + findOwnInput ctx = + Data.List.filter (f addr) (txInfoOutputs $ scriptContextTxInfo ctx) + where + f addr TxOut{txOutAddress = otherAddress} = addr == otherAddress getContinuingOutputs _ = traceError "Lf" -- "Can't get any continuing outputs" -{-# INLINABLE getContinuingOutputs #-} +{-# INLINEABLE getContinuingOutputs #-} -- | Check if a transaction was signed by the given public key. txSignedBy :: TxInfo -> PubKeyHash -> Bool -txSignedBy TxInfo{txInfoSignatories} k = case Data.List.find ((==) k) txInfoSignatories of +txSignedBy TxInfo{txInfoSignatories} k = + case Data.List.find ((==) k) txInfoSignatories of Just _ -> True Nothing -> False -{-# INLINABLE txSignedBy #-} +{-# INLINEABLE txSignedBy #-} -- | Get the values paid to a public key address by a pending transaction. pubKeyOutputsAt :: PubKeyHash -> TxInfo -> List Value pubKeyOutputsAt pk p = - let flt TxOut{txOutAddress = Address (PubKeyCredential pk') _, txOutValue} | pk == pk' = Just txOutValue - flt _ = Nothing - in Data.List.mapMaybe flt (txInfoOutputs p) -{-# INLINABLE pubKeyOutputsAt #-} + let flt + TxOut + { txOutAddress = Address (PubKeyCredential pk') _ + , txOutValue = txOutVal + } | pk == pk' = Just txOutVal + flt _ = Nothing + in Data.List.mapMaybe flt (txInfoOutputs p) +{-# INLINEABLE pubKeyOutputsAt #-} -- | Get the total value paid to a public key address by a pending transaction. valuePaidTo :: TxInfo -> PubKeyHash -> Value valuePaidTo ptx pkh = Data.List.mconcat (pubKeyOutputsAt pkh ptx) -{-# INLINABLE valuePaidTo #-} +{-# INLINEABLE valuePaidTo #-} -- | Get the total value of inputs spent by this transaction. valueSpent :: TxInfo -> Value valueSpent = Data.List.foldMap (txOutValue . txInInfoResolved) . txInfoInputs -{-# INLINABLE valueSpent #-} +{-# INLINEABLE valueSpent #-} -- | Get the total value of outputs produced by this transaction. valueProduced :: TxInfo -> Value valueProduced = Data.List.foldMap txOutValue . txInfoOutputs -{-# INLINABLE valueProduced #-} +{-# INLINEABLE valueProduced #-} -- | The 'CurrencySymbol' of the current validator script. ownCurrencySymbol :: ScriptContext -> CurrencySymbol -ownCurrencySymbol ScriptContext{scriptContextPurpose=Minting cs} = cs -ownCurrencySymbol _ = traceError "Lh" -- "Can't get currency symbol of the current validator script" -{-# INLINABLE ownCurrencySymbol #-} +ownCurrencySymbol ScriptContext{scriptContextPurpose = Minting cs} = cs +ownCurrencySymbol _ = + traceError "Lh" -- "Can't get currency symbol of the current validator script" +{-# INLINEABLE ownCurrencySymbol #-} -{- | Check if the pending transaction spends a specific transaction output +{-| Check if the pending transaction spends a specific transaction output (identified by the hash of a transaction and an index into that transactions' outputs) -} spendsOutput :: TxInfo -> TxId -> Integer -> Bool spendsOutput p h i = - let spendsOutRef inp = - let outRef = txInInfoOutRef inp - in h == txOutRefId outRef - && i == txOutRefIdx outRef - in Data.List.any spendsOutRef (txInfoInputs p) -{-# INLINABLE spendsOutput #-} + let spendsOutRef inp = + let outRef = txInInfoOutRef inp + in h + == txOutRefId outRef + && i + == txOutRefIdx outRef + in Data.List.any spendsOutRef (txInfoInputs p) +{-# INLINEABLE spendsOutput #-} diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Tx.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Tx.hs index 42c5f390a64..3903026121f 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Tx.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Tx.hs @@ -1,36 +1,43 @@ --- editorconfig-checker-disable-file {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -module PlutusLedgerApi.V2.Data.Tx - ( - -- * Transactions - TxId (..) - , ScriptTag (..) - , RedeemerPtr (..) - , Redeemers - -- * Transaction outputs - , TxOut(..) - , TxOutRef(..) - , OutputDatum (..) - , isPubKeyOut - , isPayToScriptOut - , outAddress - , outValue - , txOutPubKey - , outDatum - , outReferenceScript - , pubKeyHashTxOut - ) where +module PlutusLedgerApi.V2.Data.Tx ( + -- * Transactions + TxId (..), + ScriptTag (..), + RedeemerPtr (..), + Redeemers, + + -- * Transaction outputs + TxOut, + pattern TxOut, + txOutAddress, + txOutValue, + txOutDatum, + txOutReferenceScript, + TxOutRef (..), + OutputDatum, + pattern NoOutputDatum, + pattern OutputDatumHash, + pattern OutputDatum, + isPubKeyOut, + isPayToScriptOut, + outAddress, + outValue, + txOutPubKey, + outDatum, + outReferenceScript, + pubKeyHashTxOut, +) where import Control.DeepSeq (NFData) import Control.Lens @@ -39,83 +46,113 @@ import GHC.Generics (Generic) import Prettyprinter import PlutusTx qualified +import PlutusTx.AsData qualified as PlutusTx import PlutusTx.Bool qualified as PlutusTx import PlutusTx.Eq qualified as PlutusTx -import PlutusLedgerApi.V1.Address import PlutusLedgerApi.V1.Crypto +import PlutusLedgerApi.V1.Data.Address import PlutusLedgerApi.V1.Data.Tx hiding (TxOut (..), isPayToScriptOut, isPubKeyOut, outAddress, outValue, pubKeyHashTxOut, txOutDatum, txOutPubKey) import PlutusLedgerApi.V1.Data.Value import PlutusLedgerApi.V1.Scripts --- | The datum attached to an output: either nothing; a datum hash; or the datum itself (an "inline datum"). -data OutputDatum = NoOutputDatum | OutputDatumHash DatumHash | OutputDatum Datum - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) +{-| The datum attached to an output: either nothing; a datum hash; +or the datum itself (an "inline datum"). +-} +PlutusTx.asData + [d| + data OutputDatum = NoOutputDatum | OutputDatumHash DatumHash | OutputDatum Datum + deriving stock (Show, Eq, Generic) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + deriving anyclass (NFData) + |] instance PlutusTx.Eq OutputDatum where - {-# INLINABLE (==) #-} - NoOutputDatum == NoOutputDatum = True - (OutputDatumHash dh) == (OutputDatumHash dh') = dh PlutusTx.== dh' - (OutputDatum d) == (OutputDatum d') = d PlutusTx.== d' - _ == _ = False + {-# INLINEABLE (==) #-} + NoOutputDatum == NoOutputDatum = True + (OutputDatumHash dh) == (OutputDatumHash dh') = dh PlutusTx.== dh' + (OutputDatum d) == (OutputDatum d') = d PlutusTx.== d' + _ == _ = False instance Pretty OutputDatum where - pretty NoOutputDatum = "no datum" - pretty (OutputDatumHash dh) = "datum hash: " <+> pretty dh - pretty (OutputDatum d) = "inline datum : " <+> pretty d - --- | A transaction output, consisting of a target address, a value, --- optionally a datum/datum hash, and optionally a reference script. -data TxOut = TxOut { - txOutAddress :: Address, - txOutValue :: Value, - txOutDatum :: OutputDatum, - txOutReferenceScript :: Maybe ScriptHash - } - deriving stock (Show, Eq, Generic) + pretty NoOutputDatum = "no datum" + pretty (OutputDatumHash dh) = "datum hash: " <+> pretty dh + pretty (OutputDatum d) = "inline datum : " <+> pretty d + +{-| A transaction output, consisting of a target address, a value, +optionally a datum/datum hash, and optionally a reference script. +-} +PlutusTx.asData + [d| + data TxOut = TxOut + { txOutAddress :: Address + , txOutValue :: Value + , txOutDatum :: OutputDatum + , txOutReferenceScript :: Maybe ScriptHash + } + deriving stock (Show, Eq, Generic) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + |] instance Pretty TxOut where - pretty TxOut{txOutAddress, txOutValue, txOutDatum, txOutReferenceScript} = - hang 2 $ vsep ["-" <+> pretty txOutValue <+> "addressed to", pretty txOutAddress, "with datum", pretty txOutDatum, "with referenceScript", pretty txOutReferenceScript] + pretty TxOut{txOutAddress, txOutValue, txOutDatum, txOutReferenceScript} = + hang 2 $ + vsep + [ "-" <+> pretty txOutValue <+> "addressed to" + , pretty txOutAddress + , "with datum" + , pretty txOutDatum + , "with referenceScript" + , pretty txOutReferenceScript + ] instance PlutusTx.Eq TxOut where - {-# INLINABLE (==) #-} - (TxOut txOutAddress txOutValue txOutDatum txOutRefScript) == (TxOut txOutAddress' txOutValue' txOutDatum' txOutRefScript') = - txOutAddress PlutusTx.== txOutAddress' - PlutusTx.&& txOutValue PlutusTx.== txOutValue' - PlutusTx.&& txOutDatum PlutusTx.== txOutDatum' - PlutusTx.&& txOutRefScript PlutusTx.== txOutRefScript' + {-# INLINEABLE (==) #-} + (TxOut txOutAddress1 txOutValue1 txOutDatum1 txOutRefScript1) + == (TxOut txOutAddress2 txOutValue2 txOutDatum2 txOutRefScript2) = + txOutAddress1 + PlutusTx.== txOutAddress2 + PlutusTx.&& txOutValue1 + PlutusTx.== txOutValue2 + PlutusTx.&& txOutDatum1 + PlutusTx.== txOutDatum2 + PlutusTx.&& txOutRefScript1 + PlutusTx.== txOutRefScript2 -- | The public key attached to a 'TxOut', if there is one. txOutPubKey :: TxOut -> Maybe PubKeyHash -txOutPubKey TxOut{txOutAddress} = toPubKeyHash txOutAddress +txOutPubKey = toPubKeyHash . txOutAddress -- | The validator hash attached to a 'TxOut', if there is one. txOutScriptHash :: TxOut -> Maybe ScriptHash -txOutScriptHash TxOut{txOutAddress} = toScriptHash txOutAddress +txOutScriptHash = toScriptHash . txOutAddress -- | The address of a transaction output. outAddress :: Lens' TxOut Address -outAddress = lens txOutAddress s where - s tx a = tx { txOutAddress = a } +outAddress = lens txOutAddress s + where + s tx a = tx{txOutAddress = a} -- | The datum attached to a 'TxOut'. outDatum :: Lens' TxOut OutputDatum -outDatum = lens txOutDatum s where - s tx v = tx { txOutDatum = v } +outDatum = lens txOutDatum s + where + s tx v = tx{txOutDatum = v} --- | The value of a transaction output. --- | TODO: Compute address again +{-| The value of a transaction output. +| TODO: Compute address again +-} outValue :: Lens' TxOut Value -outValue = lens txOutValue s where - s tx v = tx { txOutValue = v } +outValue = lens txOutValue s + where + s tx v = tx{txOutValue = v} -- | The reference script attached to a 'TxOut'. outReferenceScript :: Lens' TxOut (Maybe ScriptHash) -outReferenceScript = lens txOutReferenceScript s where - s tx v = tx { txOutReferenceScript = v } +outReferenceScript = lens txOutReferenceScript s + where + s tx v = tx{txOutReferenceScript = v} -- | Whether the output is a pay-to-pubkey output. isPubKeyOut :: TxOut -> Bool @@ -129,7 +166,5 @@ isPayToScriptOut = isJust . txOutScriptHash pubKeyHashTxOut :: Value -> PubKeyHash -> TxOut pubKeyHashTxOut v pkh = TxOut (pubKeyHashAddress pkh) v NoOutputDatum Nothing -PlutusTx.makeIsDataIndexed ''OutputDatum [('NoOutputDatum,0), ('OutputDatumHash,1), ('OutputDatum,2)] PlutusTx.makeLift ''OutputDatum -PlutusTx.makeIsDataIndexed ''TxOut [('TxOut,0)] PlutusTx.makeLift ''TxOut diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Contexts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Contexts.hs index 2637e740ff4..9a0e59f6467 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Contexts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Contexts.hs @@ -1,62 +1,143 @@ --- editorconfig-checker-disable-file {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-strictness #-} -module PlutusLedgerApi.V3.Data.Contexts - ( ColdCommitteeCredential (..) - , HotCommitteeCredential (..) - , DRepCredential (..) - , DRep (..) - , Delegatee (..) - , TxCert (..) - , Voter (..) - , Vote (..) - , GovernanceActionId (..) - , Committee (..) - , Constitution (..) - , ProtocolVersion (..) - , ChangedParameters (..) - , GovernanceAction (..) - , ProposalProcedure (..) - , ScriptPurpose (..) - , ScriptInfo (..) - , TxInInfo (..) - , TxInfo (..) - , ScriptContext (..) - , findOwnInput - , findDatum - , findDatumHash - , findTxInByTxOutRef - , findContinuingOutputs - , getContinuingOutputs - , txSignedBy - - -- * Validator functions - , pubKeyOutputsAt - , valuePaidTo - , valueSpent - , valueProduced - , ownCurrencySymbol - , spendsOutput - ) where +module PlutusLedgerApi.V3.Data.Contexts ( + ColdCommitteeCredential (..), + HotCommitteeCredential (..), + DRepCredential (..), + DRep, + pattern DRep, + pattern DRepAlwaysAbstain, + pattern DRepAlwaysNoConfidence, + Delegatee, + pattern DelegStake, + pattern DelegVote, + pattern DelegStakeVote, + TxCert, + pattern TxCertRegStaking, + pattern TxCertUnRegStaking, + pattern TxCertDelegStaking, + pattern TxCertRegDeleg, + pattern TxCertRegDRep, + pattern TxCertUpdateDRep, + pattern TxCertUnRegDRep, + pattern TxCertPoolRegister, + pattern TxCertPoolRetire, + pattern TxCertAuthHotCommittee, + pattern TxCertResignColdCommittee, + Voter, + pattern CommitteeVoter, + pattern DRepVoter, + pattern StakePoolVoter, + Vote, + pattern VoteNo, + pattern VoteYes, + pattern Abstain, + GovernanceActionId, + pattern GovernanceActionId, + gaidTxId, + gaidGovActionIx, + Committee, + pattern Committee, + committeeMembers, + committeeQuorum, + Constitution (..), + ProtocolVersion, + pattern ProtocolVersion, + pvMajor, + pvMinor, + ChangedParameters (..), + GovernanceAction, + pattern ParameterChange, + pattern HardForkInitiation, + pattern TreasuryWithdrawals, + pattern NoConfidence, + pattern UpdateCommittee, + pattern NewConstitution, + pattern InfoAction, + ProposalProcedure, + pattern ProposalProcedure, + ppDeposit, + ppReturnAddr, + ppGovernanceAction, + ScriptPurpose, + pattern Minting, + pattern Spending, + pattern Rewarding, + pattern Certifying, + pattern Voting, + pattern Proposing, + ScriptInfo, + pattern MintingScript, + pattern SpendingScript, + pattern RewardingScript, + pattern CertifyingScript, + pattern VotingScript, + pattern ProposingScript, + TxInInfo, + pattern TxInInfo, + txInInfoOutRef, + txInInfoResolved, + TxInfo, + pattern TxInfo, + txInfoInputs, + txInfoReferenceInputs, + txInfoOutputs, + txInfoFee, + txInfoMint, + txInfoTxCerts, + txInfoWdrl, + txInfoValidRange, + txInfoSignatories, + txInfoRedeemers, + txInfoData, + txInfoId, + txInfoVotes, + txInfoProposalProcedures, + txInfoCurrentTreasuryAmount, + txInfoTreasuryDonation, + ScriptContext, + pattern ScriptContext, + scriptContextTxInfo, + scriptContextRedeemer, + scriptContextScriptInfo, + findOwnInput, + findDatum, + findDatumHash, + findTxInByTxOutRef, + findContinuingOutputs, + getContinuingOutputs, + txSignedBy, + + -- * Validator functions + pubKeyOutputsAt, + valuePaidTo, + valueSpent, + valueProduced, + ownCurrencySymbol, + spendsOutput, +) where import GHC.Generics (Generic) import Prettyprinter (nest, vsep, (<+>)) import Prettyprinter.Extras import PlutusLedgerApi.Data.V2 qualified as V2 -import PlutusLedgerApi.V3.Tx qualified as V3 +import PlutusLedgerApi.V3.Data.Tx qualified as V3 import PlutusTx qualified +import PlutusTx.AsData qualified as PlutusTx import PlutusTx.Data.AssocMap import PlutusTx.Data.List (List) import PlutusTx.Data.List qualified as Data.List @@ -107,20 +188,18 @@ newtype DRepCredential = DRepCredential V2.Credential PlutusTx.makeLift ''DRepCredential -data DRep - = DRep DRepCredential - | DRepAlwaysAbstain - | DRepAlwaysNoConfidence - deriving stock (Generic, Haskell.Show, Haskell.Eq) - deriving (Pretty) via (PrettyShow DRep) +PlutusTx.asData + [d| + data DRep + = DRep DRepCredential + | DRepAlwaysAbstain + | DRepAlwaysNoConfidence + deriving stock (Generic, Haskell.Show, Haskell.Eq) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + deriving (Pretty) via (PrettyShow DRep) + |] PlutusTx.makeLift ''DRep -PlutusTx.makeIsDataIndexed - ''DRep - [ ('DRep, 0) - , ('DRepAlwaysAbstain, 1) - , ('DRepAlwaysNoConfidence, 2) - ] instance PlutusTx.Eq DRep where {-# INLINEABLE (==) #-} @@ -129,20 +208,18 @@ instance PlutusTx.Eq DRep where DRepAlwaysNoConfidence == DRepAlwaysNoConfidence = Haskell.True _ == _ = Haskell.False -data Delegatee - = DelegStake V2.PubKeyHash - | DelegVote DRep - | DelegStakeVote V2.PubKeyHash DRep - deriving stock (Generic, Haskell.Show, Haskell.Eq) - deriving (Pretty) via (PrettyShow Delegatee) +PlutusTx.asData + [d| + data Delegatee + = DelegStake V2.PubKeyHash + | DelegVote DRep + | DelegStakeVote V2.PubKeyHash DRep + deriving stock (Generic, Haskell.Show, Haskell.Eq) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + deriving (Pretty) via (PrettyShow Delegatee) + |] PlutusTx.makeLift ''Delegatee -PlutusTx.makeIsDataIndexed - ''Delegatee - [ ('DelegStake, 0) - , ('DelegVote, 1) - , ('DelegStakeVote, 2) - ] instance PlutusTx.Eq Delegatee where {-# INLINEABLE (==) #-} @@ -152,51 +229,41 @@ instance PlutusTx.Eq Delegatee where a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' _ == _ = Haskell.False -data TxCert - = -- | Register staking credential with an optional deposit amount - TxCertRegStaking V2.Credential (Haskell.Maybe V2.Lovelace) - | -- | Un-Register staking credential with an optional refund amount - TxCertUnRegStaking V2.Credential (Haskell.Maybe V2.Lovelace) - | -- | Delegate staking credential to a Delegatee - TxCertDelegStaking V2.Credential Delegatee - | -- | Register and delegate staking credential to a Delegatee in one certificate. Noter that - -- deposit is mandatory. - TxCertRegDeleg V2.Credential Delegatee V2.Lovelace - | -- | Register a DRep with a deposit value. The optional anchor is omitted. - TxCertRegDRep DRepCredential V2.Lovelace - | -- | Update a DRep. The optional anchor is omitted. - TxCertUpdateDRep DRepCredential - | -- | UnRegister a DRep with mandatory refund value - TxCertUnRegDRep DRepCredential V2.Lovelace - | -- | A digest of the PoolParams - TxCertPoolRegister - V2.PubKeyHash - -- ^ poolId - V2.PubKeyHash - -- ^ pool VFR - | -- | The retirement certificate and the Epoch in which the retirement will take place - TxCertPoolRetire V2.PubKeyHash Haskell.Integer - | -- | Authorize a Hot credential for a specific Committee member's cold credential - TxCertAuthHotCommittee ColdCommitteeCredential HotCommitteeCredential - | TxCertResignColdCommittee ColdCommitteeCredential - deriving stock (Generic, Haskell.Show, Haskell.Eq) - deriving (Pretty) via (PrettyShow TxCert) +PlutusTx.asData + [d| + data TxCert + = -- \| Register staking credential with an optional deposit amount + TxCertRegStaking V2.Credential (Haskell.Maybe V2.Lovelace) + | -- \| Un-Register staking credential with an optional refund amount + TxCertUnRegStaking V2.Credential (Haskell.Maybe V2.Lovelace) + | -- \| Delegate staking credential to a Delegatee + TxCertDelegStaking V2.Credential Delegatee + | -- \| Register and delegate staking credential to a Delegatee in one certificate. Noter that + -- deposit is mandatory. + TxCertRegDeleg V2.Credential Delegatee V2.Lovelace + | -- \| Register a DRep with a deposit value. The optional anchor is omitted. + TxCertRegDRep DRepCredential V2.Lovelace + | -- \| Update a DRep. The optional anchor is omitted. + TxCertUpdateDRep DRepCredential + | -- \| UnRegister a DRep with mandatory refund value + TxCertUnRegDRep DRepCredential V2.Lovelace + | -- \| A digest of the PoolParams + TxCertPoolRegister + V2.PubKeyHash + -- \^ poolId + V2.PubKeyHash + | -- \^ pool VFR + -- \| The retirement certificate and the Epoch in which the retirement will take place + TxCertPoolRetire V2.PubKeyHash Haskell.Integer + | -- \| Authorize a Hot credential for a specific Committee member's cold credential + TxCertAuthHotCommittee ColdCommitteeCredential HotCommitteeCredential + | TxCertResignColdCommittee ColdCommitteeCredential + deriving stock (Generic, Haskell.Show, Haskell.Eq) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + deriving (Pretty) via (PrettyShow TxCert) + |] PlutusTx.makeLift ''TxCert -PlutusTx.makeIsDataIndexed - ''TxCert - [ ('TxCertRegStaking, 0) - , ('TxCertUnRegStaking, 1) - , ('TxCertDelegStaking, 2) - , ('TxCertRegDeleg, 3) - , ('TxCertRegDRep, 4) - , ('TxCertUpdateDRep, 5) - , ('TxCertUnRegDRep, 6) - , ('TxCertPoolRegister, 7) - , ('TxCertPoolRetire, 8) - , ('TxCertAuthHotCommittee, 9) - , ('TxCertResignColdCommittee, 10) - ] instance PlutusTx.Eq TxCert where {-# INLINEABLE (==) #-} @@ -220,20 +287,18 @@ instance PlutusTx.Eq TxCert where a PlutusTx.== a' _ == _ = Haskell.False -data Voter - = CommitteeVoter HotCommitteeCredential - | DRepVoter DRepCredential - | StakePoolVoter V2.PubKeyHash - deriving stock (Generic, Haskell.Show, Haskell.Eq) - deriving (Pretty) via (PrettyShow Voter) +PlutusTx.asData + [d| + data Voter + = CommitteeVoter HotCommitteeCredential + | DRepVoter DRepCredential + | StakePoolVoter V2.PubKeyHash + deriving stock (Generic, Haskell.Show, Haskell.Eq) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + deriving (Pretty) via (PrettyShow Voter) + |] PlutusTx.makeLift ''Voter -PlutusTx.makeIsDataIndexed - ''Voter - [ ('CommitteeVoter, 0) - , ('DRepVoter, 1) - , ('StakePoolVoter, 2) - ] instance PlutusTx.Eq Voter where {-# INLINEABLE (==) #-} @@ -246,20 +311,18 @@ instance PlutusTx.Eq Voter where _ == _ = Haskell.False -- | A vote. The optional anchor is omitted. -data Vote - = VoteNo - | VoteYes - | Abstain - deriving stock (Generic, Haskell.Show, Haskell.Eq) - deriving (Pretty) via (PrettyShow Vote) +PlutusTx.asData + [d| + data Vote + = VoteNo + | VoteYes + | Abstain + deriving stock (Generic, Haskell.Show, Haskell.Eq) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + deriving (Pretty) via (PrettyShow Vote) + |] PlutusTx.makeLift ''Vote -PlutusTx.makeIsDataIndexed - ''Vote - [ ('VoteNo, 0) - , ('VoteYes, 1) - , ('Abstain, 2) - ] instance PlutusTx.Eq Vote where {-# INLINEABLE (==) #-} @@ -269,14 +332,17 @@ instance PlutusTx.Eq Vote where _ == _ = Haskell.False -- | Similar to TxOutRef, but for GovActions -data GovernanceActionId = GovernanceActionId - { gaidTxId :: V3.TxId - , gaidGovActionIx :: Haskell.Integer - } - deriving stock (Generic, Haskell.Show, Haskell.Eq) +PlutusTx.asData + [d| + data GovernanceActionId = GovernanceActionId + { gaidTxId :: V3.TxId + , gaidGovActionIx :: Haskell.Integer + } + deriving stock (Generic, Haskell.Show, Haskell.Eq) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + |] PlutusTx.makeLift ''GovernanceActionId -PlutusTx.makeIsDataIndexed ''GovernanceActionId [('GovernanceActionId, 0)] instance Pretty GovernanceActionId where pretty GovernanceActionId{..} = @@ -290,16 +356,20 @@ instance PlutusTx.Eq GovernanceActionId where GovernanceActionId a b == GovernanceActionId a' b' = a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' -data Committee = Committee - { committeeMembers :: Map ColdCommitteeCredential Haskell.Integer - -- ^ Committee members with epoch number when each of them expires - , committeeQuorum :: PlutusTx.Rational - -- ^ Quorum of the committee that is necessary for a successful vote - } - deriving stock (Generic, Haskell.Show) +PlutusTx.asData + [d| + data Committee = Committee + { committeeMembers :: Map ColdCommitteeCredential Haskell.Integer + , -- \^ Committee members with epoch number when each of them expires + committeeQuorum :: PlutusTx.Rational + } + -- \^ Quorum of the committee that is necessary for a successful vote + + deriving stock (Generic, Haskell.Show) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + |] PlutusTx.makeLift ''Committee -PlutusTx.makeIsDataIndexed ''Committee [('Committee, 0)] instance Pretty Committee where pretty Committee{..} = @@ -325,14 +395,17 @@ instance PlutusTx.Eq Constitution where {-# INLINEABLE (==) #-} Constitution a == Constitution a' = a PlutusTx.== a' -data ProtocolVersion = ProtocolVersion - { pvMajor :: Haskell.Integer - , pvMinor :: Haskell.Integer - } - deriving stock (Generic, Haskell.Show, Haskell.Eq) +PlutusTx.asData + [d| + data ProtocolVersion = ProtocolVersion + { pvMajor :: Haskell.Integer + , pvMinor :: Haskell.Integer + } + deriving stock (Generic, Haskell.Show, Haskell.Eq) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + |] PlutusTx.makeLift ''ProtocolVersion -PlutusTx.makeIsDataIndexed ''ProtocolVersion [('ProtocolVersion, 0)] instance Pretty ProtocolVersion where pretty ProtocolVersion{..} = @@ -346,12 +419,12 @@ instance PlutusTx.Eq ProtocolVersion where ProtocolVersion a b == ProtocolVersion a' b' = a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' -{- | A Plutus Data object containing proposed parameter changes. The Data object contains +{-| A Plutus Data object containing proposed parameter changes. The Data object contains a @Map@ with one entry per changed parameter, from the parameter ID to the new value. Unchanged parameters are not included. The mapping from parameter IDs to parameters can be found in -[conway.cddl](https://github.com/IntersectMBO/cardano-ledger/blob/master/eras/conway/impl/cddl-files/conway.cddl). +[conway.cddl](https://github.com/IntersectMBO/cardano-ledger/blob/master/eras/conway/impl/cddl-files/conway.cddl). -- editorconfig-checker-disable-file /Invariant:/ This map is non-empty, and the keys are stored in ascending order. -} @@ -369,49 +442,51 @@ newtype ChangedParameters = ChangedParameters {getChangedParameters :: PlutusTx. PlutusTx.makeLift ''ChangedParameters -data GovernanceAction - = ParameterChange - (Haskell.Maybe GovernanceActionId) - ChangedParameters - (Haskell.Maybe V2.ScriptHash) -- ^ Hash of the constitution script - | -- | proposal to update protocol version - HardForkInitiation (Haskell.Maybe GovernanceActionId) ProtocolVersion - | TreasuryWithdrawals - (Map V2.Credential V2.Lovelace) - (Haskell.Maybe V2.ScriptHash) -- ^ Hash of the constitution script - | NoConfidence (Haskell.Maybe GovernanceActionId) - | UpdateCommittee - (Haskell.Maybe GovernanceActionId) - (List ColdCommitteeCredential) -- ^ Committee members to be removed - (Map ColdCommitteeCredential Haskell.Integer) -- ^ Committee members to be added - Rational -- ^ New quorum - | NewConstitution (Haskell.Maybe GovernanceActionId) Constitution - | InfoAction - deriving stock (Generic, Haskell.Show) - deriving (Pretty) via (PrettyShow GovernanceAction) +PlutusTx.asData + [d| + data GovernanceAction + = ParameterChange + (Haskell.Maybe GovernanceActionId) + ChangedParameters + (Haskell.Maybe V2.ScriptHash) + | -- \^ Hash of the constitution script + -- \| proposal to update protocol version + HardForkInitiation (Haskell.Maybe GovernanceActionId) ProtocolVersion + | TreasuryWithdrawals + (Map V2.Credential V2.Lovelace) + (Haskell.Maybe V2.ScriptHash) + | -- \^ Hash of the constitution script + NoConfidence (Haskell.Maybe GovernanceActionId) + | UpdateCommittee + (Haskell.Maybe GovernanceActionId) + (List ColdCommitteeCredential) + -- \^ Committee members to be removed + (Map ColdCommitteeCredential Haskell.Integer) + -- \^ Committee members to be added + Rational + | -- \^ New quorum + NewConstitution (Haskell.Maybe GovernanceActionId) Constitution + | InfoAction + deriving stock (Generic, Haskell.Show) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + deriving (Pretty) via (PrettyShow GovernanceAction) + |] PlutusTx.makeLift ''GovernanceAction -PlutusTx.makeIsDataIndexed - ''GovernanceAction - [ ('ParameterChange, 0) - , ('HardForkInitiation, 1) - , ('TreasuryWithdrawals, 2) - , ('NoConfidence, 3) - , ('UpdateCommittee, 4) - , ('NewConstitution, 5) - , ('InfoAction, 6) - ] -- | A proposal procedure. The optional anchor is omitted. -data ProposalProcedure = ProposalProcedure - { ppDeposit :: V2.Lovelace - , ppReturnAddr :: V2.Credential - , ppGovernanceAction :: GovernanceAction - } - deriving stock (Generic, Haskell.Show) +PlutusTx.asData + [d| + data ProposalProcedure = ProposalProcedure + { ppDeposit :: V2.Lovelace + , ppReturnAddr :: V2.Credential + , ppGovernanceAction :: GovernanceAction + } + deriving stock (Generic, Haskell.Show) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + |] PlutusTx.makeLift ''ProposalProcedure -PlutusTx.makeIsDataIndexed ''ProposalProcedure [('ProposalProcedure, 0)] instance Pretty ProposalProcedure where pretty ProposalProcedure{..} = @@ -422,70 +497,63 @@ instance Pretty ProposalProcedure where ] -- | A `ScriptPurpose` uniquely identifies a Plutus script within a transaction. -data ScriptPurpose - = Minting V2.CurrencySymbol - | Spending V3.TxOutRef - | Rewarding V2.Credential - | Certifying - Haskell.Integer - -- ^ 0-based index of the given `TxCert` in `txInfoTxCerts` - TxCert - | Voting Voter - | Proposing - Haskell.Integer - -- ^ 0-based index of the given `ProposalProcedure` in `txInfoProposalProcedures` - ProposalProcedure - deriving stock (Generic, Haskell.Show) - deriving (Pretty) via (PrettyShow ScriptPurpose) +PlutusTx.asData + [d| + data ScriptPurpose + = Minting V2.CurrencySymbol + | Spending V3.TxOutRef + | Rewarding V2.Credential + | Certifying + Haskell.Integer + -- \^ 0-based index of the given `TxCert` in `txInfoTxCerts` + TxCert + | Voting Voter + | Proposing + Haskell.Integer + -- \^ 0-based index of the given `ProposalProcedure` in `txInfoProposalProcedures` + ProposalProcedure + deriving stock (Generic, Haskell.Show) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + deriving (Pretty) via (PrettyShow ScriptPurpose) + |] PlutusTx.makeLift ''ScriptPurpose -PlutusTx.makeIsDataIndexed - ''ScriptPurpose - [ ('Minting, 0) - , ('Spending, 1) - , ('Rewarding, 2) - , ('Certifying, 3) - , ('Voting, 4) - , ('Proposing, 5) - ] -- | Like `ScriptPurpose` but with an optional datum for spending scripts. -data ScriptInfo - = MintingScript V2.CurrencySymbol - | SpendingScript V3.TxOutRef (Haskell.Maybe V2.Datum) - | RewardingScript V2.Credential - | CertifyingScript - Haskell.Integer - -- ^ 0-based index of the given `TxCert` in `txInfoTxCerts` - TxCert - | VotingScript Voter - | ProposingScript - Haskell.Integer - -- ^ 0-based index of the given `ProposalProcedure` in `txInfoProposalProcedures` - ProposalProcedure - deriving stock (Generic, Haskell.Show) - deriving (Pretty) via (PrettyShow ScriptInfo) +PlutusTx.asData + [d| + data ScriptInfo + = MintingScript V2.CurrencySymbol + | SpendingScript V3.TxOutRef (Haskell.Maybe V2.Datum) + | RewardingScript V2.Credential + | CertifyingScript + Haskell.Integer + -- \^ 0-based index of the given `TxCert` in `txInfoTxCerts` + TxCert + | VotingScript Voter + | ProposingScript + Haskell.Integer + -- \^ 0-based index of the given `ProposalProcedure` in `txInfoProposalProcedures` + ProposalProcedure + deriving stock (Generic, Haskell.Show) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + deriving (Pretty) via (PrettyShow ScriptInfo) + |] PlutusTx.makeLift ''ScriptInfo -PlutusTx.makeIsDataIndexed - ''ScriptInfo - [ ('MintingScript, 0) - , ('SpendingScript, 1) - , ('RewardingScript, 2) - , ('CertifyingScript, 3) - , ('VotingScript, 4) - , ('ProposingScript, 5) - ] -- | An input of a pending transaction. -data TxInInfo = TxInInfo - { txInInfoOutRef :: V3.TxOutRef - , txInInfoResolved :: V2.TxOut - } - deriving stock (Generic, Haskell.Show, Haskell.Eq) +PlutusTx.asData + [d| + data TxInInfo = TxInInfo + { txInInfoOutRef :: V3.TxOutRef + , txInInfoResolved :: V2.TxOut + } + deriving stock (Generic, Haskell.Show, Haskell.Eq) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + |] PlutusTx.makeLift ''TxInInfo -PlutusTx.makeIsDataIndexed ''TxInInfo [('TxInInfo, 0)] instance PlutusTx.Eq TxInInfo where TxInInfo ref res == TxInInfo ref' res' = @@ -496,47 +564,54 @@ instance Pretty TxInInfo where pretty txInInfoOutRef <+> "->" <+> pretty txInInfoResolved -- | TxInfo for PlutusV3 -data TxInfo = TxInfo - { txInfoInputs :: List TxInInfo - , txInfoReferenceInputs :: List TxInInfo - , txInfoOutputs :: List V2.TxOut - , txInfoFee :: V2.Lovelace - , txInfoMint :: V2.Value - -- ^ The 'Value' minted by this transaction. - -- - -- /Invariant:/ This field does not contain Ada with zero quantity, unlike - -- their namesakes in Plutus V1 and V2's ScriptContexts. - , txInfoTxCerts :: List TxCert - , txInfoWdrl :: Map V2.Credential V2.Lovelace - , txInfoValidRange :: V2.POSIXTimeRange - , txInfoSignatories :: List V2.PubKeyHash - , txInfoRedeemers :: Map ScriptPurpose V2.Redeemer - , txInfoData :: Map V2.DatumHash V2.Datum - , txInfoId :: V3.TxId - , txInfoVotes :: Map Voter (Map GovernanceActionId Vote) - , txInfoProposalProcedures :: List ProposalProcedure - , txInfoCurrentTreasuryAmount :: Haskell.Maybe V2.Lovelace - , txInfoTreasuryDonation :: Haskell.Maybe V2.Lovelace - } - deriving stock (Generic, Haskell.Show) +PlutusTx.asData + [d| + data TxInfo = TxInfo + { txInfoInputs :: List TxInInfo + , txInfoReferenceInputs :: List TxInInfo + , txInfoOutputs :: List V2.TxOut + , txInfoFee :: V2.Lovelace + , txInfoMint :: V2.Value + , -- \^ The 'Value' minted by this transaction. + -- + -- /Invariant:/ This field does not contain Ada with zero quantity, unlike + -- their namesakes in Plutus V1 and V2's ScriptContexts. + txInfoTxCerts :: List TxCert + , txInfoWdrl :: Map V2.Credential V2.Lovelace + , txInfoValidRange :: V2.POSIXTimeRange + , txInfoSignatories :: List V2.PubKeyHash + , txInfoRedeemers :: Map ScriptPurpose V2.Redeemer + , txInfoData :: Map V2.DatumHash V2.Datum + , txInfoId :: V3.TxId + , txInfoVotes :: Map Voter (Map GovernanceActionId Vote) + , txInfoProposalProcedures :: List ProposalProcedure + , txInfoCurrentTreasuryAmount :: Haskell.Maybe V2.Lovelace + , txInfoTreasuryDonation :: Haskell.Maybe V2.Lovelace + } + deriving stock (Generic, Haskell.Show) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + |] PlutusTx.makeLift ''TxInfo -PlutusTx.makeIsDataIndexed ''TxInfo [('TxInfo, 0)] -- | The context that the currently-executing script can access. -data ScriptContext = ScriptContext - { scriptContextTxInfo :: TxInfo - -- ^ information about the transaction the currently-executing script is included in - , scriptContextRedeemer :: V2.Redeemer - -- ^ Redeemer for the currently-executing script - , scriptContextScriptInfo :: ScriptInfo - -- ^ the purpose of the currently-executing script, along with information associated - -- with the purpose - } - deriving stock (Generic, Haskell.Show) +PlutusTx.asData + [d| + data ScriptContext = ScriptContext + { scriptContextTxInfo :: TxInfo + , -- \^ information about the transaction the currently-executing script is included in + scriptContextRedeemer :: V2.Redeemer + , -- \^ Redeemer for the currently-executing script + scriptContextScriptInfo :: ScriptInfo + } + -- \^ the purpose of the currently-executing script, along with information associated + -- with the purpose + + deriving stock (Generic, Haskell.Show) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + |] PlutusTx.makeLift ''ScriptContext -PlutusTx.makeIsDataIndexed ''ScriptContext [('ScriptContext, 0)] {-# INLINEABLE findOwnInput #-} @@ -560,18 +635,18 @@ findDatum dsh TxInfo{txInfoData} = lookup dsh txInfoData {-# INLINEABLE findDatumHash #-} -{- | Find the hash of a datum, if it is part of the pending transaction's +{-| Find the hash of a datum, if it is part of the pending transaction's hashes -} findDatumHash :: V2.Datum -> TxInfo -> Haskell.Maybe V2.DatumHash findDatumHash ds TxInfo{txInfoData} = PlutusTx.fst PlutusTx.<$> PlutusTx.find f (toList txInfoData) - where - f (_, ds') = ds' PlutusTx.== ds + where + f (_, ds') = ds' PlutusTx.== ds {-# INLINEABLE findTxInByTxOutRef #-} -{- | Given a UTXO reference and a transaction (`TxInfo`), resolve it to one of the +{-| Given a UTXO reference and a transaction (`TxInfo`), resolve it to one of the transaction's inputs (`TxInInfo`). Note: this only searches the true transaction inputs and not the referenced transaction inputs. @@ -584,7 +659,7 @@ findTxInByTxOutRef outRef TxInfo{txInfoInputs} = {-# INLINEABLE findContinuingOutputs #-} -{- | Find the indices of all the outputs that pay to the same script address we are +{-| Find the indices of all the outputs that pay to the same script address we are currently spending from, if any. -} findContinuingOutputs :: ScriptContext -> List Haskell.Integer @@ -594,13 +669,13 @@ findContinuingOutputs ctx Data.List.findIndices (f txOutAddress) (txInfoOutputs (scriptContextTxInfo ctx)) - where - f addr V2.TxOut{txOutAddress = otherAddress} = addr PlutusTx.== otherAddress + where + f addr V2.TxOut{txOutAddress = otherAddress} = addr PlutusTx.== otherAddress findContinuingOutputs _ = PlutusTx.traceError "Le" -- "Can't find any continuing outputs" {-# INLINEABLE getContinuingOutputs #-} -{- | Get all the outputs that pay to the same script address we are currently spending +{-| Get all the outputs that pay to the same script address we are currently spending from, if any. -} getContinuingOutputs :: ScriptContext -> List V2.TxOut @@ -608,8 +683,8 @@ getContinuingOutputs ctx | Haskell.Just TxInInfo{txInInfoResolved = V2.TxOut{txOutAddress}} <- findOwnInput ctx = Data.List.filter (f txOutAddress) (txInfoOutputs (scriptContextTxInfo ctx)) - where - f addr V2.TxOut{txOutAddress = otherAddress} = addr PlutusTx.== otherAddress + where + f addr V2.TxOut{txOutAddress = otherAddress} = addr PlutusTx.== otherAddress getContinuingOutputs _ = PlutusTx.traceError "Lf" -- "Can't get any continuing outputs" {-# INLINEABLE txSignedBy #-} @@ -660,7 +735,7 @@ ownCurrencySymbol _ = {-# INLINEABLE spendsOutput #-} -{- | Check if the pending transaction spends a specific transaction output +{-| Check if the pending transaction spends a specific transaction output (identified by the hash of a transaction and an index into that transactions' outputs) -} @@ -668,12 +743,12 @@ spendsOutput :: TxInfo -> V3.TxId -> Haskell.Integer -> Haskell.Bool spendsOutput txInfo txId i = let spendsOutRef inp = let outRef = txInInfoOutRef inp - in txId PlutusTx.== V3.txOutRefId outRef - PlutusTx.&& i PlutusTx.== V3.txOutRefIdx outRef + in txId + PlutusTx.== V3.txOutRefId outRef + PlutusTx.&& i + PlutusTx.== V3.txOutRefIdx outRef in Data.List.any spendsOutRef (txInfoInputs txInfo) - - instance Pretty TxInfo where pretty TxInfo{..} = vsep diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Tx.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Tx.hs new file mode 100644 index 00000000000..84c4f7f5f9b --- /dev/null +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Tx.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-specialise #-} + +module PlutusLedgerApi.V3.Data.Tx ( + TxId (..), + TxOutRef, + pattern TxOutRef, + txOutRefId, + txOutRefIdx, +) where + +import Control.DeepSeq (NFData) +import Data.Function ((&)) +import Data.String (IsString) +import GHC.Generics (Generic) +import PlutusLedgerApi.V1.Bytes (LedgerBytes (..)) +import PlutusTx qualified +import PlutusTx.AsData qualified as PlutusTx +import PlutusTx.Blueprint.Class (HasBlueprintSchema (..)) +import PlutusTx.Blueprint.Definition (HasBlueprintDefinition) +import PlutusTx.Blueprint.Schema (withSchemaInfo) +import PlutusTx.Blueprint.Schema.Annotation (SchemaInfo (..)) +import PlutusTx.Bool qualified as PlutusTx +import PlutusTx.Builtins.Internal qualified as PlutusTx +import PlutusTx.Eq qualified as PlutusTx +import PlutusTx.IsData.Class (FromData, ToData, UnsafeFromData) +import PlutusTx.Lift (makeLift) +import PlutusTx.Ord qualified as PlutusTx +import Prettyprinter (Pretty, pretty) + +{-| A transaction ID, i.e. the hash of a transaction. Hashed with BLAKE2b-256. 32 byte. + +This is a simple type without any validation, __use with caution__. +You may want to add checks for its invariants. See the Shelley ledger specification. +-} +newtype TxId = TxId {getTxId :: PlutusTx.BuiltinByteString} + deriving stock (Eq, Ord, Generic) + deriving anyclass (NFData, HasBlueprintDefinition) + deriving newtype (PlutusTx.Eq, PlutusTx.Ord, ToData, FromData, UnsafeFromData) + deriving + ( IsString + -- ^ from hex encoding + , Show + -- ^ using hex encoding + , Pretty + -- ^ using hex encoding + ) + via LedgerBytes + +instance HasBlueprintSchema TxId referencedTypes where + schema = + schema @PlutusTx.BuiltinByteString + & withSchemaInfo \info -> + info{title = Just "TxId"} + +{-| A reference to a transaction output. This is a +pair of a transaction ID (`TxId`), and an index indicating which of the outputs +of that transaction we are referring to. +-} +PlutusTx.asData + [d| + data TxOutRef = TxOutRef + { txOutRefId :: TxId + , -- \^ The transaction ID. + txOutRefIdx :: Integer + } + -- \^ Index into the referenced transaction's outputs + + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) + deriving anyclass (NFData, HasBlueprintDefinition) + |] + +instance Pretty TxOutRef where + pretty TxOutRef{txOutRefId = id', txOutRefIdx = idx} = pretty id' <> "!" <> pretty idx + +instance PlutusTx.Eq TxOutRef where + {-# INLINEABLE (==) #-} + l == r = + (txOutRefId l PlutusTx.== txOutRefId r) + PlutusTx.&& (txOutRefIdx l PlutusTx.== txOutRefIdx r) + +---------------------------------------------------------------------------------------------------- +-- TH Splices -------------------------------------------------------------------------------------- + +$(makeLift ''TxId) +$(makeLift ''TxOutRef) diff --git a/plutus-ledger-api/test/Spec.hs b/plutus-ledger-api/test/Spec.hs index 772faf953f5..3255e2a12dc 100644 --- a/plutus-ledger-api/test/Spec.hs +++ b/plutus-ledger-api/test/Spec.hs @@ -11,7 +11,6 @@ import PlutusPrelude import Spec.CBOR.DeserialiseFailureInfo qualified import Spec.ContextDecoding qualified import Spec.CostModelParams qualified -import Spec.Data.ContextDecoding qualified import Spec.Data.CostModelParams qualified import Spec.Data.Eval qualified import Spec.Data.Versions qualified @@ -33,116 +32,142 @@ main :: IO () main = defaultMain tests v1_evalCtxForTesting :: V1.EvaluationContext -v1_evalCtxForTesting = fst $ unsafeFromRight $ runWriterT $ V1.mkEvaluationContext (fmap snd V1.costModelParamsForTesting) +v1_evalCtxForTesting = + fst $ unsafeFromRight $ runWriterT $ V1.mkEvaluationContext (fmap snd V1.costModelParamsForTesting) --- | Constructing a V3 context with the first 223 parameters. --- As a result, the cost model parameters for `integerToByteString` and `byteStringToInteger` --- should be set to large numbers, preventing them from being used. +{-| Constructing a V3 context with the first 223 parameters. +As a result, the cost model parameters for `integerToByteString` and `byteStringToInteger` +should be set to large numbers, preventing them from being used. +-} v3_evalCtxTooFewParams :: V3.EvaluationContext -v3_evalCtxTooFewParams = fst $ unsafeFromRight $ runWriterT $ V3.mkEvaluationContext (take 223 $ fmap snd V3.costModelParamsForTesting) +v3_evalCtxTooFewParams = + fst $ + unsafeFromRight $ + runWriterT $ + V3.mkEvaluationContext (take 223 $ fmap snd V3.costModelParamsForTesting) alwaysTrue :: TestTree -alwaysTrue = testCase "always true script returns true" $ +alwaysTrue = + testCase "always true script returns true" $ let script = either (error . show) id $ V1.deserialiseScript alonzoPV (alwaysSucceedingNAryFunction 2) (_, res) = V1.evaluateScriptCounting alonzoPV V1.Quiet v1_evalCtxForTesting script [I 1, I 2] - in assertBool "succeeds" (isRight res) + in assertBool "succeeds" (isRight res) alwaysFalse :: TestTree -alwaysFalse = testCase "always false script returns false" $ +alwaysFalse = + testCase "always false script returns false" $ let script = either (error . show) id $ V1.deserialiseScript alonzoPV (alwaysFailingNAryFunction 2) (_, res) = V1.evaluateScriptCounting alonzoPV V1.Quiet v1_evalCtxForTesting script [I 1, I 2] - in assertBool "fails" (isLeft res) + in assertBool "fails" (isLeft res) unavailableBuiltins :: TestTree -unavailableBuiltins = testCase "builtins are unavailable before Alonzo" $ +unavailableBuiltins = + testCase "builtins are unavailable before Alonzo" $ let res = V1.deserialiseScript maryPV summingFunction - in assertBool "fails" (isLeft res) + in assertBool "fails" (isLeft res) availableBuiltins :: TestTree -availableBuiltins = testCase "builtins are available after Alonzo" $ +availableBuiltins = + testCase "builtins are available after Alonzo" $ let res = V1.deserialiseScript alonzoPV summingFunction - in assertBool "succeeds" (isRight res) + in assertBool "succeeds" (isRight res) integerToByteStringExceedsBudget :: TestTree -integerToByteStringExceedsBudget = testCase "integerToByteString should exceed budget" $ +integerToByteStringExceedsBudget = + testCase "integerToByteString should exceed budget" $ let script = either (error . show) id $ V3.deserialiseScript changPV integerToByteStringFunction (_, res) = V3.evaluateScriptCounting changPV V3.Quiet v3_evalCtxTooFewParams script (I 1) - in case res of - Left _ -> assertFailure "fails" - Right (ExBudget cpu _mem) -> assertBool "did not exceed budget" (cpu >= fromIntegral (maxBound :: Int64)) + in case res of + Left _ -> assertFailure "fails" + Right (ExBudget cpu _mem) -> assertBool "did not exceed budget" (cpu >= fromIntegral (maxBound :: Int64)) saltedFunction :: TestTree saltedFunction = - let evaluate ss ss' args = - let s = either (error . show) id $ V1.deserialiseScript alonzoPV ss - s' = either (error . show) id $ V1.deserialiseScript alonzoPV ss' - in ( V1.evaluateScriptCounting alonzoPV V1.Quiet v1_evalCtxForTesting s args - , V1.evaluateScriptCounting alonzoPV V1.Quiet v1_evalCtxForTesting s' args - ) - in testGroup "salted function" - [ testProperty "saturated" $ \(n :: Word8) salt fWhich -> - let f = (if fWhich then alwaysSucceedingNAryFunction else alwaysFailingNAryFunction) $ fromInteger $ toInteger n - f' = saltFunction salt f - args = replicate (fromEnum n) $ I 1 - ((_, res), (_, res')) = evaluate f f' args - in cover 25 (isRight res) "success" $ - cover 25 (isLeft res) "fail" $ - void res === void res' - .&&. fWhich === isRight res - , testProperty "unsaturated" $ \(n :: Word8) (n' :: Word8) salt fWhich -> - let f = (if fWhich then alwaysSucceedingNAryFunction else alwaysFailingNAryFunction) $ - fromInteger (toInteger n) + fromInteger (toInteger n') + 1 - f' = saltFunction salt f - args = replicate (fromEnum n) $ I 1 - ((_, res), (_, res')) = evaluate f f' args - in cover 25 (isRight res) "success" $ - void res === void res' - , testProperty "oversaturated" $ \(n :: Word8) (n' :: Word8) salt fWhich -> - let f = (if fWhich then alwaysSucceedingNAryFunction else alwaysFailingNAryFunction) $ - fromInteger (toInteger n) - f' = saltFunction salt f - args = replicate (fromEnum n + fromEnum n' + 1) $ I 1 - ((_, res), (_, res')) = evaluate f f' args - in cover 25 (isLeft res) "fail" $ - void res === void res' - , testProperty "salt" $ \(n :: Word8) salt salt' fWhich -> - let f = (if fWhich then alwaysSucceedingNAryFunction else alwaysFailingNAryFunction) $ fromInteger $ toInteger n - f' = saltFunction salt f - f'' = saltFunction salt' f - in salt /= salt' ==> f' /= f'' - ] - + let evaluate ss ss' args = + let s = either (error . show) id $ V1.deserialiseScript alonzoPV ss + s' = either (error . show) id $ V1.deserialiseScript alonzoPV ss' + in ( V1.evaluateScriptCounting alonzoPV V1.Quiet v1_evalCtxForTesting s args + , V1.evaluateScriptCounting alonzoPV V1.Quiet v1_evalCtxForTesting s' args + ) + in testGroup + "salted function" + [ testProperty "saturated" $ \(n :: Word8) salt fWhich -> + let f = + (if fWhich then alwaysSucceedingNAryFunction else alwaysFailingNAryFunction) $ + fromInteger $ + toInteger n + f' = saltFunction salt f + args = replicate (fromEnum n) $ I 1 + ((_, res), (_, res')) = evaluate f f' args + in cover 25 (isRight res) "success" $ + cover 25 (isLeft res) "fail" $ + void res + === void res' + .&&. fWhich + === isRight res + , testProperty "unsaturated" $ \(n :: Word8) (n' :: Word8) salt fWhich -> + let f = + (if fWhich then alwaysSucceedingNAryFunction else alwaysFailingNAryFunction) $ + fromInteger (toInteger n) + fromInteger (toInteger n') + 1 + f' = saltFunction salt f + args = replicate (fromEnum n) $ I 1 + ((_, res), (_, res')) = evaluate f f' args + in cover 25 (isRight res) "success" $ + void res === void res' + , testProperty "oversaturated" $ \(n :: Word8) (n' :: Word8) salt fWhich -> + let f = + (if fWhich then alwaysSucceedingNAryFunction else alwaysFailingNAryFunction) $ + fromInteger (toInteger n) + f' = saltFunction salt f + args = replicate (fromEnum n + fromEnum n' + 1) $ I 1 + ((_, res), (_, res')) = evaluate f f' args + in cover 25 (isLeft res) "fail" $ + void res === void res' + , testProperty "salt" $ \(n :: Word8) salt salt' fWhich -> + let f = + (if fWhich then alwaysSucceedingNAryFunction else alwaysFailingNAryFunction) $ + fromInteger $ + toInteger n + f' = saltFunction salt f + f'' = saltFunction salt' f + in salt /= salt' ==> f' /= f'' + ] tests :: TestTree -tests = testGroup "plutus-ledger-api" - [ testGroup "basic evaluation tests" - [ - alwaysTrue - , alwaysFalse - , saltedFunction - , unavailableBuiltins - , availableBuiltins - , integerToByteStringExceedsBudget - ] - , testGroup "Common" - [ Spec.Interval.tests - , Spec.CBOR.DeserialiseFailureInfo.tests - , Spec.ScriptDecodeError.tests - ] - , testGroup "Context-dependent tests" - [ testGroup "Original" - [ Spec.Eval.tests - , Spec.Versions.tests - , Spec.CostModelParams.tests - , Spec.ContextDecoding.tests - , Value.test_Value +tests = + testGroup + "plutus-ledger-api" + [ testGroup + "basic evaluation tests" + [ alwaysTrue + , alwaysFalse + , saltedFunction + , unavailableBuiltins + , availableBuiltins + , integerToByteStringExceedsBudget + ] + , testGroup + "Common" + [ Spec.Interval.tests + , Spec.CBOR.DeserialiseFailureInfo.tests + , Spec.ScriptDecodeError.tests ] - , testGroup "Data" - [ Spec.Data.Eval.tests - , Spec.Data.Versions.tests - , Spec.Data.CostModelParams.tests - , Spec.Data.ContextDecoding.tests - , Data.Value.test_Value + , testGroup + "Context-dependent tests" + [ testGroup + "Original" + [ Spec.Eval.tests + , Spec.Versions.tests + , Spec.CostModelParams.tests + , Spec.ContextDecoding.tests + , Value.test_Value + ] + , testGroup + "Data" + [ Spec.Data.Eval.tests + , Spec.Data.Versions.tests + , Spec.Data.CostModelParams.tests + , Data.Value.test_Value + ] ] - ] ] diff --git a/plutus-ledger-api/test/Spec/Data/ContextDecoding.hs b/plutus-ledger-api/test/Spec/Data/ContextDecoding.hs deleted file mode 100644 index 9e7720bbe0f..00000000000 --- a/plutus-ledger-api/test/Spec/Data/ContextDecoding.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -module Spec.Data.ContextDecoding where - -import Codec.Serialise qualified as S -import Data.ByteString.Lazy as BSL -import Data.Maybe -import PlutusCore.Data -import PlutusLedgerApi.Data.V1 qualified as V1 -import PlutusLedgerApi.Data.V2 qualified as V2 -import PlutusLedgerApi.Data.V3 qualified as V3 -import PlutusTx.IsData -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = testGroup "context decoding" [ test_v1Context ] - -test_v1Context :: TestTree -test_v1Context = testCase "v1context" $ do - input <- BSL.readFile "test/Spec/v1-context-data" - let (d :: Data) = S.deserialise input - assertBool "can't parse as V1 context" - (isJust $ fromBuiltinData @V1.ScriptContext (V1.BuiltinData d)) - -- Note, these should return Nothing and not throw - assertBool "can parse as V2 context" - (isNothing $ fromBuiltinData @V2.ScriptContext (V2.BuiltinData d)) - assertBool "can parse as V3 context" - (isNothing $ fromBuiltinData @V3.ScriptContext (V3.BuiltinData d))