diff --git a/plutus-core/testlib/Test/Tasty/Extras.hs b/plutus-core/testlib/Test/Tasty/Extras.hs index 86e183241ee..98d71ca10e3 100644 --- a/plutus-core/testlib/Test/Tasty/Extras.hs +++ b/plutus-core/testlib/Test/Tasty/Extras.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} module Test.Tasty.Extras ( Layer (..) @@ -24,6 +24,7 @@ module Test.Tasty.Extras , goldenVsDoc , goldenVsDocM , nestedGoldenVsText + , nestedGoldenVsTextPredM , nestedGoldenVsTextM , nestedGoldenVsDoc , nestedGoldenVsDocM @@ -33,16 +34,18 @@ module Test.Tasty.Extras import PlutusPrelude hiding (toList) import Control.Monad.Free.Church (F (runF), MonadFree, liftF) -import Control.Monad.Reader +import Control.Monad.Reader (MonadReader (ask, local), ReaderT (..), asks, mapReaderT) import Data.ByteString.Lazy qualified as BSL import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) -import Data.Version -import GHC.Exts +import Data.Text.IO qualified as TIO +import Data.Version (showVersion) +import GHC.Exts (IsList (Item, fromList, toList)) import System.FilePath (joinPath, ()) -import System.Info -import Test.Tasty -import Test.Tasty.Golden +import System.Info (compilerVersion) +import Test.Tasty (TestName, TestTree, testGroup) +import Test.Tasty.Golden (createDirectoriesAndWriteFile, goldenVsStringDiff) +import Test.Tasty.Golden.Advanced (goldenTest) -- | We use the GHC version number to create directories with names like `9.2` -- and `9.6` containing golden files whose contents depend on the GHC version. @@ -206,6 +209,28 @@ goldenVsDocM name ref val = goldenVsTextM name ref $ render <$> val nestedGoldenVsText :: TestName -> FilePath -> Text -> TestNested nestedGoldenVsText name ext = nestedGoldenVsTextM name ext . pure +{-| Compare the contents of a file under a name prefix against a 'Text' +using a predicate. +-} +nestedGoldenVsTextPredM + :: TestName + -- ^ The name of the test + -> FilePath + -- ^ The file extension + -> IO Text + -- ^ The text-producing action to execute + -> (Text -> Text -> Bool) + -- ^ How to compare golden file contents with the produced text + -> TestNested +nestedGoldenVsTextPredM name ext action predicate = do + filePath <- asks $ foldr () (name ++ ext ++ ".golden") + embed $ goldenTest name (TIO.readFile filePath) action + do \golden actual -> pure + if predicate golden actual + then Nothing + else Just "Predicate failed on golden file" + do createDirectoriesAndWriteFile filePath . BSL.fromStrict . encodeUtf8 + -- | Check the contents of a file under a name prefix against a 'Text'. nestedGoldenVsTextM :: TestName -> FilePath -> IO Text -> TestNested nestedGoldenVsTextM name ext text = do @@ -219,3 +244,4 @@ nestedGoldenVsDoc name ext = nestedGoldenVsDocM name ext . pure -- | Check the contents of a file under a name prefix against a 'Text'. nestedGoldenVsDocM :: TestName -> FilePath -> IO (Doc ann) -> TestNested nestedGoldenVsDocM name ext val = nestedGoldenVsTextM name ext $ render <$> val + diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs index adf7ac663f9..7d6269c2ac1 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -104,7 +104,7 @@ test_IntegerDistribution = \(AsArbitraryBuiltin (i :: Integer)) -> let magnitudes = magnitudesPositive nextInterestingBound highInterestingBound (low, high) = - maybe (error $ "Panic: unknown integer") (bimap (* signum i) (* signum i)) $ + maybe (error "Panic: unknown integer") (bimap (* signum i) (* signum i)) $ find ((>= abs i) . snd) magnitudes bounds = map snd magnitudes isInteresting = i `elem` concat @@ -390,7 +390,7 @@ test_BuiltinArray = let arrayOfInts = mkConstant @(Vector Integer) @DefaultUni () (Vector.fromList [1..10]) let index = mkConstant @Integer @DefaultUni () 5 expectedValue = mkConstant @Integer @DefaultUni () 6 - term = mkIterAppNoAnn (tyInst () (builtin () IndexArray) integer) [index, arrayOfInts] + term = mkIterAppNoAnn (tyInst () (builtin () IndexArray) integer) [arrayOfInts, index] typecheckEvaluateCekNoEmit def defaultBuiltinCostModelForTesting term @?= Right (EvaluationSuccess expectedValue) ] diff --git a/plutus-ledger-api/CostModel/Data/Params/CostModelParams/costModelParamNames.txt.golden b/plutus-ledger-api/CostModel/Data/Params/CostModelParams/costModelParamNames.txt.golden new file mode 100644 index 00000000000..a84e243661f --- /dev/null +++ b/plutus-ledger-api/CostModel/Data/Params/CostModelParams/costModelParamNames.txt.golden @@ -0,0 +1,303 @@ +addInteger-cpu-arguments-intercept +addInteger-cpu-arguments-slope +addInteger-memory-arguments-intercept +addInteger-memory-arguments-slope +appendByteString-cpu-arguments-intercept +appendByteString-cpu-arguments-slope +appendByteString-memory-arguments-intercept +appendByteString-memory-arguments-slope +appendString-cpu-arguments-intercept +appendString-cpu-arguments-slope +appendString-memory-arguments-intercept +appendString-memory-arguments-slope +bData-cpu-arguments +bData-memory-arguments +blake2b_256-cpu-arguments-intercept +blake2b_256-cpu-arguments-slope +blake2b_256-memory-arguments +cekApplyCost-exBudgetCPU +cekApplyCost-exBudgetMemory +cekBuiltinCost-exBudgetCPU +cekBuiltinCost-exBudgetMemory +cekConstCost-exBudgetCPU +cekConstCost-exBudgetMemory +cekDelayCost-exBudgetCPU +cekDelayCost-exBudgetMemory +cekForceCost-exBudgetCPU +cekForceCost-exBudgetMemory +cekLamCost-exBudgetCPU +cekLamCost-exBudgetMemory +cekStartupCost-exBudgetCPU +cekStartupCost-exBudgetMemory +cekVarCost-exBudgetCPU +cekVarCost-exBudgetMemory +chooseData-cpu-arguments +chooseData-memory-arguments +chooseList-cpu-arguments +chooseList-memory-arguments +chooseUnit-cpu-arguments +chooseUnit-memory-arguments +consByteString-cpu-arguments-intercept +consByteString-cpu-arguments-slope +consByteString-memory-arguments-intercept +consByteString-memory-arguments-slope +constrData-cpu-arguments +constrData-memory-arguments +decodeUtf8-cpu-arguments-intercept +decodeUtf8-cpu-arguments-slope +decodeUtf8-memory-arguments-intercept +decodeUtf8-memory-arguments-slope +divideInteger-cpu-arguments-constant +divideInteger-cpu-arguments-model-arguments-c00 +divideInteger-cpu-arguments-model-arguments-c01 +divideInteger-cpu-arguments-model-arguments-c02 +divideInteger-cpu-arguments-model-arguments-c10 +divideInteger-cpu-arguments-model-arguments-c11 +divideInteger-cpu-arguments-model-arguments-c20 +divideInteger-cpu-arguments-model-arguments-minimum +divideInteger-memory-arguments-intercept +divideInteger-memory-arguments-minimum +divideInteger-memory-arguments-slope +encodeUtf8-cpu-arguments-intercept +encodeUtf8-cpu-arguments-slope +encodeUtf8-memory-arguments-intercept +encodeUtf8-memory-arguments-slope +equalsByteString-cpu-arguments-constant +equalsByteString-cpu-arguments-intercept +equalsByteString-cpu-arguments-slope +equalsByteString-memory-arguments +equalsData-cpu-arguments-intercept +equalsData-cpu-arguments-slope +equalsData-memory-arguments +equalsInteger-cpu-arguments-intercept +equalsInteger-cpu-arguments-slope +equalsInteger-memory-arguments +equalsString-cpu-arguments-constant +equalsString-cpu-arguments-intercept +equalsString-cpu-arguments-slope +equalsString-memory-arguments +fstPair-cpu-arguments +fstPair-memory-arguments +headList-cpu-arguments +headList-memory-arguments +iData-cpu-arguments +iData-memory-arguments +ifThenElse-cpu-arguments +ifThenElse-memory-arguments +indexByteString-cpu-arguments +indexByteString-memory-arguments +lengthOfByteString-cpu-arguments +lengthOfByteString-memory-arguments +lessThanByteString-cpu-arguments-intercept +lessThanByteString-cpu-arguments-slope +lessThanByteString-memory-arguments +lessThanEqualsByteString-cpu-arguments-intercept +lessThanEqualsByteString-cpu-arguments-slope +lessThanEqualsByteString-memory-arguments +lessThanEqualsInteger-cpu-arguments-intercept +lessThanEqualsInteger-cpu-arguments-slope +lessThanEqualsInteger-memory-arguments +lessThanInteger-cpu-arguments-intercept +lessThanInteger-cpu-arguments-slope +lessThanInteger-memory-arguments +listData-cpu-arguments +listData-memory-arguments +mapData-cpu-arguments +mapData-memory-arguments +mkCons-cpu-arguments +mkCons-memory-arguments +mkNilData-cpu-arguments +mkNilData-memory-arguments +mkNilPairData-cpu-arguments +mkNilPairData-memory-arguments +mkPairData-cpu-arguments +mkPairData-memory-arguments +modInteger-cpu-arguments-constant +modInteger-cpu-arguments-model-arguments-c00 +modInteger-cpu-arguments-model-arguments-c01 +modInteger-cpu-arguments-model-arguments-c02 +modInteger-cpu-arguments-model-arguments-c10 +modInteger-cpu-arguments-model-arguments-c11 +modInteger-cpu-arguments-model-arguments-c20 +modInteger-cpu-arguments-model-arguments-minimum +modInteger-memory-arguments-intercept +modInteger-memory-arguments-slope +multiplyInteger-cpu-arguments-intercept +multiplyInteger-cpu-arguments-slope +multiplyInteger-memory-arguments-intercept +multiplyInteger-memory-arguments-slope +nullList-cpu-arguments +nullList-memory-arguments +quotientInteger-cpu-arguments-constant +quotientInteger-cpu-arguments-model-arguments-c00 +quotientInteger-cpu-arguments-model-arguments-c01 +quotientInteger-cpu-arguments-model-arguments-c02 +quotientInteger-cpu-arguments-model-arguments-c10 +quotientInteger-cpu-arguments-model-arguments-c11 +quotientInteger-cpu-arguments-model-arguments-c20 +quotientInteger-cpu-arguments-model-arguments-minimum +quotientInteger-memory-arguments-intercept +quotientInteger-memory-arguments-minimum +quotientInteger-memory-arguments-slope +remainderInteger-cpu-arguments-constant +remainderInteger-cpu-arguments-model-arguments-c00 +remainderInteger-cpu-arguments-model-arguments-c01 +remainderInteger-cpu-arguments-model-arguments-c02 +remainderInteger-cpu-arguments-model-arguments-c10 +remainderInteger-cpu-arguments-model-arguments-c11 +remainderInteger-cpu-arguments-model-arguments-c20 +remainderInteger-cpu-arguments-model-arguments-minimum +remainderInteger-memory-arguments-intercept +remainderInteger-memory-arguments-slope +serialiseData-cpu-arguments-intercept +serialiseData-cpu-arguments-slope +serialiseData-memory-arguments-intercept +serialiseData-memory-arguments-slope +sha2_256-cpu-arguments-intercept +sha2_256-cpu-arguments-slope +sha2_256-memory-arguments +sha3_256-cpu-arguments-intercept +sha3_256-cpu-arguments-slope +sha3_256-memory-arguments +sliceByteString-cpu-arguments-intercept +sliceByteString-cpu-arguments-slope +sliceByteString-memory-arguments-intercept +sliceByteString-memory-arguments-slope +sndPair-cpu-arguments +sndPair-memory-arguments +subtractInteger-cpu-arguments-intercept +subtractInteger-cpu-arguments-slope +subtractInteger-memory-arguments-intercept +subtractInteger-memory-arguments-slope +tailList-cpu-arguments +tailList-memory-arguments +trace-cpu-arguments +trace-memory-arguments +unBData-cpu-arguments +unBData-memory-arguments +unConstrData-cpu-arguments +unConstrData-memory-arguments +unIData-cpu-arguments +unIData-memory-arguments +unListData-cpu-arguments +unListData-memory-arguments +unMapData-cpu-arguments +unMapData-memory-arguments +verifyEcdsaSecp256k1Signature-cpu-arguments +verifyEcdsaSecp256k1Signature-memory-arguments +verifyEd25519Signature-cpu-arguments-intercept +verifyEd25519Signature-cpu-arguments-slope +verifyEd25519Signature-memory-arguments +verifySchnorrSecp256k1Signature-cpu-arguments-intercept +verifySchnorrSecp256k1Signature-cpu-arguments-slope +verifySchnorrSecp256k1Signature-memory-arguments +cekConstrCost-exBudgetCPU +cekConstrCost-exBudgetMemory +cekCaseCost-exBudgetCPU +cekCaseCost-exBudgetMemory +bls12_381_G1_add-cpu-arguments +bls12_381_G1_add-memory-arguments +bls12_381_G1_compress-cpu-arguments +bls12_381_G1_compress-memory-arguments +bls12_381_G1_equal-cpu-arguments +bls12_381_G1_equal-memory-arguments +bls12_381_G1_hashToGroup-cpu-arguments-intercept +bls12_381_G1_hashToGroup-cpu-arguments-slope +bls12_381_G1_hashToGroup-memory-arguments +bls12_381_G1_neg-cpu-arguments +bls12_381_G1_neg-memory-arguments +bls12_381_G1_scalarMul-cpu-arguments-intercept +bls12_381_G1_scalarMul-cpu-arguments-slope +bls12_381_G1_scalarMul-memory-arguments +bls12_381_G1_uncompress-cpu-arguments +bls12_381_G1_uncompress-memory-arguments +bls12_381_G2_add-cpu-arguments +bls12_381_G2_add-memory-arguments +bls12_381_G2_compress-cpu-arguments +bls12_381_G2_compress-memory-arguments +bls12_381_G2_equal-cpu-arguments +bls12_381_G2_equal-memory-arguments +bls12_381_G2_hashToGroup-cpu-arguments-intercept +bls12_381_G2_hashToGroup-cpu-arguments-slope +bls12_381_G2_hashToGroup-memory-arguments +bls12_381_G2_neg-cpu-arguments +bls12_381_G2_neg-memory-arguments +bls12_381_G2_scalarMul-cpu-arguments-intercept +bls12_381_G2_scalarMul-cpu-arguments-slope +bls12_381_G2_scalarMul-memory-arguments +bls12_381_G2_uncompress-cpu-arguments +bls12_381_G2_uncompress-memory-arguments +bls12_381_finalVerify-cpu-arguments +bls12_381_finalVerify-memory-arguments +bls12_381_millerLoop-cpu-arguments +bls12_381_millerLoop-memory-arguments +bls12_381_mulMlResult-cpu-arguments +bls12_381_mulMlResult-memory-arguments +keccak_256-cpu-arguments-intercept +keccak_256-cpu-arguments-slope +keccak_256-memory-arguments +blake2b_224-cpu-arguments-intercept +blake2b_224-cpu-arguments-slope +blake2b_224-memory-arguments +integerToByteString-cpu-arguments-c0 +integerToByteString-cpu-arguments-c1 +integerToByteString-cpu-arguments-c2 +integerToByteString-memory-arguments-intercept +integerToByteString-memory-arguments-slope +byteStringToInteger-cpu-arguments-c0 +byteStringToInteger-cpu-arguments-c1 +byteStringToInteger-cpu-arguments-c2 +byteStringToInteger-memory-arguments-intercept +byteStringToInteger-memory-arguments-slope +andByteString-cpu-arguments-intercept +andByteString-cpu-arguments-slope1 +andByteString-cpu-arguments-slope2 +andByteString-memory-arguments-intercept +andByteString-memory-arguments-slope +orByteString-cpu-arguments-intercept +orByteString-cpu-arguments-slope1 +orByteString-cpu-arguments-slope2 +orByteString-memory-arguments-intercept +orByteString-memory-arguments-slope +xorByteString-cpu-arguments-intercept +xorByteString-cpu-arguments-slope1 +xorByteString-cpu-arguments-slope2 +xorByteString-memory-arguments-intercept +xorByteString-memory-arguments-slope +complementByteString-cpu-arguments-intercept +complementByteString-cpu-arguments-slope +complementByteString-memory-arguments-intercept +complementByteString-memory-arguments-slope +readBit-cpu-arguments +readBit-memory-arguments +writeBits-cpu-arguments-intercept +writeBits-cpu-arguments-slope +writeBits-memory-arguments-intercept +writeBits-memory-arguments-slope +replicateByte-cpu-arguments-intercept +replicateByte-cpu-arguments-slope +replicateByte-memory-arguments-intercept +replicateByte-memory-arguments-slope +shiftByteString-cpu-arguments-intercept +shiftByteString-cpu-arguments-slope +shiftByteString-memory-arguments-intercept +shiftByteString-memory-arguments-slope +rotateByteString-cpu-arguments-intercept +rotateByteString-cpu-arguments-slope +rotateByteString-memory-arguments-intercept +rotateByteString-memory-arguments-slope +countSetBits-cpu-arguments-intercept +countSetBits-cpu-arguments-slope +countSetBits-memory-arguments +findFirstSetBit-cpu-arguments-intercept +findFirstSetBit-cpu-arguments-slope +findFirstSetBit-memory-arguments +ripemd_160-cpu-arguments-intercept +ripemd_160-cpu-arguments-slope +ripemd_160-memory-arguments +lengthArray-cpu-arguments +lengthArray-memory-arguments +listToArray-cpu-arguments +listToArray-memory-arguments +indexArray-cpu-arguments +indexArray-memory-arguments diff --git a/plutus-ledger-api/CostModel/Params/CostModelParams/costModelParamNames.txt.golden b/plutus-ledger-api/CostModel/Params/CostModelParams/costModelParamNames.txt.golden new file mode 100644 index 00000000000..af03f20c567 --- /dev/null +++ b/plutus-ledger-api/CostModel/Params/CostModelParams/costModelParamNames.txt.golden @@ -0,0 +1,297 @@ +addInteger-cpu-arguments-intercept +addInteger-cpu-arguments-slope +addInteger-memory-arguments-intercept +addInteger-memory-arguments-slope +appendByteString-cpu-arguments-intercept +appendByteString-cpu-arguments-slope +appendByteString-memory-arguments-intercept +appendByteString-memory-arguments-slope +appendString-cpu-arguments-intercept +appendString-cpu-arguments-slope +appendString-memory-arguments-intercept +appendString-memory-arguments-slope +bData-cpu-arguments +bData-memory-arguments +blake2b_256-cpu-arguments-intercept +blake2b_256-cpu-arguments-slope +blake2b_256-memory-arguments +cekApplyCost-exBudgetCPU +cekApplyCost-exBudgetMemory +cekBuiltinCost-exBudgetCPU +cekBuiltinCost-exBudgetMemory +cekConstCost-exBudgetCPU +cekConstCost-exBudgetMemory +cekDelayCost-exBudgetCPU +cekDelayCost-exBudgetMemory +cekForceCost-exBudgetCPU +cekForceCost-exBudgetMemory +cekLamCost-exBudgetCPU +cekLamCost-exBudgetMemory +cekStartupCost-exBudgetCPU +cekStartupCost-exBudgetMemory +cekVarCost-exBudgetCPU +cekVarCost-exBudgetMemory +chooseData-cpu-arguments +chooseData-memory-arguments +chooseList-cpu-arguments +chooseList-memory-arguments +chooseUnit-cpu-arguments +chooseUnit-memory-arguments +consByteString-cpu-arguments-intercept +consByteString-cpu-arguments-slope +consByteString-memory-arguments-intercept +consByteString-memory-arguments-slope +constrData-cpu-arguments +constrData-memory-arguments +decodeUtf8-cpu-arguments-intercept +decodeUtf8-cpu-arguments-slope +decodeUtf8-memory-arguments-intercept +decodeUtf8-memory-arguments-slope +divideInteger-cpu-arguments-constant +divideInteger-cpu-arguments-model-arguments-c00 +divideInteger-cpu-arguments-model-arguments-c01 +divideInteger-cpu-arguments-model-arguments-c02 +divideInteger-cpu-arguments-model-arguments-c10 +divideInteger-cpu-arguments-model-arguments-c11 +divideInteger-cpu-arguments-model-arguments-c20 +divideInteger-cpu-arguments-model-arguments-minimum +divideInteger-memory-arguments-intercept +divideInteger-memory-arguments-minimum +divideInteger-memory-arguments-slope +encodeUtf8-cpu-arguments-intercept +encodeUtf8-cpu-arguments-slope +encodeUtf8-memory-arguments-intercept +encodeUtf8-memory-arguments-slope +equalsByteString-cpu-arguments-constant +equalsByteString-cpu-arguments-intercept +equalsByteString-cpu-arguments-slope +equalsByteString-memory-arguments +equalsData-cpu-arguments-intercept +equalsData-cpu-arguments-slope +equalsData-memory-arguments +equalsInteger-cpu-arguments-intercept +equalsInteger-cpu-arguments-slope +equalsInteger-memory-arguments +equalsString-cpu-arguments-constant +equalsString-cpu-arguments-intercept +equalsString-cpu-arguments-slope +equalsString-memory-arguments +fstPair-cpu-arguments +fstPair-memory-arguments +headList-cpu-arguments +headList-memory-arguments +iData-cpu-arguments +iData-memory-arguments +ifThenElse-cpu-arguments +ifThenElse-memory-arguments +indexByteString-cpu-arguments +indexByteString-memory-arguments +lengthOfByteString-cpu-arguments +lengthOfByteString-memory-arguments +lessThanByteString-cpu-arguments-intercept +lessThanByteString-cpu-arguments-slope +lessThanByteString-memory-arguments +lessThanEqualsByteString-cpu-arguments-intercept +lessThanEqualsByteString-cpu-arguments-slope +lessThanEqualsByteString-memory-arguments +lessThanEqualsInteger-cpu-arguments-intercept +lessThanEqualsInteger-cpu-arguments-slope +lessThanEqualsInteger-memory-arguments +lessThanInteger-cpu-arguments-intercept +lessThanInteger-cpu-arguments-slope +lessThanInteger-memory-arguments +listData-cpu-arguments +listData-memory-arguments +mapData-cpu-arguments +mapData-memory-arguments +mkCons-cpu-arguments +mkCons-memory-arguments +mkNilData-cpu-arguments +mkNilData-memory-arguments +mkNilPairData-cpu-arguments +mkNilPairData-memory-arguments +mkPairData-cpu-arguments +mkPairData-memory-arguments +modInteger-cpu-arguments-constant +modInteger-cpu-arguments-model-arguments-c00 +modInteger-cpu-arguments-model-arguments-c01 +modInteger-cpu-arguments-model-arguments-c02 +modInteger-cpu-arguments-model-arguments-c10 +modInteger-cpu-arguments-model-arguments-c11 +modInteger-cpu-arguments-model-arguments-c20 +modInteger-cpu-arguments-model-arguments-minimum +modInteger-memory-arguments-intercept +modInteger-memory-arguments-slope +multiplyInteger-cpu-arguments-intercept +multiplyInteger-cpu-arguments-slope +multiplyInteger-memory-arguments-intercept +multiplyInteger-memory-arguments-slope +nullList-cpu-arguments +nullList-memory-arguments +quotientInteger-cpu-arguments-constant +quotientInteger-cpu-arguments-model-arguments-c00 +quotientInteger-cpu-arguments-model-arguments-c01 +quotientInteger-cpu-arguments-model-arguments-c02 +quotientInteger-cpu-arguments-model-arguments-c10 +quotientInteger-cpu-arguments-model-arguments-c11 +quotientInteger-cpu-arguments-model-arguments-c20 +quotientInteger-cpu-arguments-model-arguments-minimum +quotientInteger-memory-arguments-intercept +quotientInteger-memory-arguments-minimum +quotientInteger-memory-arguments-slope +remainderInteger-cpu-arguments-constant +remainderInteger-cpu-arguments-model-arguments-c00 +remainderInteger-cpu-arguments-model-arguments-c01 +remainderInteger-cpu-arguments-model-arguments-c02 +remainderInteger-cpu-arguments-model-arguments-c10 +remainderInteger-cpu-arguments-model-arguments-c11 +remainderInteger-cpu-arguments-model-arguments-c20 +remainderInteger-cpu-arguments-model-arguments-minimum +remainderInteger-memory-arguments-intercept +remainderInteger-memory-arguments-slope +serialiseData-cpu-arguments-intercept +serialiseData-cpu-arguments-slope +serialiseData-memory-arguments-intercept +serialiseData-memory-arguments-slope +sha2_256-cpu-arguments-intercept +sha2_256-cpu-arguments-slope +sha2_256-memory-arguments +sha3_256-cpu-arguments-intercept +sha3_256-cpu-arguments-slope +sha3_256-memory-arguments +sliceByteString-cpu-arguments-intercept +sliceByteString-cpu-arguments-slope +sliceByteString-memory-arguments-intercept +sliceByteString-memory-arguments-slope +sndPair-cpu-arguments +sndPair-memory-arguments +subtractInteger-cpu-arguments-intercept +subtractInteger-cpu-arguments-slope +subtractInteger-memory-arguments-intercept +subtractInteger-memory-arguments-slope +tailList-cpu-arguments +tailList-memory-arguments +trace-cpu-arguments +trace-memory-arguments +unBData-cpu-arguments +unBData-memory-arguments +unConstrData-cpu-arguments +unConstrData-memory-arguments +unIData-cpu-arguments +unIData-memory-arguments +unListData-cpu-arguments +unListData-memory-arguments +unMapData-cpu-arguments +unMapData-memory-arguments +verifyEcdsaSecp256k1Signature-cpu-arguments +verifyEcdsaSecp256k1Signature-memory-arguments +verifyEd25519Signature-cpu-arguments-intercept +verifyEd25519Signature-cpu-arguments-slope +verifyEd25519Signature-memory-arguments +verifySchnorrSecp256k1Signature-cpu-arguments-intercept +verifySchnorrSecp256k1Signature-cpu-arguments-slope +verifySchnorrSecp256k1Signature-memory-arguments +cekConstrCost-exBudgetCPU +cekConstrCost-exBudgetMemory +cekCaseCost-exBudgetCPU +cekCaseCost-exBudgetMemory +bls12_381_G1_add-cpu-arguments +bls12_381_G1_add-memory-arguments +bls12_381_G1_compress-cpu-arguments +bls12_381_G1_compress-memory-arguments +bls12_381_G1_equal-cpu-arguments +bls12_381_G1_equal-memory-arguments +bls12_381_G1_hashToGroup-cpu-arguments-intercept +bls12_381_G1_hashToGroup-cpu-arguments-slope +bls12_381_G1_hashToGroup-memory-arguments +bls12_381_G1_neg-cpu-arguments +bls12_381_G1_neg-memory-arguments +bls12_381_G1_scalarMul-cpu-arguments-intercept +bls12_381_G1_scalarMul-cpu-arguments-slope +bls12_381_G1_scalarMul-memory-arguments +bls12_381_G1_uncompress-cpu-arguments +bls12_381_G1_uncompress-memory-arguments +bls12_381_G2_add-cpu-arguments +bls12_381_G2_add-memory-arguments +bls12_381_G2_compress-cpu-arguments +bls12_381_G2_compress-memory-arguments +bls12_381_G2_equal-cpu-arguments +bls12_381_G2_equal-memory-arguments +bls12_381_G2_hashToGroup-cpu-arguments-intercept +bls12_381_G2_hashToGroup-cpu-arguments-slope +bls12_381_G2_hashToGroup-memory-arguments +bls12_381_G2_neg-cpu-arguments +bls12_381_G2_neg-memory-arguments +bls12_381_G2_scalarMul-cpu-arguments-intercept +bls12_381_G2_scalarMul-cpu-arguments-slope +bls12_381_G2_scalarMul-memory-arguments +bls12_381_G2_uncompress-cpu-arguments +bls12_381_G2_uncompress-memory-arguments +bls12_381_finalVerify-cpu-arguments +bls12_381_finalVerify-memory-arguments +bls12_381_millerLoop-cpu-arguments +bls12_381_millerLoop-memory-arguments +bls12_381_mulMlResult-cpu-arguments +bls12_381_mulMlResult-memory-arguments +keccak_256-cpu-arguments-intercept +keccak_256-cpu-arguments-slope +keccak_256-memory-arguments +blake2b_224-cpu-arguments-intercept +blake2b_224-cpu-arguments-slope +blake2b_224-memory-arguments +integerToByteString-cpu-arguments-c0 +integerToByteString-cpu-arguments-c1 +integerToByteString-cpu-arguments-c2 +integerToByteString-memory-arguments-intercept +integerToByteString-memory-arguments-slope +byteStringToInteger-cpu-arguments-c0 +byteStringToInteger-cpu-arguments-c1 +byteStringToInteger-cpu-arguments-c2 +byteStringToInteger-memory-arguments-intercept +byteStringToInteger-memory-arguments-slope +andByteString-cpu-arguments-intercept +andByteString-cpu-arguments-slope1 +andByteString-cpu-arguments-slope2 +andByteString-memory-arguments-intercept +andByteString-memory-arguments-slope +orByteString-cpu-arguments-intercept +orByteString-cpu-arguments-slope1 +orByteString-cpu-arguments-slope2 +orByteString-memory-arguments-intercept +orByteString-memory-arguments-slope +xorByteString-cpu-arguments-intercept +xorByteString-cpu-arguments-slope1 +xorByteString-cpu-arguments-slope2 +xorByteString-memory-arguments-intercept +xorByteString-memory-arguments-slope +complementByteString-cpu-arguments-intercept +complementByteString-cpu-arguments-slope +complementByteString-memory-arguments-intercept +complementByteString-memory-arguments-slope +readBit-cpu-arguments +readBit-memory-arguments +writeBits-cpu-arguments-intercept +writeBits-cpu-arguments-slope +writeBits-memory-arguments-intercept +writeBits-memory-arguments-slope +replicateByte-cpu-arguments-intercept +replicateByte-cpu-arguments-slope +replicateByte-memory-arguments-intercept +replicateByte-memory-arguments-slope +shiftByteString-cpu-arguments-intercept +shiftByteString-cpu-arguments-slope +shiftByteString-memory-arguments-intercept +shiftByteString-memory-arguments-slope +rotateByteString-cpu-arguments-intercept +rotateByteString-cpu-arguments-slope +rotateByteString-memory-arguments-intercept +rotateByteString-memory-arguments-slope +countSetBits-cpu-arguments-intercept +countSetBits-cpu-arguments-slope +countSetBits-memory-arguments +findFirstSetBit-cpu-arguments-intercept +findFirstSetBit-cpu-arguments-slope +findFirstSetBit-memory-arguments +ripemd_160-cpu-arguments-intercept +ripemd_160-cpu-arguments-slope +ripemd_160-memory-arguments diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal index a6271509f7c..e093dab1628 100644 --- a/plutus-ledger-api/plutus-ledger-api.cabal +++ b/plutus-ledger-api/plutus-ledger-api.cabal @@ -195,6 +195,7 @@ test-suite plutus-ledger-api-test , tasty-hedgehog , tasty-hunit , tasty-quickcheck + , text -- A suite for tests that use the Plutus Tx plugin. We don't merge those into -- @plutus-ledger-api-test@, because @plutus-ledger-api@ has to be buildable for older versions of diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs index 2ea79cf7706..019cfef535d 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs @@ -101,6 +101,9 @@ builtinsIntroducedIn = Map.fromList [ ChooseData, ConstrData, MapData, ListData, IData, BData, UnConstrData, UnMapData, UnListData, UnIData, UnBData, EqualsData, MkPairData, MkNilData, MkNilPairData ]), + ((PlutusV1, futurePV), Set.fromList [ + ListToArray, IndexArray, LengthArray + ]), ((PlutusV2, vasilPV), Set.fromList [ SerialiseData ]), @@ -110,6 +113,9 @@ builtinsIntroducedIn = Map.fromList [ ((PlutusV2, plominPV), Set.fromList [ IntegerToByteString, ByteStringToInteger ]), + ((PlutusV2, futurePV), Set.fromList [ + ListToArray, IndexArray, LengthArray + ]), ((PlutusV3, changPV), Set.fromList [ Bls12_381_G1_add, Bls12_381_G1_neg, Bls12_381_G1_scalarMul, Bls12_381_G1_equal, Bls12_381_G1_hashToGroup, @@ -128,7 +134,8 @@ builtinsIntroducedIn = Map.fromList [ ]), ((PlutusV3, futurePV), Set.fromList [ ExpModInteger, - CaseList, CaseData + CaseList, CaseData, + ListToArray, IndexArray, LengthArray ]) ] diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/ParamName.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/ParamName.hs index c4007c855f5..b5ecd9f50ac 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/ParamName.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/ParamName.hs @@ -181,6 +181,12 @@ data ParamName = | VerifyEd25519Signature'cpu'arguments'intercept | VerifyEd25519Signature'cpu'arguments'slope | VerifyEd25519Signature'memory'arguments + | LengthArray'cpu'arguments + | LengthArray'memory'arguments + | ListToArray'cpu'arguments + | ListToArray'memory'arguments + | IndexArray'cpu'arguments + | IndexArray'memory'arguments deriving stock (Eq, Ord, Enum, Ix, Bounded, Generic) deriving IsParamName via (GenericParamName ParamName) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/ParamName.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/ParamName.hs index 1f6ef6f5610..34a639d79bd 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/ParamName.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/ParamName.hs @@ -200,5 +200,11 @@ data ParamName = | ByteStringToInteger'cpu'arguments'c2 | ByteStringToInteger'memory'arguments'intercept | ByteStringToInteger'memory'arguments'slope + | LengthArray'cpu'arguments + | LengthArray'memory'arguments + | ListToArray'cpu'arguments + | ListToArray'memory'arguments + | IndexArray'cpu'arguments + | IndexArray'memory'arguments deriving stock (Eq, Ord, Enum, Ix, Bounded, Generic) deriving IsParamName via (GenericParamName ParamName) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/ParamName.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/ParamName.hs index 606b3d44528..9bd0dc026bc 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/ParamName.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/ParamName.hs @@ -313,7 +313,12 @@ data ParamName = | Ripemd_160'cpu'arguments'intercept | Ripemd_160'cpu'arguments'slope | Ripemd_160'memory'arguments - + | LengthArray'cpu'arguments + | LengthArray'memory'arguments + | ListToArray'cpu'arguments + | ListToArray'memory'arguments + | IndexArray'cpu'arguments + | IndexArray'memory'arguments -- not enabled yet: -- ExpModInteger'cpu'arguments -- ExpModInteger'memory'arguments diff --git a/plutus-ledger-api/test/Spec.hs b/plutus-ledger-api/test/Spec.hs index 772faf953f5..65309836680 100644 --- a/plutus-ledger-api/test/Spec.hs +++ b/plutus-ledger-api/test/Spec.hs @@ -1,4 +1,5 @@ --- editorconfig-checker-disable-file +{-# LANGUAGE BlockArguments #-} + module Main where import PlutusLedgerApi.Common.Versions @@ -23,6 +24,7 @@ import Spec.V1.Value qualified as Value import Spec.Versions qualified import Test.Tasty +import Test.Tasty.Extras import Test.Tasty.HUnit import Test.Tasty.QuickCheck @@ -33,116 +35,195 @@ 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" $ - 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) +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) alwaysFalse :: TestTree -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) +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) 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" $ - 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)) +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)) 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 + , runTestNested ["CostModel", "Params"] [Spec.CostModelParams.tests] + , Spec.ContextDecoding.tests + , Value.test_Value + ] + , testGroup + "Data" + [ Spec.Data.Eval.tests + , Spec.Data.Versions.tests + , runTestNested + ["CostModel", "Data", "Params"] + [Spec.Data.CostModelParams.tests] + , Spec.Data.ContextDecoding.tests + , Data.Value.test_Value + ] ] - ] ] diff --git a/plutus-ledger-api/test/Spec/CostModelParams.hs b/plutus-ledger-api/test/Spec/CostModelParams.hs index c5e45208009..18793527d3d 100644 --- a/plutus-ledger-api/test/Spec/CostModelParams.hs +++ b/plutus-ledger-api/test/Spec/CostModelParams.hs @@ -1,78 +1,112 @@ --- editorconfig-checker-disable-file +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} -module Spec.CostModelParams where - --- import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCostModelParamsForTesting) -import PlutusLedgerApi.Common +module Spec.CostModelParams where +import PlutusLedgerApi.Common (CostModelApplyWarn (CMTooManyParamsWarn, cmActual, cmExpected), + IsParamName (readParamName, showParamName)) import PlutusLedgerApi.Test.V3.EvaluationContext qualified as V3 -import PlutusLedgerApi.V1 as V1 -import PlutusLedgerApi.V2 as V2 -import PlutusLedgerApi.V3 as V3 +import PlutusLedgerApi.V1 qualified as V1 +import PlutusLedgerApi.V2 qualified as V2 +import PlutusLedgerApi.V3 qualified as V3 -import Control.Monad.Except -import Control.Monad.Writer.Strict -import Data.Either -import Data.Foldable -import Data.List.Extra -import Data.Set as Set -import Test.Tasty -import Test.Tasty.HUnit +import Control.Monad.Except (runExcept) +import Control.Monad.Writer.Strict (WriterT (runWriterT)) +import Data.Either (isRight) +import Data.Foldable (for_) +import Data.List.Extra (enumerate) +import Data.Set (isProperSubsetOf, isSubsetOf) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Test.Tasty.Extras (TestNested, embed, nestedGoldenVsTextPredM, testNestedNamed) +import Test.Tasty.HUnit (assertBool, testCase, (@=?)) -tests :: TestTree +tests :: TestNested tests = - testGroup + testNestedNamed + "CostModelParams" "costModelParams" - [ testCase "length" $ do - 166 @=? length v1_ParamNames - 185 @=? length v2_ParamNames - 297 @=? length v3_ParamNames - , testCase "tripping paramname" $ do - for_ v1_ParamNames $ \ p -> - assertBool "tripping v1 cm params failed" $ Just p == readParamName (showParamName p) - for_ v2_ParamNames $ \ p -> - assertBool "tripping v2 cm params failed" $ Just p == readParamName (showParamName p) - for_ v3_ParamNames $ \ p -> - assertBool "tripping v3 cm params failed" $ Just p == readParamName (showParamName p) --- *** FIXME !!! *** : The introduction of the new bitwise builtins has messed --- this up because defaultCostModelParamsForTesting is the cost model parameters --- for model C, which now includes the new bitwise builtins. --- , testCase "default values costmodelparamsfortesting" $ do --- defaultCostModelParamsForTesting @=? Just (toCostModelParams V3.costModelParamsForTesting) - , testCase "context length" $ do - let costValuesForTesting = fmap snd V3.costModelParamsForTesting - -- the `costModelParamsForTesting` reflects only the latest version (V3), so this should succeed because the lengths match - assertBool "wrong number of arguments in V3.mkEvaluationContext" $ isRight $ runExcept $ runWriterT $ V3.mkEvaluationContext costValuesForTesting - -- this one should succeed because we allow adding new builtins to an existing version, by appending new cost model parameters, for more info: - -- See Note [Cost model parameters from the ledger's point of view] - assertBool "larger number of params did not warn" $ hasWarnMoreParams (length v3_ParamNames) (1 + length v3_ParamNames) $ - runExcept $ runWriterT $ V3.mkEvaluationContext $ costValuesForTesting ++ [1] -- dummy param value appended - , testCase "cost model parameters" $ do - -- v1 is missing some cost model parameters because new builtins are added in v2 - assertBool "v1 params is not a proper subset of v2 params" $ v1_ParamNames `paramProperSubset` v2_ParamNames - -- v1/v2 and v3 cost models are not comparable because we added new builtins in v3 but also - -- removed some superseded cost model parameters. - assertBool "v1 params and v3 params are comparable" $ - not (v1_ParamNames `paramSubset` v3_ParamNames) - && not (v3_ParamNames `paramSubset` v1_ParamNames) - assertBool "v2 params and v3 params are comparable" $ - not (v2_ParamNames `paramSubset` v3_ParamNames) - && not (v3_ParamNames `paramSubset` v2_ParamNames) + [ embed $ testCase "length" do + 172 @=? length v1_ParamNames + 191 @=? length v2_ParamNames + 303 @=? length v3_ParamNames + , embed $ testCase "tripping paramname" do + for_ v1_ParamNames \p -> + assertBool "tripping v1 cm params failed" $ + Just p == readParamName (showParamName p) + for_ v2_ParamNames \p -> + assertBool "tripping v2 cm params failed" $ + Just p == readParamName (showParamName p) + for_ v3_ParamNames \p -> + assertBool "tripping v3 cm params failed" $ + Just p == readParamName (showParamName p) + , -- \*** FIXME !!! *** : The introduction of the new bitwise builtins has + -- messed this up because defaultCostModelParamsForTesting is the cost + -- model parameters for model C, + -- which now includes the new bitwise builtins. + -- , testCase "default values costmodelparamsfortesting" do + -- defaultCostModelParamsForTesting + -- @=? Just (toCostModelParams V3.costModelParamsForTesting) + embed $ testCase "context length" do + let costValuesForTesting = fmap snd V3.costModelParamsForTesting + -- the `costModelParamsForTesting` reflects only the latest + -- version (V3), so this should succeed because the lengths match + assertBool "wrong number of arguments in V3.mkEvaluationContext" $ + isRight $ + runExcept $ + runWriterT $ + V3.mkEvaluationContext costValuesForTesting + -- this one should succeed because we allow adding new builtins to an + -- existing version, by appending new cost model parameters, + -- for more info: + -- See Note [Cost model parameters from the ledger's point of view] + assertBool "larger number of params did not warn" + $ hasWarnMoreParams + (length v3_ParamNames) + (1 + length v3_ParamNames) + $ runExcept + $ runWriterT + $ V3.mkEvaluationContext + $ costValuesForTesting ++ [1] -- dummy param value appended + , embed $ testCase "cost model parameters" do + -- v1 is missing some cost model parameters + -- because new builtins are added in v2 + assertBool "v1 params is not a proper subset of v2 params" $ + v1_ParamNames `paramProperSubset` v2_ParamNames + -- v1/v2 and v3 cost models are not comparable because we added + -- new builtins in v3 but also removed some superseded cost model + -- parameters. + assertBool "v1 params and v3 params are comparable" $ + not (v1_ParamNames `paramSubset` v3_ParamNames) + && not (v3_ParamNames `paramSubset` v1_ParamNames) + assertBool "v2 params and v3 params are comparable" $ + not (v2_ParamNames `paramSubset` v3_ParamNames) + && not (v3_ParamNames `paramSubset` v2_ParamNames) + , -- Fail if new cost model parameters names aren't appended to the end + nestedGoldenVsTextPredM + "costModelParamNames" + ".txt" + do pure (Text.unlines (map showParamName v3_ParamNames)) + Text.isPrefixOf ] - where - hasWarnMoreParams :: Int -> Int -> Either a (b, [CostModelApplyWarn]) -> Bool - hasWarnMoreParams testExpected testActual (Right (_,[CMTooManyParamsWarn{..}])) - | testExpected==cmExpected && testActual==cmActual = True - hasWarnMoreParams _ _ _ = False + where + hasWarnMoreParams :: Int -> Int -> Either a (b, [CostModelApplyWarn]) -> Bool + hasWarnMoreParams + testExpected + testActual + (Right (_, [CMTooManyParamsWarn{..}])) + | testExpected == cmExpected && testActual == cmActual = True + hasWarnMoreParams _ _ _ = False - paramProperSubset pA pB = - Set.fromList (showParamName <$> pA) `Set.isProperSubsetOf` Set.fromList (showParamName <$> pB) + paramProperSubset pA pB = + Set.fromList (showParamName <$> pA) + `isProperSubsetOf` Set.fromList (showParamName <$> pB) - paramSubset pA pB = - Set.fromList (showParamName <$> pA) `Set.isSubsetOf` Set.fromList (showParamName <$> pB) + paramSubset pA pB = + Set.fromList (showParamName <$> pA) + `isSubsetOf` Set.fromList (showParamName <$> pB) - v1_ParamNames = enumerate @V1.ParamName - v2_ParamNames = enumerate @V2.ParamName - v3_ParamNames = enumerate @V3.ParamName + v1_ParamNames = enumerate @V1.ParamName + v2_ParamNames = enumerate @V2.ParamName + v3_ParamNames = enumerate @V3.ParamName diff --git a/plutus-ledger-api/test/Spec/Data/CostModelParams.hs b/plutus-ledger-api/test/Spec/Data/CostModelParams.hs index 9a7eab8323a..3692cc9f7b5 100644 --- a/plutus-ledger-api/test/Spec/Data/CostModelParams.hs +++ b/plutus-ledger-api/test/Spec/Data/CostModelParams.hs @@ -1,76 +1,112 @@ --- editorconfig-checker-disable-file +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} -module Spec.Data.CostModelParams where -import PlutusLedgerApi.Common +module Spec.Data.CostModelParams where -import PlutusLedgerApi.Data.V1 as V1 -import PlutusLedgerApi.Data.V2 as V2 -import PlutusLedgerApi.Data.V3 as V3 +import PlutusLedgerApi.Common (CostModelApplyWarn (CMTooManyParamsWarn, cmActual, cmExpected), + IsParamName (readParamName, showParamName)) +import PlutusLedgerApi.Data.V1 qualified as V1 +import PlutusLedgerApi.Data.V2 qualified as V2 +import PlutusLedgerApi.Data.V3 qualified as V3 import PlutusLedgerApi.Test.V3.Data.EvaluationContext qualified as V3 -import Control.Monad.Except -import Control.Monad.Writer.Strict -import Data.Either -import Data.Foldable -import Data.List.Extra -import Data.Set as Set -import Test.Tasty -import Test.Tasty.HUnit +import Control.Monad.Except (runExcept) +import Control.Monad.Writer.Strict (WriterT (runWriterT)) +import Data.Either (isRight) +import Data.Foldable (for_) +import Data.List.Extra (enumerate) +import Data.Set (isProperSubsetOf, isSubsetOf) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Test.Tasty.Extras (TestNested, embed, nestedGoldenVsTextPredM, testNestedNamed) +import Test.Tasty.HUnit (assertBool, testCase, (@=?)) -tests :: TestTree +tests :: TestNested tests = - testGroup + testNestedNamed + "CostModelParams" "costModelParams" - [ testCase "length" $ do - 166 @=? length v1_ParamNames - 185 @=? length v2_ParamNames - 297 @=? length v3_ParamNames - , testCase "tripping paramname" $ do - for_ v1_ParamNames $ \ p -> - assertBool "tripping v1 cm params failed" $ Just p == readParamName (showParamName p) - for_ v2_ParamNames $ \ p -> - assertBool "tripping v2 cm params failed" $ Just p == readParamName (showParamName p) - for_ v3_ParamNames $ \ p -> - assertBool "tripping v3 cm params failed" $ Just p == readParamName (showParamName p) --- *** FIXME !!! *** : The introduction of the new bitwise builtins has messed --- this up because defaultCostModelParamsForTesting is the cost model parameters --- for model C, which now includes the new bitwise builtins. --- , testCase "default values costmodelparamsfortesting" $ do --- defaultCostModelParamsForTesting @=? Just (toCostModelParams V3.costModelParamsForTesting) - , testCase "context length" $ do - let costValuesForTesting = fmap snd V3.costModelParamsForTesting - -- the `costModelParamsForTesting` reflects only the latest version (V3), so this should succeed because the lengths match - assertBool "wrong number of arguments in V3.mkEvaluationContext" $ isRight $ runExcept $ runWriterT $ V3.mkEvaluationContext costValuesForTesting - -- this one should succeed because we allow adding new builtins to an existing version, by appending new cost model parameters, for more info: - -- See Note [Cost model parameters from the ledger's point of view] - assertBool "larger number of params did not warn" $ hasWarnMoreParams (length v3_ParamNames) (1 + length v3_ParamNames) $ - runExcept $ runWriterT $ V3.mkEvaluationContext $ costValuesForTesting ++ [1] -- dummy param value appended - , testCase "cost model parameters" $ do - -- v1 is missing some cost model parameters because new builtins are added in v2 - assertBool "v1 params is not a proper subset of v2 params" $ v1_ParamNames `paramProperSubset` v2_ParamNames - -- v1/v2 and v3 cost models are not comparable because we added new builtins in v3 but also - -- removed some superseded cost model parameters. - assertBool "v1 params and v3 params are comparable" $ - not (v1_ParamNames `paramSubset` v3_ParamNames) - && not (v3_ParamNames `paramSubset` v1_ParamNames) - assertBool "v2 params and v3 params are comparable" $ - not (v2_ParamNames `paramSubset` v3_ParamNames) - && not (v3_ParamNames `paramSubset` v2_ParamNames) + [ embed $ testCase "length" do + 172 @=? length v1_ParamNames + 191 @=? length v2_ParamNames + 303 @=? length v3_ParamNames + , embed $ testCase "tripping paramname" do + for_ v1_ParamNames \p -> + assertBool "tripping v1 cm params failed" $ + Just p == readParamName (showParamName p) + for_ v2_ParamNames \p -> + assertBool "tripping v2 cm params failed" $ + Just p == readParamName (showParamName p) + for_ v3_ParamNames \p -> + assertBool "tripping v3 cm params failed" $ + Just p == readParamName (showParamName p) + , -- \*** FIXME !!! *** : The introduction of the new bitwise builtins has + -- messed this up because defaultCostModelParamsForTesting is the cost + -- model parameters for model C, + -- which now includes the new bitwise builtins. + -- , testCase "default values costmodelparamsfortesting" do + -- defaultCostModelParamsForTesting + -- @=? Just (toCostModelParams V3.costModelParamsForTesting) + embed $ testCase "context length" do + let costValuesForTesting = fmap snd V3.costModelParamsForTesting + -- the `costModelParamsForTesting` reflects only the latest + -- version (V3), so this should succeed because the lengths match + assertBool "wrong number of arguments in V3.mkEvaluationContext" $ + isRight $ + runExcept $ + runWriterT $ + V3.mkEvaluationContext costValuesForTesting + -- this one should succeed because we allow adding new builtins to an + -- existing version, by appending new cost model parameters, + -- for more info: + -- See Note [Cost model parameters from the ledger's point of view] + assertBool "larger number of params did not warn" + $ hasWarnMoreParams + (length v3_ParamNames) + (1 + length v3_ParamNames) + $ runExcept + $ runWriterT + $ V3.mkEvaluationContext + $ costValuesForTesting ++ [1] -- dummy param value appended + , embed $ testCase "cost model parameters" do + -- v1 is missing some cost model parameters + -- because new builtins are added in v2 + assertBool "v1 params is not a proper subset of v2 params" $ + v1_ParamNames `paramProperSubset` v2_ParamNames + -- v1/v2 and v3 cost models are not comparable because we added + -- new builtins in v3 but also removed some superseded cost model + -- parameters. + assertBool "v1 params and v3 params are comparable" $ + not (v1_ParamNames `paramSubset` v3_ParamNames) + && not (v3_ParamNames `paramSubset` v1_ParamNames) + assertBool "v2 params and v3 params are comparable" $ + not (v2_ParamNames `paramSubset` v3_ParamNames) + && not (v3_ParamNames `paramSubset` v2_ParamNames) + , -- Fail if new cost model parameters names aren't appended to the end + nestedGoldenVsTextPredM + "costModelParamNames" + ".txt" + do pure (Text.unlines (map showParamName v3_ParamNames)) + Text.isPrefixOf ] - where - hasWarnMoreParams :: Int -> Int -> Either a (b, [CostModelApplyWarn]) -> Bool - hasWarnMoreParams testExpected testActual (Right (_,[CMTooManyParamsWarn{..}])) - | testExpected==cmExpected && testActual==cmActual = True - hasWarnMoreParams _ _ _ = False + where + hasWarnMoreParams :: Int -> Int -> Either a (b, [CostModelApplyWarn]) -> Bool + hasWarnMoreParams + testExpected + testActual + (Right (_, [CMTooManyParamsWarn{..}])) + | testExpected == cmExpected && testActual == cmActual = True + hasWarnMoreParams _ _ _ = False - paramProperSubset pA pB = - Set.fromList (showParamName <$> pA) `Set.isProperSubsetOf` Set.fromList (showParamName <$> pB) + paramProperSubset pA pB = + Set.fromList (showParamName <$> pA) + `isProperSubsetOf` Set.fromList (showParamName <$> pB) - paramSubset pA pB = - Set.fromList (showParamName <$> pA) `Set.isSubsetOf` Set.fromList (showParamName <$> pB) + paramSubset pA pB = + Set.fromList (showParamName <$> pA) + `isSubsetOf` Set.fromList (showParamName <$> pB) - v1_ParamNames = enumerate @V1.ParamName - v2_ParamNames = enumerate @V2.ParamName - v3_ParamNames = enumerate @V3.ParamName + v1_ParamNames = enumerate @V1.ParamName + v2_ParamNames = enumerate @V2.ParamName + v3_ParamNames = enumerate @V3.ParamName diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Common/EvaluationContext.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Common/EvaluationContext.hs index 73c4ee9d948..10eeb3c1ec1 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Common/EvaluationContext.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Common/EvaluationContext.hs @@ -1,6 +1,5 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} module PlutusLedgerApi.Test.Common.EvaluationContext ( MCostModel , MCekMachineCosts diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/Data/EvaluationContext.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/Data/EvaluationContext.hs index 0849ba62a39..cd78c295d09 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/Data/EvaluationContext.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/Data/EvaluationContext.hs @@ -18,10 +18,11 @@ import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts import Data.Int (Int64) import Data.Map qualified as Map import Data.Maybe +import GHC.Stack (HasCallStack) -- | Example values of costs for @PlutusV3@, in expected ledger order. -- Suitable to be used in testing. -costModelParamsForTesting :: [(V3.ParamName, Int64)] +costModelParamsForTesting :: HasCallStack => [(V3.ParamName, Int64)] costModelParamsForTesting = Map.toList $ fromJust $ Common.extractCostModelParamsLedgerOrder mCostModel @@ -29,7 +30,7 @@ costModelParamsForTesting = Map.toList $ fromJust $ mCostModel :: MCostModel mCostModel = -- nothing to clear because v4 does not exist (yet). - (toMCostModel defaultCekCostModelForTesting) & builtinCostModel %~ clearBuiltinCostModel' + toMCostModel defaultCekCostModelForTesting & builtinCostModel %~ clearBuiltinCostModel' {- | Assign to `mempty` those CEK constructs that @PlutusV3@ introduces (indirectly by introducing a ledger language version with those CEK constructs). @@ -84,6 +85,9 @@ clearBuiltinCostModel r = r , paramFindFirstSetBit = mempty , paramRipemd_160 = mempty , paramExpModInteger = mempty + , paramLengthArray = mempty + , paramListToArray = mempty + , paramIndexArray = mempty } diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/EvaluationContext.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/EvaluationContext.hs index 21529c32bb0..c5eadb16a39 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/EvaluationContext.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/EvaluationContext.hs @@ -19,10 +19,11 @@ import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts import Data.Int (Int64) import Data.Map qualified as Map import Data.Maybe +import GHC.Stack (HasCallStack) -- | Example values of costs for @PlutusV3@, in expected ledger order. -- Suitable to be used in testing. -costModelParamsForTesting :: [(V3.ParamName, Int64)] +costModelParamsForTesting :: HasCallStack => [(V3.ParamName, Int64)] costModelParamsForTesting = Map.toList $ fromJust $ Common.extractCostModelParamsLedgerOrder mCostModel @@ -30,7 +31,7 @@ costModelParamsForTesting = Map.toList $ fromJust $ mCostModel :: MCostModel mCostModel = -- nothing to clear because v4 does not exist (yet). - (toMCostModel defaultCekCostModelForTesting) & builtinCostModel %~ clearBuiltinCostModel' + toMCostModel defaultCekCostModelForTesting & builtinCostModel %~ clearBuiltinCostModel' {- | Assign to `mempty` those CEK constructs that @PlutusV3@ introduces (indirectly by introducing a ledger language version with those CEK constructs). @@ -85,6 +86,9 @@ clearBuiltinCostModel r = r , paramFindFirstSetBit = mempty , paramRipemd_160 = mempty , paramExpModInteger = mempty + , paramLengthArray = mempty + , paramListToArray = mempty + , paramIndexArray = mempty } diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index f872c951304..c5bf14c9deb 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -115,6 +115,7 @@ test-suite plutus-tx-plugin-tests hs-source-dirs: test main-is: Spec.hs other-modules: + Array.Spec AsData.Budget.Spec AsData.Budget.Types AssocMap.Spec diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs index 367f3ba9644..6049cf4b507 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs @@ -239,6 +239,11 @@ builtinNames = [ , 'Builtins.mkNilPairData , 'Builtins.mkCons + , ''Builtins.BuiltinArray + , 'Builtins.lengthOfArray + , 'Builtins.listToArray + , 'Builtins.indexArray + , ''Builtins.BuiltinData , 'Builtins.chooseData , 'Builtins.caseData' @@ -460,6 +465,11 @@ defineBuiltinTerms = do PLC.MkNilPairData -> defineBuiltinInl 'Builtins.mkNilPairData PLC.MkCons -> defineBuiltinInl 'Builtins.mkCons + -- Arrays + PLC.LengthArray -> defineBuiltinInl 'Builtins.lengthOfArray + PLC.ListToArray -> defineBuiltinInl 'Builtins.listToArray + PLC.IndexArray -> defineBuiltinInl 'Builtins.indexArray + -- Data PLC.ChooseData -> defineBuiltinInl 'Builtins.chooseData PLC.EqualsData -> defineBuiltinInl 'Builtins.equalsData @@ -597,9 +607,7 @@ defineBuiltinTerms = do PLC.ExpModInteger -> defineBuiltinInl 'Builtins.expModInteger -defineBuiltinTypes - :: CompilingDefault uni fun m ann - => m () +defineBuiltinTypes :: CompilingDefault uni fun m ann => m () defineBuiltinTypes = do defineBuiltinType ''Builtins.BuiltinByteString . ($> annMayInline) $ PLC.toTypeAst $ Proxy @BS.ByteString defineBuiltinType ''Integer . ($> annMayInline) $ PLC.toTypeAst $ Proxy @Integer @@ -609,6 +617,7 @@ defineBuiltinTypes = do defineBuiltinType ''Builtins.BuiltinData . ($> annMayInline) $ PLC.toTypeAst $ Proxy @PLC.Data defineBuiltinType ''Builtins.BuiltinPair . ($> annMayInline) $ PLC.TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniProtoPair) defineBuiltinType ''Builtins.BuiltinList . ($> annMayInline) $ PLC.TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniProtoList) + defineBuiltinType ''Builtins.BuiltinArray . ($> annMayInline) $ PLC.TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniProtoArray) defineBuiltinType ''Builtins.BuiltinBLS12_381_G1_Element . ($> annMayInline) $ PLC.toTypeAst $ Proxy @BLS12_381.G1.Element defineBuiltinType ''Builtins.BuiltinBLS12_381_G2_Element . ($> annMayInline) $ PLC.toTypeAst $ Proxy @BLS12_381.G2.Element defineBuiltinType ''Builtins.BuiltinBLS12_381_MlResult . ($> annMayInline) $ PLC.toTypeAst $ Proxy @BLS12_381.Pairing.MlResult diff --git a/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.eval.golden b/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.eval.golden new file mode 100644 index 00000000000..361ee8e0beb --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.eval.golden @@ -0,0 +1 @@ +I 3 \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.pir.golden b/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.pir.golden new file mode 100644 index 00000000000..738862c5941 --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.pir.golden @@ -0,0 +1,26 @@ +(let + !indexArray : all a. array a -> integer -> a = indexArray + in + indexArray {data}) + (let + !unitval : unit = () + in + let + !mkNilData : unit -> list data = mkNilData + in + let + !mkI : integer -> data = iData + in + let + !mkCons : all a. a -> list a -> list a = mkCons + in + let + !listToArray : all a. list a -> array a = listToArray + in + listToArray + {data} + (mkCons + {data} + (mkI 1) + (mkCons {data} (mkI 2) (mkCons {data} (mkI 3) (mkNilData unitval))))) + 2 \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.uplc.golden b/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.uplc.golden new file mode 100644 index 00000000000..b6021691ff4 --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledIndexArray.uplc.golden @@ -0,0 +1,21 @@ +(program + 1.1.0 + ((\indexArray -> force indexArray) + indexArray + ((\unitval -> + (\mkNilData -> + (\mkI -> + (\mkCons -> + (\listToArray -> + force listToArray + (force mkCons + (mkI 1) + (force mkCons + (mkI 2) + (force mkCons (mkI 3) (mkNilData unitval))))) + listToArray) + mkCons) + iData) + mkNilData) + ()) + 2)) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.eval.golden b/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.eval.golden new file mode 100644 index 00000000000..e440e5c8425 --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.eval.golden @@ -0,0 +1 @@ +3 \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.pir.golden b/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.pir.golden new file mode 100644 index 00000000000..b215127edfd --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.pir.golden @@ -0,0 +1 @@ +lengthArray {data} [I 1, I 2, I 3] \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.uplc.golden b/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.uplc.golden new file mode 100644 index 00000000000..a71685a77f0 --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledLengthArray.uplc.golden @@ -0,0 +1 @@ +(program 1.1.0 (force lengthArray [I 1, I 2, I 3])) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/9.6/compiledListToArray.eval.golden b/plutus-tx-plugin/test/Array/9.6/compiledListToArray.eval.golden new file mode 100644 index 00000000000..e3446f4a641 --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledListToArray.eval.golden @@ -0,0 +1 @@ +[I 1, I 2, I 3] \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/9.6/compiledListToArray.pir.golden b/plutus-tx-plugin/test/Array/9.6/compiledListToArray.pir.golden new file mode 100644 index 00000000000..e3446f4a641 --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledListToArray.pir.golden @@ -0,0 +1 @@ +[I 1, I 2, I 3] \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/9.6/compiledListToArray.uplc.golden b/plutus-tx-plugin/test/Array/9.6/compiledListToArray.uplc.golden new file mode 100644 index 00000000000..1ae8317b7b8 --- /dev/null +++ b/plutus-tx-plugin/test/Array/9.6/compiledListToArray.uplc.golden @@ -0,0 +1 @@ +(program 1.1.0 [I 1, I 2, I 3]) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Array/Spec.hs b/plutus-tx-plugin/test/Array/Spec.hs new file mode 100644 index 00000000000..48be90974dc --- /dev/null +++ b/plutus-tx-plugin/test/Array/Spec.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-optimize #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-simplifier-beta #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-simplifier-evaluate-builtins #-} + +module Array.Spec where + +import PlutusCore.Test (goldenUEval) +import PlutusTx +import PlutusTx.Builtins.Internal +import PlutusTx.Test (goldenPirReadable, goldenUPlcReadable) +import Test.Tasty.Extras + +smokeTests :: TestNested +smokeTests = + testNested + "Array" + [ testNestedGhc + [ goldenPirReadable "compiledListToArray" compiledListToArray + , goldenUPlcReadable "compiledListToArray" compiledListToArray + , goldenUEval "compiledListToArray" [compiledListToArray] + , goldenPirReadable "compiledLengthArray" compiledLengthArray + , goldenUPlcReadable "compiledLengthArray" compiledLengthArray + , goldenUEval "compiledLengthArray" [compiledLengthArray] + , goldenPirReadable "compiledIndexArray" compiledIndexArray + , goldenUPlcReadable "compiledIndexArray" compiledIndexArray + , goldenUEval "compiledIndexArray" [compiledIndexArray] + ] + ] + +compiledListToArray :: CompiledCode (BuiltinArray BuiltinData) +compiledListToArray = + $$( compile + [|| + listToArray + ( mkCons + (mkI 1) + ( mkCons + (mkI 2) + ( mkCons + (mkI 3) + (mkNilData unitval) + ) + ) + ) + ||] + ) + +compiledLengthArray :: CompiledCode BuiltinInteger +compiledLengthArray = + $$(compile [||lengthOfArray||]) `unsafeApplyCode` compiledListToArray + +compiledIndexArray :: CompiledCode BuiltinData +compiledIndexArray = + $$(compile [||indexArray||]) + `unsafeApplyCode` compiledListToArray + `unsafeApplyCode` liftCodeDef 2 diff --git a/plutus-tx-plugin/test/Spec.hs b/plutus-tx-plugin/test/Spec.hs index f9b3a5acf10..5a69c0c6f74 100644 --- a/plutus-tx-plugin/test/Spec.hs +++ b/plutus-tx-plugin/test/Spec.hs @@ -1,5 +1,6 @@ module Main (main) where +import Array.Spec qualified as Array import AsData.Budget.Spec qualified as AsData.Budget import AssocMap.Spec qualified as AssocMap import Blueprint.Tests qualified @@ -49,4 +50,5 @@ tests = , embed Unicode.tests , embed AssocMap.propertyTests , embed List.propertyTests + , Array.smokeTests ] diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index be380ec2ab0..eeaa7d3abb7 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -86,6 +86,12 @@ module PlutusTx.Builtins ( , BI.tail , uncons , unsafeUncons + -- * Arrays + , BI.BuiltinArray + , BI.listToArray + , sopListToArray + , BI.lengthOfArray + , BI.indexArray -- * Tracing , trace -- * BLS12_381 @@ -454,6 +460,10 @@ pairToPair :: BI.BuiltinPair a b -> (a, b) pairToPair tup = (BI.fst tup, BI.snd tup) {-# INLINE pairToPair #-} +sopListToArray :: (HasToOpaque a arep, MkNil arep) => [a] -> BI.BuiltinArray arep +sopListToArray l = BI.listToArray (toOpaque l) +{-# INLINABLE sopListToArray #-} + -- | Given five values for the five different constructors of 'BuiltinData', selects -- one depending on which corresponds to the actual constructor of the given value. chooseData :: forall a . BuiltinData -> a -> a -> a -> a -> a -> a diff --git a/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs b/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs index ee9951155b0..ab2b22097c8 100644 --- a/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs +++ b/plutus-tx/src/PlutusTx/Builtins/HasBuiltin.hs @@ -18,7 +18,7 @@ import PlutusTx.Builtins.Internal import Data.ByteString (ByteString) import Data.Kind qualified as GHC import Data.Text (Text) -import Data.Vector.Strict (Vector) +import Data.Vector.Strict qualified as Strict {- Note [useToOpaque and useFromOpaque] It used to be possible to use 'toBuiltin'/'fromBuiltin' within a smart contract, but this is no @@ -92,9 +92,12 @@ instance HasFromBuiltin a => HasFromBuiltin (BuiltinList a) where type FromBuiltin (BuiltinList a) = [FromBuiltin a] fromBuiltin (BuiltinList xs) = map fromBuiltin xs -instance HasToBuiltin a => HasToBuiltin (Vector a) where - type ToBuiltin (Vector a) = BuiltinArray (ToBuiltin a) - toBuiltin = useToOpaque (BuiltinArray . map toBuiltin) +instance HasToBuiltin a => HasToBuiltin (Strict.Vector a) where + type ToBuiltin (Strict.Vector a) = BuiltinArray (ToBuiltin a) + toBuiltin = useToOpaque (BuiltinArray . fmap toBuiltin) +instance HasFromBuiltin a => HasFromBuiltin (BuiltinArray a) where + type FromBuiltin (BuiltinArray a) = Strict.Vector (FromBuiltin a) + fromBuiltin (BuiltinArray xs) = fmap fromBuiltin xs instance (HasToBuiltin a, HasToBuiltin b) => HasToBuiltin (a, b) where type ToBuiltin (a, b) = BuiltinPair (ToBuiltin a) (ToBuiltin b) diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index 3cae9fa6f21..e1e86caef9f 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Internal.hs @@ -31,6 +31,8 @@ import Data.Hashable (Hashable (..)) import Data.Kind (Type) import Data.Text as Text (Text, empty) import Data.Text.Encoding as Text (decodeUtf8, encodeUtf8) +import Data.Vector.Strict (Vector) +import Data.Vector.Strict qualified as Vector import GHC.Generics (Generic) import PlutusCore.Bitwise qualified as Bitwise import PlutusCore.Builtin (BuiltinResult (..)) @@ -551,6 +553,30 @@ serialiseData :: BuiltinData -> BuiltinByteString serialiseData (BuiltinData b) = BuiltinByteString $ BSL.toStrict $ serialise b {-# OPAQUE serialiseData #-} +{- +ARRAY +-} + +data BuiltinArray a = BuiltinArray ~(Vector a) deriving stock (Data) + +instance Haskell.Show a => Haskell.Show (BuiltinArray a) where + show (BuiltinArray v) = show v +instance Haskell.Eq a => Haskell.Eq (BuiltinArray a) where + (==) (BuiltinArray v1) (BuiltinArray v2) = (==) v1 v2 +instance Haskell.Ord a => Haskell.Ord (BuiltinArray a) where + compare (BuiltinArray v1) (BuiltinArray v2) = compare v1 v2 + +lengthOfArray :: BuiltinArray a -> BuiltinInteger +lengthOfArray (BuiltinArray v) = toInteger (Vector.length v) +{-# OPAQUE lengthOfArray #-} + +listToArray :: BuiltinList a -> BuiltinArray a +listToArray (BuiltinList l) = BuiltinArray (Vector.fromList l) +{-# OPAQUE listToArray #-} + +indexArray :: BuiltinArray a -> BuiltinInteger -> a +indexArray (BuiltinArray v) i = v Vector.! fromInteger i +{-# OPAQUE indexArray #-} {- BLS12_381 diff --git a/plutus-tx/src/PlutusTx/Lift/Class.hs b/plutus-tx/src/PlutusTx/Lift/Class.hs index 7df54048efc..89f9e9d2053 100644 --- a/plutus-tx/src/PlutusTx/Lift/Class.hs +++ b/plutus-tx/src/PlutusTx/Lift/Class.hs @@ -40,6 +40,7 @@ import Data.ByteString qualified as BS import Data.Kind qualified as GHC import Data.Proxy import Data.Text qualified as T +import Data.Vector.Strict qualified as Strict import GHC.TypeLits (ErrorMessage (..), TypeError) -- We do not use qualified import because the whole module contains off-chain code @@ -180,6 +181,16 @@ instance (HasFromBuiltin arep, uni `PLC.HasTermLevel` [FromBuiltin arep]) => Lift uni (BuiltinList arep) where lift = liftBuiltin . fromBuiltin +-- See Note [Lift and Typeable instances for builtins] +instance uni `PLC.HasTypeLevel` Strict.Vector => Typeable uni BuiltinArray where + typeRep _ = typeRepBuiltin (Proxy @Strict.Vector) + +-- See Note [Lift and Typeable instances for builtins] +instance ( HasFromBuiltin arep + , uni `PLC.HasTermLevel` Strict.Vector (FromBuiltin arep) + ) => Lift uni (BuiltinArray arep) where + lift = liftBuiltin . fromBuiltin + instance uni `PLC.HasTypeLevel` (,) => Typeable uni BuiltinPair where typeRep _ = typeRepBuiltin (Proxy @(,))