diff --git a/plutus-benchmark/cardano-loans/src/CardanoLoans/Test.hs b/plutus-benchmark/cardano-loans/src/CardanoLoans/Test.hs index 5c53694190c..353b7fbc78c 100644 --- a/plutus-benchmark/cardano-loans/src/CardanoLoans/Test.hs +++ b/plutus-benchmark/cardano-loans/src/CardanoLoans/Test.hs @@ -9,14 +9,26 @@ module CardanoLoans.Test where import PlutusTx -import PlutusTx.Prelude +import PlutusTx.Prelude hiding ((<>)) import CardanoLoans.Validator (LoanDatum (..), LoanRedeemer (..), loanValidatorCode) +import PlutusLedgerApi.Test.ScriptContextBuilder.Builder + ( buildScriptContext + , withAddress + , withInlineDatum + , withOutRef + , withOutput + , withSigner + , withSpendingScript + , withTxOutAddress + , withTxOutValue + , withValidRange + , withValue + ) import PlutusLedgerApi.V1.Address (pubKeyHashAddress) import PlutusLedgerApi.V1.Value qualified as Value -import PlutusLedgerApi.V2.Tx qualified as Tx import PlutusLedgerApi.V3 -import PlutusTx.AssocMap qualified as Map +import Prelude ((<>)) validatorCodeFullyApplied :: CompiledCode BuiltinUnit validatorCodeFullyApplied = @@ -24,62 +36,32 @@ validatorCodeFullyApplied = testScriptContext :: ScriptContext testScriptContext = - ScriptContext - { scriptContextTxInfo = txInfo - , scriptContextRedeemer - , scriptContextScriptInfo - } + buildScriptContext + ( withValidRange + ( Interval + (LowerBound (Finite 110) True) + (UpperBound (Finite 1100) True) + ) + <> withSigner testBeneficiaryPKH + <> withSpendingScript + (toBuiltinData CloseAsk) + ( withOutRef txOutRef + <> withAddress (pubKeyHashAddress testBeneficiaryPKH) + <> withValue (Value.lovelaceValue 1000) + <> withInlineDatum (toBuiltinData testLoanDatum) + ) + <> withOutput + ( withTxOutAddress (pubKeyHashAddress testBeneficiaryPKH) + <> withTxOutValue (Value.lovelaceValue 1000) + ) + ) where - txInfo = - TxInfo - { txInfoInputs = - [ TxInInfo - { txInInfoOutRef = txOutRef - , txInInfoResolved = Tx.pubKeyHashTxOut (Value.lovelaceValue 1000) testBeneficiaryPKH - } - ] - , txInfoReferenceInputs = mempty - , txInfoOutputs = - [ TxOut - { txOutAddress = pubKeyHashAddress testBeneficiaryPKH - , txOutValue = Value.lovelaceValue 1000 - , txOutDatum = NoOutputDatum - , txOutReferenceScript = Nothing - } - ] - , txInfoTxCerts = mempty - , txInfoRedeemers = Map.empty - , txInfoVotes = Map.empty - , txInfoProposalProcedures = mempty - , txInfoCurrentTreasuryAmount = Nothing - , txInfoTreasuryDonation = Nothing - , txInfoFee = 0 - , txInfoMint = emptyMintValue - , txInfoWdrl = Map.empty - , txInfoValidRange = - Interval - (LowerBound (Finite 110) True) - (UpperBound (Finite 1100) True) - , txInfoSignatories = [testBeneficiaryPKH] - , txInfoData = Map.empty - , txInfoId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145" - } - - scriptContextRedeemer :: Redeemer - scriptContextRedeemer = Redeemer $ toBuiltinData CloseAsk - txOutRef :: TxOutRef txOutRef = TxOutRef txOutRefId txOutRefIdx where txOutRefId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145" txOutRefIdx = 0 - scriptContextScriptInfo :: ScriptInfo - scriptContextScriptInfo = SpendingScript txOutRef (Just datum) - where - datum :: Datum - datum = Datum (toBuiltinData testLoanDatum) - testLoanDatum :: LoanDatum testLoanDatum = askDatum where diff --git a/plutus-benchmark/linear-vesting/exe/MainOptimized.hs b/plutus-benchmark/linear-vesting/exe/MainOptimized.hs new file mode 100644 index 00000000000..9083073cda1 --- /dev/null +++ b/plutus-benchmark/linear-vesting/exe/MainOptimized.hs @@ -0,0 +1,13 @@ +module Main (main) where + +import Data.Text qualified as Text +import LinearVesting.TestOptimized (validatorOptimizedCodeFullyApplied) +import PlutusTx.Test (displayEvalResult, evaluateCompiledCode) + +main :: IO () +main = do + putStrLn "" + putStrLn $ + Text.unpack $ + displayEvalResult $ + evaluateCompiledCode validatorOptimizedCodeFullyApplied diff --git a/plutus-benchmark/linear-vesting/src/LinearVesting/Test.hs b/plutus-benchmark/linear-vesting/src/LinearVesting/Test.hs index 94dd34e218c..7a62e997c2c 100644 --- a/plutus-benchmark/linear-vesting/src/LinearVesting/Test.hs +++ b/plutus-benchmark/linear-vesting/src/LinearVesting/Test.hs @@ -9,66 +9,56 @@ module LinearVesting.Test where import PlutusTx -import PlutusTx.Prelude +import PlutusTx.Prelude hiding ((<>)) import LinearVesting.Validator (VestingDatum (..), VestingRedeemer (..), validatorCode) -import PlutusLedgerApi.Data.V3 +import PlutusLedgerApi.Data.V3 qualified as PV3D +import PlutusLedgerApi.Test.ScriptContextBuilder.Builder + ( buildScriptContext + , withAddress + , withInlineDatum + , withOutRef + , withSigner + , withSpendingScript + , withValidRange + ) import PlutusLedgerApi.V1.Data.Value (assetClass) -import PlutusTx.Data.AssocMap qualified as Map -import PlutusTx.Data.List qualified as List +import PlutusLedgerApi.V3 qualified as PV3 +import Prelude ((<>)) validatorCodeFullyApplied :: CompiledCode BuiltinUnit validatorCodeFullyApplied = validatorCode `unsafeApplyCode` liftCodeDef (toBuiltinData testScriptContext) -testScriptContext :: ScriptContext +testScriptContext :: PV3.ScriptContext testScriptContext = - ScriptContext - { scriptContextTxInfo = txInfo - , scriptContextRedeemer - , scriptContextScriptInfo - } + buildScriptContext + ( withValidRange + ( PV3.Interval + (PV3.LowerBound (PV3.Finite 110) True) + (PV3.UpperBound (PV3.Finite 1100) True) + ) + <> withSigner testBeneficiaryPKH + <> withSpendingScript + (toBuiltinData FullUnlock) + ( withOutRef (PV3.TxOutRef txOutRefId txOutRefIdx) + <> withAddress (PV3.Address (PV3.ScriptCredential scriptHash) Nothing) + <> withInlineDatum (toBuiltinData testVestingDatum) + ) + ) where - txInfo = - TxInfo - { txInfoInputs = mempty - , txInfoReferenceInputs = mempty - , txInfoOutputs = mempty - , txInfoTxCerts = mempty - , txInfoRedeemers = Map.empty - , txInfoVotes = Map.empty - , txInfoProposalProcedures = mempty - , txInfoCurrentTreasuryAmount = Nothing - , txInfoTreasuryDonation = Nothing - , txInfoFee = 0 - , txInfoMint = emptyMintValue - , txInfoWdrl = Map.empty - , txInfoValidRange = - Interval - (LowerBound (Finite 110) True) - (UpperBound (Finite 1100) True) - , txInfoSignatories = List.singleton testBeneficiaryPKH - , txInfoData = Map.empty - , txInfoId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145" - } - - scriptContextRedeemer :: Redeemer - scriptContextRedeemer = Redeemer (toBuiltinData FullUnlock) - - scriptContextScriptInfo :: ScriptInfo - scriptContextScriptInfo = - SpendingScript (TxOutRef txOutRefId txOutRefIdx) (Just datum) - where - txOutRefId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145" - txOutRefIdx = 0 - datum :: Datum - datum = Datum (toBuiltinData testVestingDatum) + txOutRefId :: PV3.TxId + txOutRefId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145" + txOutRefIdx :: Integer + txOutRefIdx = 0 + scriptHash :: PV3.ScriptHash + scriptHash = PV3.ScriptHash "deadbeef" testVestingDatum :: VestingDatum testVestingDatum = VestingDatum - { beneficiary = Address (PubKeyCredential testBeneficiaryPKH) Nothing - , vestingAsset = assetClass (CurrencySymbol "$") (TokenName "test-asset") + { beneficiary = PV3D.Address (PV3D.PubKeyCredential testBeneficiaryPKHData) Nothing + , vestingAsset = assetClass (PV3D.CurrencySymbol "$") (PV3D.TokenName "test-asset") , totalVestingQty = 1000 , vestingPeriodStart = 0 , vestingPeriodEnd = 100 @@ -76,5 +66,8 @@ testVestingDatum = , totalInstallments = 10 } -testBeneficiaryPKH :: PubKeyHash -testBeneficiaryPKH = PubKeyHash "" +testBeneficiaryPKH :: PV3.PubKeyHash +testBeneficiaryPKH = PV3.PubKeyHash "" + +testBeneficiaryPKHData :: PV3D.PubKeyHash +testBeneficiaryPKHData = PV3D.PubKeyHash "" diff --git a/plutus-benchmark/linear-vesting/src/LinearVesting/TestOptimized.hs b/plutus-benchmark/linear-vesting/src/LinearVesting/TestOptimized.hs new file mode 100644 index 00000000000..943603702f1 --- /dev/null +++ b/plutus-benchmark/linear-vesting/src/LinearVesting/TestOptimized.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module LinearVesting.TestOptimized where + +import LinearVesting.Test (testScriptContext) +import LinearVesting.ValidatorOptimized (validatorOptimizedCode) +import PlutusTx +import PlutusTx.Prelude + +validatorOptimizedCodeFullyApplied :: CompiledCode BuiltinUnit +validatorOptimizedCodeFullyApplied = + validatorOptimizedCode `unsafeApplyCode` liftCodeDef (toBuiltinData testScriptContext) diff --git a/plutus-benchmark/linear-vesting/src/LinearVesting/Validator.hs b/plutus-benchmark/linear-vesting/src/LinearVesting/Validator.hs index a6b252fa3bc..6e9e7672472 100644 --- a/plutus-benchmark/linear-vesting/src/LinearVesting/Validator.hs +++ b/plutus-benchmark/linear-vesting/src/LinearVesting/Validator.hs @@ -29,6 +29,7 @@ module LinearVesting.Validator where import PlutusTx +import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.Prelude import Prelude qualified as Haskell @@ -38,6 +39,8 @@ import PlutusLedgerApi.V3.Data.Contexts (txSignedBy) import PlutusTx.Data.List (List) import PlutusTx.Data.List qualified as List +{-# ANN module ("onchain-contract" :: Haskell.String) #-} + data VestingDatum = VestingDatum { beneficiary :: Address , vestingAsset :: AssetClass @@ -139,13 +142,17 @@ validateVestingFullUnlock ctx = vestingDatum :: VestingDatum = unsafeFromBuiltinData datum PubKeyCredential beneficiaryKey = addressCredential (beneficiary vestingDatum) in - if - | not (txSignedBy txInfo beneficiaryKey) -> - traceError "Missing beneficiary signature" - | vestingPeriodEnd vestingDatum >= currentTimeApproximation -> - traceError "Unlock not permitted until vestingPeriodEnd time" - | otherwise -> - True + BI.ifThenElse + (not (txSignedBy txInfo beneficiaryKey)) + (\_ -> traceError "Missing beneficiary signature") + ( \_ -> + BI.ifThenElse + (vestingPeriodEnd vestingDatum >= currentTimeApproximation) + (\_ -> traceError "Unlock not permitted until vestingPeriodEnd time") + (\_ -> True) + BI.unitval + ) + BI.unitval getLowerInclusiveTimeRange :: POSIXTimeRange -> POSIXTime getLowerInclusiveTimeRange = \case @@ -153,6 +160,19 @@ getLowerInclusiveTimeRange = \case if inclusive then posixTime else posixTime + 1 _ -> traceError "Time range not Finite" +-- Evaluation was SUCCESSFUL, result is: +-- () + +-- Execution budget spent: +-- CPU 30,837,131 +-- MEM 131,619 + +-- Evaluation traces: +-- 1. Parsing ScriptContext... +-- 2. Parsed ScriptContext +-- 3. Parsed Redeemer +-- 4. Full unlock requested +-- 5. Validation completed {-# INLINEABLE typedValidator #-} typedValidator :: ScriptContext -> Bool typedValidator context = diff --git a/plutus-benchmark/linear-vesting/src/LinearVesting/ValidatorOptimized.hs b/plutus-benchmark/linear-vesting/src/LinearVesting/ValidatorOptimized.hs new file mode 100644 index 00000000000..151bf478908 --- /dev/null +++ b/plutus-benchmark/linear-vesting/src/LinearVesting/ValidatorOptimized.hs @@ -0,0 +1,399 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -fno-full-laziness #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-spec-constr #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-} +{-# OPTIONS_GHC -fno-unbox-strict-fields #-} +{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:conservative-optimisation #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-remove-trace #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:preserve-logging #-} + +module LinearVesting.ValidatorOptimized where + +import PlutusTx (CompiledCode, compile) +import PlutusTx.Bool (Bool (..)) +import PlutusTx.Builtins.HasOpaque () +import PlutusTx.Builtins.Internal qualified as BI +import PlutusTx.Trace (traceError) + +{-# INLINE builtinIf #-} +builtinIf :: Bool -> (BI.BuiltinUnit -> a) -> (BI.BuiltinUnit -> a) -> a +builtinIf cond t f = BI.ifThenElse cond t f BI.unitval + +{-# INLINE builtinNot #-} +builtinNot :: Bool -> Bool +builtinNot b = builtinIf b (\_ -> False) (\_ -> True) + +{-# INLINE builtinAnd #-} +builtinAnd :: Bool -> Bool -> Bool +builtinAnd b1 b2 = builtinIf b1 (\_ -> b2) (\_ -> False) + +{-# INLINE divCeil #-} +divCeil :: BI.BuiltinInteger -> BI.BuiltinInteger -> BI.BuiltinInteger +divCeil x y = BI.addInteger 1 (BI.divideInteger (BI.subtractInteger x 1) y) + +{-# INLINE lowerInclusiveTime #-} +lowerInclusiveTime :: BI.BuiltinData -> BI.BuiltinInteger +lowerInclusiveTime iv = + let ivFields = BI.snd (BI.unsafeDataAsConstr iv) + lower = BI.head ivFields + !lowerFields = BI.snd (BI.unsafeDataAsConstr lower) + extended = BI.head lowerFields + closureData = BI.head (BI.tail lowerFields) + closureTag = BI.fst (BI.unsafeDataAsConstr closureData) + !extCon = BI.unsafeDataAsConstr extended + extTag = BI.fst extCon + extFields = BI.snd extCon + offset = + builtinIf + (BI.equalsInteger closureTag 1) + (\_ -> 0) + (\_ -> 1) + in builtinIf + (BI.equalsInteger extTag 1) + (\_ -> BI.addInteger (BI.unsafeDataAsI (BI.head extFields)) offset) + (\_ -> traceError "Time range not Finite") + +{-# INLINE txSignedByOptimized #-} +txSignedByOptimized :: BI.BuiltinList BI.BuiltinData -> BI.BuiltinByteString -> Bool +txSignedByOptimized signatories pkh = + BI.caseList' + False + ( \s ss -> + let sBytes = BI.unsafeDataAsB s + in builtinIf + (BI.equalsByteString sBytes pkh) + (\_ -> True) + (\_ -> txSignedByOptimized ss pkh) + ) + signatories + +{-# INLINE findInputByOutRef #-} +findInputByOutRef :: BI.BuiltinData -> BI.BuiltinList BI.BuiltinData -> BI.BuiltinData +findInputByOutRef ref inputs = + BI.caseList' + (traceError "Own input not found") + ( \txIn txIns -> + let txInFields = BI.snd (BI.unsafeDataAsConstr txIn) + txInRef = BI.head txInFields + in builtinIf + (BI.equalsData txInRef ref) + (\_ -> txIn) + (\_ -> findInputByOutRef ref txIns) + ) + inputs + +{-# INLINE findOutputByAddress #-} +findOutputByAddress :: BI.BuiltinData -> BI.BuiltinList BI.BuiltinData -> BI.BuiltinData +findOutputByAddress addr outputs = + BI.caseList' + (traceError "Own output not found") + ( \out outs -> + let outFields = BI.snd (BI.unsafeDataAsConstr out) + outAddr = BI.head outFields + in builtinIf + (BI.equalsData outAddr addr) + (\_ -> out) + (\_ -> findOutputByAddress addr outs) + ) + outputs + +{-# INLINE countInputsAtScript #-} +countInputsAtScript :: BI.BuiltinByteString -> BI.BuiltinList BI.BuiltinData -> BI.BuiltinInteger +countInputsAtScript scriptHash inputs = + BI.caseList' + 0 + ( \txIn txIns -> + let txInFields = BI.snd (BI.unsafeDataAsConstr txIn) + resolvedOut = BI.head (BI.tail txInFields) + resolvedFields = BI.snd (BI.unsafeDataAsConstr resolvedOut) + addr = BI.head resolvedFields + addrFields = BI.snd (BI.unsafeDataAsConstr addr) + cred = BI.head addrFields + !credCon = BI.unsafeDataAsConstr cred + credTag = BI.fst credCon + credFields = BI.snd credCon + rest = countInputsAtScript scriptHash txIns + in builtinIf + (BI.equalsInteger credTag 1) + ( \_ -> + let vh = BI.unsafeDataAsB (BI.head credFields) + in builtinIf + (BI.equalsByteString vh scriptHash) + (\_ -> BI.addInteger 1 rest) + (\_ -> rest) + ) + (\_ -> rest) + ) + inputs + +{-# INLINE valueOf #-} +valueOf :: BI.BuiltinData -> BI.BuiltinByteString -> BI.BuiltinByteString -> BI.BuiltinInteger +valueOf valueData cs tn = + let outer = BI.unsafeDataAsMap valueData + in findCurrency outer + where + findCurrency :: BI.BuiltinList (BI.BuiltinPair BI.BuiltinData BI.BuiltinData) -> BI.BuiltinInteger + findCurrency pairs = + builtinIf + (BI.null pairs) + (\_ -> 0) + ( \_ -> + let pair = BI.head pairs + key = BI.unsafeDataAsB (BI.fst pair) + in builtinIf + (BI.equalsByteString key cs) + (\_ -> findToken (BI.unsafeDataAsMap (BI.snd pair))) + (\_ -> findCurrency (BI.tail pairs)) + ) + + findToken :: BI.BuiltinList (BI.BuiltinPair BI.BuiltinData BI.BuiltinData) -> BI.BuiltinInteger + findToken pairs = + builtinIf + (BI.null pairs) + (\_ -> 0) + ( \_ -> + let pair = BI.head pairs + key = BI.unsafeDataAsB (BI.fst pair) + in builtinIf + (BI.equalsByteString key tn) + (\_ -> BI.unsafeDataAsI (BI.snd pair)) + (\_ -> findToken (BI.tail pairs)) + ) + +{-# INLINE getScriptHashFromAddress #-} +getScriptHashFromAddress :: BI.BuiltinData -> BI.BuiltinByteString +getScriptHashFromAddress addr = + let addrFields = BI.snd (BI.unsafeDataAsConstr addr) + cred = BI.head addrFields + !credCon = BI.unsafeDataAsConstr cred + credTag = BI.fst credCon + credFields = BI.snd credCon + in builtinIf + (BI.equalsInteger credTag 1) + (\_ -> BI.unsafeDataAsB (BI.head credFields)) + (\_ -> traceError "Expected ScriptCredential") + +{-# INLINE getPubKeyHashFromAddress #-} +getPubKeyHashFromAddress :: BI.BuiltinData -> BI.BuiltinByteString +getPubKeyHashFromAddress addr = + let addrFields = BI.snd (BI.unsafeDataAsConstr addr) + cred = BI.head addrFields + !credCon = BI.unsafeDataAsConstr cred + credTag = BI.fst credCon + credFields = BI.snd credCon + in builtinIf + (BI.equalsInteger credTag 0) + (\_ -> BI.unsafeDataAsB (BI.head credFields)) + (\_ -> traceError "Expected PubKeyCredential") + +{-# INLINE getSpendingInfo #-} +getSpendingInfo :: BI.BuiltinData -> BI.BuiltinPair BI.BuiltinData BI.BuiltinData +getSpendingInfo scriptInfo = + let con = BI.unsafeDataAsConstr scriptInfo + tag = BI.fst con + fields = BI.snd con + in builtinIf + (BI.equalsInteger tag 1) + ( \_ -> + let ownRef = BI.head fields + maybeDatum = BI.head (BI.tail fields) + !mdCon = BI.unsafeDataAsConstr maybeDatum + mdTag = BI.fst mdCon + mdFields = BI.snd mdCon + in builtinIf + (BI.equalsInteger mdTag 0) + (\_ -> BI.mkPairData ownRef (BI.head mdFields)) + (\_ -> traceError "Missing datum") + ) + (\_ -> traceError "Not spending script") + +{-# INLINE validateVestingPartialUnlockOptimized #-} +validateVestingPartialUnlockOptimized + :: BI.BuiltinList BI.BuiltinData + -> BI.BuiltinList BI.BuiltinData + -> BI.BuiltinData + -> BI.BuiltinList BI.BuiltinData + -> BI.BuiltinData + -> BI.BuiltinData + -> Bool +validateVestingPartialUnlockOptimized txInputs txOutputs txValidRange txSignatories ownRef vestingDatum = + let ownInput = findInputByOutRef ownRef txInputs + ownInputFields = BI.snd (BI.unsafeDataAsConstr ownInput) + resolvedOut = BI.head (BI.tail ownInputFields) + !resolvedFields = BI.snd (BI.unsafeDataAsConstr resolvedOut) + !inputAddress = BI.head resolvedFields + + scriptHash = getScriptHashFromAddress inputAddress + ownOutput = findOutputByAddress inputAddress txOutputs + !ownOutputFields = BI.snd (BI.unsafeDataAsConstr ownOutput) + outputDatum = BI.head (BI.tail (BI.tail ownOutputFields)) + + resolvedDatum = BI.head (BI.tail (BI.tail resolvedFields)) + + vdFields = BI.snd (BI.unsafeDataAsConstr vestingDatum) + vdFields1 = BI.tail vdFields + !vdFields2 = BI.tail vdFields1 + !vdFields3 = BI.tail vdFields2 + !vdFields4 = BI.tail vdFields3 + !vdFields5 = BI.tail vdFields4 + !vdFields6 = BI.tail vdFields5 + + beneficiaryAddr = BI.head vdFields + assetClassData = BI.head vdFields1 + totalVestingQty = BI.unsafeDataAsI (BI.head vdFields2) + vestingPeriodStart = BI.unsafeDataAsI (BI.head vdFields3) + vestingPeriodEnd = BI.unsafeDataAsI (BI.head vdFields4) + firstUnlockPossibleAfter = BI.unsafeDataAsI (BI.head vdFields5) + totalInstallments = BI.unsafeDataAsI (BI.head vdFields6) + + assetCon = BI.unsafeDataAsConstr assetClassData + assetFields = BI.snd assetCon + assetCs = BI.unsafeDataAsB (BI.head assetFields) + assetTn = BI.unsafeDataAsB (BI.head (BI.tail assetFields)) + + oldRemainingQty = valueOf (BI.head (BI.tail resolvedFields)) assetCs assetTn + newRemainingQty = valueOf (BI.head (BI.tail ownOutputFields)) assetCs assetTn + + vestingPeriodLength = BI.subtractInteger vestingPeriodEnd vestingPeriodStart + currentTimeApproximation = lowerInclusiveTime txValidRange + vestingTimeRemaining = BI.subtractInteger vestingPeriodEnd currentTimeApproximation + timeBetweenTwoInstallments = divCeil vestingPeriodLength totalInstallments + futureInstallments = divCeil vestingTimeRemaining timeBetweenTwoInstallments + expectedRemainingQty = + divCeil (BI.multiplyInteger futureInstallments totalVestingQty) totalInstallments + + beneficiaryHash = getPubKeyHashFromAddress beneficiaryAddr + signed = txSignedByOptimized txSignatories beneficiaryHash + in builtinIf + (builtinNot signed) + (\_ -> traceError "Missing beneficiary signature") + ( \_ -> + builtinIf + (BI.lessThanEqualsInteger currentTimeApproximation firstUnlockPossibleAfter) + (\_ -> traceError "Unlock not permitted until firstUnlockPossibleAfter time") + ( \_ -> + builtinIf + (BI.lessThanEqualsInteger newRemainingQty 0) + (\_ -> traceError "Zero remaining assets not allowed") + ( \_ -> + builtinIf + (BI.lessThanEqualsInteger oldRemainingQty newRemainingQty) + (\_ -> traceError "Remaining asset is not decreasing") + ( \_ -> + builtinIf + (builtinNot (BI.equalsInteger expectedRemainingQty newRemainingQty)) + (\_ -> traceError "Mismatched remaining asset") + ( \_ -> + builtinIf + (builtinNot (BI.equalsData resolvedDatum outputDatum)) + (\_ -> traceError "Datum Modification Prohibited") + ( \_ -> + builtinIf + (builtinNot (BI.equalsInteger (countInputsAtScript scriptHash txInputs) 1)) + (\_ -> traceError "Double satisfaction") + (\_ -> True) + ) + ) + ) + ) + ) + ) + +{-# INLINE validateVestingFullUnlockOptimized #-} +validateVestingFullUnlockOptimized + :: BI.BuiltinData + -> BI.BuiltinList BI.BuiltinData + -> BI.BuiltinData + -> Bool +validateVestingFullUnlockOptimized txValidRange txSignatories vestingDatum = + let !vdFields = BI.snd (BI.unsafeDataAsConstr vestingDatum) + vdFields1 = BI.tail vdFields + vdFields2 = BI.tail vdFields1 + vdFields3 = BI.tail vdFields2 + vdFields4 = BI.tail vdFields3 + + beneficiaryAddr = BI.head vdFields + vestingPeriodEnd = BI.unsafeDataAsI (BI.head vdFields4) + currentTimeApproximation = lowerInclusiveTime txValidRange + beneficiaryHash = getPubKeyHashFromAddress beneficiaryAddr + in builtinIf + (builtinNot (txSignedByOptimized txSignatories beneficiaryHash)) + (\_ -> traceError "Missing beneficiary signature") + ( \_ -> + builtinIf + (BI.lessThanEqualsInteger currentTimeApproximation vestingPeriodEnd) + (\_ -> traceError "Unlock not permitted until vestingPeriodEnd time") + (\_ -> True) + ) + +{-# INLINEABLE untypedValidatorOptimized #-} +untypedValidatorOptimized :: BI.BuiltinData -> BI.BuiltinUnit +untypedValidatorOptimized scriptContextData = + let ctx = BI.trace "Parsing ScriptContext..." scriptContextData + ctxFields = BI.snd (BI.unsafeDataAsConstr ctx) + txInfoData = BI.head ctxFields + redeemerData = BI.head (BI.tail ctxFields) + scriptInfoData = BI.head (BI.tail (BI.tail ctxFields)) + + txInfoFields = BI.snd (BI.unsafeDataAsConstr txInfoData) + txInfoFields1 = BI.tail txInfoFields + txInfoFields2 = BI.tail txInfoFields1 + txInfoFields3 = BI.tail txInfoFields2 + txInfoFields4 = BI.tail txInfoFields3 + txInfoFields5 = BI.tail txInfoFields4 + txInfoFields6 = BI.tail txInfoFields5 + txInfoFields7 = BI.tail txInfoFields6 + txInfoFields8 = BI.tail txInfoFields7 + + txInputs = BI.unsafeDataAsList (BI.head txInfoFields) + txOutputs = BI.unsafeDataAsList (BI.head txInfoFields2) + txValidRange = BI.head txInfoFields7 + txSignatories = BI.unsafeDataAsList (BI.head txInfoFields8) + + spendingInfo = getSpendingInfo scriptInfoData + ownRef = BI.fst spendingInfo + datumData = BI.snd spendingInfo + + redeemerTag = BI.fst (BI.unsafeDataAsConstr redeemerData) + + result = + BI.trace + "Parsed ScriptContext" + ( BI.trace + "Parsed Redeemer" + ( BI.caseInteger + redeemerTag + [ BI.trace + "Partial unlock requested" + ( validateVestingPartialUnlockOptimized + txInputs + txOutputs + txValidRange + txSignatories + ownRef + datumData + ) + , BI.trace + "Full unlock requested" + (validateVestingFullUnlockOptimized txValidRange txSignatories datumData) + ] + ) + ) + in builtinIf + result + (\_ -> BI.trace "Validation completed" BI.unitval) + (\_ -> traceError "Validation failed") + +validatorOptimizedCode :: CompiledCode (BI.BuiltinData -> BI.BuiltinUnit) +validatorOptimizedCode = $$(compile [||untypedValidatorOptimized||]) diff --git a/plutus-benchmark/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal index bbdf57bf09f..6d16eea4cc2 100644 --- a/plutus-benchmark/plutus-benchmark.cabal +++ b/plutus-benchmark/plutus-benchmark.cabal @@ -740,11 +740,14 @@ library linear-vesting-internal hs-source-dirs: linear-vesting/src exposed-modules: LinearVesting.Test + LinearVesting.TestOptimized LinearVesting.Validator + LinearVesting.ValidatorOptimized build-depends: - , base >=4.9 && <5 + , base >=4.9 && <5 , plutus-ledger-api + , plutus-ledger-api:plutus-ledger-api-testlib , plutus-tx , plutus-tx-plugin @@ -758,6 +761,16 @@ executable linear-vesting , plutus-tx:plutus-tx-testlib , text +executable linear-vesting-optimized + import: lang, ghc-version-support, os-support + main-is: MainOptimized.hs + hs-source-dirs: linear-vesting/exe + build-depends: + , base >=4.9 && <5 + , linear-vesting-internal + , plutus-tx:plutus-tx-testlib + , text + ------------------ Cardano Open Oracle Protocol ------------------- library coop diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal index 1baf8304b01..f845e02e0e8 100644 --- a/plutus-ledger-api/plutus-ledger-api.cabal +++ b/plutus-ledger-api/plutus-ledger-api.cabal @@ -137,6 +137,9 @@ library plutus-ledger-api-testlib PlutusLedgerApi.Test.Common.EvaluationContext PlutusLedgerApi.Test.EvaluationEvent PlutusLedgerApi.Test.Examples + PlutusLedgerApi.Test.ScriptContextBuilder.Builder + PlutusLedgerApi.Test.ScriptContextBuilder.Lenses + PlutusLedgerApi.Test.ScriptContextBuilder.Lenses.TH PlutusLedgerApi.Test.Scripts PlutusLedgerApi.Test.V1.Data.EvaluationContext PlutusLedgerApi.Test.V1.Data.Value @@ -156,6 +159,7 @@ library plutus-ledger-api-testlib , base64-bytestring , bytestring , containers + , lens , plutus-core ^>=1.57 , plutus-core:plutus-core-testlib , plutus-ledger-api ^>=1.57 @@ -163,6 +167,7 @@ library plutus-ledger-api-testlib , prettyprinter , QuickCheck , serialise + , template-haskell , text test-suite plutus-ledger-api-test diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/ScriptContextBuilder/Builder.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/ScriptContextBuilder/Builder.hs new file mode 100644 index 00000000000..3ae3c6eb927 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/ScriptContextBuilder/Builder.hs @@ -0,0 +1,517 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module PlutusLedgerApi.Test.ScriptContextBuilder.Builder + ( UnitTestArgs (..) + , InputBuilder (..) + , TxOutBuilder (..) + , ScriptContextBuilder (..) + , ScriptContextBuilderState (..) + , buildScriptContext + , withRedeemer + , withFee + , withSigner + , withSigners + , withMint + , withMintingScript + , withSpendingScript + , withRewardingScript + , withRewardingScriptWithBuilder + , withOutput + , withInput + , withScriptInput + , withReferenceInput + , withValue + , withValidRange + , withOutRef + , withInlineDatum + , withReferenceScript + , withAddress + , withWithdrawal + , mkInput + , addInput + , addMint + , mkMintingScriptWithPurpose + , addChangeOutput + , signAndAddChangeOutput + , negateValue + , mkAdaValue + , mkTxOut + , withTxOutReferenceScript + , withTxOutInlineDatum + , withTxOutValue + , withTxOutAddress + , addOutput + , addReferenceInput + , buildBalancedScriptContext + , balanceWithChangeOutput + , builderPlaceHolderTxOutRef + ) +where + +import Data.Function (on) +import Data.List (insert, insertBy, sortBy) +import Data.Ord (comparing) +import GHC.Generics (Generic) +import PlutusLedgerApi.V1 qualified as PV1 +import PlutusLedgerApi.V1.Address +import PlutusLedgerApi.V1.Value +import PlutusLedgerApi.V3 +import PlutusLedgerApi.V3.MintValue +import PlutusTx qualified +import PlutusTx.AssocMap qualified as Map +import PlutusTx.Builtins.HasOpaque + ( stringToBuiltinByteStringHex + ) +import PlutusTx.Eq qualified + +instance PlutusTx.Eq.Eq ScriptPurpose where + (==) a b = PlutusTx.toBuiltinData a == PlutusTx.toBuiltinData b + +{- + Convert a hex encoded haskell `String` to a `CurrencySymbol`. +-} +currencySymbolFromHex :: String -> PV1.CurrencySymbol +currencySymbolFromHex = PV1.CurrencySymbol . stringToBuiltinByteStringHex + +data UnitTestArgs = UnitTestArgs + { utaScriptContext :: ScriptContext + , utaParameters :: [BuiltinData] + } + deriving stock (Generic) + +mkAdaValue :: Int -> Value +mkAdaValue i = assetClassValue (assetClass adaSymbol adaToken) (fromIntegral i) + +addMint :: ScriptContext -> Value -> BuiltinData -> ScriptContext +addMint ctx newMint redeemer = + let existingMint = Value $ mintValueToMap (txInfoMint (scriptContextTxInfo ctx)) + mergedMint = UnsafeMintValue $ getValue $ existingMint <> newMint + mintCS = head $ Map.keys $ getValue newMint + existingRedeemers = txInfoRedeemers (scriptContextTxInfo ctx) + updatedRedeemers = Map.insert (Minting mintCS) (Redeemer redeemer) existingRedeemers + in ctx {scriptContextTxInfo = (scriptContextTxInfo ctx) {txInfoMint = mergedMint, txInfoRedeemers = updatedRedeemers}} + +addInput :: TxInInfo -> ScriptContext -> ScriptContext +addInput newInput ctx = + let existingInputs = txInfoInputs (scriptContextTxInfo ctx) + sortedInputs = insertBy (comparing txInInfoOutRef) newInput existingInputs + in ctx {scriptContextTxInfo = (scriptContextTxInfo ctx) {txInfoInputs = sortedInputs}} + +addReferenceInput :: TxInInfo -> ScriptContext -> ScriptContext +addReferenceInput newInput ctx = + let existingInputs = txInfoReferenceInputs (scriptContextTxInfo ctx) + sortedInputs = insertBy (comparing txInInfoOutRef) newInput existingInputs + in ctx {scriptContextTxInfo = (scriptContextTxInfo ctx) {txInfoReferenceInputs = sortedInputs}} + +addOutput :: TxOut -> ScriptContext -> ScriptContext +addOutput newOutput ctx = + let existingOutputs = txInfoOutputs (scriptContextTxInfo ctx) + in ctx {scriptContextTxInfo = (scriptContextTxInfo ctx) {txInfoOutputs = newOutput : existingOutputs}} + +newtype InputBuilder = InputBuilder {runInputBuilder :: InputBuilderState -> InputBuilderState} + +data InputBuilderState = InputBuilderState + { ibOutRef :: TxOutRef + -- ^ UTXO reference for the input. + , ibAddress :: Address + -- ^ Address of the input. + , ibValue :: Value + -- ^ The value (assets) contained in the input. + , ibDatum :: OutputDatum + -- ^ Optional inline datum. + , ibReferenceScript :: Maybe ScriptHash + -- ^ Optional reference script. + } + +instance Semigroup InputBuilder where + InputBuilder a <> InputBuilder b = InputBuilder (a . b) + +instance Monoid InputBuilder where + mempty = InputBuilder id + +builderPlaceHolderTxOutRef :: TxOutRef +builderPlaceHolderTxOutRef = TxOutRef "deadbeef" 0 + +builderPlaceHolderAddress :: Address +builderPlaceHolderAddress = pubKeyHashAddress (PubKeyHash "deadbeef") + +defaultInputBuilderState :: InputBuilderState +defaultInputBuilderState = + InputBuilderState + { ibOutRef = builderPlaceHolderTxOutRef + , ibAddress = builderPlaceHolderAddress + , ibValue = mempty + , ibDatum = NoOutputDatum + , ibReferenceScript = Nothing + } + +withOutRef :: TxOutRef -> InputBuilder +withOutRef outRef = InputBuilder $ \inputBuilder -> inputBuilder {ibOutRef = outRef} + +withAddress :: Address -> InputBuilder +withAddress address = InputBuilder $ \inputBuilder -> inputBuilder {ibAddress = address} + +withValue :: Value -> InputBuilder +withValue value = InputBuilder $ \inputBuilder -> inputBuilder {ibValue = value} + +withInlineDatum :: BuiltinData -> InputBuilder +withInlineDatum datum = InputBuilder $ \inputBuilder -> inputBuilder {ibDatum = OutputDatum $ Datum datum} + +withReferenceScript :: ScriptHash -> InputBuilder +withReferenceScript scriptHash = InputBuilder $ \inputBuilder -> inputBuilder {ibReferenceScript = Just scriptHash} + +mkInput :: InputBuilder -> TxInInfo +mkInput (InputBuilder modify) = + let builder = modify defaultInputBuilderState + in TxInInfo + { txInInfoOutRef = ibOutRef builder + , txInInfoResolved = + TxOut + { txOutAddress = ibAddress builder + , txOutValue = ibValue builder + , txOutDatum = ibDatum builder + , txOutReferenceScript = Nothing + } + } + +-- TxOutBuilder +newtype TxOutBuilder = TxOutBuilder {runTxOutBuilder :: TxOutBuilderState -> TxOutBuilderState} + +data TxOutBuilderState = TxOutBuilderState + { tobAddress :: Address + , tobValue :: Value + , tobDatum :: OutputDatum + , tobReferenceScript :: Maybe ScriptHash + } + +defaultTxOutBuilderState :: TxOutBuilderState +defaultTxOutBuilderState = + TxOutBuilderState + { tobAddress = builderPlaceHolderAddress + , tobValue = mempty + , tobDatum = NoOutputDatum + , tobReferenceScript = Nothing + } + +instance Semigroup TxOutBuilder where + (TxOutBuilder f) <> (TxOutBuilder g) = TxOutBuilder (f . g) + +instance Monoid TxOutBuilder where + mempty = TxOutBuilder id + +withTxOutAddress :: Address -> TxOutBuilder +withTxOutAddress addr = TxOutBuilder $ \tob -> tob {tobAddress = addr} + +withTxOutValue :: Value -> TxOutBuilder +withTxOutValue val = TxOutBuilder $ \tob -> tob {tobValue = tobValue tob <> val} + +withTxOutInlineDatum :: BuiltinData -> TxOutBuilder +withTxOutInlineDatum datum = TxOutBuilder $ \tob -> tob {tobDatum = OutputDatum $ Datum datum} + +withTxOutReferenceScript :: ScriptHash -> TxOutBuilder +withTxOutReferenceScript scriptHash = TxOutBuilder $ \tob -> tob {tobReferenceScript = Just scriptHash} + +mkTxOut :: TxOutBuilder -> TxOut +mkTxOut (TxOutBuilder modify) = + let finalState = modify defaultTxOutBuilderState + in TxOut + { txOutAddress = tobAddress finalState + , txOutValue = tobValue finalState + , txOutDatum = tobDatum finalState + , txOutReferenceScript = tobReferenceScript finalState + } + +mkMintingScriptWithPurpose :: Value -> BuiltinData -> ScriptContext +mkMintingScriptWithPurpose mintValue redeemer = + ScriptContext + mintingScriptTxInfo + (Redeemer redeemer) + (MintingScript mintCS) + where + mintCS :: CurrencySymbol + mintCS = head $ Map.keys $ getValue mintValue + + mintingScriptTxInfo :: TxInfo + mintingScriptTxInfo = + TxInfo + { txInfoInputs = mempty + , txInfoReferenceInputs = mempty + , txInfoOutputs = mempty + , txInfoFee = 0 + , txInfoMint = UnsafeMintValue $ getValue mintValue + , txInfoTxCerts = mempty + , txInfoWdrl = Map.empty + , txInfoValidRange = always + , txInfoSignatories = mempty + , txInfoRedeemers = Map.unsafeFromList [(Minting mintCS, Redeemer redeemer)] + , txInfoData = Map.empty + , txInfoId = TxId "" + , txInfoVotes = Map.empty + , txInfoProposalProcedures = mempty + , txInfoCurrentTreasuryAmount = Nothing + , txInfoTreasuryDonation = Nothing + } + +negateValue :: Value -> Value +negateValue (Value val) = Value $ Map.mapWithKey (\_ -> Map.mapWithKey (\_ x -> negate x)) val + +addChangeOutput :: PubKeyHash -> ScriptContext -> ScriptContext +addChangeOutput signerPkh ctx = + let totalInputValue = foldMap (txOutValue . txInInfoResolved) (txInfoInputs $ scriptContextTxInfo ctx) + totalOutputValue = foldMap txOutValue (txInfoOutputs $ scriptContextTxInfo ctx) + feeValue = mkAdaValue $ fromIntegral $ getLovelace $ txInfoFee $ scriptContextTxInfo ctx + mintedValue = Value $ mintValueToMap (txInfoMint (scriptContextTxInfo ctx)) + changeValue = mintedValue <> totalInputValue <> negateValue feeValue <> negateValue totalOutputValue + changeOutput = TxOut (pubKeyHashAddress signerPkh) changeValue NoOutputDatum Nothing + in ctx {scriptContextTxInfo = (scriptContextTxInfo ctx) {txInfoOutputs = changeOutput : txInfoOutputs (scriptContextTxInfo ctx)}} + +balanceWithChangeOutput :: ScriptContext -> ScriptContext +balanceWithChangeOutput ctx = + let resolvedInputs = map txInInfoResolved (txInfoInputs $ scriptContextTxInfo ctx) + signerPkh = case filter (isPubKeyAddress . txOutAddress) resolvedInputs of + (TxOut (Address (PubKeyCredential pkh) _) _ _ _ : _) -> pkh + _ -> PubKeyHash "deadbeef" + -- \^ Fallback to default if no public key input is found + totalInputValue = foldMap (txOutValue . txInInfoResolved) (txInfoInputs $ scriptContextTxInfo ctx) + totalOutputValue = foldMap txOutValue (txInfoOutputs $ scriptContextTxInfo ctx) + feeValue = mkAdaValue $ fromIntegral $ getLovelace $ txInfoFee $ scriptContextTxInfo ctx + mintedValue = Value $ mintValueToMap (txInfoMint (scriptContextTxInfo ctx)) + changeValue = mintedValue <> totalInputValue <> negateValue feeValue <> negateValue totalOutputValue + changeOutput = TxOut (pubKeyHashAddress signerPkh) changeValue NoOutputDatum Nothing + in ctx {scriptContextTxInfo = (scriptContextTxInfo ctx) {txInfoOutputs = txInfoOutputs (scriptContextTxInfo ctx) <> [changeOutput]}} + where + isPubKeyAddress :: Address -> Bool + isPubKeyAddress (Address (PubKeyCredential _) _) = True + isPubKeyAddress _ = False + +addSigner :: PubKeyHash -> ScriptContext -> ScriptContext +addSigner signerPkh ctx = + ctx {scriptContextTxInfo = (scriptContextTxInfo ctx) {txInfoSignatories = signerPkh : txInfoSignatories (scriptContextTxInfo ctx)}} + +signAndAddChangeOutput :: PubKeyHash -> ScriptContext -> ScriptContext +signAndAddChangeOutput signerPkh ctx = + let signedCtx = addChangeOutput signerPkh ctx + in addSigner signerPkh signedCtx + +-- Script Context Builder + +newtype ScriptContextBuilder = ScriptContextBuilder {runBuilder :: ScriptContextBuilderState -> ScriptContextBuilderState} + +data ScriptContextBuilderState = ScriptContextBuilderState + { scbInputs :: [TxInInfo] + , scbReferenceInputs :: [TxInInfo] + , scbOutputs :: [TxOut] + , scbFee :: Integer + , scbMint :: Value + , scbCerts :: [TxCert] + , scbWdrl :: Map.Map Credential Lovelace + , scbValidRange :: POSIXTimeRange + , scbSignatories :: [PubKeyHash] + , scbRedeemers :: Map.Map ScriptPurpose Redeemer + , scbTxId :: TxId + , scbScriptInfo :: ScriptInfo + , scbRedeemer :: BuiltinData + } + +defaultScriptContextBuilderState :: ScriptContextBuilderState +defaultScriptContextBuilderState = + ScriptContextBuilderState + { scbInputs = [] + , scbReferenceInputs = [] + , scbOutputs = [] + , scbFee = 0 + , scbMint = mempty + , scbCerts = [] + , scbWdrl = Map.empty + , scbValidRange = always + , scbRedeemers = Map.empty + , scbSignatories = [] + , scbTxId = TxId "deadbeef" + , scbScriptInfo = MintingScript $ currencySymbolFromHex "deadbeef" + , scbRedeemer = PlutusTx.toBuiltinData () + } + +instance Semigroup ScriptContextBuilder where + (ScriptContextBuilder f) <> (ScriptContextBuilder g) = ScriptContextBuilder (g . f) + +instance Monoid ScriptContextBuilder where + mempty = ScriptContextBuilder id + +withFee :: Integer -> ScriptContextBuilder +withFee fee = ScriptContextBuilder $ \scb -> scb {scbFee = fee} + +withValidRange :: POSIXTimeRange -> ScriptContextBuilder +withValidRange validRange = ScriptContextBuilder $ \scb -> scb {scbValidRange = validRange} + +withSigner :: PubKeyHash -> ScriptContextBuilder +withSigner pkh = ScriptContextBuilder $ \scb -> + scb {scbSignatories = insert pkh (scbSignatories scb)} + +withSigners :: [PubKeyHash] -> ScriptContextBuilder +withSigners pks = ScriptContextBuilder $ \scb -> + scb {scbSignatories = foldr (\p acc -> insert p acc) (scbSignatories scb) pks} + +withMint :: Value -> BuiltinData -> ScriptContextBuilder +withMint value redeemer = ScriptContextBuilder $ \scb -> + let mintCS = head $ Map.keys $ getValue value + newRedeemers = Map.insert (Minting mintCS) (Redeemer redeemer) (scbRedeemers scb) + in scb {scbMint = scbMint scb <> value, scbRedeemers = newRedeemers} + +withOutput :: TxOutBuilder -> ScriptContextBuilder +withOutput modify = ScriptContextBuilder $ \scb -> + scb {scbOutputs = mkTxOut modify : scbOutputs scb} + +withInput :: InputBuilder -> ScriptContextBuilder +withInput modify = ScriptContextBuilder $ \scb -> + let newInput = mkInput modify + newInputAddress = txOutAddress $ txInInfoResolved newInput + in if isPubKeyAddress newInputAddress + then + scb {scbInputs = insertBy (comparing txInInfoOutRef) newInput (scbInputs scb)} + else + error "withInput: Input address is not a public key address" + where + isPubKeyAddress :: Address -> Bool + isPubKeyAddress (Address (PubKeyCredential _) _) = True + isPubKeyAddress _ = False + +withScriptInput :: BuiltinData -> InputBuilder -> ScriptContextBuilder +withScriptInput redeemer modify = ScriptContextBuilder $ \scb -> + let newInput = mkInput modify + inputOutRef = txInInfoOutRef newInput + newRedeemers = Map.insert (Spending inputOutRef) (Redeemer redeemer) (scbRedeemers scb) + in if isScriptAddress (txOutAddress $ txInInfoResolved newInput) + then scb {scbInputs = insertBy (comparing txInInfoOutRef) newInput (scbInputs scb), scbRedeemers = newRedeemers} + else error "withScriptInput: Input address is not a script address" + where + isScriptAddress :: Address -> Bool + isScriptAddress (Address (ScriptCredential _) _) = True + isScriptAddress _ = False + +withReferenceInput :: InputBuilder -> ScriptContextBuilder +withReferenceInput modify = ScriptContextBuilder $ \scb -> + let newRefInput = mkInput modify + in scb {scbReferenceInputs = insertBy (comparing txInInfoOutRef) newRefInput (scbReferenceInputs scb)} + +withMintingScript :: Value -> BuiltinData -> ScriptContextBuilder +withMintingScript mintValue redeemer = + withMint mintValue redeemer + <> ScriptContextBuilder + ( \scb -> + let mintCS = head $ Map.keys $ getValue mintValue + in scb {scbScriptInfo = MintingScript mintCS} + ) + +withSpendingScript :: BuiltinData -> InputBuilder -> ScriptContextBuilder +withSpendingScript redeemer modify = ScriptContextBuilder $ \scb -> + let scriptInput = mkInput modify + outRef = txInInfoOutRef scriptInput + newRedeemers = Map.insert (Spending outRef) (Redeemer redeemer) (scbRedeemers scb) + datum = + case txOutDatum $ txInInfoResolved scriptInput of + NoOutputDatum -> Nothing + OutputDatum (Datum dat) -> Just (Datum dat) + _ -> Nothing + in scb {scbScriptInfo = SpendingScript outRef datum, scbInputs = insertBy (comparing txInInfoOutRef) scriptInput (scbInputs scb), scbRedeemers = newRedeemers, scbRedeemer = redeemer} + +withRewardingScript :: BuiltinData -> Credential -> Integer -> ScriptContextBuilder +withRewardingScript redeemer cred adaAmount = + ScriptContextBuilder $ \scb -> + let newWdrl = Map.insert cred (fromIntegral adaAmount) (scbWdrl scb) + newRedeemers = Map.insert (Rewarding cred) (Redeemer redeemer) (scbRedeemers scb) + in scb + { scbWdrl = newWdrl + , scbRedeemers = newRedeemers + , scbRedeemer = redeemer + , scbScriptInfo = RewardingScript cred + } + +withRewardingScriptWithBuilder :: (ScriptContextBuilderState -> BuiltinData) -> Credential -> Integer -> ScriptContextBuilder +withRewardingScriptWithBuilder mkRedeemer cred adaAmount = + ScriptContextBuilder $ \scb -> + let redeemer = mkRedeemer scb + newWdrl = Map.insert cred (fromIntegral adaAmount) (scbWdrl scb) + newRedeemers = Map.insert (Rewarding cred) (Redeemer redeemer) (scbRedeemers scb) + in scb + { scbWdrl = newWdrl + , scbRedeemers = newRedeemers + , scbRedeemer = redeemer + , scbScriptInfo = RewardingScript cred + } + +withWithdrawal :: Credential -> Integer -> ScriptContextBuilder +withWithdrawal cred adaAmount = ScriptContextBuilder $ \scb -> + let newWdrl = Map.insert cred (fromIntegral adaAmount) (scbWdrl scb) + in scb {scbWdrl = newWdrl} + +withRedeemer :: BuiltinData -> ScriptContextBuilder +withRedeemer redeemer = ScriptContextBuilder $ \scb -> scb {scbRedeemer = redeemer} + +buildScriptContext :: ScriptContextBuilder -> ScriptContext +buildScriptContext modify = + let finalState = runBuilder modify defaultScriptContextBuilderState + txInfo = + TxInfo + { txInfoInputs = reverse $ scbInputs finalState + , txInfoReferenceInputs = reverse $ scbReferenceInputs finalState + , txInfoOutputs = reverse $ scbOutputs finalState + , txInfoMint = UnsafeMintValue $ getValue (scbMint finalState) + , txInfoRedeemers = scbRedeemers finalState + , txInfoFee = fromIntegral (scbFee finalState) + , txInfoSignatories = scbSignatories finalState + , txInfoTxCerts = scbCerts finalState + , txInfoWdrl = scbWdrl finalState + , txInfoValidRange = scbValidRange finalState + , txInfoData = Map.empty + , txInfoId = scbTxId finalState + , txInfoVotes = Map.empty + , txInfoProposalProcedures = [] + , txInfoCurrentTreasuryAmount = Nothing + , txInfoTreasuryDonation = Nothing + } + in ScriptContext txInfo (Redeemer $ scbRedeemer finalState) (scbScriptInfo finalState) + +comparePurposeLedger :: ScriptPurpose -> ScriptPurpose -> Ordering +comparePurposeLedger a b = comparing toInt a b + where + toInt :: ScriptPurpose -> Int + toInt (Spending _) = 0 + toInt (Minting _) = 1 + toInt (Certifying _ _) = 2 + toInt (Rewarding _) = 3 + toInt _ = 10 + +-- TODO: handle others + +buildBalancedScriptContext :: ScriptContextBuilder -> ScriptContext +buildBalancedScriptContext modify = + let finalState = runBuilder modify defaultScriptContextBuilderState + txInfo = + TxInfo + { txInfoInputs = scbInputs finalState + , txInfoReferenceInputs = scbReferenceInputs finalState + , txInfoOutputs = scbOutputs finalState + , txInfoMint = UnsafeMintValue $ getValue (scbMint finalState) + , txInfoRedeemers = Map.unsafeFromList $ sortBy (comparePurposeLedger `on` fst) $ Map.toList $ scbRedeemers finalState + , txInfoFee = fromIntegral (scbFee finalState) + , txInfoSignatories = scbSignatories finalState + , txInfoTxCerts = scbCerts finalState + , txInfoWdrl = scbWdrl finalState + , txInfoValidRange = scbValidRange finalState + , txInfoData = Map.empty + , txInfoId = scbTxId finalState + , txInfoVotes = Map.empty + , txInfoProposalProcedures = [] + , txInfoCurrentTreasuryAmount = Nothing + , txInfoTreasuryDonation = Nothing + } + in balanceWithChangeOutput $ ScriptContext txInfo (Redeemer $ scbRedeemer finalState) (scbScriptInfo finalState) diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/ScriptContextBuilder/Lenses.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/ScriptContextBuilder/Lenses.hs new file mode 100644 index 00000000000..98fae2f5dc0 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/ScriptContextBuilder/Lenses.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ImplicitPrelude #-} + +module PlutusLedgerApi.Test.ScriptContextBuilder.Lenses + ( scriptContextTxInfoL + , scriptContextRedeemerL + , scriptContextScriptInfoL + , txInfoInputsL + , txInfoMintL + , txInfoSignatoriesL + , txInfoOutputsL + , txInfoValidRangeL + , txInfoRedeemersL + , txInfoFeeL + , txInfoWdrlL + , txInfoVotesL + , txInfoTxCertsL + , txInfoTreasuryDonationL + , txInfoReferenceInputsL + , txInfoProposalProceduresL + , txInfoIdL + , txInfoDataL + , txInfoCurrentTreasuryAmountL + , txInInfoOutRefL + , txInInfoResolvedL + , txOutRefIdL + , txOutRefIdxL + , txOutAddressL + , txOutValueL + , txOutDatumL + , txOutReferenceScriptL + , addressCredentialL + , addressStakingCredentialL + , mintValueMapL + , valueMapL + , ivFromL + , ivToL + , lowerBoundExtendedL + , lowerBoundClosureL + , upperBoundExtendedL + , upperBoundClosureL + , _NegInf + , _Finite + , _PosInf + , _NoOutputDatum + , _OutputDatumHash + , _OutputDatum + , _Datum + , _Redeemer + ) +where + +import Control.Lens qualified as L +import Data.List (sortBy) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Ord (comparing) +import PlutusLedgerApi.Test.ScriptContextBuilder.Lenses.TH (makeLensesWithL) +import PlutusLedgerApi.V1 qualified as PV1 +import PlutusLedgerApi.V3 + ( OutputDatum + , ScriptContext + , TxInInfo + , TxInfo + , TxOut + , TxOutRef + ) +import PlutusLedgerApi.V3 qualified as PV3 +import PlutusLedgerApi.V3.MintValue +import PlutusTx.AssocMap qualified as AssocMap +import PlutusTx.Prelude qualified as PlutusTx + +makeLensesWithL ''ScriptContext + +L.makeLensesFor + [ ("txInfoInputs", "txInfoInputsL") + , ("txInfoMint", "txInfoMintL") + , ("txInfoSignatories", "txInfoSignatoriesL") + , ("txInfoOutputs", "txInfoOutputsL") + , ("txInfoValidRange", "txInfoValidRangeL") + , ("txInfoFee", "txInfoFeeL") + , ("txInfoWdrl", "txInfoWdrlL") + , ("txInfoVotes", "txInfoVotesL") + , ("txInfoTxCerts", "txInfoTxCertsL") + , ("txInfoTreasuryDonation", "txInfoTreasuryDonationL") + , ("txInfoReferenceInputs", "txInfoReferenceInputsL") + , ("txInfoProposalProcedures", "txInfoProposalProceduresL") + , ("txInfoId", "txInfoIdL") + , ("txInfoData", "txInfoDataL") + , ("txInfoCurrentTreasuryAmount", "txInfoCurrentTreasuryAmountL") + ] + ''TxInfo + +makeLensesWithL ''TxInInfo + +makeLensesWithL ''TxOutRef + +makeLensesWithL ''TxOut + +makeLensesWithL ''PV1.Address + +L.makePrisms ''PV1.Credential +L.makePrisms ''PV1.StakingCredential +L.makePrisms ''OutputDatum + +makeLensesWithL ''PV1.Interval + +L.makePrisms ''PV1.Extended + +_Datum :: forall a. (PV1.FromData a, PV1.ToData a) => L.Prism' PV1.Datum a +_Datum = L.prism' from to + where + to :: PV1.Datum -> Maybe a + to = PV1.fromBuiltinData . PV1.getDatum + + from :: a -> PV1.Datum + from = PV1.Datum . PV1.toBuiltinData + +_Redeemer :: forall a. (PV1.FromData a, PV1.ToData a) => L.Prism' PV1.Redeemer a +_Redeemer = L.prism' from to + where + to :: PV1.Redeemer -> Maybe a + to = PV1.fromBuiltinData . PV1.getRedeemer + + from :: a -> PV1.Redeemer + from = PV1.Redeemer . PV1.toBuiltinData + +txInfoRedeemersL :: L.Lens' PV3.TxInfo (Map PV3.ScriptPurpose PV3.Redeemer) +txInfoRedeemersL = L.lens getter setter + where + getter txInfo = Map.fromList $ AssocMap.toList $ PV3.txInfoRedeemers txInfo + setter txInfo redeemerMap = txInfo {PV3.txInfoRedeemers = AssocMap.unsafeFromList $ Map.toList redeemerMap} + +mintValueMapL :: L.Lens' MintValue (Map PV1.CurrencySymbol (Map PV1.TokenName Integer)) +mintValueMapL = L.lens getter setter + where + getter mp = Map.fromList $ AssocMap.toList $ PlutusTx.fmap (\v -> Map.fromList $ AssocMap.toList v) $ mintValueToMap mp + setter _ v = + UnsafeMintValue $ + AssocMap.unsafeFromList $ + sortBy (comparing fst) $ + Map.toList $ + fmap (AssocMap.unsafeFromList . sortBy (comparing fst) . Map.toList) v + +valueMapL :: L.Lens' PV1.Value (Map PV1.CurrencySymbol (Map PV1.TokenName Integer)) +valueMapL = L.lens getter setter + where + getter mp = + Map.fromList $ + AssocMap.toList $ + PlutusTx.fmap (\v -> Map.fromList $ AssocMap.toList v) $ + PV1.getValue mp + setter _ v = + PV1.Value $ + AssocMap.unsafeFromList $ + sortBy (comparing fst) $ + Map.toList $ + fmap (AssocMap.unsafeFromList . sortBy (comparing fst) . Map.toList) v + +lowerBoundExtendedL :: L.Lens' (PV1.LowerBound a) (PV1.Extended a) +lowerBoundExtendedL = L.lens getter setter + where + getter (PV1.LowerBound e _) = e + setter (PV1.LowerBound _ c) e = PV1.LowerBound e c + +lowerBoundClosureL :: L.Lens' (PV1.LowerBound a) PV1.Closure +lowerBoundClosureL = L.lens getter setter + where + getter (PV1.LowerBound _ c) = c + setter (PV1.LowerBound e _) c = PV1.LowerBound e c + +upperBoundExtendedL :: L.Lens' (PV1.UpperBound a) (PV1.Extended a) +upperBoundExtendedL = L.lens getter setter + where + getter (PV1.UpperBound e _) = e + setter (PV1.UpperBound _ c) e = PV1.UpperBound e c + +upperBoundClosureL :: L.Lens' (PV1.UpperBound a) PV1.Closure +upperBoundClosureL = L.lens getter setter + where + getter (PV1.UpperBound _ c) = c + setter (PV1.UpperBound e _) c = PV1.UpperBound e c diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/ScriptContextBuilder/Lenses/TH.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/ScriptContextBuilder/Lenses/TH.hs new file mode 100644 index 00000000000..b46da5b5bf6 --- /dev/null +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/ScriptContextBuilder/Lenses/TH.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ImplicitPrelude #-} + +module PlutusLedgerApi.Test.ScriptContextBuilder.Lenses.TH + ( makeLensesWithL + ) where + +import Control.Lens qualified as L +import Language.Haskell.TH (DecsQ, Name) + +{-| Uses 'makeLensesWith' to automatically create lens fields, but adds the 'L' +suffix to each lens field name. -} +makeLensesWithL :: Name -> DecsQ +makeLensesWithL = L.makeLensesWith (L.defaultFieldRules L.& L.lensField L..~ L.mappingNamer (\s -> [s ++ "L"])) diff --git a/plutus-tx-plugin/test/AsData/Budget/9.6/destructSum-manual.golden.eval b/plutus-tx-plugin/test/AsData/Budget/9.6/destructSum-manual.golden.eval index f3a963935af..feba1699949 100644 --- a/plutus-tx-plugin/test/AsData/Budget/9.6/destructSum-manual.golden.eval +++ b/plutus-tx-plugin/test/AsData/Budget/9.6/destructSum-manual.golden.eval @@ -1,6 +1,6 @@ -CPU: 6_401_583 -Memory: 25_195 -AST Size: 218 -Flat Size: 226 +CPU: 5_268_584 +Memory: 19_092 +AST Size: 186 +Flat Size: 196 (con data (Constr 0 [I 20, I 40, I 60, I 80])) \ No newline at end of file diff --git a/plutus-tx-plugin/test/AsData/Budget/9.6/destructSum-manual.golden.pir b/plutus-tx-plugin/test/AsData/Budget/9.6/destructSum-manual.golden.pir index 18039203d97..bf98b74f2d4 100644 --- a/plutus-tx-plugin/test/AsData/Budget/9.6/destructSum-manual.golden.pir +++ b/plutus-tx-plugin/test/AsData/Budget/9.6/destructSum-manual.golden.pir @@ -1,115 +1,102 @@ let - data Unit | Unit_match where - Unit : Unit - !fail : unit -> data - = \(ds : unit) -> - let - !defaultBody : data = error {data} - in - Unit_match (error {Unit}) {data} defaultBody - !`$mInts` : - all r. - data -> - (integer -> integer -> integer -> integer -> r) -> - (unit -> r) -> - r - = /\r -> - \(scrut : data) - (cont : integer -> integer -> integer -> integer -> r) - (fail : unit -> r) -> - let - !l : list data - = case - (list data) - (unConstrData scrut) - [(\(l : integer) (r : list data) -> r)] - !l : list data = tailList {data} l - !l : list data = tailList {data} l - in - cont - (unIData (headList {data} l)) - (unIData (headList {data} l)) - (unIData (headList {data} l)) - (unIData (headList {data} (tailList {data} l))) + !snd : all a b. pair a b -> b + = /\a b -> \(x : pair a b) -> case b x [(\(l : a) (r : b) -> r)] in \(d : data) -> let - !tup : pair integer (list data) = unConstrData d + !constrPair : pair integer (list data) = unConstrData d in - case - (all dead. data) - (equalsInteger 0 (case integer tup [(\(l : integer) (r : list data) -> l)])) - [ (/\dead -> - let - !tup : pair integer (list data) = unConstrData d + (let + a = integer -> list data -> data + in + /\b -> \(f : a -> b) (x : a) -> f x) + {data} + ((let + b = list data + in + /\r -> \(p : pair integer b) (f : integer -> b -> r) -> case r p [f]) + {data} + constrPair) + (\(idx : integer) (args : list data) -> + case + data + idx + [ (headList {data} args) + , (headList {data} args) + , (let + !intsB : list data + = (let + a = pair integer (list data) + in + /\b -> \(f : a -> b) (x : a) -> f x) + {list data} + (snd {integer} {list data}) + (unConstrData (headList {data} (tailList {data} args))) + !intsA : list data + = (let + a = pair integer (list data) + in + /\b -> \(f : a -> b) (x : a) -> f x) + {list data} + (snd {integer} {list data}) + (unConstrData (headList {data} args)) + !b1_tail : list data = tailList {data} intsB + !b : integer = unIData (headList {data} b1_tail) + !b2_tail : list data = tailList {data} b1_tail + !b : integer = unIData (headList {data} b2_tail) + !b : integer + = unIData + ((let + a = list data + in + /\b -> \(f : a -> b) (x : a) -> f x) + {data} + (headList {data}) + (tailList {data} b2_tail)) + !b : integer = unIData (headList {data} intsB) + !a1_tail : list data = tailList {data} intsA + !a : integer = unIData (headList {data} a1_tail) + !a2_tail : list data = tailList {data} a1_tail + !a : integer = unIData (headList {data} a2_tail) + !a : integer + = unIData + ((let + a = list data + in + /\b -> \(f : a -> b) (x : a) -> f x) + {data} + (headList {data}) + (tailList {data} a2_tail)) + !a : integer = unIData (headList {data} intsA) in - case - (all dead. data) - (equalsInteger - 1 - (case integer tup [(\(l : integer) (r : list data) -> l)])) - [ (/\dead -> - let - !tup : pair integer (list data) = unConstrData d - in - case - (all dead. data) - (equalsInteger - 2 - (case integer tup [(\(l : integer) (r : list data) -> l)])) - [ (/\dead -> fail ()) - , (/\dead -> - let - !args : list data - = case - (list data) - tup - [(\(l : integer) (r : list data) -> r)] - !y : data = headList {data} (tailList {data} args) - !ds : data = headList {data} args - in - `$mInts` - {data} - ds - (\(x : integer) - (y : integer) - (z : integer) - (w : integer) -> - `$mInts` - {data} - y - (\(x : integer) - (y : integer) - (z : integer) - (w : integer) -> - constrData - 0 - (mkCons - {data} - (iData (addInteger x x)) - (mkCons - {data} - (iData (addInteger y y)) - (mkCons - {data} - (iData (addInteger z z)) - (mkCons - {data} - (iData (addInteger w w)) - []))))) - (\(void : unit) -> fail ())) - (\(void : unit) -> fail ())) ] - {all dead. dead}) - , (/\dead -> - headList - {data} - (case - (list data) - tup - [(\(l : integer) (r : list data) -> r)])) ] - {all dead. dead}) - , (/\dead -> - headList + (let + a = list data + in + /\b -> \(f : a -> b) (x : a) -> f x) {data} - (case (list data) tup [(\(l : integer) (r : list data) -> r)])) ] - {all dead. dead} \ No newline at end of file + (constrData 0) + ((let + a = list data + in + /\b -> \(f : a -> b) (x : a) -> f x) + {list data} + (mkCons {data} (iData (addInteger a b))) + ((let + a = list data + in + /\b -> \(f : a -> b) (x : a) -> f x) + {list data} + (mkCons {data} (iData (addInteger a b))) + ((let + a = list data + in + /\b -> \(f : a -> b) (x : a) -> f x) + {list data} + (mkCons {data} (iData (addInteger a b))) + ((let + a = list data + in + /\b -> \(f : a -> b) (x : a) -> f x) + {list data} + (mkCons {data} (iData (addInteger a b))) + []))))) ]) \ No newline at end of file diff --git a/plutus-tx-plugin/test/AsData/Budget/9.6/destructSum-manual.golden.uplc b/plutus-tx-plugin/test/AsData/Budget/9.6/destructSum-manual.golden.uplc index 2104f3f5fd4..d3bf578f554 100644 --- a/plutus-tx-plugin/test/AsData/Budget/9.6/destructSum-manual.golden.uplc +++ b/plutus-tx-plugin/test/AsData/Budget/9.6/destructSum-manual.golden.uplc @@ -1,54 +1,79 @@ (program 1.1.0 (\d -> - (\cse -> - case - (equalsInteger 0 (case cse [(\l r -> l)])) - [ (case - (equalsInteger 1 (case cse [(\l r -> l)])) - [ (case - (equalsInteger 2 (case cse [(\l r -> l)])) - [ ((\cse -> case cse [cse]) error) - , ((\args -> - (\y -> - (\`$mInts` -> - `$mInts` - (force headList args) - (\x y z w -> - `$mInts` - y - (\x y z w -> - constrData - 0 - (force mkCons - (iData (addInteger x x)) - (force mkCons - (iData (addInteger y y)) - (force mkCons - (iData (addInteger z z)) - (force mkCons - (iData - (addInteger w w)) - []))))) - (\void -> - (\cse -> case cse [cse]) error))) - (\scrut cont fail -> - (\l -> - (\l -> - (\l -> - cont - (unIData (force headList l)) - (unIData (force headList l)) - (unIData (force headList l)) - (unIData - (force headList - (force tailList l)))) - (force tailList l)) - (force tailList l)) - (case (unConstrData scrut) [(\l r -> r)])) - (\void -> (\cse -> case cse [cse]) error)) - (force headList (force tailList args))) - (case cse [(\l r -> r)])) ]) - , (force headList (case cse [(\l r -> r)])) ]) - , (force headList (case cse [(\l r -> r)])) ]) - (unConstrData d))) \ No newline at end of file + case + (unConstrData d) + [ (\idx + args -> + case + idx + [ (force headList args) + , (force headList args) + , ((\intsB -> + (\intsA -> + (\b1_tail -> + (\b -> + (\b2_tail -> + (\b -> + (\b -> + (\b -> + (\a1_tail -> + (\a -> + (\a2_tail -> + (\a -> + (\a -> + constrData + 0 + (force + mkCons + (iData + (addInteger + (unIData + (force + headList + intsA)) + b)) + (force + mkCons + (iData + (addInteger + a + b)) + (force + mkCons + (iData + (addInteger + a + b)) + (force + mkCons + (iData + (addInteger + a + b)) + []))))) + (unIData + (force headList + (force tailList + a2_tail)))) + (unIData + (force headList + a2_tail))) + (force tailList a1_tail)) + (unIData + (force headList a1_tail))) + (force tailList intsA)) + (unIData (force headList intsB))) + (unIData + (force headList + (force tailList b2_tail)))) + (unIData (force headList b2_tail))) + (force tailList b1_tail)) + (unIData (force headList b1_tail))) + (force tailList intsB)) + (case + (unConstrData (force headList args)) + [(\l r -> r)])) + (case + (unConstrData (force headList (force tailList args))) + [(\l r -> r)])) ]) ])) \ No newline at end of file diff --git a/plutus-tx-plugin/test/AsData/Budget/Spec.hs b/plutus-tx-plugin/test/AsData/Budget/Spec.hs index 725aa5409b3..6deb20f8621 100644 --- a/plutus-tx-plugin/test/AsData/Budget/Spec.hs +++ b/plutus-tx-plugin/test/AsData/Budget/Spec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} @@ -11,6 +12,7 @@ import Test.Tasty.Extras import AsData.Budget.Types import PlutusTx.Builtins qualified as PlutusTx +import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.Code import PlutusTx.IsData qualified as PlutusTx import PlutusTx.Lift (liftCodeDef) @@ -129,20 +131,39 @@ destructSum = ||] ) -destructSumManual :: CompiledCode (PlutusTx.BuiltinData -> Ints) +destructSumManual :: CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData) destructSumManual = $$( compile [|| \d -> - case PlutusTx.unsafeFromBuiltinData d of - ThisDManual is -> is - ThatDManual is -> is - TheseDManual (Ints x1 y1 z1 w1) (Ints x2 y2 z2 w2) -> - Ints - (x1 `PlutusTx.addInteger` x2) - (y1 `PlutusTx.addInteger` y2) - (z1 `PlutusTx.addInteger` z2) - (w1 `PlutusTx.addInteger` w2) + let !constrPair = BI.unsafeDataAsConstr d + in BI.casePair constrPair $ \idx args -> + BI.caseInteger + idx + [ (BI.head args) + , (BI.head args) + , let intsA = BI.snd $ BI.unsafeDataAsConstr $ BI.head args + intsB = BI.snd $ BI.unsafeDataAsConstr $ BI.head (BI.tail args) + in let a1 = BI.unsafeDataAsI (BI.head intsA) + !a1_tail = BI.tail intsA + a2 = BI.unsafeDataAsI (BI.head a1_tail) + !a2_tail = BI.tail a1_tail + a3 = BI.unsafeDataAsI (BI.head a2_tail) + a4 = BI.unsafeDataAsI (BI.head $ BI.tail a2_tail) + + b1 = BI.unsafeDataAsI (BI.head intsB) + !b1_tail = BI.tail intsB + b2 = BI.unsafeDataAsI (BI.head b1_tail) + !b2_tail = BI.tail b1_tail + b3 = BI.unsafeDataAsI (BI.head b2_tail) + b4 = BI.unsafeDataAsI (BI.head $ BI.tail b2_tail) + in BI.mkConstr 0 $ + BI.mkCons (BI.mkI $ a1 `PlutusTx.addInteger` b1) $ + BI.mkCons (BI.mkI $ a2 `PlutusTx.addInteger` b2) $ + BI.mkCons (BI.mkI $ a3 `PlutusTx.addInteger` b3) $ + BI.mkCons (BI.mkI $ a4 `PlutusTx.addInteger` b4) $ + BI.mkNilData BI.unitval + ] ||] )