diff --git a/.github/workflows/add-triage-label.yml b/.github/workflows/add-triage-label.yml index 963b4a3ba56..d896fb0ec22 100644 --- a/.github/workflows/add-triage-label.yml +++ b/.github/workflows/add-triage-label.yml @@ -1,9 +1,13 @@ +# Whenever a new issue is opened, this workflow adds the "status: needs triage" +# label, unless the issue already has one of the "Internal" labels. + name: Add Triage Label on: issues: types: - reopened - opened + jobs: add-triage-label: runs-on: ubuntu-latest @@ -13,10 +17,41 @@ jobs: - name: Run uses: actions/github-script@v7 with: - script: | - github.rest.issues.addLabels({ - issue_number: context.issue.number, - owner: context.repo.owner, - repo: context.repo.repo, - labels: ["status: needs triage"] - }) \ No newline at end of file + script: | + const INTERNAL_LABELS = ["Internal", "status: triaged"]; + + async function getIssueLabels() { + const { data: labels } = await github.rest.issues.listLabelsOnIssue({ + owner: context.repo.owner, + repo: context.repo.repo, + issue_number: context.issue.number + }); + return labels.map(label => label.name); + } + + async function issueHasInternalLabels() { + const labels = await getIssueLabels(); + return INTERNAL_LABELS.some(item => labels.includes(item)); + } + + async function addNeedsTriageLabelToIssue() { + await github.rest.issues.addLabels({ + issue_number: context.issue.number, + owner: context.repo.owner, + repo: context.repo.repo, + labels: ["status: needs triage"] + }); + } + + try { + if (!await issueHasInternalLabels()) { + await addNeedsTriageLabelToIssue(); + } + } catch (error) { + core.setFailed(`Error: ${error}`); + } + + + + + \ No newline at end of file diff --git a/.github/workflows/longitudinal-benchmark.yml b/.github/workflows/longitudinal-benchmark.yml index 0b704711783..26c74321742 100644 --- a/.github/workflows/longitudinal-benchmark.yml +++ b/.github/workflows/longitudinal-benchmark.yml @@ -41,7 +41,7 @@ jobs: run: git config core.hooksPath no-hooks - name: Store benchmark result - uses: benchmark-action/github-action-benchmark@v1.19.3 + uses: benchmark-action/github-action-benchmark@v1.20.3 with: name: Plutus Benchmarks tool: 'customSmallerIsBetter' diff --git a/.github/workflows/nightly.yml b/.github/workflows/nightly.yml index c7f14577e29..3dcbec1628e 100644 --- a/.github/workflows/nightly.yml +++ b/.github/workflows/nightly.yml @@ -3,32 +3,41 @@ name: Nightly Test Suite on: schedule: - cron: 0 0 * * * # daily at midnight + workflow_dispatch: # or manually dispatch the job + inputs: + hedgehog-tests: + description: Numer of tests to run (--hedgehog-tests XXXXX) + required: false + default: "50000" + +env: + HEDGEHOG_TESTS: ${{ github.event.inputs.hedgehog-tests || 50000 }} jobs: nightly-test-suite: + timeout-minutes: 14400 runs-on: ubuntu-latest steps: - name: Checkout uses: actions/checkout@v4 - - name: Quick Install Nix - uses: cachix/install-nix-action@V27 - with: - extra_nix_config: | - experimental-features = nix-command flakes - accept-flake-config = true + - name: Install Nix + uses: DeterminateSystems/nix-installer-action@main + - name: Use Magic Nix Cache + uses: DeterminateSystems/magic-nix-cache-action@main + - name: plutus-core-nightly if: always() run: | pushd plutus-core - nix run --no-warn-dirty --accept-flake-config .#plutus-core-test -- --hedgehog-tests 10000 + nix run --no-warn-dirty --accept-flake-config .#plutus-core-test -- --hedgehog-tests $HEDGEHOG_TESTS popd - name: plutus-ir-nightly if: always() run: | pushd plutus-core - nix run --no-warn-dirty --accept-flake-config .#plutus-ir-test -- --hedgehog-tests 10000 + nix run --no-warn-dirty --accept-flake-config .#plutus-ir-test -- --hedgehog-tests $HEDGEHOG_TESTS popd diff --git a/RELEASE.adoc b/RELEASE.adoc index 2bc8e778281..797060bd304 100644 --- a/RELEASE.adoc +++ b/RELEASE.adoc @@ -75,19 +75,11 @@ This updates versions and version bounds, and assembles the changelogs.open a PR - Choose as git tag `x.y.z.0` - Choose as target the git commit hash which points to the release commit - Click `Generate release notes` to automatically fill in the details of what's changed -- Create and attach pir&uplc executables to the release by running the following commands inside the repository where its HEAD is at the release commit: -- -+ -[source,bash] -------------- -nix build .#hydraJobs.x86_64-linux.musl64.ghc96.pir -cp ./result/bin/pir ./pir-x86_64-linux-ghc96 - -nix build .#hydraJobs.x86_64-linux.musl64.ghc96.uplc -cp ./result/bin/uplc ./uplc-x86_64-linux-ghc96 -------------- +- Create and attach pir&uplc executables to the release by running the following script inside the repository where its HEAD is at the release commit: `./scripts/prepare-bins.sh`. This will create `pir-x86_64-linux-ghc96` and `uplc-x86_64-linux-ghc96` executables, compress them and put in the project's root folder. Upload them to the release draft. - Click `Publish release`. -7. Open a PR in the https://github.com/IntersectMBO/cardano-haskell-packages[CHaP repository] for publishing the new version. Run `./scripts/add-from-github.sh "https://github.com/IntersectMBO/plutus" COMMIT-SHA LIST-OF-UPDATED-PACKAGES` (see https://github.com/IntersectMBO/cardano-haskell-packages#-from-github[the README on CHaP]). Example: https://github.com/IntersectMBO/cardano-haskell-packages/pull/394. +7. Open a PR in the https://github.com/IntersectMBO/cardano-haskell-packages[CHaP repository] for publishing the new version. + +If you are making PR from your own fork then don't forget to sync your fork with the upstream first. + +Run `./scripts/add-from-github.sh "https://github.com/IntersectMBO/plutus" COMMIT-SHA LIST-OF-UPDATED-PACKAGES` (see https://github.com/IntersectMBO/cardano-haskell-packages#-from-github[the README on CHaP]). Example: https://github.com/IntersectMBO/cardano-haskell-packages/pull/764. - If issues are found, create a release branch `release/x.y.z`, fix the issues on master, backport the fixes to `release/x.y.z`, tag `x.y.z.0-rc2`, and go to step 4. - Why not just fix the issues on master and tag `x.y.z.0-rc2` from master? It is desirable to minimize the amount of change between `rc1` and `rc2`, because it may reduce the tests and checks that need to be performed against `rc2`. diff --git a/doc/read-the-docs-site/plutus-doc.cabal b/doc/read-the-docs-site/plutus-doc.cabal index 1c31b3d75b1..86f51515c0c 100644 --- a/doc/read-the-docs-site/plutus-doc.cabal +++ b/doc/read-the-docs-site/plutus-doc.cabal @@ -17,13 +17,6 @@ source-repository head type: git location: https://github.com/IntersectMBO/plutus -flag defer-plugin-errors - description: - Defer errors from the plugin, useful for things like Haddock that can't handle it. - - default: False - manual: True - common lang default-language: Haskell2010 default-extensions: @@ -47,8 +40,6 @@ common lang -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas - if flag(defer-plugin-errors) - common ghc-version-support -- See the section on GHC versions in CONTRIBUTING if (impl(ghc <9.6) || impl(ghc >=9.7)) diff --git a/plutus-core/changelog.d/20240517_094957_unsafeFixIO_v2_new_prims.md b/plutus-core/changelog.d/20240517_094957_unsafeFixIO_v2_new_prims.md new file mode 100644 index 00000000000..1cd71254e72 --- /dev/null +++ b/plutus-core/changelog.d/20240517_094957_unsafeFixIO_v2_new_prims.md @@ -0,0 +1,5 @@ + +### Added + +- Primitives `integerToByteString` and `byteStringToInteger` are added to PlutusV2, + enabled at protocol version 10. diff --git a/plutus-core/changelog.d/20240520_192738_effectfully_remove_UnknownBuiltin.md b/plutus-core/changelog.d/20240520_192738_effectfully_remove_UnknownBuiltin.md new file mode 100644 index 00000000000..5fe160f9919 --- /dev/null +++ b/plutus-core/changelog.d/20240520_192738_effectfully_remove_UnknownBuiltin.md @@ -0,0 +1,3 @@ +### Removed + +- `UnknownBuiltin` and `UnknownBuiltinType` in #6064. diff --git a/plutus-core/plutus-core/src/PlutusCore/Error.hs b/plutus-core/plutus-core/src/PlutusCore/Error.hs index 7b4b1e8d42a..7ec30398602 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Error.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Error.hs @@ -55,8 +55,7 @@ throwingEither r e = case e of -- | An error encountered during parsing. data ParserError - = UnknownBuiltinType !T.Text !SourcePos - | BuiltinTypeNotAStar !T.Text !SourcePos + = BuiltinTypeNotAStar !T.Text !SourcePos | UnknownBuiltinFunction !T.Text !SourcePos ![T.Text] | InvalidBuiltinConstant !T.Text !T.Text !SourcePos deriving stock (Eq, Ord, Generic) @@ -171,8 +170,6 @@ instance Pretty SourcePos where pretty = pretty . sourcePosPretty instance Pretty ParserError where - pretty (UnknownBuiltinType s loc) = - "Unknown built-in type" <+> squotes (pretty s) <+> "at" <+> pretty loc pretty (BuiltinTypeNotAStar ty loc) = "Expected a type of kind star (to later parse a constant), but got:" <+> squotes (pretty ty) <+> "at" <+> pretty loc diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Exception.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Exception.hs index d49792a5f0e..bd10f0267fe 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Exception.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Exception.hs @@ -59,8 +59,7 @@ data MachineError fun | BuiltinTermArgumentExpectedMachineError -- ^ A builtin expected a term argument, but something else was received. | UnexpectedBuiltinTermArgumentMachineError - -- ^ A builtin received a term argument when something else was expected. - | UnknownBuiltin fun + -- ^ A builtin received a term argument when something else was expected | NonConstrScrutinized | MissingCaseBranch Word64 deriving stock (Show, Eq, Functor, Generic) @@ -160,8 +159,6 @@ instance (HasPrettyDefaults config ~ 'True, Pretty fun) => "A builtin received a term argument when something else was expected" prettyBy _ (UnliftingMachineError unliftingError) = pretty unliftingError - prettyBy _ (UnknownBuiltin fun) = - "Encountered an unknown built-in function:" <+> pretty fun prettyBy _ NonConstrScrutinized = "A non-constructor value was scrutinized in a case expression" prettyBy _ (MissingCaseBranch i) = diff --git a/plutus-ledger-api/exe/analyse-script-events/Main.hs b/plutus-ledger-api/exe/analyse-script-events/Main.hs index 9b4be82bc36..62a881d0f2c 100644 --- a/plutus-ledger-api/exe/analyse-script-events/Main.hs +++ b/plutus-ledger-api/exe/analyse-script-events/Main.hs @@ -37,7 +37,7 @@ import Data.Primitive.PrimArray qualified as P import Data.SatInt (fromSatInt) import System.Directory.Extra (listFiles) import System.Environment (getArgs, getProgName) -import System.FilePath (isExtensionOf) +import System.FilePath (isExtensionOf, takeFileName) import System.IO (stderr) import Text.Printf (hPrintf, printf) @@ -302,6 +302,70 @@ countBuiltins eventFiles = do P.itraversePrimArray_ printEntry finalCounts where printEntry i c = printf "%-35s %12d\n" (show (toEnum i :: DefaultFun)) c + +data EvaluationResult = OK ExBudget | Failed | DeserialisationError + +-- Convert to a string for use in an R frame +toRString :: EvaluationResult -> String +toRString = \case + OK _ -> "T" + Failed -> "F" + DeserialisationError -> "NA" + +-- Print out the actual and claimed CPU and memory cost of every script. +analyseCosts :: EventAnalyser +analyseCosts ctx _ ev = + case ev of + PlutusV1Event ScriptEvaluationData{..} _ -> + let result = + case deserialiseScript PlutusV1 dataProtocolVersion dataScript of + Left _ -> DeserialisationError + Right script -> + case + V1.evaluateScriptRestricting + dataProtocolVersion + V1.Quiet + ctx + dataBudget + script + dataInputs + of + (_, Left _) -> Failed + (_, Right cost) -> OK cost + in printCost result dataBudget + + PlutusV2Event ScriptEvaluationData{..} _ -> + let result = + case deserialiseScript PlutusV2 dataProtocolVersion dataScript of + Left _ -> DeserialisationError + Right script -> + case + V2.evaluateScriptRestricting + dataProtocolVersion + V2.Quiet + ctx + dataBudget + script + dataInputs + of + (_, Left _) -> Failed + (_, Right cost) -> OK cost + in printCost result dataBudget + + where printCost :: EvaluationResult -> ExBudget -> IO () + printCost result claimedCost = + let (claimedCPU, claimedMem) = costAsInts claimedCost + in case result of + OK cost -> + let (actualCPU, actualMem) = costAsInts cost + in printf "%15d %15d %15d %15d %2s\n" actualCPU claimedCPU actualMem claimedMem (toRString result) + -- Something went wrong; print the cost as "NA" ("Not Available" in R) so that R can + -- still process it. + _ -> + printf "%15s %15d %15s %15d %2s\n" "NA" claimedCPU "NA" claimedMem (toRString result) + costAsInts :: ExBudget -> (Int, Int) + costAsInts (ExBudget (V2.ExCPU cpu) (V2.ExMemory mem)) = (fromSatInt cpu, fromSatInt mem) + -- Extract the script from an evaluation event and apply some analysis function analyseUnappliedScript :: (Term NamedDeBruijn DefaultUni DefaultFun () -> IO ()) @@ -325,6 +389,10 @@ analyseOneFile -> IO () analyseOneFile analyse eventFile = do events <- loadEvents eventFile + printf "# %s\n" $ takeFileName eventFile + -- Print the file in the output so we can narrow down the location of + -- interesting/anomalous data. This may not be helpful for some of the + -- analyses. case ( mkContext V1.mkEvaluationContext (eventsCostParamsV1 events) , mkContext V2.mkEvaluationContext (eventsCostParamsV2 events) ) of @@ -354,29 +422,6 @@ analyseOneFile analyse eventFile = do Nothing -> putStrLn "*** ctxV2 missing ***" -max_tx_ex_steps :: Double -max_tx_ex_steps = 10_000_000_000 - -max_tx_ex_mem :: Double -max_tx_ex_mem = 14_000_000 - --- Print out the CPU and memory budgets of each script event. These are the costs --- paid for by the submitters, not the actual costs consumed during execution. --- TODO: add a version that tells us the actual execution costs. -getBudgets :: EventAnalyser -getBudgets _ctx _params ev = - let printFractions d = - let ExBudget (V2.ExCPU cpu) (V2.ExMemory mem) = dataBudget d - in printf "%15d %10.8f %15d %10.8f\n" - (fromSatInt cpu :: Int) - ((fromSatInt cpu) / max_tx_ex_steps) - (fromSatInt mem :: Int) - ((fromSatInt mem) / max_tx_ex_mem) - - in case ev of - PlutusV1Event evdata _expected -> printFractions evdata - PlutusV2Event evdata _expected -> printFractions evdata - main :: IO () main = let analyses = @@ -400,10 +445,10 @@ main = , "count the total number of occurrences of each builtin in validator scripts" , countBuiltins ) - , ( "budgets" - , "print (claimed) budgets of scripts" - , putStrLn " cpu cpuFraction mem memFraction" - `thenDoAnalysis` getBudgets + , ( "costs" + , "print actual and claimed costs of scripts" + , putStrLn " cpuActual cpuClaimed memActual memClaimed status" + `thenDoAnalysis` analyseCosts ) ] @@ -411,17 +456,21 @@ main = (prelude `thenDoAnalysis` analyser) files = prelude >> doAnalysis analyser files usage = do - getProgName >>= hPrintf stderr "Usage: %s \n" + getProgName >>= hPrintf stderr "Usage: %s []\n" + hPrintf stderr "Analyse the .event files in (default = current directory)\n" hPrintf stderr "Avaliable analyses:\n" mapM_ printDescription analyses where printDescription (n,h,_) = hPrintf stderr " %-16s: %s\n" n h + go name dir = + case find (\(n,_,_) -> n == name) analyses of + Nothing -> printf "Unknown analysis: %s\n" name >> usage + Just (_,_,analysis) -> + filter ("event" `isExtensionOf`) <$> listFiles dir >>= \case + [] -> printf "No .event files in %s\n" dir + eventFiles -> analysis eventFiles + in getArgs >>= \case - [dir, name] -> - case find (\(n,_,_) -> n == name) analyses of - Nothing -> printf "Unknown analysis: %s\n" name >> usage - Just (_,_,analysis) -> - filter ("event" `isExtensionOf`) <$> listFiles dir >>= \case - [] -> printf "No event files in %s\n" dir - eventFiles -> analysis eventFiles - _ -> usage + [name] -> go name "." + [name, dir] -> go name dir + _ -> usage diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/ProtocolVersions.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/ProtocolVersions.hs index fdf7fbc08a5..158c57fde4a 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/ProtocolVersions.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/ProtocolVersions.hs @@ -11,6 +11,7 @@ module PlutusLedgerApi.Common.ProtocolVersions , vasilPV , valentinePV , conwayPV + , conwayPlus1PV , knownPVs , futurePV ) where @@ -68,10 +69,25 @@ valentinePV = MajorProtocolVersion 8 conwayPV :: MajorProtocolVersion conwayPV = MajorProtocolVersion 9 +-- | The next HF after Conway. It doesn't yet have a name, and it's not +-- yet known whether it will be an intra-era HF or introduce a new era. +conwayPlus1PV :: MajorProtocolVersion +conwayPlus1PV = MajorProtocolVersion 10 + -- | The set of protocol versions that are "known", i.e. that have been released -- and have actual differences associated with them. knownPVs :: Set.Set MajorProtocolVersion -knownPVs = Set.fromList [ shelleyPV, allegraPV, maryPV, alonzoPV, vasilPV, valentinePV, conwayPV ] +knownPVs = + Set.fromList + [ shelleyPV + , allegraPV + , maryPV + , alonzoPV + , vasilPV + , valentinePV + , conwayPV + , conwayPlus1PV + ] -- | This is a placeholder for when we don't yet know what protocol version will -- be used for something. It's a very high protocol version that should never diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs index 728b096ea3c..24a553dd651 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs @@ -81,7 +81,6 @@ instance Pretty PlutusLedgerLanguage where pretty = viaShow {-| A map indicating which builtin functions were introduced in which 'MajorProtocolVersion'. -Each builtin function should appear at most once. This __must__ be updated when new builtins are added. See Note [New builtins/language versions and protocol versions] @@ -107,6 +106,9 @@ builtinsIntroducedIn = Map.fromList [ ((PlutusV2, valentinePV), Set.fromList [ VerifyEcdsaSecp256k1Signature, VerifySchnorrSecp256k1Signature ]), + ((PlutusV2, conwayPlus1PV), Set.fromList [ + IntegerToByteString, ByteStringToInteger + ]), ((PlutusV3, conwayPV), Set.fromList [ Bls12_381_G1_add, Bls12_381_G1_neg, Bls12_381_G1_scalarMul, Bls12_381_G1_equal, Bls12_381_G1_hashToGroup, @@ -173,10 +175,10 @@ and 'MajorProtocolVersion'? See Note [New builtins/language versions and protocol versions] -} builtinsAvailableIn :: PlutusLedgerLanguage -> MajorProtocolVersion -> Set.Set DefaultFun -builtinsAvailableIn thisLv thisPv = fold $ Map.elems $ - Map.takeWhileAntitone builtinAvailableIn builtinsIntroducedIn +builtinsAvailableIn thisLv thisPv = fold $ + Map.filterWithKey (const . alreadyIntroduced) builtinsIntroducedIn where - builtinAvailableIn :: (PlutusLedgerLanguage, MajorProtocolVersion) -> Bool - builtinAvailableIn (introducedInLv,introducedInPv) = + alreadyIntroduced :: (PlutusLedgerLanguage, MajorProtocolVersion) -> Bool + alreadyIntroduced (introducedInLv,introducedInPv) = -- both should be satisfied introducedInLv <= thisLv && introducedInPv <= thisPv diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/ParamName.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/ParamName.hs index 292ea06f506..1f6ef6f5610 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/ParamName.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/ParamName.hs @@ -190,5 +190,15 @@ data ParamName = | VerifySchnorrSecp256k1Signature'cpu'arguments'intercept | VerifySchnorrSecp256k1Signature'cpu'arguments'slope | VerifySchnorrSecp256k1Signature'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 deriving stock (Eq, Ord, Enum, Ix, Bounded, Generic) deriving IsParamName via (GenericParamName ParamName) diff --git a/plutus-ledger-api/test/Spec/CostModelParams.hs b/plutus-ledger-api/test/Spec/CostModelParams.hs index 6cff19826ac..3edb933edc4 100644 --- a/plutus-ledger-api/test/Spec/CostModelParams.hs +++ b/plutus-ledger-api/test/Spec/CostModelParams.hs @@ -30,8 +30,8 @@ tests = [ testCase "length" $ do 166 @=? length v1_ParamNames 166 @=? length V1.costModelParamsForTesting - 175 @=? length v2_ParamNames - 175 @=? length V2.costModelParamsForTesting + 185 @=? length v2_ParamNames + 185 @=? length V2.costModelParamsForTesting 233 @=? length v3_ParamNames 233 @=? length V3.costModelParamsForTesting , testCase "tripping paramname" $ do diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V2/EvaluationContext.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V2/EvaluationContext.hs index a95463039cd..e7bbec6cd2d 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V2/EvaluationContext.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V2/EvaluationContext.hs @@ -52,4 +52,6 @@ clearBuiltinCostModel r = r { paramSerialiseData = mempty , paramVerifyEcdsaSecp256k1Signature = mempty , paramVerifySchnorrSecp256k1Signature = mempty + , paramIntegerToByteString = mempty + , paramByteStringToInteger = mempty } diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/EvaluationContext.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/EvaluationContext.hs index e4e7e74c3ed..62ae7ccab21 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/EvaluationContext.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/V3/EvaluationContext.hs @@ -67,6 +67,4 @@ clearBuiltinCostModel r = r , paramBls12_381_finalVerify = mempty , paramKeccak_256 = mempty , paramBlake2b_224 = mempty - , paramIntegerToByteString = mempty - , paramByteStringToInteger = mempty } diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index 2ebff4e86e2..bdf5c1a1482 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -128,6 +128,7 @@ test-suite plutus-tx-plugin-tests other-modules: AsData.Budget.Spec AsData.Budget.Types + AssocMap.Spec Blueprint.Tests Blueprint.Tests.Lib Blueprint.Tests.Lib.AsData.Blueprint @@ -171,6 +172,7 @@ test-suite plutus-tx-plugin-tests TH.Spec TH.TestTH Unicode.Spec + Util.Common build-depends: , base >=4.9 && <5 @@ -192,6 +194,7 @@ test-suite plutus-tx-plugin-tests , tasty-hunit , template-haskell , text + , these default-extensions: Strict ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/plutus-tx-plugin/test/AssocMap/Spec.hs b/plutus-tx-plugin/test/AssocMap/Spec.hs new file mode 100644 index 00000000000..d8658ebd69c --- /dev/null +++ b/plutus-tx-plugin/test/AssocMap/Spec.hs @@ -0,0 +1,806 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} + +module AssocMap.Spec where + +import Test.Tasty.Extras + +import Data.List (nubBy, sort) +import Data.Map.Strict qualified as Map +import Data.These qualified as Haskell +import Hedgehog (Gen, MonadTest, Property, Range, forAll, property, (===)) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import PlutusTx.AssocMap qualified as AssocMap +import PlutusTx.Builtins qualified as PlutusTx +import PlutusTx.Code +import PlutusTx.Data.AssocMap qualified as Data.AssocMap +import PlutusTx.IsData () +import PlutusTx.IsData qualified as P +import PlutusTx.Lift (liftCodeDef, makeLift) +import PlutusTx.List qualified as PlutusTx +import PlutusTx.Prelude qualified as PlutusTx +import PlutusTx.Show qualified as PlutusTx +import PlutusTx.Test +import PlutusTx.TH (compile) +import PlutusTx.These (These (..), these) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) +import Util.Common (cekResultMatchesHaskellValue, compiledCodeToTerm, unsafeRunTermCek) + + +-- | Test the performance and interaction between 'insert', 'delete' and 'lookup'. +map1 :: + CompiledCode + ( Integer -> + ( Maybe PlutusTx.BuiltinByteString + , Maybe PlutusTx.BuiltinByteString + , Maybe PlutusTx.BuiltinByteString + , Maybe PlutusTx.BuiltinByteString + , Maybe PlutusTx.BuiltinByteString + ) + ) +map1 = + $$( compile + [|| + \n -> + let m :: Data.AssocMap.Map Integer PlutusTx.BuiltinByteString + m = + foldr + (\i -> + Data.AssocMap.insert + (n PlutusTx.+ i) + (PlutusTx.encodeUtf8 (PlutusTx.show i)) + ) + (Data.AssocMap.singleton n "0") + (PlutusTx.enumFromTo 1 10) + m' = Data.AssocMap.delete (n PlutusTx.+ 5) m + in ( Data.AssocMap.lookup n m + , Data.AssocMap.lookup (n PlutusTx.+ 5) m + , Data.AssocMap.lookup (n PlutusTx.+ 10) m + , Data.AssocMap.lookup (n PlutusTx.+ 20) m + , Data.AssocMap.lookup (n PlutusTx.+ 5) m' + ) + ||] + ) + +-- | Test that 'unionWith' is implemented correctly. Due to the nature of 'Map k v', +-- some type errors are only caught when running the PlutusTx compiler on code which uses +-- 'unionWith'. +map2 :: CompiledCode (Integer -> [(Integer, PlutusTx.BuiltinString)]) +map2 = + $$( compile + [|| + \n -> + let m1 = + Data.AssocMap.unsafeFromList + [ (n PlutusTx.+ 1, "one") + , (n PlutusTx.+ 2, "two") + , (n PlutusTx.+ 3, "three") + , (n PlutusTx.+ 4, "four") + , (n PlutusTx.+ 5, "five") + ] + m2 = + Data.AssocMap.unsafeFromList + [ (n PlutusTx.+ 3, "THREE") + , (n PlutusTx.+ 4, "FOUR") + , (n PlutusTx.+ 6, "SIX") + , (n PlutusTx.+ 7, "SEVEN") + ] + m = Data.AssocMap.unionWith PlutusTx.appendByteString m1 m2 + in PlutusTx.fmap (\(k, v) -> (k, PlutusTx.decodeUtf8 v)) (Data.AssocMap.toList m) + ||] + ) + +-- | Similar to map2, but uses 'union' instead of 'unionWith'. Evaluating 'map3' and 'map2' +-- should yield the same result. +map3 :: CompiledCode (Integer -> [(Integer, PlutusTx.BuiltinString)]) +map3 = + $$( compile + [|| + \n -> + let m1 = + Data.AssocMap.unsafeFromList + [ (n PlutusTx.+ 1, "one") + , (n PlutusTx.+ 2, "two") + , (n PlutusTx.+ 3, "three") + , (n PlutusTx.+ 4, "four") + , (n PlutusTx.+ 5, "five") + ] + m2 = + Data.AssocMap.unsafeFromList + [ (n PlutusTx.+ 3, "THREE") + , (n PlutusTx.+ 4, "FOUR") + , (n PlutusTx.+ 6, "SIX") + , (n PlutusTx.+ 7, "SEVEN") + ] + m = Data.AssocMap.union m1 m2 + f = these id id PlutusTx.appendByteString + in PlutusTx.fmap (\(k, v) -> (k, PlutusTx.decodeUtf8 (f v))) (Data.AssocMap.toList m) + ||] + ) + +lookupProgram :: CompiledCode (Integer -> AssocMap.Map Integer Integer -> Maybe Integer) +lookupProgram = $$(compile [|| AssocMap.lookup ||]) + +dataLookupProgram :: CompiledCode (Integer -> Data.AssocMap.Map Integer Integer -> Maybe Integer) +dataLookupProgram = $$(compile [|| Data.AssocMap.lookup ||]) + +memberProgram :: CompiledCode (Integer -> AssocMap.Map Integer Integer -> Bool) +memberProgram = $$(compile [|| AssocMap.member ||]) + +dataMemberProgram :: CompiledCode (Integer -> Data.AssocMap.Map Integer Integer -> Bool) +dataMemberProgram = $$(compile [|| Data.AssocMap.member ||]) + +insertProgram + :: CompiledCode + ( Integer + -> Integer + -> AssocMap.Map Integer Integer + -> [(Integer, Integer)] + ) +insertProgram = + $$(compile + [|| \k v m -> + PlutusTx.sort $ AssocMap.toList $ AssocMap.insert k v m + ||]) + +dataInsertProgram + :: CompiledCode + ( Integer + -> Integer + -> Data.AssocMap.Map Integer Integer + -> [(Integer, Integer)] + ) +dataInsertProgram = + $$(compile + [|| \k v m -> + PlutusTx.sort $ Data.AssocMap.toList $ Data.AssocMap.insert k v m + ||]) + +deleteProgram + :: CompiledCode + ( Integer + -> AssocMap.Map Integer Integer + -> [(Integer, Integer)] + ) +deleteProgram = + $$(compile + [|| \k m -> + PlutusTx.sort $ AssocMap.toList $ AssocMap.delete k m + ||]) + +dataDeleteProgram + :: CompiledCode + ( Integer + -> Data.AssocMap.Map Integer Integer + -> [(Integer, Integer)] + ) +dataDeleteProgram = + $$(compile + [|| \k m -> + PlutusTx.sort $ Data.AssocMap.toList $ Data.AssocMap.delete k m + ||]) + +allProgram + :: CompiledCode + ( Integer + -> AssocMap.Map Integer Integer + -> Bool + ) +allProgram = + $$(compile [|| \num m -> AssocMap.all (\x -> x PlutusTx.< num) m ||]) + +dataAllProgram + :: CompiledCode + ( Integer + -> Data.AssocMap.Map Integer Integer + -> Bool + ) +dataAllProgram = + $$(compile [|| \num m -> Data.AssocMap.all (\x -> x PlutusTx.< num) m ||]) + +dataAnyProgram + :: CompiledCode + ( Integer + -> Data.AssocMap.Map Integer Integer + -> Bool + ) +dataAnyProgram = + $$(compile [|| \num m -> Data.AssocMap.any (\x -> x PlutusTx.< num) m ||]) + +keysProgram + :: CompiledCode + ( AssocMap.Map Integer Integer + -> [Integer] + ) +keysProgram = + $$(compile [|| AssocMap.keys ||]) + +dataNoDuplicateKeysProgram + :: CompiledCode + ( Data.AssocMap.Map Integer Integer + -> Bool + ) +dataNoDuplicateKeysProgram = + $$(compile [|| Data.AssocMap.noDuplicateKeys ||]) + +unionProgram + :: CompiledCode + ( AssocMap.Map Integer Integer + -> AssocMap.Map Integer Integer + -> [(Integer, These Integer Integer)] + ) +unionProgram = + $$(compile + [|| \m1 m2 -> + PlutusTx.sort $ AssocMap.toList $ AssocMap.union m1 m2 + ||]) + +dataUnionProgram + :: CompiledCode + ( Data.AssocMap.Map Integer Integer + -> Data.AssocMap.Map Integer Integer + -> [(Integer, These Integer Integer)] + ) +dataUnionProgram = + $$(compile + [|| \m1 m2 -> + PlutusTx.sort $ Data.AssocMap.toList $ Data.AssocMap.union m1 m2 + ||]) + +unionWithProgram + :: CompiledCode + ( AssocMap.Map Integer Integer + -> AssocMap.Map Integer Integer + -> [(Integer, Integer)] + ) +unionWithProgram = + $$(compile + [|| \m1 m2 -> + PlutusTx.sort $ AssocMap.toList $ AssocMap.unionWith (\x _ -> x) m1 m2 + ||]) + +dataUnionWithProgram + :: CompiledCode + ( Data.AssocMap.Map Integer Integer + -> Data.AssocMap.Map Integer Integer + -> [(Integer, Integer)] + ) +dataUnionWithProgram = + $$(compile + [|| \m1 m2 -> + PlutusTx.sort $ Data.AssocMap.toList $ Data.AssocMap.unionWith (\x _ -> x) m1 m2 + ||]) + +encodedDataAssocMap + :: CompiledCode + ( Data.AssocMap.Map Integer Integer + -> PlutusTx.BuiltinData + ) +encodedDataAssocMap = $$(compile [|| P.toBuiltinData ||]) + +encodedAssocMap + :: CompiledCode + ( AssocMap.Map Integer Integer + -> PlutusTx.BuiltinData + ) +encodedAssocMap = $$(compile [|| P.toBuiltinData ||]) + +mDecodedDataAssocMap + :: CompiledCode + ( Data.AssocMap.Map Integer Integer + -> PlutusTx.Maybe [(Integer, Integer)] + ) +mDecodedDataAssocMap = + $$(compile + [|| fmap (PlutusTx.sort . Data.AssocMap.toList) . P.fromBuiltinData . P.toBuiltinData + ||]) + +mDecodedAssocMap + :: CompiledCode + ( AssocMap.Map Integer Integer + -> PlutusTx.Maybe [(Integer, Integer)] + ) +mDecodedAssocMap = + $$(compile + [|| fmap (PlutusTx.sort . AssocMap.toList) . P.fromBuiltinData . P.toBuiltinData + ||]) + +decodedDataAssocMap + :: CompiledCode + ( Data.AssocMap.Map Integer Integer + -> [(Integer, Integer)] + ) +decodedDataAssocMap = + $$(compile + [|| PlutusTx.sort . Data.AssocMap.toList . P.unsafeFromBuiltinData . P.toBuiltinData + ||]) + +decodedAssocMap + :: CompiledCode + ( AssocMap.Map Integer Integer + -> [(Integer, Integer)] + ) +decodedAssocMap = + $$(compile + [|| PlutusTx.sort . AssocMap.toList . P.unsafeFromBuiltinData . P.toBuiltinData + ||]) + +-- | The semantics of PlutusTx maps and their operations. +-- The 'PlutusTx' implementations maps ('Data.AssocMap.Map' and 'AssocMap.Map') +-- are checked against the semantics to ensure correctness. +newtype AssocMapS k v = AssocMapS [(k, v)] + deriving stock (Show, Eq) + +semanticsToAssocMap :: AssocMapS k v -> AssocMap.Map k v +semanticsToAssocMap = AssocMap.unsafeFromList . toListS + +semanticsToDataAssocMap + :: (P.ToData k, P.ToData v) + => AssocMapS k v -> Data.AssocMap.Map k v +semanticsToDataAssocMap = Data.AssocMap.unsafeFromList . toListS + +assocMapToSemantics :: AssocMap.Map k v -> AssocMapS k v +assocMapToSemantics = unsafeFromListS . AssocMap.toList + +dataAssocMapToSemantics + :: (P.UnsafeFromData k, P.UnsafeFromData v) + => Data.AssocMap.Map k v -> AssocMapS k v +dataAssocMapToSemantics = unsafeFromListS . Data.AssocMap.toList + +nullS :: AssocMapS k v -> Bool +nullS (AssocMapS l) = null l + +sortS :: (Ord k, Ord v) => AssocMapS k v -> AssocMapS k v +sortS (AssocMapS l) = AssocMapS $ sort l + +toListS :: AssocMapS k v -> [(k, v)] +toListS (AssocMapS l) = l + +unsafeFromListS :: [(k, v)] -> AssocMapS k v +unsafeFromListS = AssocMapS + +safeFromListS :: Ord k => [(k, v)] -> AssocMapS k v +safeFromListS = AssocMapS . Map.toList . Map.fromList + +lookupS :: Integer -> AssocMapS Integer Integer -> Maybe Integer +lookupS k (AssocMapS l) = Map.lookup k . Map.fromList $ l + +memberS :: Integer -> AssocMapS Integer Integer -> Bool +memberS k (AssocMapS l) = Map.member k . Map.fromList $ l + +insertS :: Integer -> Integer -> AssocMapS Integer Integer -> AssocMapS Integer Integer +insertS k v (AssocMapS l) = + AssocMapS . Map.toList . Map.insert k v . Map.fromList $ l + +deleteS :: Integer -> AssocMapS Integer Integer -> AssocMapS Integer Integer +deleteS k (AssocMapS l) = + AssocMapS . Map.toList . Map.delete k . Map.fromList $ l + +allS :: (Integer -> Bool) -> AssocMapS Integer Integer -> Bool +allS p (AssocMapS l) = all (p . snd) l + +anyS :: (Integer -> Bool) -> AssocMapS Integer Integer -> Bool +anyS p (AssocMapS l) = any (p . snd) l + +keysS :: AssocMapS Integer Integer -> [Integer] +keysS (AssocMapS l) = map fst l + +noDuplicateKeysS :: AssocMapS Integer Integer -> Bool +noDuplicateKeysS (AssocMapS l) = + length l == length (nubBy (\(k1, _) (k2, _) -> k1 == k2) l) + +mapS :: (a -> b) -> AssocMapS k a -> AssocMapS k b +mapS f (AssocMapS l) = AssocMapS $ map (\(k, v) -> (k, f v)) l + +makeLift ''AssocMapS + +-- | The semantics of 'union' is based on the 'AssocMap' implementation. +-- The code is duplicated here to avoid any issues if the 'AssocMap' implementation changes. +unionS + :: AssocMapS Integer Integer + -> AssocMapS Integer Integer + -> AssocMapS Integer (Haskell.These Integer Integer) +unionS (AssocMapS ls) (AssocMapS rs) = + let + f a b' = case b' of + Nothing -> Haskell.This a + Just b -> Haskell.These a b + + ls' = fmap (\(c, i) -> (c, f i (lookupS c (AssocMapS rs)))) ls + + -- Keeps only those keys which don't appear in the left map. + rs' = filter (\(c, _) -> not (any (\(c', _) -> c' == c) ls)) rs + + rs'' = fmap (fmap Haskell.That) rs' + in + AssocMapS (ls' ++ rs'') + +haskellToPlutusThese :: Haskell.These a b -> These a b +haskellToPlutusThese = \case + Haskell.This a -> This a + Haskell.That b -> That b + Haskell.These a b -> These a b + +unionWithS + :: (Integer -> Integer -> Integer) + -> AssocMapS Integer Integer + -> AssocMapS Integer Integer + -> AssocMapS Integer Integer +unionWithS merge (AssocMapS ls) (AssocMapS rs) = + AssocMapS + . Map.toList + $ Map.unionWith merge (Map.fromList ls) (Map.fromList rs) + +genAssocMapS :: Gen (AssocMapS Integer Integer) +genAssocMapS = + AssocMapS . Map.toList <$> Gen.map rangeLength genPair + where + genPair :: Gen (Integer, Integer) + genPair = do + (,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem + +genUnsafeAssocMapS :: Gen (AssocMapS Integer Integer) +genUnsafeAssocMapS = do + AssocMapS <$> Gen.list rangeLength genPair + where + genPair :: Gen (Integer, Integer) + genPair = do + (,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem + +-- | The 'Equivalence' class is used to define an equivalence relation +-- between `AssocMapS` and the 'PlutusTx' implementations. +class Equivalence l where + (~~) :: + ( MonadTest m + , Show k + , Show v + , Ord k + , Ord v + , P.UnsafeFromData k + , P.UnsafeFromData v + ) => AssocMapS k v -> l k v -> m () + +-- | An `AssocMap.Map` is equivalent to an `AssocMapS` if they have the same elements. +instance Equivalence AssocMap.Map where + assocMapS ~~ assocMap = + sortS assocMapS === sortS (assocMapToSemantics assocMap) + +-- | An `Data.AssocMap.Map` is equivalent to an `AssocMapS` if they have the same elements. +instance Equivalence Data.AssocMap.Map where + assocMapS ~~ dataAssocMap = + sortS assocMapS === sortS (dataAssocMapToSemantics dataAssocMap) + +rangeElem :: Range Integer +rangeElem = Range.linear 0 100 + +rangeLength :: Range Int +rangeLength = Range.linear 0 100 + +safeFromListSpec :: Property +safeFromListSpec = property $ do + assocMapS <- forAll genAssocMapS + let assocMap = AssocMap.safeFromList . toListS $ assocMapS + dataAssocMap = Data.AssocMap.safeFromList . toListS $ assocMapS + assocMapS ~~ assocMap + assocMapS ~~ dataAssocMap + +unsafeFromListSpec :: Property +unsafeFromListSpec = property $ do + assocMapS <- forAll genAssocMapS + let assocMap = AssocMap.unsafeFromList . toListS $ assocMapS + dataAssocMap = Data.AssocMap.unsafeFromList . toListS $ assocMapS + assocMapS ~~ assocMap + assocMapS ~~ dataAssocMap + +lookupSpec :: Property +lookupSpec = property $ do + assocMapS <- forAll genAssocMapS + key <- forAll $ Gen.integral rangeElem + let assocMap = semanticsToAssocMap assocMapS + dataAssocMap = semanticsToDataAssocMap assocMapS + expected = lookupS key assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ lookupProgram + `unsafeApplyCode` (liftCodeDef key) + `unsafeApplyCode` (liftCodeDef assocMap) + ) + (===) + expected + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataLookupProgram + `unsafeApplyCode` (liftCodeDef key) + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + expected + +memberSpec :: Property +memberSpec = property $ do + assocMapS <- forAll genAssocMapS + key <- forAll $ Gen.integral rangeElem + let assocMap = semanticsToAssocMap assocMapS + dataAssocMap = semanticsToDataAssocMap assocMapS + expected = memberS key assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ memberProgram + `unsafeApplyCode` (liftCodeDef key) + `unsafeApplyCode` (liftCodeDef assocMap) + ) + (===) + expected + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataMemberProgram + `unsafeApplyCode` (liftCodeDef key) + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + expected + +insertSpec :: Property +insertSpec = property $ do + assocMapS <- forAll genAssocMapS + key <- forAll $ Gen.integral rangeElem + value <- forAll $ Gen.integral rangeElem + let assocMap = semanticsToAssocMap assocMapS + dataAssocMap = semanticsToDataAssocMap assocMapS + expected = sortS $ insertS key value assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ insertProgram + `unsafeApplyCode` (liftCodeDef key) + `unsafeApplyCode` (liftCodeDef value) + `unsafeApplyCode` (liftCodeDef assocMap) + ) + (===) + expected + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataInsertProgram + `unsafeApplyCode` (liftCodeDef key) + `unsafeApplyCode` (liftCodeDef value) + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + expected + +deleteSpec :: Property +deleteSpec = property $ do + assocMapS <- forAll genAssocMapS + key <- forAll $ Gen.integral rangeElem + let assocMap = semanticsToAssocMap assocMapS + dataAssocMap = semanticsToDataAssocMap assocMapS + expected = sortS $ deleteS key assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ deleteProgram + `unsafeApplyCode` (liftCodeDef key) + `unsafeApplyCode` (liftCodeDef assocMap) + ) + (===) + expected + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataDeleteProgram + `unsafeApplyCode` (liftCodeDef key) + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + expected + +allSpec :: Property +allSpec = property $ do + assocMapS <- forAll genAssocMapS + num <- forAll $ Gen.integral rangeElem + let assocMap = semanticsToAssocMap assocMapS + dataAssocMap = semanticsToDataAssocMap assocMapS + expected = allS (< num) assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ allProgram + `unsafeApplyCode` (liftCodeDef num) + `unsafeApplyCode` (liftCodeDef assocMap) + ) + (===) + expected + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataAllProgram + `unsafeApplyCode` (liftCodeDef num) + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + expected + +anySpec :: Property +anySpec = property $ do + assocMapS <- forAll genAssocMapS + num <- forAll $ Gen.integral rangeElem + let dataAssocMap = semanticsToDataAssocMap assocMapS + expected = anyS (< num) assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataAnyProgram + `unsafeApplyCode` (liftCodeDef num) + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + expected + +keysSpec :: Property +keysSpec = property $ do + assocMapS <- forAll genAssocMapS + let assocMap = semanticsToAssocMap assocMapS + expected = keysS assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ keysProgram + `unsafeApplyCode` (liftCodeDef assocMap) + ) + (===) + expected + +noDuplicateKeysSpec :: Property +noDuplicateKeysSpec = property $ do + assocMapS <- forAll genAssocMapS + let dataAssocMap = semanticsToDataAssocMap assocMapS + expected = noDuplicateKeysS assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataNoDuplicateKeysProgram + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + expected + +unionSpec :: Property +unionSpec = property $ do + -- resizing the generator for performance + assocMapS1 <- forAll (Gen.resize 20 genAssocMapS) + assocMapS2 <- forAll (Gen.resize 20 genAssocMapS) + let assocMap1 = semanticsToAssocMap assocMapS1 + assocMap2 = semanticsToAssocMap assocMapS2 + dataAssocMap1 = semanticsToDataAssocMap assocMapS1 + dataAssocMap2 = semanticsToDataAssocMap assocMapS2 + expected = mapS haskellToPlutusThese $ sortS $ unionS assocMapS1 assocMapS2 + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ unionProgram + `unsafeApplyCode` (liftCodeDef assocMap1) + `unsafeApplyCode` (liftCodeDef assocMap2) + ) + (===) + expected + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataUnionProgram + `unsafeApplyCode` (liftCodeDef dataAssocMap1) + `unsafeApplyCode` (liftCodeDef dataAssocMap2) + ) + (===) + expected + +unionWithSpec :: Property +unionWithSpec = property $ do + -- resizing the generator for performance + assocMapS1 <- forAll (Gen.resize 20 genAssocMapS) + assocMapS2 <- forAll (Gen.resize 20 genAssocMapS) + let assocMap1 = semanticsToAssocMap assocMapS1 + assocMap2 = semanticsToAssocMap assocMapS2 + dataAssocMap1 = semanticsToDataAssocMap assocMapS1 + dataAssocMap2 = semanticsToDataAssocMap assocMapS2 + merge i1 _ = i1 + expected = unionWithS merge assocMapS1 assocMapS2 + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ unionWithProgram + `unsafeApplyCode` (liftCodeDef assocMap1) + `unsafeApplyCode` (liftCodeDef assocMap2) + ) + (===) + expected + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ dataUnionWithProgram + `unsafeApplyCode` (liftCodeDef dataAssocMap1) + `unsafeApplyCode` (liftCodeDef dataAssocMap2) + ) + (===) + expected + +builtinDataEncodingSpec :: Property +builtinDataEncodingSpec = property $ do + assocMapS <- forAll genAssocMapS + let assocMap = semanticsToAssocMap assocMapS + dataAssocMap = semanticsToDataAssocMap assocMapS + unsafeRunTermCek + ( compiledCodeToTerm + $ encodedDataAssocMap `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + === + unsafeRunTermCek + ( compiledCodeToTerm + $ encodedAssocMap `unsafeApplyCode` (liftCodeDef assocMap) + ) + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ mDecodedAssocMap + `unsafeApplyCode` (liftCodeDef assocMap) + ) + (===) + (Just assocMapS) + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ mDecodedDataAssocMap + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + (Just assocMapS) + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ decodedAssocMap + `unsafeApplyCode` (liftCodeDef assocMap) + ) + (===) + assocMapS + cekResultMatchesHaskellValue + ( compiledCodeToTerm + $ decodedDataAssocMap + `unsafeApplyCode` (liftCodeDef dataAssocMap) + ) + (===) + assocMapS + +goldenTests :: TestNested +goldenTests = + testNestedGhc + "Budget" + [ goldenPirReadable "map1" map1 + , goldenUPlcReadable "map1" map1 + , goldenEvalCekCatch "map1" $ [map1 `unsafeApplyCode` (liftCodeDef 100)] + , goldenBudget "map1-budget" $ map1 `unsafeApplyCode` (liftCodeDef 100) + , goldenPirReadable "map2" map2 + , goldenUPlcReadable "map2" map2 + , goldenEvalCekCatch "map2" $ [map2 `unsafeApplyCode` (liftCodeDef 100)] + , goldenBudget "map2-budget" $ map2 `unsafeApplyCode` (liftCodeDef 100) + , goldenPirReadable "map3" map2 + , goldenUPlcReadable "map3" map2 + , goldenEvalCekCatch "map3" $ [map2 `unsafeApplyCode` (liftCodeDef 100)] + , goldenBudget "map3-budget" $ map2 `unsafeApplyCode` (liftCodeDef 100) + ] + +propertyTests :: TestTree +propertyTests = + testGroup "Map property tests" + [ testProperty "safeFromList" safeFromListSpec + , testProperty "unsafeFromList" unsafeFromListSpec + , testProperty "lookup" lookupSpec + , testProperty "member" memberSpec + , testProperty "insert" insertSpec + , testProperty "all" allSpec + , testProperty "any" anySpec + , testProperty "keys" keysSpec + , testProperty "noDuplicateKeys" noDuplicateKeysSpec + , testProperty "delete" deleteSpec + , testProperty "union" unionSpec + , testProperty "unionWith" unionWithSpec + , testProperty "builtinDataEncoding" builtinDataEncodingSpec + ] diff --git a/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden b/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden new file mode 100644 index 00000000000..3a0c427ec3e --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map1-budget.budget.golden @@ -0,0 +1,2 @@ +({cpu: 390169748 +| mem: 869909}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.eval.golden b/plutus-tx-plugin/test/Budget/9.6/map1.eval.golden new file mode 100644 index 00000000000..2976eddf5c9 --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map1.eval.golden @@ -0,0 +1,8 @@ +(constr + 0 + (constr 0 (con bytestring #30)) + (constr 0 (con bytestring #35)) + (constr 0 (con bytestring #3130)) + (constr 1) + (constr 1) +) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden new file mode 100644 index 00000000000..dc42876c182 --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map1.pir.golden @@ -0,0 +1,404 @@ +letrec + data (List :: * -> *) a | List_match where + Nil : List a + Cons : a -> List a -> List a +in +letrec + !`$fEnumBool_$cenumFromTo` : integer -> integer -> List integer + = \(x : integer) (lim : integer) -> + ifThenElse + {all dead. List integer} + (lessThanEqualsInteger x lim) + (/\dead -> + Cons {integer} x (`$fEnumBool_$cenumFromTo` (addInteger 1 x) lim)) + (/\dead -> Nil {integer}) + {all dead. dead} +in +letrec + !go : List integer -> integer -> List integer + = \(acc : List integer) (n : integer) -> + let + !x : integer = quotientInteger n 10 + in + ifThenElse + {all dead. List integer} + (equalsInteger 0 x) + (/\dead -> Cons {integer} (remainderInteger n 10) acc) + (/\dead -> go (Cons {integer} (remainderInteger n 10) acc) x) + {all dead. dead} +in +letrec + !go : + List integer -> List string -> List string + = \(ds : List integer) -> + List_match + {integer} + ds + {all dead. List string -> List string} + (/\dead -> \(x : List string) -> x) + (\(x : integer) + (xs : List integer) -> + /\dead -> + let + !acc : List string -> List string = go xs + in + \(eta : List string) -> + Cons + {string} + (ifThenElse + {all dead. string} + (equalsInteger 0 x) + (/\dead -> "0") + (/\dead -> + ifThenElse + {all dead. string} + (equalsInteger 1 x) + (/\dead -> "1") + (/\dead -> + ifThenElse + {all dead. string} + (equalsInteger 2 x) + (/\dead -> "2") + (/\dead -> + ifThenElse + {all dead. string} + (equalsInteger 3 x) + (/\dead -> "3") + (/\dead -> + ifThenElse + {all dead. string} + (equalsInteger 4 x) + (/\dead -> "4") + (/\dead -> + ifThenElse + {all dead. string} + (equalsInteger 5 x) + (/\dead -> "5") + (/\dead -> + ifThenElse + {all dead. string} + (equalsInteger 6 x) + (/\dead -> "6") + (/\dead -> + ifThenElse + {all dead. string} + (equalsInteger 7 x) + (/\dead -> "7") + (/\dead -> + ifThenElse + {all dead. string} + (equalsInteger + 8 + x) + (/\dead -> "8") + (/\dead -> + ifThenElse + {string} + (equalsInteger + 9 + x) + "9" + "") + {all dead. dead}) + {all dead. dead}) + {all dead. dead}) + {all dead. dead}) + {all dead. dead}) + {all dead. dead}) + {all dead. dead}) + {all dead. dead}) + {all dead. dead}) + (acc eta)) + {all dead. dead} +in +letrec + !`$fShowBuiltinByteString_$cshowsPrec` : + integer -> integer -> List string -> List string + = \(p : integer) (n : integer) -> + ifThenElse + {all dead. List string -> List string} + (lessThanInteger n 0) + (/\dead -> + \(eta : List string) -> + Cons + {string} + "-" + (`$fShowBuiltinByteString_$cshowsPrec` + p + (subtractInteger 0 n) + eta)) + (/\dead -> go (go (Nil {integer}) n)) + {all dead. dead} +in +let + data (Tuple5 :: * -> * -> * -> * -> * -> *) a b c d e | Tuple5_match where + Tuple5 : a -> b -> c -> d -> e -> Tuple5 a b c d e + data (Tuple2 :: * -> * -> *) a b | Tuple2_match where + Tuple2 : a -> b -> Tuple2 a b +in +letrec + !go : all a. integer -> List a -> Tuple2 (List a) (List a) + = /\a -> + \(ds : integer) (ds : List a) -> + List_match + {a} + ds + {all dead. Tuple2 (List a) (List a)} + (/\dead -> Tuple2 {List a} {List a} (Nil {a}) (Nil {a})) + (\(y : a) (ys : List a) -> + /\dead -> + ifThenElse + {all dead. Tuple2 (List a) (List a)} + (equalsInteger 1 ds) + (/\dead -> + Tuple2 + {List a} + {List a} + ((let + a = List a + in + \(c : a -> a -> a) (n : a) -> c y n) + (\(ds : a) (ds : List a) -> Cons {a} ds ds) + (Nil {a})) + ys) + (/\dead -> + Tuple2_match + {List a} + {List a} + (go {a} (subtractInteger ds 1) ys) + {Tuple2 (List a) (List a)} + (\(zs : List a) (ws : List a) -> + Tuple2 {List a} {List a} (Cons {a} y zs) ws)) + {all dead. dead}) + {all dead. dead} +in +letrec + !go : List string -> integer + = \(ds : List string) -> + List_match + {string} + ds + {all dead. integer} + (/\dead -> 0) + (\(x : string) (xs : List string) -> /\dead -> addInteger 1 (go xs)) + {all dead. dead} +in +letrec + !concatBuiltinStrings : List string -> string + = \(ds : List string) -> + List_match + {string} + ds + {string} + "" + (\(x : string) (ds : List string) -> + List_match + {string} + ds + {all dead. string} + (/\dead -> x) + (\(ipv : string) (ipv : List string) -> + /\dead -> + Tuple2_match + {List string} + {List string} + (let + !n : integer = divideInteger (go ds) 2 + in + ifThenElse + {all dead. Tuple2 (List string) (List string)} + (lessThanEqualsInteger n 0) + (/\dead -> + Tuple2 {List string} {List string} (Nil {string}) ds) + (/\dead -> go {string} n ds) + {all dead. dead}) + {string} + (\(ipv : List string) (ipv : List string) -> + appendString + (concatBuiltinStrings ipv) + (concatBuiltinStrings ipv))) + {all dead. dead}) +in +let + data Unit | Unit_match where + Unit : Unit + data (Maybe :: * -> *) a | Maybe_match where + Just : a -> Maybe a + Nothing : Maybe a + !lookup : + all k a. + (\a -> a -> data) k -> + (\a -> data -> a) a -> + k -> + (\k a -> list (pair data data)) k a -> + Maybe a + = /\k a -> + \(`$dToData` : (\a -> a -> data) k) + (`$dUnsafeFromData` : (\a -> data -> a) a) + (ds : k) + (ds : (\k a -> list (pair data data)) k a) -> + Maybe_match + {data} + (let + !k : data = `$dToData` ds + in + letrec + !go : list (pair data data) -> Maybe data + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> Maybe data} + xs + (\(ds : Unit) -> Nothing {data}) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + in + ifThenElse + {all dead. Maybe data} + (equalsData k (fstPair {data} {data} hd)) + (/\dead -> + let + !ds : list (pair data data) + = tailList {pair data data} xs + in + Just {data} (sndPair {data} {data} hd)) + (/\dead -> go (tailList {pair data data} xs)) + {all dead. dead}) + Unit + in + go ds) + {all dead. Maybe a} + (\(a : data) -> /\dead -> Just {a} (`$dUnsafeFromData` a)) + (/\dead -> Nothing {a}) + {all dead. dead} + data Bool | Bool_match where + True : Bool + False : Bool +in +\(n : integer) -> + let + !nt : list (pair data data) + = (let + b = (\k a -> list (pair data data)) integer bytestring + in + \(k : integer -> b -> b) (z : b) -> + letrec + !go : List integer -> b + = \(ds : List integer) -> + List_match + {integer} + ds + {all dead. b} + (/\dead -> z) + (\(y : integer) (ys : List integer) -> + /\dead -> k y (go ys)) + {all dead. dead} + in + \(eta : List integer) -> go eta) + (\(i : integer) -> + let + !ds : integer = addInteger n i + !ds : bytestring + = encodeUtf8 + (concatBuiltinStrings + (`$fShowBuiltinByteString_$cshowsPrec` + 0 + i + (Nil {string}))) + in + \(ds : (\k a -> list (pair data data)) integer bytestring) -> + let + !k : data = iData ds + !a : data = bData ds + in + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> + mkCons {pair data data} (mkPairData k a) []) + (\(ds : Unit) -> + let + !hd : pair data data + = headList {pair data data} xs + !tl : list (pair data data) + = tailList {pair data data} xs + in + ifThenElse + {all dead. list (pair data data)} + (equalsData k (fstPair {data} {data} hd)) + (/\dead -> + mkCons {pair data data} (mkPairData k a) tl) + (/\dead -> mkCons {pair data data} hd (go tl)) + {all dead. dead}) + Unit + in + go ds) + (mkCons {pair data data} (mkPairData (iData n) (B #30)) []) + (`$fEnumBool_$cenumFromTo` 1 10) + !nt : list (pair data data) + = let + !k : data = iData (addInteger 5 n) + in + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> []) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + !tl : list (pair data data) = tailList {pair data data} xs + in + ifThenElse + {all dead. list (pair data data)} + (equalsData k (fstPair {data} {data} hd)) + (/\dead -> tl) + (/\dead -> mkCons {pair data data} hd (go tl)) + {all dead. dead}) + Unit + in + go nt + in + Tuple5 + {Maybe bytestring} + {Maybe bytestring} + {Maybe bytestring} + {Maybe bytestring} + {Maybe bytestring} + (lookup {integer} {bytestring} (\(i : integer) -> iData i) unBData n nt) + (lookup + {integer} + {bytestring} + (\(i : integer) -> iData i) + unBData + (addInteger 5 n) + nt) + (lookup + {integer} + {bytestring} + (\(i : integer) -> iData i) + unBData + (addInteger 10 n) + nt) + (lookup + {integer} + {bytestring} + (\(i : integer) -> iData i) + unBData + (addInteger 20 n) + nt) + (lookup + {integer} + {bytestring} + (\(i : integer) -> iData i) + unBData + (addInteger 5 n) + nt) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden new file mode 100644 index 00000000000..9553f47f06b --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map1.uplc.golden @@ -0,0 +1,412 @@ +program + 1.1.0 + ((\fix1 -> + (\`$fEnumBool_$cenumFromTo` -> + (\go -> + (\go -> + (\`$fShowBuiltinByteString_$cshowsPrec` -> + (\go -> + (\go -> + (\concatBuiltinStrings + n -> + (\nt -> + (\cse -> + (\nt -> + (\lookup -> + constr 0 + [ (lookup (\i -> iData i) unBData n nt) + , (lookup + (\i -> iData i) + unBData + cse + nt) + , (lookup + (\i -> iData i) + unBData + (addInteger 10 n) + nt) + , (lookup + (\i -> iData i) + unBData + (addInteger 20 n) + nt) + , (lookup + (\i -> iData i) + unBData + cse + nt) ]) + (\`$dToData` + `$dUnsafeFromData` + ds + ds -> + force + (case + ((\k -> + fix1 + (\go + xs -> + force + (force chooseList) + xs + (\ds -> constr 1 []) + (\ds -> + (\hd -> + force + (force + ifThenElse + (equalsData + k + (force + (force + fstPair) + hd)) + (delay + ((\ds -> + constr 0 + [ (force + (force + sndPair) + hd) ]) + (force + tailList + xs))) + (delay + (go + (force + tailList + xs))))) + (force headList + xs)) + (constr 0 [])) + ds) + (`$dToData` ds)) + [ (\a -> + delay + (constr 0 + [ (`$dUnsafeFromData` + a) ])) + , (delay (constr 1 [])) ]))) + ((\k -> + fix1 + (\go xs -> + force (force chooseList) + xs + (\ds -> []) + (\ds -> + (\hd -> + (\tl -> + force + (force ifThenElse + (equalsData + k + (force + (force + fstPair) + hd)) + (delay tl) + (delay + (force mkCons + hd + (go tl))))) + (force tailList xs)) + (force headList xs)) + (constr 0 [])) + nt) + (iData cse))) + (addInteger 5 n)) + ((\z -> + (\go eta -> + go eta) + (fix1 + (\go + ds -> + force + (case + ds + [ (delay z) + , (\y + ys -> + delay + ((\ds -> + (\ds + ds -> + (\k -> + (\a -> + fix1 + (\go + xs -> + force + (force + chooseList) + xs + (\ds -> + force + mkCons + (mkPairData + k + a) + [ ]) + (\ds -> + (\hd -> + (\tl -> + force + (force + ifThenElse + (equalsData + k + (force + (force + fstPair) + hd)) + (delay + (force + mkCons + (mkPairData + k + a) + tl)) + (delay + (force + mkCons + hd + (go + tl))))) + (force + tailList + xs)) + (force + headList + xs)) + (constr 0 + [])) + ds) + (bData ds)) + (iData ds)) + (encodeUtf8 + (concatBuiltinStrings + (`$fShowBuiltinByteString_$cshowsPrec` + 0 + y + (constr 0 + []))))) + (addInteger n y) + (go ys))) ])))) + (force mkCons (mkPairData (iData n) (B #30)) []) + (`$fEnumBool_$cenumFromTo` 1 10))) + (fix1 + (\concatBuiltinStrings + ds -> + case + ds + [ "" + , (\x + ds -> + force + (case + ds + [ (delay x) + , (\ipv + ipv -> + delay + (case + ((\n -> + force + (force + ifThenElse + (lessThanEqualsInteger + n + 0) + (delay + (constr 0 + [ (constr 0 + []) + , ds ])) + (delay + (force go + n + ds)))) + (divideInteger + (go ds) + 2)) + [ (\ipv + ipv -> + appendString + (concatBuiltinStrings + ipv) + (concatBuiltinStrings + ipv)) ])) ])) ]))) + (fix1 + (\go ds -> + force + (case + ds + [ (delay 0) + , (\x xs -> + delay (addInteger 1 (go xs))) ])))) + (fix1 + (\go + arg -> + delay + (\ds + ds -> + force + (case + ds + [ (delay + (constr 0 + [(constr 0 []), (constr 0 [])])) + , (\y + ys -> + delay + (force + (force + ifThenElse + (equalsInteger 1 ds) + (delay + (constr 0 + [ (constr 1 + [y, (constr 0 [])]) + , ys ])) + (delay + (case + (force + (go (delay (\x -> x))) + (subtractInteger ds 1) + ys) + [ (\zs + ws -> + constr 0 + [ (constr 1 + [y, zs]) + , ws ]) ]))))) ]))) + (delay (\x -> x)))) + (fix1 + (\`$fShowBuiltinByteString_$cshowsPrec` p n -> + force + (force ifThenElse + (lessThanInteger n 0) + (delay + (\eta -> + constr 1 + [ "-" + , (`$fShowBuiltinByteString_$cshowsPrec` + p + (subtractInteger 0 n) + eta) ])) + (delay (go (go (constr 0 []) n))))))) + (fix1 + (\go + ds -> + force + (case + ds + [ (delay (\x -> x)) + , (\x + xs -> + delay + ((\acc + eta -> + constr 1 + [ (force + (force + ifThenElse + (equalsInteger 0 x) + (delay "0") + (delay + (force + (force + ifThenElse + (equalsInteger 1 x) + (delay "1") + (delay + (force + (force + ifThenElse + (equalsInteger + 2 + x) + (delay "2") + (delay + (force + (force + ifThenElse + (equalsInteger + 3 + x) + (delay + "3") + (delay + (force + (force + ifThenElse + (equalsInteger + 4 + x) + (delay + "4") + (delay + (force + (force + ifThenElse + (equalsInteger + 5 + x) + (delay + "5") + (delay + (force + (force + ifThenElse + (equalsInteger + 6 + x) + (delay + "6") + (delay + (force + (force + ifThenElse + (equalsInteger + 7 + x) + (delay + "7") + (delay + (force + (force + ifThenElse + (equalsInteger + 8 + x) + (delay + "8") + (delay + (force + ifThenElse + (equalsInteger + 9 + x) + "9" + "")))))))))))))))))))))))))))) + , (acc eta) ]) + (go xs))) ])))) + (fix1 + (\go acc n -> + (\x -> + force + (force ifThenElse + (equalsInteger 0 x) + (delay (constr 1 [(remainderInteger n 10), acc])) + (delay + (go (constr 1 [(remainderInteger n 10), acc]) x)))) + (quotientInteger n 10)))) + (fix1 + (\`$fEnumBool_$cenumFromTo` x lim -> + force + (force ifThenElse + (lessThanEqualsInteger x lim) + (delay + (constr 1 + [x, (`$fEnumBool_$cenumFromTo` (addInteger 1 x) lim)])) + (delay (constr 0 [])))))) + (\f -> (\s -> s s) (\s -> f (\x -> s s x)))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden b/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden new file mode 100644 index 00000000000..2c63bc124a1 --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map2-budget.budget.golden @@ -0,0 +1,2 @@ +({cpu: 155458417 +| mem: 394122}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map2.eval.golden b/plutus-tx-plugin/test/Budget/9.6/map2.eval.golden new file mode 100644 index 00000000000..e8e3b12565c --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map2.eval.golden @@ -0,0 +1,27 @@ +(constr + 1 + (constr 0 (con integer 105) (con string "five")) + (constr + 1 + (constr 0 (con integer 104) (con string "fourFOUR")) + (constr + 1 + (constr 0 (con integer 103) (con string "threeTHREE")) + (constr + 1 + (constr 0 (con integer 102) (con string "two")) + (constr + 1 + (constr 0 (con integer 101) (con string "one")) + (constr + 1 + (constr 0 (con integer 106) (con string "SIX")) + (constr + 1 (constr 0 (con integer 107) (con string "SEVEN")) (constr 0) + ) + ) + ) + ) + ) + ) +) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden new file mode 100644 index 00000000000..c735c68c517 --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map2.pir.golden @@ -0,0 +1,338 @@ +let + data Unit | Unit_match where + Unit : Unit + data (Tuple2 :: * -> * -> *) a b | Tuple2_match where + Tuple2 : a -> b -> Tuple2 a b +in +letrec + data (List :: * -> *) a | List_match where + Nil : List a + Cons : a -> List a -> List a +in +letrec + !go : list (pair data data) -> List (Tuple2 integer bytestring) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> List (Tuple2 integer bytestring)} + xs + (\(ds : Unit) -> Nil {Tuple2 integer bytestring}) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + !tl : list (pair data data) = tailList {pair data data} xs + in + Cons + {Tuple2 integer bytestring} + (Tuple2 + {integer} + {bytestring} + (unIData (fstPair {data} {data} hd)) + (unBData (sndPair {data} {data} hd))) + (go tl)) + Unit +in +letrec + !go : list (pair data data) -> list (pair data data) -> list (pair data data) + = \(acc : list (pair data data)) (xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> acc) + (\(ds : Unit) -> + go + (mkCons {pair data data} (headList {pair data data} xs) acc) + (tailList {pair data data} xs)) + Unit +in +let + data (Maybe :: * -> *) a | Maybe_match where + Just : a -> Maybe a + Nothing : Maybe a + data Bool | Bool_match where + True : Bool + False : Bool +in +letrec + !goList : List (Tuple2 data data) -> list (pair data data) + = \(ds : List (Tuple2 data data)) -> + List_match + {Tuple2 data data} + ds + {all dead. list (pair data data)} + (/\dead -> []) + (\(d : Tuple2 data data) (ds : List (Tuple2 data data)) -> + /\dead -> + mkCons + {pair data data} + (Tuple2_match + {data} + {data} + d + {pair data data} + (\(d : data) (d : data) -> mkPairData d d)) + (goList ds)) + {all dead. dead} +in +let + !unsafeFromList : + all k a. + (\a -> a -> data) k -> + (\a -> a -> data) a -> + List (Tuple2 k a) -> + (\k a -> list (pair data data)) k a + = /\k a -> + \(`$dToData` : (\a -> a -> data) k) + (`$dToData` : (\a -> a -> data) a) -> + letrec + !go : List (Tuple2 k a) -> List (Tuple2 data data) + = \(ds : List (Tuple2 k a)) -> + List_match + {Tuple2 k a} + ds + {all dead. List (Tuple2 data data)} + (/\dead -> Nil {Tuple2 data data}) + (\(x : Tuple2 k a) (xs : List (Tuple2 k a)) -> + /\dead -> + Cons + {Tuple2 data data} + (Tuple2_match + {k} + {a} + x + {Tuple2 data data} + (\(k : k) (a : a) -> + Tuple2 + {data} + {data} + (`$dToData` k) + (`$dToData` a))) + (go xs)) + {all dead. dead} + in + \(eta : List (Tuple2 k a)) -> + let + !eta : List (Tuple2 data data) = go eta + in + goList eta +in +\(n : integer) -> + let + !nt : list (pair data data) + = unsafeFromList + {integer} + {bytestring} + (\(i : integer) -> iData i) + bData + ((let + a = Tuple2 integer bytestring + in + \(g : all b. (a -> b -> b) -> b -> b) -> + g {List a} (\(ds : a) (ds : List a) -> Cons {a} ds ds) (Nil {a})) + (/\a -> + \(c : Tuple2 integer bytestring -> a -> a) (n : a) -> + c + (Tuple2 {integer} {bytestring} (addInteger 3 n) #5448524545) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 4 n) + #464f5552) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 6 n) + #534958) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 7 n) + #534556454e) + n))))) + in + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> []) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + !tl : list (pair data data) = tailList {pair data data} xs + !v' : data = sndPair {data} {data} hd + !k' : data = fstPair {data} {data} hd + in + letrec + !go : list (pair data data) -> Maybe data + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> Maybe data} + xs + (\(ds : Unit) -> Nothing {data}) + (\(ds : Unit) -> + let + !hd : pair data data + = headList {pair data data} xs + in + ifThenElse + {all dead. Maybe data} + (equalsData k' (fstPair {data} {data} hd)) + (/\dead -> + let + !ds : list (pair data data) + = tailList {pair data data} xs + in + Just {data} (sndPair {data} {data} hd)) + (/\dead -> go (tailList {pair data data} xs)) + {all dead. dead}) + Unit + in + Maybe_match + {data} + (go nt) + {all dead. list (pair data data)} + (\(r : data) -> + /\dead -> + mkCons + {pair data data} + (mkPairData + k' + (bData (appendByteString (unBData v') (unBData r)))) + (go tl)) + (/\dead -> mkCons {pair data data} (mkPairData k' v') (go tl)) + {all dead. dead}) + Unit + in + let + !nt : list (pair data data) + = unsafeFromList + {integer} + {bytestring} + (\(i : integer) -> iData i) + bData + ((let + a = Tuple2 integer bytestring + in + \(g : all b. (a -> b -> b) -> b -> b) -> + g {List a} (\(ds : a) (ds : List a) -> Cons {a} ds ds) (Nil {a})) + (/\a -> + \(c : Tuple2 integer bytestring -> a -> a) (n : a) -> + c + (Tuple2 {integer} {bytestring} (addInteger 1 n) #6f6e65) + (c + (Tuple2 {integer} {bytestring} (addInteger 2 n) #74776f) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 3 n) + #7468726565) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 4 n) + #666f7572) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 5 n) + #66697665) + n)))))) + in + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> []) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + !tl' : list (pair data data) + = go (tailList {pair data data} xs) + in + Bool_match + (let + !k : data = fstPair {data} {data} hd + in + letrec + !go : list (pair data data) -> Bool + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> Bool} + xs + (\(ds : Unit) -> False) + (\(ds : Unit) -> + ifThenElse + {all dead. Bool} + (equalsData + k + (fstPair + {data} + {data} + (headList {pair data data} xs))) + (/\dead -> + let + !ds : list (pair data data) + = tailList {pair data data} xs + in + True) + (/\dead -> go (tailList {pair data data} xs)) + {all dead. dead}) + Unit + in + go nt) + {all dead. list (pair data data)} + (/\dead -> tl') + (/\dead -> mkCons {pair data data} hd tl') + {all dead. dead}) + Unit + in + let + !nt : list (pair data data) + = let + !rs' : list (pair data data) = go nt + !ls' : list (pair data data) = go nt + in + go rs' ls' + in + (let + a = Tuple2 integer bytestring + in + /\b -> + \(f : a -> b) -> + letrec + !go : List a -> List b + = \(ds : List a) -> + List_match + {a} + ds + {all dead. List b} + (/\dead -> Nil {b}) + (\(x : a) (xs : List a) -> /\dead -> Cons {b} (f x) (go xs)) + {all dead. dead} + in + \(eta : List a) -> go eta) + {Tuple2 integer string} + (\(ds : Tuple2 integer bytestring) -> + Tuple2_match + {integer} + {bytestring} + ds + {Tuple2 integer string} + (\(k : integer) (v : bytestring) -> + Tuple2 {integer} {string} k (decodeUtf8 v))) + (go nt) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden new file mode 100644 index 00000000000..f1bf99b0f21 --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden @@ -0,0 +1,272 @@ +program + 1.1.0 + ((\fix1 -> + (\go -> + (\go -> + (\goList + n -> + (\unsafeFromList -> + (\cse -> + (\cse -> + (\nt -> + (\go -> + (\nt -> + (\nt -> + fix1 + (\go + ds -> + force + (case + ds + [ (delay (constr 0 [])) + , (\x + xs -> + delay + (constr 1 + [ (case + x + [ (\k + v -> + constr 0 + [ k + , (decodeUtf8 + v) ]) ]) + , (go xs) ])) ])) + (go nt)) + ((\rs' -> + (\ls' -> go rs' ls') (go nt)) + (fix1 + (\go + xs -> + force + (force chooseList) + xs + (\ds -> []) + (\ds -> + (\hd -> + (\tl' -> + force + (case + ((\k -> + fix1 + (\go + xs -> + force + (force + chooseList) + xs + (\ds -> + constr 1 + []) + (\ds -> + force + (force + ifThenElse + (equalsData + k + (force + (force + fstPair) + (force + headList + xs))) + (delay + ((\ds -> + constr 0 + [ ]) + (force + tailList + xs))) + (delay + (go + (force + tailList + xs))))) + (constr 0 + [])) + nt) + (force + (force + fstPair) + hd)) + [ (delay tl') + , (delay + (force mkCons + hd + tl')) ])) + (go (force tailList xs))) + (force headList xs)) + (constr 0 [])) + nt))) + (unsafeFromList + (\i -> iData i) + bData + (constr 1 + [ (constr 0 [(addInteger 1 n), #6f6e65]) + , (constr 1 + [ (constr 0 + [(addInteger 2 n), #74776f]) + , (constr 1 + [ (constr 0 [cse, #7468726565]) + , (constr 1 + [ (constr 0 + [cse, #666f7572]) + , (constr 1 + [ (constr 0 + [ (addInteger + 5 + n) + , #66697665 ]) + , (constr 0 + [ ]) ]) ]) ]) ]) ]))) + (fix1 + (\go + xs -> + force + (force chooseList) + xs + (\ds -> []) + (\ds -> + (\hd -> + (\tl -> + (\v' -> + (\k' -> + force + (case + (fix1 + (\go + xs -> + force + (force + chooseList) + xs + (\ds -> + constr 1 []) + (\ds -> + (\hd -> + force + (force + ifThenElse + (equalsData + k' + (force + (force + fstPair) + hd)) + (delay + ((\ds -> + constr 0 + [ (force + (force + sndPair) + hd) ]) + (force + tailList + xs))) + (delay + (go + (force + tailList + xs))))) + (force + headList + xs)) + (constr 0 [])) + nt) + [ (\r -> + delay + (force + mkCons + (mkPairData + k' + (bData + (appendByteString + (unBData + v') + (unBData + r)))) + (go tl))) + , (delay + (force mkCons + (mkPairData + k' + v') + (go tl))) ])) + (force (force fstPair) hd)) + (force (force sndPair) hd)) + (force tailList xs)) + (force headList xs)) + (constr 0 [])))) + (unsafeFromList + (\i -> iData i) + bData + (constr 1 + [ (constr 0 [cse, #5448524545]) + , (constr 1 + [ (constr 0 [cse, #464f5552]) + , (constr 1 + [ (constr 0 + [(addInteger 6 n), #534958]) + , (constr 1 + [ (constr 0 + [ (addInteger 7 n) + , #534556454e ]) + , (constr 0 []) ]) ]) ]) ]))) + (addInteger 4 n)) + (addInteger 3 n)) + (\`$dToData` `$dToData` -> + (\go eta -> goList (go eta)) + (fix1 + (\go ds -> + force + (case + ds + [ (delay (constr 0 [])) + , (\x xs -> + delay + (constr 1 + [ (case + x + [ (\k a -> + constr 0 + [ (`$dToData` k) + , (`$dToData` a) ]) ]) + , (go xs) ])) ]))))) + (fix1 + (\goList ds -> + force + (case + ds + [ (delay []) + , (\d ds -> + delay + (force mkCons + (case d [(\d d -> mkPairData d d)]) + (goList ds))) ])))) + (fix1 + (\go acc xs -> + force (force chooseList) + xs + (\ds -> acc) + (\ds -> + go + (force mkCons (force headList xs) acc) + (force tailList xs)) + (constr 0 [])))) + (fix1 + (\go xs -> + force (force chooseList) + xs + (\ds -> constr 0 []) + (\ds -> + (\hd -> + (\tl -> + constr 1 + [ (constr 0 + [ (unIData (force (force fstPair) hd)) + , (unBData (force (force sndPair) hd)) ]) + , (go tl) ]) + (force tailList xs)) + (force headList xs)) + (constr 0 [])))) + (\f -> (\s -> s s) (\s -> f (\x -> s s x)))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map3-budget.budget.golden b/plutus-tx-plugin/test/Budget/9.6/map3-budget.budget.golden new file mode 100644 index 00000000000..2c63bc124a1 --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map3-budget.budget.golden @@ -0,0 +1,2 @@ +({cpu: 155458417 +| mem: 394122}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map3.eval.golden b/plutus-tx-plugin/test/Budget/9.6/map3.eval.golden new file mode 100644 index 00000000000..e8e3b12565c --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map3.eval.golden @@ -0,0 +1,27 @@ +(constr + 1 + (constr 0 (con integer 105) (con string "five")) + (constr + 1 + (constr 0 (con integer 104) (con string "fourFOUR")) + (constr + 1 + (constr 0 (con integer 103) (con string "threeTHREE")) + (constr + 1 + (constr 0 (con integer 102) (con string "two")) + (constr + 1 + (constr 0 (con integer 101) (con string "one")) + (constr + 1 + (constr 0 (con integer 106) (con string "SIX")) + (constr + 1 (constr 0 (con integer 107) (con string "SEVEN")) (constr 0) + ) + ) + ) + ) + ) + ) +) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map3.pir.golden b/plutus-tx-plugin/test/Budget/9.6/map3.pir.golden new file mode 100644 index 00000000000..c735c68c517 --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map3.pir.golden @@ -0,0 +1,338 @@ +let + data Unit | Unit_match where + Unit : Unit + data (Tuple2 :: * -> * -> *) a b | Tuple2_match where + Tuple2 : a -> b -> Tuple2 a b +in +letrec + data (List :: * -> *) a | List_match where + Nil : List a + Cons : a -> List a -> List a +in +letrec + !go : list (pair data data) -> List (Tuple2 integer bytestring) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> List (Tuple2 integer bytestring)} + xs + (\(ds : Unit) -> Nil {Tuple2 integer bytestring}) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + !tl : list (pair data data) = tailList {pair data data} xs + in + Cons + {Tuple2 integer bytestring} + (Tuple2 + {integer} + {bytestring} + (unIData (fstPair {data} {data} hd)) + (unBData (sndPair {data} {data} hd))) + (go tl)) + Unit +in +letrec + !go : list (pair data data) -> list (pair data data) -> list (pair data data) + = \(acc : list (pair data data)) (xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> acc) + (\(ds : Unit) -> + go + (mkCons {pair data data} (headList {pair data data} xs) acc) + (tailList {pair data data} xs)) + Unit +in +let + data (Maybe :: * -> *) a | Maybe_match where + Just : a -> Maybe a + Nothing : Maybe a + data Bool | Bool_match where + True : Bool + False : Bool +in +letrec + !goList : List (Tuple2 data data) -> list (pair data data) + = \(ds : List (Tuple2 data data)) -> + List_match + {Tuple2 data data} + ds + {all dead. list (pair data data)} + (/\dead -> []) + (\(d : Tuple2 data data) (ds : List (Tuple2 data data)) -> + /\dead -> + mkCons + {pair data data} + (Tuple2_match + {data} + {data} + d + {pair data data} + (\(d : data) (d : data) -> mkPairData d d)) + (goList ds)) + {all dead. dead} +in +let + !unsafeFromList : + all k a. + (\a -> a -> data) k -> + (\a -> a -> data) a -> + List (Tuple2 k a) -> + (\k a -> list (pair data data)) k a + = /\k a -> + \(`$dToData` : (\a -> a -> data) k) + (`$dToData` : (\a -> a -> data) a) -> + letrec + !go : List (Tuple2 k a) -> List (Tuple2 data data) + = \(ds : List (Tuple2 k a)) -> + List_match + {Tuple2 k a} + ds + {all dead. List (Tuple2 data data)} + (/\dead -> Nil {Tuple2 data data}) + (\(x : Tuple2 k a) (xs : List (Tuple2 k a)) -> + /\dead -> + Cons + {Tuple2 data data} + (Tuple2_match + {k} + {a} + x + {Tuple2 data data} + (\(k : k) (a : a) -> + Tuple2 + {data} + {data} + (`$dToData` k) + (`$dToData` a))) + (go xs)) + {all dead. dead} + in + \(eta : List (Tuple2 k a)) -> + let + !eta : List (Tuple2 data data) = go eta + in + goList eta +in +\(n : integer) -> + let + !nt : list (pair data data) + = unsafeFromList + {integer} + {bytestring} + (\(i : integer) -> iData i) + bData + ((let + a = Tuple2 integer bytestring + in + \(g : all b. (a -> b -> b) -> b -> b) -> + g {List a} (\(ds : a) (ds : List a) -> Cons {a} ds ds) (Nil {a})) + (/\a -> + \(c : Tuple2 integer bytestring -> a -> a) (n : a) -> + c + (Tuple2 {integer} {bytestring} (addInteger 3 n) #5448524545) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 4 n) + #464f5552) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 6 n) + #534958) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 7 n) + #534556454e) + n))))) + in + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> []) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + !tl : list (pair data data) = tailList {pair data data} xs + !v' : data = sndPair {data} {data} hd + !k' : data = fstPair {data} {data} hd + in + letrec + !go : list (pair data data) -> Maybe data + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> Maybe data} + xs + (\(ds : Unit) -> Nothing {data}) + (\(ds : Unit) -> + let + !hd : pair data data + = headList {pair data data} xs + in + ifThenElse + {all dead. Maybe data} + (equalsData k' (fstPair {data} {data} hd)) + (/\dead -> + let + !ds : list (pair data data) + = tailList {pair data data} xs + in + Just {data} (sndPair {data} {data} hd)) + (/\dead -> go (tailList {pair data data} xs)) + {all dead. dead}) + Unit + in + Maybe_match + {data} + (go nt) + {all dead. list (pair data data)} + (\(r : data) -> + /\dead -> + mkCons + {pair data data} + (mkPairData + k' + (bData (appendByteString (unBData v') (unBData r)))) + (go tl)) + (/\dead -> mkCons {pair data data} (mkPairData k' v') (go tl)) + {all dead. dead}) + Unit + in + let + !nt : list (pair data data) + = unsafeFromList + {integer} + {bytestring} + (\(i : integer) -> iData i) + bData + ((let + a = Tuple2 integer bytestring + in + \(g : all b. (a -> b -> b) -> b -> b) -> + g {List a} (\(ds : a) (ds : List a) -> Cons {a} ds ds) (Nil {a})) + (/\a -> + \(c : Tuple2 integer bytestring -> a -> a) (n : a) -> + c + (Tuple2 {integer} {bytestring} (addInteger 1 n) #6f6e65) + (c + (Tuple2 {integer} {bytestring} (addInteger 2 n) #74776f) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 3 n) + #7468726565) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 4 n) + #666f7572) + (c + (Tuple2 + {integer} + {bytestring} + (addInteger 5 n) + #66697665) + n)))))) + in + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> []) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + !tl' : list (pair data data) + = go (tailList {pair data data} xs) + in + Bool_match + (let + !k : data = fstPair {data} {data} hd + in + letrec + !go : list (pair data data) -> Bool + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> Bool} + xs + (\(ds : Unit) -> False) + (\(ds : Unit) -> + ifThenElse + {all dead. Bool} + (equalsData + k + (fstPair + {data} + {data} + (headList {pair data data} xs))) + (/\dead -> + let + !ds : list (pair data data) + = tailList {pair data data} xs + in + True) + (/\dead -> go (tailList {pair data data} xs)) + {all dead. dead}) + Unit + in + go nt) + {all dead. list (pair data data)} + (/\dead -> tl') + (/\dead -> mkCons {pair data data} hd tl') + {all dead. dead}) + Unit + in + let + !nt : list (pair data data) + = let + !rs' : list (pair data data) = go nt + !ls' : list (pair data data) = go nt + in + go rs' ls' + in + (let + a = Tuple2 integer bytestring + in + /\b -> + \(f : a -> b) -> + letrec + !go : List a -> List b + = \(ds : List a) -> + List_match + {a} + ds + {all dead. List b} + (/\dead -> Nil {b}) + (\(x : a) (xs : List a) -> /\dead -> Cons {b} (f x) (go xs)) + {all dead. dead} + in + \(eta : List a) -> go eta) + {Tuple2 integer string} + (\(ds : Tuple2 integer bytestring) -> + Tuple2_match + {integer} + {bytestring} + ds + {Tuple2 integer string} + (\(k : integer) (v : bytestring) -> + Tuple2 {integer} {string} k (decodeUtf8 v))) + (go nt) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/9.6/map3.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map3.uplc.golden new file mode 100644 index 00000000000..f1bf99b0f21 --- /dev/null +++ b/plutus-tx-plugin/test/Budget/9.6/map3.uplc.golden @@ -0,0 +1,272 @@ +program + 1.1.0 + ((\fix1 -> + (\go -> + (\go -> + (\goList + n -> + (\unsafeFromList -> + (\cse -> + (\cse -> + (\nt -> + (\go -> + (\nt -> + (\nt -> + fix1 + (\go + ds -> + force + (case + ds + [ (delay (constr 0 [])) + , (\x + xs -> + delay + (constr 1 + [ (case + x + [ (\k + v -> + constr 0 + [ k + , (decodeUtf8 + v) ]) ]) + , (go xs) ])) ])) + (go nt)) + ((\rs' -> + (\ls' -> go rs' ls') (go nt)) + (fix1 + (\go + xs -> + force + (force chooseList) + xs + (\ds -> []) + (\ds -> + (\hd -> + (\tl' -> + force + (case + ((\k -> + fix1 + (\go + xs -> + force + (force + chooseList) + xs + (\ds -> + constr 1 + []) + (\ds -> + force + (force + ifThenElse + (equalsData + k + (force + (force + fstPair) + (force + headList + xs))) + (delay + ((\ds -> + constr 0 + [ ]) + (force + tailList + xs))) + (delay + (go + (force + tailList + xs))))) + (constr 0 + [])) + nt) + (force + (force + fstPair) + hd)) + [ (delay tl') + , (delay + (force mkCons + hd + tl')) ])) + (go (force tailList xs))) + (force headList xs)) + (constr 0 [])) + nt))) + (unsafeFromList + (\i -> iData i) + bData + (constr 1 + [ (constr 0 [(addInteger 1 n), #6f6e65]) + , (constr 1 + [ (constr 0 + [(addInteger 2 n), #74776f]) + , (constr 1 + [ (constr 0 [cse, #7468726565]) + , (constr 1 + [ (constr 0 + [cse, #666f7572]) + , (constr 1 + [ (constr 0 + [ (addInteger + 5 + n) + , #66697665 ]) + , (constr 0 + [ ]) ]) ]) ]) ]) ]))) + (fix1 + (\go + xs -> + force + (force chooseList) + xs + (\ds -> []) + (\ds -> + (\hd -> + (\tl -> + (\v' -> + (\k' -> + force + (case + (fix1 + (\go + xs -> + force + (force + chooseList) + xs + (\ds -> + constr 1 []) + (\ds -> + (\hd -> + force + (force + ifThenElse + (equalsData + k' + (force + (force + fstPair) + hd)) + (delay + ((\ds -> + constr 0 + [ (force + (force + sndPair) + hd) ]) + (force + tailList + xs))) + (delay + (go + (force + tailList + xs))))) + (force + headList + xs)) + (constr 0 [])) + nt) + [ (\r -> + delay + (force + mkCons + (mkPairData + k' + (bData + (appendByteString + (unBData + v') + (unBData + r)))) + (go tl))) + , (delay + (force mkCons + (mkPairData + k' + v') + (go tl))) ])) + (force (force fstPair) hd)) + (force (force sndPair) hd)) + (force tailList xs)) + (force headList xs)) + (constr 0 [])))) + (unsafeFromList + (\i -> iData i) + bData + (constr 1 + [ (constr 0 [cse, #5448524545]) + , (constr 1 + [ (constr 0 [cse, #464f5552]) + , (constr 1 + [ (constr 0 + [(addInteger 6 n), #534958]) + , (constr 1 + [ (constr 0 + [ (addInteger 7 n) + , #534556454e ]) + , (constr 0 []) ]) ]) ]) ]))) + (addInteger 4 n)) + (addInteger 3 n)) + (\`$dToData` `$dToData` -> + (\go eta -> goList (go eta)) + (fix1 + (\go ds -> + force + (case + ds + [ (delay (constr 0 [])) + , (\x xs -> + delay + (constr 1 + [ (case + x + [ (\k a -> + constr 0 + [ (`$dToData` k) + , (`$dToData` a) ]) ]) + , (go xs) ])) ]))))) + (fix1 + (\goList ds -> + force + (case + ds + [ (delay []) + , (\d ds -> + delay + (force mkCons + (case d [(\d d -> mkPairData d d)]) + (goList ds))) ])))) + (fix1 + (\go acc xs -> + force (force chooseList) + xs + (\ds -> acc) + (\ds -> + go + (force mkCons (force headList xs) acc) + (force tailList xs)) + (constr 0 [])))) + (fix1 + (\go xs -> + force (force chooseList) + xs + (\ds -> constr 0 []) + (\ds -> + (\hd -> + (\tl -> + constr 1 + [ (constr 0 + [ (unIData (force (force fstPair) hd)) + , (unBData (force (force sndPair) hd)) ]) + , (go tl) ]) + (force tailList xs)) + (force headList xs)) + (constr 0 [])))) + (\f -> (\s -> s s) (\s -> f (\x -> s s x)))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/Spec.hs b/plutus-tx-plugin/test/Budget/Spec.hs index b9200ed45c8..891c9d27b91 100644 --- a/plutus-tx-plugin/test/Budget/Spec.hs +++ b/plutus-tx-plugin/test/Budget/Spec.hs @@ -19,7 +19,7 @@ import Test.Tasty.Extras import Budget.WithGHCOptimisations qualified as WithGHCOptTest import Budget.WithoutGHCOptimisations qualified as WithoutGHCOptTest import PlutusTx.AsData qualified as AsData -import PlutusTx.Builtins qualified as PlutusTx +import PlutusTx.Builtins qualified as PlutusTx hiding (null) import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.Code import PlutusTx.IsData qualified as IsData diff --git a/plutus-tx-plugin/test/Spec.hs b/plutus-tx-plugin/test/Spec.hs index 5847ced49e5..85228a20758 100644 --- a/plutus-tx-plugin/test/Spec.hs +++ b/plutus-tx-plugin/test/Spec.hs @@ -1,6 +1,7 @@ module Main (main) where import AsData.Budget.Spec qualified as AsData.Budget +import AssocMap.Spec qualified as AssocMap import Blueprint.Tests qualified import Budget.Spec qualified as Budget import IntegerLiterals.NoStrict.NegativeLiterals.Spec qualified @@ -20,7 +21,7 @@ import TH.Spec qualified as TH import Unicode.Spec qualified as Unicode main :: IO () -main = defaultMain $ runTestNestedIn ["test"] tests +main = defaultMain $ testGroup "" [runTestNestedIn ["test"] tests, AssocMap.propertyTests] tests :: TestNested tests = @@ -42,4 +43,5 @@ tests = , Strictness.tests , Blueprint.Tests.goldenTests , pure Unicode.tests + , AssocMap.goldenTests ] diff --git a/plutus-tx-plugin/test/Util/Common.hs b/plutus-tx-plugin/test/Util/Common.hs new file mode 100644 index 00000000000..977f78124ba --- /dev/null +++ b/plutus-tx-plugin/test/Util/Common.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} + +module Util.Common + ( Program + , Term + , toAnonDeBruijnTerm + , toNamedDeBruijnTerm + , compiledCodeToTerm + , haskellValueToTerm + , unsafeRunTermCek + , runTermCek + , cekResultMatchesHaskellValue + ) +where + +import PlutusTx qualified as Tx + +import PlutusCore qualified as PLC +import PlutusCore.Default +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC + +import UntypedPlutusCore qualified as UPLC +import UntypedPlutusCore.Evaluation.Machine.Cek as Cek + +import Data.Text (Text) + +type Term = UPLC.Term PLC.NamedDeBruijn DefaultUni DefaultFun () +type Program = UPLC.Program PLC.NamedDeBruijn DefaultUni DefaultFun () + +{- | Given a DeBruijn-named term, give every variable the name "v". If we later + call unDeBruijn, that will rename the variables to things like "v123", where + 123 is the relevant de Bruijn index.-} +toNamedDeBruijnTerm + :: UPLC.Term UPLC.DeBruijn DefaultUni DefaultFun () + -> UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () +toNamedDeBruijnTerm = UPLC.termMapNames UPLC.fakeNameDeBruijn + +{- | Remove the textual names from a NamedDeBruijn term -} +toAnonDeBruijnTerm + :: Term + -> UPLC.Term UPLC.DeBruijn DefaultUni DefaultFun () +toAnonDeBruijnTerm = UPLC.termMapNames UPLC.unNameDeBruijn + +{- | Just extract the body of a program wrapped in a 'CompiledCodeIn'. We use this a lot. -} +compiledCodeToTerm + :: Tx.CompiledCodeIn DefaultUni DefaultFun a -> Term +compiledCodeToTerm (Tx.getPlcNoAnn -> UPLC.Program _ _ body) = body + +{- | Lift a Haskell value to a PLC term. The constraints get a bit out of control + if we try to do this over an arbitrary universe.-} +haskellValueToTerm + :: Tx.Lift DefaultUni a => a -> Term +haskellValueToTerm = compiledCodeToTerm . Tx.liftCodeDef + +{- | Just run a term to obtain an `EvaluationResult` (used for tests etc.) -} +unsafeRunTermCek :: Term -> EvaluationResult Term +unsafeRunTermCek = + unsafeToEvaluationResult + . (\(res, _, _) -> res) + . runCekDeBruijn PLC.defaultCekParameters Cek.restrictingEnormous Cek.noEmitter + +-- | Just run a term. +runTermCek :: + Term -> + ( Either (CekEvaluationException UPLC.NamedDeBruijn DefaultUni DefaultFun) Term + , [Text] + ) +runTermCek = + (\(res, _, logs) -> (res, logs)) + . runCekDeBruijn PLC.defaultCekParameters Cek.restrictingEnormous Cek.logEmitter + +{- | Evaluate a PLC term and check that the result matches a given Haskell value + (perhaps obtained by running the Haskell code that the term was compiled + from). We evaluate the lifted Haskell value as well, because lifting may + produce reducible terms. The function is polymorphic in the comparison + operator so that we can use it with both HUnit Assertions and QuickCheck + Properties. -} +cekResultMatchesHaskellValue + :: Tx.Lift DefaultUni a + => Term + -> (EvaluationResult Term -> EvaluationResult Term -> b) + -> a + -> b +cekResultMatchesHaskellValue term matches value = + (unsafeRunTermCek term) `matches` (unsafeRunTermCek $ haskellValueToTerm value) diff --git a/plutus-tx/changelog.d/20240516_215552_ana.pantilie95_data_assoclist.md b/plutus-tx/changelog.d/20240516_215552_ana.pantilie95_data_assoclist.md new file mode 100644 index 00000000000..73cd8f8e8af --- /dev/null +++ b/plutus-tx/changelog.d/20240516_215552_ana.pantilie95_data_assoclist.md @@ -0,0 +1,7 @@ +### Added + +- Added `Data.AssocList.Map` module which provides a map implementation based on `Data`. + +### Changed + +- The PlutusTx `These` type had the Haskell implementations of `Show`, `Eq` and `Ord` instances instead of PlutusTx ones. This has been fixed. diff --git a/plutus-tx/plutus-tx.cabal b/plutus-tx/plutus-tx.cabal index fa3513d81f2..0926ed5806f 100644 --- a/plutus-tx/plutus-tx.cabal +++ b/plutus-tx/plutus-tx.cabal @@ -75,6 +75,7 @@ library PlutusTx.Builtins.Internal PlutusTx.Code PlutusTx.Coverage + PlutusTx.Data.AssocMap PlutusTx.Either PlutusTx.Enum PlutusTx.Eq diff --git a/plutus-tx/src/PlutusTx/AssocMap.hs b/plutus-tx/src/PlutusTx/AssocMap.hs index 12cfce5684c..d5c6c800150 100644 --- a/plutus-tx/src/PlutusTx/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/AssocMap.hs @@ -39,7 +39,7 @@ module PlutusTx.AssocMap ( import Prelude qualified as Haskell -import PlutusTx.Builtins qualified as P +import PlutusTx.Builtins qualified as P hiding (null) import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.IsData import PlutusTx.Lift (makeLift) diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index cfdd8cbe23e..5e9550d9bb6 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -68,6 +68,7 @@ module PlutusTx.Builtins ( -- * Pairs , pairToPair -- * Lists + , null , matchList , matchList' , headMaybe @@ -388,6 +389,10 @@ trace = BI.trace encodeUtf8 :: BuiltinString -> BuiltinByteString encodeUtf8 = BI.encodeUtf8 +{-# INLINABLE null #-} +null :: forall a. BI.BuiltinList a -> Bool +null l = fromOpaque (BI.null l) + {-# INLINABLE matchList #-} matchList :: forall a r . BI.BuiltinList a -> (() -> r) -> (a -> BI.BuiltinList a -> r) -> r matchList l nilCase consCase = BI.chooseList l nilCase (\_ -> consCase (BI.head l) (BI.tail l)) () diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs new file mode 100644 index 00000000000..48712bd3274 --- /dev/null +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -0,0 +1,412 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module PlutusTx.Data.AssocMap ( + Map, + lookup, + member, + insert, + delete, + singleton, + empty, + null, + toList, + toBuiltinList, + safeFromList, + unsafeFromList, + unsafeFromBuiltinList, + noDuplicateKeys, + all, + any, + union, + unionWith, + ) where + +import PlutusTx.Builtins qualified as P +import PlutusTx.Builtins.Internal qualified as BI +import PlutusTx.IsData qualified as P +import PlutusTx.Lift (makeLift) +import PlutusTx.Prelude hiding (all, any, null, toList, uncons) +import PlutusTx.These + + +import Prelude qualified as Haskell + +{- | A map associating keys and values backed by `P.BuiltinData`. + +This implementation has the following characteristics: + + * The `P.toBuiltinData` and `P.unsafeFromBuiltinData` operations are no-op. + * Other operations are slower than @PlutusTx.AssocMap.Map@, although equality + checks on keys can be faster due to `P.equalsData`. + * Many operations involve converting the keys and\/or values to\/from `P.BuiltinData`. + +Therefore this implementation is likely a better choice than "PlutusTx.AssocMap.Map" +if it is part of a data type defined using @asData@, and the key and value types +have efficient `P.toBuiltinData` and `P.unsafeFromBuiltinData` operations (e.g., they +are primitive types or types defined using @asData@). + +A `Map` is considered well-defined if it has no duplicate keys. Most operations +preserve the definedness of the resulting `Map` unless otherwise noted. +It is important to observe that, in comparison to standard map implementations, +this implementation provides slow lookup and update operations because it is based +on a list representation. +-} +newtype Map k a = Map (BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData)) + deriving stock (Haskell.Eq, Haskell.Show) + +instance P.ToData (Map k a) where + {-# INLINEABLE toBuiltinData #-} + toBuiltinData (Map d) = BI.mkMap d + +instance P.FromData (Map k a) where + {-# INLINABLE fromBuiltinData #-} + fromBuiltinData = Just . Map . BI.unsafeDataAsMap + +instance P.UnsafeFromData (Map k a) where + {-# INLINABLE unsafeFromBuiltinData #-} + unsafeFromBuiltinData = Map . BI.unsafeDataAsMap + +{-# INLINEABLE lookup #-} +-- | Look up the value corresponding to the key. +-- If the `Map` is not well-defined, the result is the value associated with +-- the left-most occurrence of the key in the list. +-- This operation is O(n). +lookup :: forall k a. (P.ToData k, P.UnsafeFromData a) => k -> Map k a -> Maybe a +lookup (P.toBuiltinData -> k) (Map m) = P.unsafeFromBuiltinData <$> lookup' k m + +lookup' + :: BuiltinData + -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + -> Maybe BuiltinData +lookup' k m = go m + where + go xs = + P.matchList + xs + (\() -> Nothing) + ( \hd -> + let k' = BI.fst hd + in if P.equalsData k k' + then \_ -> Just (BI.snd hd) + else go + ) + +{-# INLINEABLE member #-} +-- | Check if the key is in the `Map`. +member :: forall k a. (P.ToData k) => k -> Map k a -> Bool +member (P.toBuiltinData -> k) (Map m) = member' k m + +member' :: BuiltinData -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool +member' k = go + where + go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool + go xs = + P.matchList + xs + (\() -> False) + ( \hd -> + let k' = BI.fst hd + in if P.equalsData k k' + then \_ -> True + else go + ) + +{-# INLINEABLE insert #-} +-- | Insert a key-value pair into the `Map`. If the key is already present, +-- the value is updated. +insert :: forall k a. (P.ToData k, P.ToData a) => k -> a -> Map k a -> Map k a +insert (P.toBuiltinData -> k) (P.toBuiltinData -> a) (Map m) = Map $ insert' k a m + +insert' + :: BuiltinData + -> BuiltinData + -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) +insert' k a = go + where + go :: + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + go xs = + P.matchList + xs + (\() -> BI.mkCons (BI.mkPairData k a) nil) + ( \hd tl -> + let k' = BI.fst hd + in if P.equalsData k k' + then BI.mkCons (BI.mkPairData k a) tl + else BI.mkCons hd (go tl) + ) + +{-# INLINEABLE delete #-} +-- | Delete a key value pair from the `Map`. +-- If the `Map` is not well-defined, it deletes the pair associated with the +-- left-most occurrence of the key in the list. +delete :: forall k a. (P.ToData k) => k -> Map k a -> Map k a +delete (P.toBuiltinData -> k) (Map m) = Map $ delete' k m + +delete' :: + BuiltinData -> + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) +delete' k = go + where + go :: + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + go xs = + P.matchList + xs + (\() -> nil) + ( \hd tl -> + let k' = BI.fst hd + in if P.equalsData k k' + then tl + else BI.mkCons hd (go tl) + ) + +{-# INLINEABLE singleton #-} +-- | Create an `Map` with a single key-value pair. +singleton :: forall k a. (P.ToData k, P.ToData a) => k -> a -> Map k a +singleton (P.toBuiltinData -> k) (P.toBuiltinData -> a) = + Map $ BI.mkCons (BI.mkPairData k a) nil + +{-# INLINEABLE empty #-} +-- | An empty `Map`. +empty :: forall k a. Map k a +empty = Map nil + +{-# INLINEABLE null #-} +-- | Check if the `Map` is empty. +null :: forall k a. Map k a -> Bool +null (Map m) = P.null m + +{-# INLINEABLE safeFromList #-} +-- | Create an `Map` from a list of key-value pairs. +-- In case of duplicates, this function will keep only one entry (the one that precedes). +-- In other words, this function de-duplicates the input list. +safeFromList :: forall k a . (P.ToData k, P.ToData a) =>[(k, a)] -> Map k a +safeFromList = + Map + . toOpaque + . foldr (uncurry go) [] + where + go k v [] = [(P.toBuiltinData k, P.toBuiltinData v)] + go k v ((k', v') : rest) = + if P.toBuiltinData k == k' + then (P.toBuiltinData k, P.toBuiltinData v) : go k v rest + else (P.toBuiltinData k', P.toBuiltinData v') : go k v rest + +{-# INLINEABLE unsafeFromList #-} +-- | Unsafely create an 'Map' from a list of pairs. +-- This should _only_ be applied to lists which have been checked to not +-- contain duplicate keys, otherwise the resulting 'Map' will contain +-- conflicting entries (two entries sharing the same key), and therefore be ill-defined. +unsafeFromList :: (P.ToData k, P.ToData a) => [(k, a)] -> Map k a +unsafeFromList = + Map + . toOpaque + . PlutusTx.Prelude.map (\(k, a) -> (P.toBuiltinData k, P.toBuiltinData a)) + +{-# INLINEABLE noDuplicateKeys #-} +-- | Check if the `Map` is well-defined. Warning: this operation is O(n^2). +noDuplicateKeys :: forall k a. Map k a -> Bool +noDuplicateKeys (Map m) = go m + where + go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool + go xs = + P.matchList + xs + (\() -> True) + ( \hd tl -> + let k = BI.fst hd + in if member k (Map tl) then False else go tl + ) + +{-# INLINEABLE all #-} +--- | Check if all values in the `Map` satisfy the predicate. +all :: forall k a. (P.UnsafeFromData a) => (a -> Bool) -> Map k a -> Bool +all p (Map m) = go m + where + go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool + go xs = + P.matchList + xs + (\() -> True) + ( \hd -> + let a = P.unsafeFromBuiltinData (BI.snd hd) + in if p a then go else \_ -> False + ) + +{-# INLINEABLE any #-} +-- | Check if any value in the `Map` satisfies the predicate. +any :: forall k a. (P.UnsafeFromData a) => (a -> Bool) -> Map k a -> Bool +any p (Map m) = go m + where + go :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> Bool + go xs = + P.matchList + xs + (\() -> False) + ( \hd -> + let a = P.unsafeFromBuiltinData (BI.snd hd) + in if p a then \_ -> True else go + ) + +{-# INLINEABLE union #-} + +-- | Combine two 'Map's into one. It saves both values if the key is present in both maps. +union :: + forall k a b. + (P.UnsafeFromData a, P.UnsafeFromData b, P.ToData a, P.ToData b) => + Map k a -> + Map k b -> + Map k (These a b) +union (Map ls) (Map rs) = Map res + where + goLeft xs = + P.matchList + xs + (\() -> nil) + ( \hd tl -> + let k = BI.fst hd + v = BI.snd hd + v' = case lookup' k rs of + Just r -> + P.toBuiltinData + ( These + (P.unsafeFromBuiltinData v) + (P.unsafeFromBuiltinData r) + :: These a b + ) + Nothing -> + P.toBuiltinData (This (P.unsafeFromBuiltinData v) :: These a b) + in BI.mkCons (BI.mkPairData k v') (goLeft tl) + ) + + goRight xs = + P.matchList + xs + (\() -> nil) + ( \hd tl -> + let k = BI.fst hd + v = BI.snd hd + v' = case lookup' k ls of + Just r -> + P.toBuiltinData + ( These + (P.unsafeFromBuiltinData v) + (P.unsafeFromBuiltinData r) + :: These a b + ) + Nothing -> + P.toBuiltinData (That (P.unsafeFromBuiltinData v) :: These a b) + in BI.mkCons (BI.mkPairData k v') (goRight tl) + ) + + res = goLeft ls `safeAppend` goRight rs + + safeAppend xs1 xs2 = + P.matchList + xs1 + (\() -> xs2) + ( \hd tl -> + let k = BI.fst hd + v = BI.snd hd + in insert' k v (safeAppend tl xs2) + ) + +-- | Combine two 'Map's with the given combination function. +unionWith :: + forall k a. + (P.UnsafeFromData a, P.ToData a) => + (a -> a -> a) -> + Map k a -> + Map k a -> + Map k a +unionWith f (Map ls) (Map rs) = + Map res + where + ls' :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + ls' = go ls + where + go xs = + P.matchList + xs + (\() -> nil) + ( \hd tl -> + let k' = BI.fst hd + v' = BI.snd hd + v'' = case lookup' k' rs of + Just r -> + P.toBuiltinData + (f (P.unsafeFromBuiltinData v') (P.unsafeFromBuiltinData r)) + Nothing -> v' + in BI.mkCons (BI.mkPairData k' v'') (go tl) + ) + + rs' :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + rs' = go rs + where + go xs = + P.matchList + xs + (\() -> nil) + ( \hd tl -> + let k' = BI.fst hd + tl' = go tl + in if member' k' ls + then tl' + else BI.mkCons hd tl' + ) + + res :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) + res = go rs' ls' + where + go acc xs = + P.matchList + xs + (\() -> acc) + (\hd -> go (BI.mkCons hd acc)) + +{-# INLINEABLE toList #-} +-- | Convert the `Map` to a list of key-value pairs. This operation is O(n). +-- See 'toBuiltinList' for a more efficient alternative. +toList :: (P.UnsafeFromData k, P.UnsafeFromData a) => Map k a -> [(k, a)] +toList d = go (toBuiltinList d) + where + go xs = + P.matchList + xs + (\() -> []) + ( \hd tl -> + (P.unsafeFromBuiltinData (BI.fst hd), P.unsafeFromBuiltinData (BI.snd hd)) + : go tl + ) + +{-# INLINEABLE toBuiltinList #-} +-- | Convert the `Map` to a `P.BuiltinList` of key-value pairs. This operation is O(1). +toBuiltinList :: Map k a -> BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) +toBuiltinList (Map d) = d + +{-# INLINEABLE unsafeFromBuiltinList #-} +-- | Unsafely create an 'Map' from a `P.BuiltinList` of key-value pairs. +-- This function is unsafe because it assumes that the elements of the list can be safely +-- decoded from their 'BuiltinData' representation. +unsafeFromBuiltinList :: + forall k a. + BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) -> + Map k a +unsafeFromBuiltinList = Map + +{-# INLINEABLE nil #-} +-- | An empty `P.BuiltinList` of key-value pairs. +nil :: BI.BuiltinList (BI.BuiltinPair BuiltinData BuiltinData) +nil = BI.mkNilPairData BI.unitval + +makeLift ''Map diff --git a/plutus-tx/src/PlutusTx/Eq.hs b/plutus-tx/src/PlutusTx/Eq.hs index 0e7b921dfad..de6e87926c7 100644 --- a/plutus-tx/src/PlutusTx/Eq.hs +++ b/plutus-tx/src/PlutusTx/Eq.hs @@ -4,6 +4,7 @@ module PlutusTx.Eq (Eq(..), (/=)) where import PlutusTx.Bool import PlutusTx.Builtins qualified as Builtins import PlutusTx.Either (Either (..)) +import PlutusTx.These import Prelude (Maybe (..)) {- HLINT ignore -} @@ -77,3 +78,10 @@ instance Eq () where instance (Eq a, Eq b) => Eq (a, b) where {-# INLINABLE (==) #-} (a, b) == (a', b') = a == a' && b == b' + +instance (Eq a, Eq b) => Eq (These a b) where + {-# INLINABLE (==) #-} + (This a) == (This a') = a == a' + (That b) == (That b') = b == b' + (These a b) == (These a' b') = a == a' && b == b' + _ == _ = False diff --git a/plutus-tx/src/PlutusTx/IsData/Instances.hs b/plutus-tx/src/PlutusTx/IsData/Instances.hs index 0da5b45e979..ad0dbf5b5d4 100644 --- a/plutus-tx/src/PlutusTx/IsData/Instances.hs +++ b/plutus-tx/src/PlutusTx/IsData/Instances.hs @@ -12,12 +12,14 @@ import PlutusTx.Bool (Bool (..)) import PlutusTx.Either (Either (..)) import PlutusTx.IsData.TH (makeIsDataIndexed, unstableMakeIsData) import PlutusTx.Maybe (Maybe (..)) +import PlutusTx.These (These (..)) -- While these types should be stable, we really don't want them changing, so index -- them explicitly to be sure. makeIsDataIndexed ''Bool [('False,0),('True,1)] makeIsDataIndexed ''Maybe [('Just,0),('Nothing,1)] makeIsDataIndexed ''Either [('Left,0),('Right,1)] +makeIsDataIndexed ''These [('This,0),('That,1),('These,2)] -- Okay to use unstableMakeIsData here since there's only one alternative and we're sure -- that will never change. diff --git a/plutus-tx/src/PlutusTx/Lift/Instances.hs b/plutus-tx/src/PlutusTx/Lift/Instances.hs index d5132023e16..98832e7b576 100644 --- a/plutus-tx/src/PlutusTx/Lift/Instances.hs +++ b/plutus-tx/src/PlutusTx/Lift/Instances.hs @@ -18,6 +18,7 @@ import PlutusTx.Bool (Bool (..)) import PlutusTx.Either (Either (..)) import PlutusTx.Lift.TH import PlutusTx.Maybe (Maybe (..)) +import PlutusTx.These (These (..)) -- Standard types -- These need to be in a separate file for TH staging reasons @@ -25,6 +26,7 @@ import PlutusTx.Maybe (Maybe (..)) makeLift ''Bool makeLift ''Maybe makeLift ''Either +makeLift ''These makeLift ''[] makeLift ''() -- include a few tuple instances for convenience diff --git a/plutus-tx/src/PlutusTx/Ord.hs b/plutus-tx/src/PlutusTx/Ord.hs index 210826488df..f92baf2e2bb 100644 --- a/plutus-tx/src/PlutusTx/Ord.hs +++ b/plutus-tx/src/PlutusTx/Ord.hs @@ -11,6 +11,7 @@ import PlutusTx.Bool (Bool (..)) import PlutusTx.Builtins qualified as Builtins import PlutusTx.Either (Either (..)) import PlutusTx.Eq +import PlutusTx.These import Prelude (Maybe (..), Ordering (..)) {- HLINT ignore -} @@ -123,3 +124,17 @@ instance (Ord a, Ord b) => Ord (a, b) where case compare a a' of EQ -> compare b b' c -> c + +instance (Ord a, Ord b) => Ord (These a b) where + {-# INLINABLE compare #-} + compare (This a) (This a') = compare a a' + compare (That b) (That b') = compare b b' + compare (These a b) (These a' b') = + case compare a a' of + EQ -> compare b b' + c -> c + compare (This _) _ = LT + compare (That _) (This _) = GT + compare (That _) (These _ _) = LT + compare (These _ _) (This _) = GT + compare (These _ _) (That _) = GT diff --git a/plutus-tx/src/PlutusTx/Show.hs b/plutus-tx/src/PlutusTx/Show.hs index 5b16c1ebf9c..e8d57caedbc 100644 --- a/plutus-tx/src/PlutusTx/Show.hs +++ b/plutus-tx/src/PlutusTx/Show.hs @@ -25,6 +25,7 @@ import PlutusTx.List (foldr) import PlutusTx.Maybe import PlutusTx.Prelude hiding (foldr) import PlutusTx.Show.TH +import PlutusTx.These instance Show Builtins.Integer where {-# INLINEABLE showsPrec #-} @@ -160,3 +161,4 @@ deriveShow ''(,,,,,,,,,,,,,,,,,,,,,,,,,) deriveShow ''(,,,,,,,,,,,,,,,,,,,,,,,,,,) deriveShow ''Maybe deriveShow ''Either +deriveShow ''These diff --git a/plutus-tx/src/PlutusTx/These.hs b/plutus-tx/src/PlutusTx/These.hs index 4ec6742e344..124a37d6102 100644 --- a/plutus-tx/src/PlutusTx/These.hs +++ b/plutus-tx/src/PlutusTx/These.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} + {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + module PlutusTx.These( These(..) , these diff --git a/scripts/prepare-bins.sh b/scripts/prepare-bins.sh new file mode 100755 index 00000000000..fada66a996f --- /dev/null +++ b/scripts/prepare-bins.sh @@ -0,0 +1,31 @@ +#!/usr/bin/env nix-shell +#! nix-shell -i bash --pure +#! nix-shell -p bash git nix upx + +set -euo pipefail + +banner='\n +Lets prepare binaries for a release:\n + 1. Build `pir`\n + 2. Compress `pir` with `upx`\n + 3. Build `uplc`\n + 4. Compress `uplc` with `upx`\n +' + +echo -e $banner + +echo "Building pir..." + +nix build ".#hydraJobs.x86_64-linux.musl64.ghc96.pir" + +echo "Compressing pir..." + +upx -9 ./result/bin/pir -o pir-x86_64-linux-ghc96 --force-overwrite + +echo "Building uplc..." + +nix build ".#hydraJobs.x86_64-linux.musl64.ghc96.uplc" + +echo "Compressing uplc..." + +upx -9 ./result/bin/uplc -o uplc-x86_64-linux-ghc96 --force-overwrite