diff --git a/.github/workflows/longitudinal-benchmark.yml b/.github/workflows/longitudinal-benchmark.yml index 6ebdd9ec7d1..dcd3361ecbf 100644 --- a/.github/workflows/longitudinal-benchmark.yml +++ b/.github/workflows/longitudinal-benchmark.yml @@ -28,7 +28,7 @@ jobs: - name: Run benchmarks env: - BENCHMARKS: "validation validation-decode" + BENCHMARKS: "validation validation-decode nofib" run: nix develop --no-warn-dirty --accept-flake-config --command bash ./scripts/run-longitudinal-benchmarks.sh # We need this otherwise the next step (Store benchmark result) will fail with: diff --git a/.github/workflows/script-evaluation-test.yml b/.github/workflows/script-evaluation-test.yml index e083f7e1745..0cdc4f5bf44 100644 --- a/.github/workflows/script-evaluation-test.yml +++ b/.github/workflows/script-evaluation-test.yml @@ -12,7 +12,7 @@ concurrency: jobs: script-evaluation-test: - runs-on: [ubuntu-latest] + runs-on: [self-hosted, default] steps: - name: Checkout @@ -21,6 +21,8 @@ jobs: - name: Quick Install Nix uses: nixbuild/nix-quick-install-action@v22 with: + # 2.14.1 seems to have issues, see https://github.com/nixbuild/nix-quick-install-action/issues/29 + nix_version: '2.13.3' nix_conf: | experimental-features = nix-command flakes accept-flake-config = true diff --git a/cabal.project b/cabal.project index 0879044bb87..ee3139d78e3 100644 --- a/cabal.project +++ b/cabal.project @@ -14,11 +14,12 @@ repository cardano-haskell-packages -- update either of these. index-state: -- Bump both the following dates if you need newer packages from Hackage - , hackage.haskell.org 2023-05-18T01:25:23Z + , hackage.haskell.org 2023-05-23T01:25:23Z -- Bump this if you need newer packages from CHaP , cardano-haskell-packages 2023-05-16T08:53:30Z packages: doc/read-the-docs-site + marlowe-cardano-minimal plutus-benchmark plutus-conformance plutus-core @@ -49,21 +50,7 @@ extra-packages: ieee, filemanip if impl(ghc >= 9.6) allow-newer: - -- unmaintained? would be good to do something here - , int-cast:base -- https://github.com/mokus0/th-extras/pull/20 , th-extras:template-haskell , th-extras:th-abstraction --- This is suboptimal, but shouldn't block us from releasing to CHaP, since --- we turn off our R dependency by default --- --- need https://github.com/tweag/HaskellR/commit/3cb01da0902ef705d2bd40874fe53333f4949b2f --- for 9.6 support --- need https://github.com/tweag/HaskellR/commit/e49242000a49b48511481c6b1bb6487d8965c524 --- to build with mtl-2.3 -source-repository-package - type: git - location: https://github.com/tweag/HaskellR - tag: 411d15fe5027494123e326c838955eff1c8e7ec8 - subdir: inline-r diff --git a/flake.lock b/flake.lock index 0b13d8eb86f..7af8fab75dd 100644 --- a/flake.lock +++ b/flake.lock @@ -421,11 +421,11 @@ "hackage-nix": { "flake": false, "locked": { - "lastModified": 1684369422, - "narHash": "sha256-NuvLofVxNBFr99LOX6J4QgRtL1c+Vp+PO6uj3IB7XJ8=", + "lastModified": 1684801452, + "narHash": "sha256-LhtRCjizpOIu7t9e1EEz2FyVx8TMlDksV0+k3nlLjy8=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "57fddaa2729bc463fbd58bb2898b3a8d056d5f6d", + "rev": "aff0eeec1d8c96a487df0e20b9531a3ec91a802f", "type": "github" }, "original": { diff --git a/marlowe-cardano-minimal/.gitignore b/marlowe-cardano-minimal/.gitignore new file mode 100644 index 00000000000..b3f908b8800 --- /dev/null +++ b/marlowe-cardano-minimal/.gitignore @@ -0,0 +1,7 @@ +*.flat +*.plutus +*.tsv +*.png +.cache/ +.ipynb_checkpoints/ +*.ipynb diff --git a/marlowe-cardano-minimal/LICENSE b/marlowe-cardano-minimal/LICENSE new file mode 100644 index 00000000000..0c8a80022ea --- /dev/null +++ b/marlowe-cardano-minimal/LICENSE @@ -0,0 +1,53 @@ +Apache License + +Version 2.0, January 2004 + +http://www.apache.org/licenses/ + +TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + +1. Definitions. + +"License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. + +"Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. + +"Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. + +"You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. + +"Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. + +"Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. + +"Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). + +"Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. + +"Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." + +"Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. + +2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. + +3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. + +4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: + +You must give any other recipients of the Work or Derivative Works a copy of this License; and +You must cause any modified files to carry prominent notices stating that You changed the files; and +You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and +If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. + +You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. +5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. + +6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. + +7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. + +8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. + +9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. + +END OF TERMS AND CONDITIONS diff --git a/marlowe-cardano-minimal/NOTICE b/marlowe-cardano-minimal/NOTICE new file mode 100644 index 00000000000..536c4061cba --- /dev/null +++ b/marlowe-cardano-minimal/NOTICE @@ -0,0 +1,14 @@ +Copyright 2019 Input Output (Hong Kong) Ltd. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/marlowe-cardano-minimal/README.md b/marlowe-cardano-minimal/README.md new file mode 100644 index 00000000000..c00a38e63f4 --- /dev/null +++ b/marlowe-cardano-minimal/README.md @@ -0,0 +1,66 @@ +# Experimental version of Marlowe validator for Cardano, with minimal dependencies + +This package is fully representative version of the Marlowe validator on chain. It is primarily for benchmarking/profiling Marlowe scripts. + +Marlowe is a platform for financial products as smart contracts. [Marlowe-Cardano](https://github.com/input-output-hk/marlowe-cardano) is an implementation of Marlowe for the Cardano blockchain, built on top of Plutus. + +In short, users write a Marlowe application in `Marlowe-Cardano`, which generates the corresponding code that is ready for the Plutus compiler with some manual revision. The code then goes through the Plutus compiler pipeline and gets executed on Cardano. + +The Plutus Core team has been working on optimizing the compiler such that a script's budget is reduced. The budget is a reflection of + +(1) script sizes +(2) execution costs + +It would be informative for both the Plutus and Marlowe teams to investigate in detail how the Marlowe scripts can be optimized. In particular, we can perform: + +(1) Benchmarking: compare the budget before and after optimizations that the Plutus team implemented. It could be helpful to do the benchmarking *as* we implement the optimization even. + +The benchmarking portion of the code lives in `plutus-benchmark`, which imports this package. + +(2) Profiling: look at each script in more detail, what functions are taking up the most budget? How can they be optimized? + +See [CONTRIBUTING.md](https://github.com/input-output-hk/plutus/blob/master/CONTRIBUTING.adoc#how-to-build-the-code-with-profiling) for profiling instructions. + +Of the most common Marlowe transactions, input application transactions are the most relevant, as they are complex and can go over the execution limits at times. So there is a priority on examining those contracts. + +## Managing versions + +### Versioning of this package + +Note that the off-chain code is evolving. However the on-chain code is very stable and is compatible with GHC 8.10.7. For best benchmarking results, eventually we may have to update some of these files by hand if the on chain code is updated. (We don't want to depend on the Marlowe repository because this will have the problem of circular dependency.) + +### Script versions + +The production version of Marlowe currently uses (PlutusV2, vasilPV, plcVersion100 or 1.0.0). We should use the same combination in the benchmarking. + +For documentation on Plutus vs PLC vs protocol version, see [here](https://github.com/input-output-hk/plutus/blob/master/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs) + +## Running the benchmarks with executable `marlowe-validators` + +The application `marlowe-validators` serialises the two Marlowe validator scripts, computes their hashes, and runs all of the benchmarks, storing the results in a pair of tab-separated-value files. + +```bash +cabal run exe:marlowe-validators +``` + +```console +Semantics: + Validator hash: 626424dba5741cb1f0a3cab8643da59ffccba351495c4257f9ec3689 + Validator file: marlowe-semantics.plutus + Measurements file: marlowe-semantics.tsv + +Role payout: + Validator hash: fb5a52cc79da601eff8901272d3115444c1cd1ae82dd42caeee7346b + Validator file: marlowe-rolepayout.plutus + Measurements file: marlowe-rolepayout.tsv +``` + +The following files are output: +- For Marlowe's semantics valdator + - Plutus script: `marlowe-semantics.plutus` + - Benchmarking results: `marlowe-semantics.tsv` + - Flat UPLC files: `benchmarks/semantics/*-uplc.flat` +- For Marlowe's role-payout valdator + - Plutus script: `marlowe-rolepayout.plutus` + - Benchmarking results: `marlowe-rolepayout.tsv` + - Flat UPLC files: `benchmarks/rolepayout/*-uplc.flat` diff --git a/marlowe-cardano-minimal/app/Benchmark/Marlowe.hs b/marlowe-cardano-minimal/app/Benchmark/Marlowe.hs new file mode 100644 index 00000000000..d94710a8a3d --- /dev/null +++ b/marlowe-cardano-minimal/app/Benchmark/Marlowe.hs @@ -0,0 +1,402 @@ + + +----------------------------------------------------------------------------- +-- +-- Module : $Headers +-- License : Apache 2.0 +-- +-- Stability : Experimental +-- Portability : Portable +-- +-- | Benchmarking support for Marlowe's validators. +-- +----------------------------------------------------------------------------- + + +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + + +module Benchmark.Marlowe ( + -- * Benchmarking + executeBenchmark +, evaluationContext +, readBenchmark +, readBenchmarks +, printBenchmark +, printResult +, tabulateResults +, writeFlatUPLC +, writeFlatUPLCs +) where + + +import Benchmark.Marlowe.Types (Benchmark (..)) +import Codec.Serialise (deserialise) +import Control.Monad (void) +import Control.Monad.Except (runExcept) +import Control.Monad.Writer (runWriterT) +import Data.Bifunctor (bimap) +import Data.List (isSuffixOf) +import Language.Marlowe.Core.V1.Semantics (MarloweData) +import Language.Marlowe.Scripts.Semantics (MarloweInput) +import Paths_marlowe_cardano_minimal (getDataDir) +import PlutusCore.Executable.AstIO (fromNamedDeBruijnUPLC) +import PlutusCore.Executable.Common (writeProgram) +import PlutusCore.Executable.Types (AstNameType (NamedDeBruijn), Format (Flat), Output (FileOutput), + PrintMode (Readable), UplcProg) +import PlutusCore.MkPlc (mkConstant) +import PlutusLedgerApi.V2 (Data (Constr, I), EvaluationContext, EvaluationError, + ExBudget (ExBudget, exBudgetCPU, exBudgetMemory), ExCPU (ExCPU), + ExMemory (ExMemory), LogOutput, ProtocolVersion (..), + ScriptContext (scriptContextTxInfo), ScriptHash (..), SerialisedScript, + TxInfo (txInfoId), VerboseMode (Verbose), evaluateScriptCounting, + fromData, mkEvaluationContext, toData) +import PlutusPrelude ((.*)) +import PlutusTx.Code (CompiledCode, getPlc) +import System.Directory (listDirectory) +import System.FilePath ((<.>), ()) +import UntypedPlutusCore (Program (..), Version (..), applyProgram) + +import Data.ByteString.Lazy qualified as LBS (readFile) + + +-- | Read all of the benchmarking cases for a particular validator. +readBenchmarks + :: FilePath + -> IO (Either String [Benchmark]) +readBenchmarks subfolder = + do + folder <- ( subfolder) <$> getDataDir + files <- filter (isSuffixOf ".benchmark") . fmap (folder ) <$> listDirectory folder + sequence <$> mapM readBenchmark files + + +-- | Read a benchmarking file. +readBenchmark + :: FilePath + -> IO (Either String Benchmark) +readBenchmark filename = + do + payload <- LBS.readFile filename + pure + $ case deserialise payload of + Constr 0 [bDatum, bRedeemer, scriptContext, I cpu, I memory] -> + do + bScriptContext <- + maybe (Left "Failed deserializing script context") pure + $ fromData scriptContext + let + bReferenceCost = Just $ ExBudget (fromInteger cpu) (fromInteger memory) + pure Benchmark{..} + _ -> Left "Failed deserializing benchmark file." + + +-- | Print a benchmarking case. +printBenchmark + :: Benchmark + -> IO () +printBenchmark Benchmark{..} = + do + putStrLn "*** DATUM ***" + print (fromData bDatum :: Maybe MarloweData) + putStrLn "*** REDEEMER ***" + print (fromData bRedeemer :: Maybe MarloweInput) + putStrLn "*** SCRIPT CONTEXT ***" + print bScriptContext + putStrLn "*** REFERENCE COST ***" + print bReferenceCost + + +-- | Run and print the results of benchmarking. +printResult + :: SerialisedScript -- ^ The serialised validator. + -> Benchmark -- ^ The benchmarking case. + -> IO () -- ^ The action to run and print the results. +printResult validator benchmark = + case executeBenchmark validator benchmark of + Right (_, Right budget) -> + putStrLn ("actual = " <> show budget <> " vs expected = " <> show (bReferenceCost benchmark)) + Right (logs, Left msg) -> print (msg, logs) + Left msg -> print msg + + +-- | Run multiple benchmarks and organize their results in a table. +tabulateResults + :: String -- ^ The name of the validator. + -> ScriptHash -- ^ The hash of the validator script. + -> SerialisedScript -- ^ The serialisation of the validator script. + -> [Benchmark] -- ^ The benchmarking cases. + -> [[String]] -- ^ A table of results, with a header in the first line. +tabulateResults name hash validator benchmarks = + let + na = "NA" + unExCPU (ExCPU n) = n + unExMemory (ExMemory n) = n + in + (["Validator", "Script", "TxId"] + <> ["Measured CPU", "Measured Memory", "Reference CPU", "Reference Memory", "Message"]) + : [ + [name, show hash, show txId] <> + case executeBenchmark validator benchmark of + Right (_, Right budget) -> + [ + show . unExCPU $ exBudgetCPU budget + , show . unExMemory $ exBudgetMemory budget + , cpuRef + , memoryRef + , mempty + ] + Right (logs, Left msg) -> [na, na, cpuRef, memoryRef, show (logs, msg)] + Left msg -> [na, na, cpuRef, memoryRef, show msg] + | + benchmark@Benchmark{..} <- benchmarks + , let txId = txInfoId $ scriptContextTxInfo bScriptContext + cpuRef = maybe na (show . unExCPU . exBudgetCPU) bReferenceCost + memoryRef = maybe na (show . unExMemory . exBudgetMemory) bReferenceCost + ] + + +-- | Write flat UPLC files for benchmarks. +writeFlatUPLCs + :: (FilePath -> Benchmark -> IO ()) + -> [Benchmark] + -> FilePath + -> IO () +writeFlatUPLCs writer benchmarks folder = + sequence_ + [ + writer (folder show txId <> "-uplc" <.> "flat") benchmark + | + benchmark@Benchmark{..} <- benchmarks + , let txId = txInfoId $ scriptContextTxInfo bScriptContext + ] + + +-- | Write a flat UPLC file for a benchmark. +writeFlatUPLC + :: CompiledCode a + -> FilePath + -> Benchmark + -> IO () +writeFlatUPLC validator filename Benchmark{..} = + let + unsafeFromRight (Right x) = x + unsafeFromRight _ = error "unsafeFromRight failed" + wrap = Program () (Version 1 0 0) + datum = wrap $ mkConstant () bDatum :: UplcProg () + redeemer = wrap $ mkConstant () bRedeemer :: UplcProg () + context = wrap $ mkConstant () $ toData bScriptContext :: UplcProg () + prog = fromNamedDeBruijnUPLC $ getPlc validator + applied = + foldl1 (unsafeFromRight .* applyProgram) + $ void prog : [datum, redeemer, context] + in + writeProgram (FileOutput filename) (Flat NamedDeBruijn) Readable applied + + +-- | Run a benchmark case. +executeBenchmark + :: SerialisedScript -- ^ The serialised validator. + -> Benchmark -- ^ The benchmarking case. + -> Either String (LogOutput, Either EvaluationError ExBudget) -- ^ An error or the cost. +executeBenchmark serialisedValidator Benchmark{..} = + case evaluationContext of + Left message -> Left message + Right ec -> + Right + $ evaluateScriptCounting (ProtocolVersion 8 0) Verbose ec serialisedValidator + [bDatum, bRedeemer, toData bScriptContext] + + +-- | The execution context for benchmarking. +evaluationContext :: Either String EvaluationContext +evaluationContext = + bimap show fst + . runExcept + . runWriterT + . mkEvaluationContext + $ snd <$> testCostModel + + +-- | Cost model, hardwired for testing and fair benchmarking. +testCostModel :: [(String, Integer)] +testCostModel = + [ + ("addInteger-cpu-arguments-intercept", 205665) + , ("addInteger-cpu-arguments-slope", 812) + , ("addInteger-memory-arguments-intercept", 1) + , ("addInteger-memory-arguments-slope", 1) + , ("appendByteString-cpu-arguments-intercept", 1000) + , ("appendByteString-cpu-arguments-slope", 571) + , ("appendByteString-memory-arguments-intercept", 0) + , ("appendByteString-memory-arguments-slope", 1) + , ("appendString-cpu-arguments-intercept", 1000) + , ("appendString-cpu-arguments-slope", 24177) + , ("appendString-memory-arguments-intercept", 4) + , ("appendString-memory-arguments-slope", 1) + , ("bData-cpu-arguments", 1000) + , ("bData-memory-arguments", 32) + , ("blake2b_256-cpu-arguments-intercept", 117366) + , ("blake2b_256-cpu-arguments-slope", 10475) + , ("blake2b_256-memory-arguments", 4) + , ("cekApplyCost-exBudgetCPU", 23000) + , ("cekApplyCost-exBudgetMemory", 100) + , ("cekBuiltinCost-exBudgetCPU", 23000) + , ("cekBuiltinCost-exBudgetMemory", 100) + , ("cekConstCost-exBudgetCPU", 23000) + , ("cekConstCost-exBudgetMemory", 100) + , ("cekDelayCost-exBudgetCPU", 23000) + , ("cekDelayCost-exBudgetMemory", 100) + , ("cekForceCost-exBudgetCPU", 23000) + , ("cekForceCost-exBudgetMemory", 100) + , ("cekLamCost-exBudgetCPU", 23000) + , ("cekLamCost-exBudgetMemory", 100) + , ("cekStartupCost-exBudgetCPU", 100) + , ("cekStartupCost-exBudgetMemory", 100) + , ("cekVarCost-exBudgetCPU", 23000) + , ("cekVarCost-exBudgetMemory", 100) + , ("chooseData-cpu-arguments", 19537) + , ("chooseData-memory-arguments", 32) + , ("chooseList-cpu-arguments", 175354) + , ("chooseList-memory-arguments", 32) + , ("chooseUnit-cpu-arguments", 46417) + , ("chooseUnit-memory-arguments", 4) + , ("consByteString-cpu-arguments-intercept", 221973) + , ("consByteString-cpu-arguments-slope", 511) + , ("consByteString-memory-arguments-intercept", 0) + , ("consByteString-memory-arguments-slope", 1) + , ("constrData-cpu-arguments", 89141) + , ("constrData-memory-arguments", 32) + , ("decodeUtf8-cpu-arguments-intercept", 497525) + , ("decodeUtf8-cpu-arguments-slope", 14068) + , ("decodeUtf8-memory-arguments-intercept", 4) + , ("decodeUtf8-memory-arguments-slope", 2) + , ("divideInteger-cpu-arguments-constant", 196500) + , ("divideInteger-cpu-arguments-model-arguments-intercept", 453240) + , ("divideInteger-cpu-arguments-model-arguments-slope", 220) + , ("divideInteger-memory-arguments-intercept", 0) + , ("divideInteger-memory-arguments-minimum", 1) + , ("divideInteger-memory-arguments-slope", 1) + , ("encodeUtf8-cpu-arguments-intercept", 1000) + , ("encodeUtf8-cpu-arguments-slope", 28662) + , ("encodeUtf8-memory-arguments-intercept", 4) + , ("encodeUtf8-memory-arguments-slope", 2) + , ("equalsByteString-cpu-arguments-constant", 245000) + , ("equalsByteString-cpu-arguments-intercept", 216773) + , ("equalsByteString-cpu-arguments-slope", 62) + , ("equalsByteString-memory-arguments", 1) + , ("equalsData-cpu-arguments-intercept", 1060367) + , ("equalsData-cpu-arguments-slope", 12586) + , ("equalsData-memory-arguments", 1) + , ("equalsInteger-cpu-arguments-intercept", 208512) + , ("equalsInteger-cpu-arguments-slope", 421) + , ("equalsInteger-memory-arguments", 1) + , ("equalsString-cpu-arguments-constant", 187000) + , ("equalsString-cpu-arguments-intercept", 1000) + , ("equalsString-cpu-arguments-slope", 52998) + , ("equalsString-memory-arguments", 1) + , ("fstPair-cpu-arguments", 80436) + , ("fstPair-memory-arguments", 32) + , ("headList-cpu-arguments", 43249) + , ("headList-memory-arguments", 32) + , ("iData-cpu-arguments", 1000) + , ("iData-memory-arguments", 32) + , ("ifThenElse-cpu-arguments", 80556) + , ("ifThenElse-memory-arguments", 1) + , ("indexByteString-cpu-arguments", 57667) + , ("indexByteString-memory-arguments", 4) + , ("lengthOfByteString-cpu-arguments", 1000) + , ("lengthOfByteString-memory-arguments", 10) + , ("lessThanByteString-cpu-arguments-intercept", 197145) + , ("lessThanByteString-cpu-arguments-slope", 156) + , ("lessThanByteString-memory-arguments", 1) + , ("lessThanEqualsByteString-cpu-arguments-intercept", 197145) + , ("lessThanEqualsByteString-cpu-arguments-slope", 156) + , ("lessThanEqualsByteString-memory-arguments", 1) + , ("lessThanEqualsInteger-cpu-arguments-intercept", 204924) + , ("lessThanEqualsInteger-cpu-arguments-slope", 473) + , ("lessThanEqualsInteger-memory-arguments", 1) + , ("lessThanInteger-cpu-arguments-intercept", 208896) + , ("lessThanInteger-cpu-arguments-slope", 511) + , ("lessThanInteger-memory-arguments", 1) + , ("listData-cpu-arguments", 52467) + , ("listData-memory-arguments", 32) + , ("mapData-cpu-arguments", 64832) + , ("mapData-memory-arguments", 32) + , ("mkCons-cpu-arguments", 65493) + , ("mkCons-memory-arguments", 32) + , ("mkNilData-cpu-arguments", 22558) + , ("mkNilData-memory-arguments", 32) + , ("mkNilPairData-cpu-arguments", 16563) + , ("mkNilPairData-memory-arguments", 32) + , ("mkPairData-cpu-arguments", 76511) + , ("mkPairData-memory-arguments", 32) + , ("modInteger-cpu-arguments-constant", 196500) + , ("modInteger-cpu-arguments-model-arguments-intercept", 453240) + , ("modInteger-cpu-arguments-model-arguments-slope", 220) + , ("modInteger-memory-arguments-intercept", 0) + , ("modInteger-memory-arguments-minimum", 1) + , ("modInteger-memory-arguments-slope", 1) + , ("multiplyInteger-cpu-arguments-intercept", 69522) + , ("multiplyInteger-cpu-arguments-slope", 11687) + , ("multiplyInteger-memory-arguments-intercept", 0) + , ("multiplyInteger-memory-arguments-slope", 1) + , ("nullList-cpu-arguments", 60091) + , ("nullList-memory-arguments", 32) + , ("quotientInteger-cpu-arguments-constant", 196500) + , ("quotientInteger-cpu-arguments-model-arguments-intercept", 453240) + , ("quotientInteger-cpu-arguments-model-arguments-slope", 220) + , ("quotientInteger-memory-arguments-intercept", 0) + , ("quotientInteger-memory-arguments-minimum", 1) + , ("quotientInteger-memory-arguments-slope", 1) + , ("remainderInteger-cpu-arguments-constant", 196500) + , ("remainderInteger-cpu-arguments-model-arguments-intercept", 453240) + , ("remainderInteger-cpu-arguments-model-arguments-slope", 220) + , ("remainderInteger-memory-arguments-intercept", 0) + , ("remainderInteger-memory-arguments-minimum", 1) + , ("remainderInteger-memory-arguments-slope", 1) + , ("serialiseData-cpu-arguments-intercept", 1159724) + , ("serialiseData-cpu-arguments-slope", 392670) + , ("serialiseData-memory-arguments-intercept", 0) + , ("serialiseData-memory-arguments-slope", 2) + , ("sha2_256-cpu-arguments-intercept", 806990) + , ("sha2_256-cpu-arguments-slope", 30482) + , ("sha2_256-memory-arguments", 4) + , ("sha3_256-cpu-arguments-intercept", 1927926) + , ("sha3_256-cpu-arguments-slope", 82523) + , ("sha3_256-memory-arguments", 4) + , ("sliceByteString-cpu-arguments-intercept", 265318) + , ("sliceByteString-cpu-arguments-slope", 0) + , ("sliceByteString-memory-arguments-intercept", 4) + , ("sliceByteString-memory-arguments-slope", 0) + , ("sndPair-cpu-arguments", 85931) + , ("sndPair-memory-arguments", 32) + , ("subtractInteger-cpu-arguments-intercept", 205665) + , ("subtractInteger-cpu-arguments-slope", 812) + , ("subtractInteger-memory-arguments-intercept", 1) + , ("subtractInteger-memory-arguments-slope", 1) + , ("tailList-cpu-arguments", 41182) + , ("tailList-memory-arguments", 32) + , ("trace-cpu-arguments", 212342) + , ("trace-memory-arguments", 32) + , ("unBData-cpu-arguments", 31220) + , ("unBData-memory-arguments", 32) + , ("unConstrData-cpu-arguments", 32696) + , ("unConstrData-memory-arguments", 32) + , ("unIData-cpu-arguments", 43357) + , ("unIData-memory-arguments", 32) + , ("unListData-cpu-arguments", 32247) + , ("unListData-memory-arguments", 32) + , ("unMapData-cpu-arguments", 38314) + , ("unMapData-memory-arguments", 32) + , ("verifyEcdsaSecp256k1Signature-cpu-arguments", 35892428) + , ("verifyEcdsaSecp256k1Signature-memory-arguments", 10) + , ("verifyEd25519Signature-cpu-arguments-intercept", 9462713) + , ("verifyEd25519Signature-cpu-arguments-slope", 1021) + , ("verifyEd25519Signature-memory-arguments", 10) + , ("verifySchnorrSecp256k1Signature-cpu-arguments-intercept", 38887044) + , ("verifySchnorrSecp256k1Signature-cpu-arguments-slope", 32947) + , ("verifySchnorrSecp256k1Signature-memory-arguments", 10) + ] diff --git a/marlowe-cardano-minimal/app/Benchmark/Marlowe/RolePayout.hs b/marlowe-cardano-minimal/app/Benchmark/Marlowe/RolePayout.hs new file mode 100644 index 00000000000..1de96fb498e --- /dev/null +++ b/marlowe-cardano-minimal/app/Benchmark/Marlowe/RolePayout.hs @@ -0,0 +1,162 @@ + + +----------------------------------------------------------------------------- +-- +-- Module : $Headers +-- License : Apache 2.0 +-- +-- Stability : Experimental +-- Portability : Portable +-- +-- | Benchmarking support for Marlowe's role-payout validator. +-- +----------------------------------------------------------------------------- + + +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + + +module Benchmark.Marlowe.RolePayout ( + -- * Benchmarking + benchmarks +, validatorBytes +, validatorHash +, exampleBenchmark +, writeUPLC +) where + + +import Benchmark.Marlowe (readBenchmarks, writeFlatUPLC) +import Benchmark.Marlowe.Types (Benchmark (..), makeBenchmark) +import Benchmark.Marlowe.Util (lovelace, makeBuiltinData, makeDatumMap, makeInput, makeOutput, + makeRedeemerMap, updateScriptHash) +import Data.Bifunctor (second) +import Language.Marlowe.Scripts.RolePayout (rolePayoutValidator, rolePayoutValidatorBytes, + rolePayoutValidatorHash) +import PlutusLedgerApi.V2 (Credential (PubKeyCredential, ScriptCredential), ExBudget (ExBudget), + Extended (NegInf, PosInf), Interval (Interval), LowerBound (LowerBound), + ScriptContext (ScriptContext, scriptContextPurpose, scriptContextTxInfo), + ScriptHash, ScriptPurpose (Spending), SerialisedScript, TxInfo (..), + TxOutRef (TxOutRef), UpperBound (UpperBound), singleton) + +import PlutusTx.AssocMap qualified as AM (empty) + + +-- | Write a flat UPLC file for a benchmark. +writeUPLC + :: FilePath + -> Benchmark + -> IO () +writeUPLC = writeFlatUPLC rolePayoutValidator + + +-- | The serialised Marlowe role-payout validator. +validatorBytes :: SerialisedScript +validatorBytes = rolePayoutValidatorBytes + + +-- | The hash for the Marlowe role-payout validator. +validatorHash :: ScriptHash +validatorHash = rolePayoutValidatorHash + + +-- | The benchmark cases for the Marlowe role-payout validator. +benchmarks :: IO (Either String [Benchmark]) +benchmarks = second (rescript <$>) <$> readBenchmarks "rolepayout" + + +-- | Revise the validator hashes in the benchmark's script context. +rescript + :: Benchmark + -> Benchmark +rescript benchmark@Benchmark{..} = + benchmark { + bScriptContext = + updateScriptHash + "e165610232235bbbbeff5b998b233daae42979dec92a6722d9cda989" + rolePayoutValidatorHash + bScriptContext + } + + +{-# DEPRECATED exampleBenchmark "Experimental, not thoroughly tested." #-} + +-- | An example benchmark for the Marlowe role-payout validator. +exampleBenchmark :: Benchmark +exampleBenchmark = + let + txInfoInputs = + [ + makeInput + "6ca85e35c485181d54b4092a49ed9fec93a3f21b603c68cbca741ec27de318cf" 0 + (PubKeyCredential "5411f58036fcd19b79cc51539233698dd9b86c2e53d132675b152ce8") + (lovelace 1008173101) + Nothing + Nothing + , makeInput + "6ca85e35c485181d54b4092a49ed9fec93a3f21b603c68cbca741ec27de318cf" 1 + (PubKeyCredential "5411f58036fcd19b79cc51539233698dd9b86c2e53d132675b152ce8") + ( + singleton "d768a767450e9ffa2d68ae61e8476fb6267884e0477d7fd19703f9d8" "Seller" 1 + <> lovelace 1034400 + ) + Nothing + Nothing + , makeInput + "ef6a9ef1b84bef3dad5e12d9bf128765595be4a92da45bda2599dc7fae7e2397" 1 + (ScriptCredential "e165610232235bbbbeff5b998b233daae42979dec92a6722d9cda989") + (lovelace 75000000) + (Just "95de9e2c3bface3de5739c0bd5197f0864315c1819c52783afb9b2ce075215f5") + Nothing + ] + txInfoReferenceInputs = + [ + makeInput + "9a8a6f387a3330b4141e1cb019380b9ac5c72151c0abc52aa4266245d3c555cd" 1 + (PubKeyCredential "f685ca45a4c8c07dd592ba1609690b56fdb0b81cef9440345de947f1") + (lovelace 12899830) + Nothing + (Just "e165610232235bbbbeff5b998b233daae42979dec92a6722d9cda989") + ] + txInfoOutputs = + [ + makeOutput + (PubKeyCredential "5411f58036fcd19b79cc51539233698dd9b86c2e53d132675b152ce8") + (lovelace 1082841547) + Nothing + Nothing + , makeOutput + (PubKeyCredential "5411f58036fcd19b79cc51539233698dd9b86c2e53d132675b152ce8") + ( + singleton "d768a767450e9ffa2d68ae61e8476fb6267884e0477d7fd19703f9d8" "Seller" 1 + <> lovelace 1034400 + ) + Nothing + Nothing + ] + txInfoFee = lovelace 331554 + txInfoMint = mempty + txInfoDCert = mempty + txInfoWdrl = AM.empty + txInfoValidRange = Interval (LowerBound NegInf False) (UpperBound PosInf False) + txInfoSignatories = ["5411f58036fcd19b79cc51539233698dd9b86c2e53d132675b152ce8"] + txInfoRedeemers = makeRedeemerMap scriptContextPurpose "d87980" + txInfoData = + makeDatumMap + "95de9e2c3bface3de5739c0bd5197f0864315c1819c52783afb9b2ce075215f5" + "d8799f581cd768a767450e9ffa2d68ae61e8476fb6267884e0477d7fd19703f9d84653656c6c6572ff" + txInfoId = "4e16f03a5533f22adbc5097a07077f3b708b1bf74b42e6b2938dd2d4156207f0" + scriptContextTxInfo = TxInfo{..} + scriptContextPurpose = + Spending $ TxOutRef "ef6a9ef1b84bef3dad5e12d9bf128765595be4a92da45bda2599dc7fae7e2397" 1 + in + makeBenchmark + ( + makeBuiltinData + "d8799f581cd768a767450e9ffa2d68ae61e8476fb6267884e0477d7fd19703f9d84653656c6c6572ff" + ) + (makeBuiltinData "d87980") + ScriptContext{..} + (Just $ ExBudget 477988519 1726844) diff --git a/marlowe-cardano-minimal/app/Benchmark/Marlowe/Semantics.hs b/marlowe-cardano-minimal/app/Benchmark/Marlowe/Semantics.hs new file mode 100644 index 00000000000..5be4fb043d8 --- /dev/null +++ b/marlowe-cardano-minimal/app/Benchmark/Marlowe/Semantics.hs @@ -0,0 +1,169 @@ + +-- editorconfig-checker-disable-file + + +----------------------------------------------------------------------------- +-- +-- Module : $Headers +-- License : Apache 2.0 +-- +-- Stability : Experimental +-- Portability : Portable +-- +-- | Benchmarking support for Marlowe's semantics validator. +-- +----------------------------------------------------------------------------- + + +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + + +module Benchmark.Marlowe.Semantics ( + -- * Benchmarking + benchmarks +, validatorBytes +, validatorHash +, exampleBenchmark +, rescript +, writeUPLC +) where + + +import Benchmark.Marlowe (readBenchmarks, writeFlatUPLC) +import Benchmark.Marlowe.Types (Benchmark (..), makeBenchmark) +import Benchmark.Marlowe.Util (lovelace, makeBuiltinData, makeDatumMap, makeInput, makeOutput, + makeRedeemerMap, updateScriptHash) +import Data.Bifunctor (second) +import Language.Marlowe.Scripts.RolePayout (rolePayoutValidatorHash) +import Language.Marlowe.Scripts.Semantics (marloweValidator, marloweValidatorBytes, + marloweValidatorHash) +import PlutusLedgerApi.V2 (Credential (PubKeyCredential, ScriptCredential), ExBudget (ExBudget), + Extended (..), Interval (Interval), LowerBound (LowerBound), + ScriptContext (ScriptContext, scriptContextPurpose, scriptContextTxInfo), + ScriptHash, ScriptPurpose (Spending), SerialisedScript, + TxInfo (TxInfo, txInfoDCert, txInfoData, txInfoFee, txInfoId, txInfoInputs, txInfoMint, txInfoOutputs, txInfoRedeemers, txInfoReferenceInputs, txInfoSignatories, txInfoValidRange, txInfoWdrl), + TxOutRef (TxOutRef), UpperBound (UpperBound), singleton) + +import PlutusTx.AssocMap qualified as AM (empty, unionWith) + + +-- | The serialised Marlowe semantics validator. +validatorBytes :: SerialisedScript +validatorBytes = marloweValidatorBytes + + +-- | The script hash for the Marlowe semantics validator. +validatorHash :: ScriptHash +validatorHash = marloweValidatorHash + + +-- | The benchmark cases for the Marlowe semantics validator. +benchmarks :: IO (Either String [Benchmark]) +benchmarks = second (rescript <$>) <$> readBenchmarks "semantics" + + +-- | Write flat UPLC for a benchmark. +writeUPLC + :: FilePath + -> Benchmark + -> IO () +writeUPLC = writeFlatUPLC marloweValidator + + +-- | Revise the validator hashes in the benchmark's script context. +rescript + :: Benchmark + -> Benchmark +rescript benchmark@Benchmark{..} = + benchmark { + bScriptContext = + updateScriptHash + "2ed2631dbb277c84334453c5c437b86325d371f0835a28b910a91a6e" + marloweValidatorHash + $ updateScriptHash + "e165610232235bbbbeff5b998b233daae42979dec92a6722d9cda989" + rolePayoutValidatorHash + bScriptContext + } + + +{-# DEPRECATED exampleBenchmark "Experimental, not thoroughly tested." #-} + +-- | An example benchmark for the Marlowe semantics validator. +exampleBenchmark :: Benchmark +exampleBenchmark = + let + txInfoInputs = + [ + makeInput + "4a6808d88ffbceadf2bd86897bbacb9ee04131c9ccd56c998bfbcb65c0f3f471" 0 + (PubKeyCredential "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07") + (lovelace 847996471) + Nothing + Nothing + , makeInput + "4a6808d88ffbceadf2bd86897bbacb9ee04131c9ccd56c998bfbcb65c0f3f471" 1 + (ScriptCredential "626424dba5741cb1f0a3cab8643da59ffccba351495c4257f9ec3689") + (lovelace 75000000) + (Just "b4c9d042bd5fbb14431ad65769e21ccf132fd57e0c62f776dcb12961c44bd663") + Nothing + , makeInput + "db85a19c081d0beca1a63399c88fe96e64f1782699461f64e52d4cb2e26a2050" 1 + (PubKeyCredential "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07") + (singleton "8bb3b343d8e404472337966a722150048c768d0a92a9813596c5338d" "Globe" 1 <> lovelace 2000000) + Nothing + Nothing + ] + txInfoReferenceInputs = [] + txInfoOutputs = + [ + makeOutput + (PubKeyCredential "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07") + (lovelace 847801537) + Nothing + Nothing + , makeOutput + (ScriptCredential "626424dba5741cb1f0a3cab8643da59ffccba351495c4257f9ec3689") + (lovelace 75000000) + (Just "290c87ba567afe9e3eba9309c37ad993d2be7dbcbfcfaeff09f0009b3d5b2ed9") + Nothing + , makeOutput + (PubKeyCredential "0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07") + (singleton "8bb3b343d8e404472337966a722150048c768d0a92a9813596c5338d" "Globe" 1 <> lovelace 1030090) + Nothing + Nothing + ] + txInfoFee = lovelace 1164844 + txInfoMint = mempty + txInfoDCert = mempty + txInfoWdrl = AM.empty + txInfoValidRange = + Interval + (LowerBound (Finite 1684449918000) True) + (UpperBound (Finite 1684450278000) False) + txInfoSignatories = ["0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07"] + txInfoRedeemers = makeRedeemerMap scriptContextPurpose "9fd8799fd87a9fd8799f51466f756e6420476c6f626520546f6b656ed87a9f45476c6f6265ffff00ffffff" + txInfoData = + AM.unionWith const + ( + makeDatumMap + "b4c9d042bd5fbb14431ad65769e21ccf132fd57e0c62f776dcb12961c44bd663" + "d8799fd8799f581c8bb3b343d8e404472337966a722150048c768d0a92a9813596c5338dffd8799fa1d8799fd8799fd87980d8799fd8799f581c0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07ffd87a80ffffd8799f4040ffff1a047868c0a0a001ffd87c9f9fd8799fd87a9fd8799f51466f756e6420476c6f626520546f6b656ed87a9f45476c6f6265ffff9fd8799f0000ffffffd87c9f9fd8799fd87a9fd8799f50466f756e64205377616e20546f6b656ed87a9f445377616effff9fd8799f0000ffffffd87c9f9fd8799fd87a9fd8799f56466f756e64204265617247617264656e20546f6b656ed87a9f4a4265617247617264656effff9fd8799f0000ffffffd87a9fd8799fd87980d8799fd8799f581c0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07ffd87a80ffffd87a9fd87a9f45476c6f6265ffffd8799f4040ffd87a9f1a017d7840ffd87a9fd8799fd87980d8799fd8799f581c0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07ffd87a80ffffd87a9fd87a9f445377616effffd8799f4040ffd87a9f1a017d7840ffd87a9fd8799fd87980d8799fd8799f581c0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07ffd87a80ffffd87a9fd87a9f4a4265617247617264656effffd8799f4040ffd87a9f1a017d7840ffd87980ffffffffff1b0000018831ac75f0d87980ffffff1b0000018831758770d87980ffffff1b00000188313e98f0d87980ffff" + ) + ( + makeDatumMap + "290c87ba567afe9e3eba9309c37ad993d2be7dbcbfcfaeff09f0009b3d5b2ed9" + "d8799fd8799f581c8bb3b343d8e404472337966a722150048c768d0a92a9813596c5338dffd8799fa1d8799fd8799fd87980d8799fd8799f581c0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07ffd87a80ffffd8799f4040ffff1a047868c0a1d8799f51466f756e6420476c6f626520546f6b656ed87a9f45476c6f6265ffff00a01b000001883109fc30ffd87c9f9fd8799fd87a9fd8799f50466f756e64205377616e20546f6b656ed87a9f445377616effff9fd8799f0000ffffffd87c9f9fd8799fd87a9fd8799f56466f756e64204265617247617264656e20546f6b656ed87a9f4a4265617247617264656effff9fd8799f0000ffffffd87a9fd8799fd87980d8799fd8799f581c0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07ffd87a80ffffd87a9fd87a9f45476c6f6265ffffd8799f4040ffd87a9f1a017d7840ffd87a9fd8799fd87980d8799fd8799f581c0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07ffd87a80ffffd87a9fd87a9f445377616effffd8799f4040ffd87a9f1a017d7840ffd87a9fd8799fd87980d8799fd8799f581c0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07ffd87a80ffffd87a9fd87a9f4a4265617247617264656effffd8799f4040ffd87a9f1a017d7840ffd87980ffffffffff1b0000018831ac75f0d87980ffffff1b0000018831758770d87980ffff" + ) + txInfoId = "b5b18fb63795bada186cc4b3876cb9a924467f0d64984c84886b58f7a907f8db" + scriptContextTxInfo = TxInfo{..} + scriptContextPurpose = + Spending $ TxOutRef "04688f43cf473ddcc27aeef0c9ccae1d7efb97d83a1dfc946d2ab36ba91a91b9" 1 + in + makeBenchmark + (makeBuiltinData "d8799fd8799f581c8bb3b343d8e404472337966a722150048c768d0a92a9813596c5338dffd8799fa1d8799fd8799fd87980d8799fd8799f581c0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07ffd87a80ffffd8799f4040ffff1a047868c0a0a001ffd87c9f9fd8799fd87a9fd8799f51466f756e6420476c6f626520546f6b656ed87a9f45476c6f6265ffff9fd8799f0000ffffffd87c9f9fd8799fd87a9fd8799f50466f756e64205377616e20546f6b656ed87a9f445377616effff9fd8799f0000ffffffd87c9f9fd8799fd87a9fd8799f56466f756e64204265617247617264656e20546f6b656ed87a9f4a4265617247617264656effff9fd8799f0000ffffffd87a9fd8799fd87980d8799fd8799f581c0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07ffd87a80ffffd87a9fd87a9f45476c6f6265ffffd8799f4040ffd87a9f1a017d7840ffd87a9fd8799fd87980d8799fd8799f581c0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07ffd87a80ffffd87a9fd87a9f445377616effffd8799f4040ffd87a9f1a017d7840ffd87a9fd8799fd87980d8799fd8799f581c0a11b0c7e25dc5d9c63171bdf39d9741b901dc903e12b4e162348e07ffd87a80ffffd87a9fd87a9f4a4265617247617264656effffd8799f4040ffd87a9f1a017d7840ffd87980ffffffffff1b0000018831ac75f0d87980ffffff1b0000018831758770d87980ffffff1b00000188313e98f0d87980ffff") + (makeBuiltinData "9fd8799fd87a9fd8799f51466f756e6420476c6f626520546f6b656ed87a9f45476c6f6265ffff00ffffff") + ScriptContext{..} + (Just $ ExBudget 4808532 1297175159) diff --git a/marlowe-cardano-minimal/app/Benchmark/Marlowe/Types.hs b/marlowe-cardano-minimal/app/Benchmark/Marlowe/Types.hs new file mode 100644 index 00000000000..c1812954a6c --- /dev/null +++ b/marlowe-cardano-minimal/app/Benchmark/Marlowe/Types.hs @@ -0,0 +1,49 @@ + + +----------------------------------------------------------------------------- +-- +-- Module : $Headers +-- License : Apache 2.0 +-- +-- Stability : Experimental +-- Portability : Portable +-- +-- | Types for benchmarking Marlowe validators. +-- +----------------------------------------------------------------------------- + + +module Benchmark.Marlowe.Types ( + -- * Benchmarking + Benchmark(..) +, makeBenchmark +) where + + +import PlutusLedgerApi.V2 (Data, ExBudget, ScriptContext, ToData, toData) + + +-- | A benchmarking case. +data Benchmark = + Benchmark + { + bDatum :: Data -- ^ The datum. + , bRedeemer :: Data -- ^ The redeemer. + , bScriptContext :: ScriptContext -- ^ The script context. + , bReferenceCost :: Maybe ExBudget + -- ^ The previously measured execution costs in production, which uses the Plutus version on + -- August 18 2022 (commit 6ed578b592f46afc0e77f4d19e5955a6eb439ba4). + } + deriving Show + + +-- | Construct a benchmarking case. +makeBenchmark + :: ToData d + => ToData r + => d + -> r + -> ScriptContext + -> Maybe ExBudget + -> Benchmark +makeBenchmark datum redeemer = Benchmark (toData datum) (toData redeemer) diff --git a/marlowe-cardano-minimal/app/Benchmark/Marlowe/Util.hs b/marlowe-cardano-minimal/app/Benchmark/Marlowe/Util.hs new file mode 100644 index 00000000000..c2c5605733e --- /dev/null +++ b/marlowe-cardano-minimal/app/Benchmark/Marlowe/Util.hs @@ -0,0 +1,133 @@ + + +----------------------------------------------------------------------------- +-- +-- Module : $Headers +-- License : Apache 2.0 +-- +-- Stability : Experimental +-- Portability : Portable +-- +-- | Utility functions for creating script contexts. +-- +----------------------------------------------------------------------------- + + +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE RecordWildCards #-} + + +module Benchmark.Marlowe.Util ( + -- * Conversion + lovelace +, makeInput +, makeOutput +, makeRedeemerMap +, makeDatumMap +, makeBuiltinData + -- * Rewriting +, updateScriptHash +) where + + +import Codec.Serialise (deserialise) +import PlutusLedgerApi.V2 (Address (Address), BuiltinData, Credential (..), Datum (Datum), + DatumHash, LedgerBytes (getLedgerBytes), + OutputDatum (NoOutputDatum, OutputDatumHash), Redeemer (Redeemer), + ScriptContext (..), ScriptHash, ScriptPurpose, TxId, TxInInfo (..), + TxInfo (..), TxOut (..), TxOutRef (TxOutRef), Value, adaSymbol, adaToken, + dataToBuiltinData, fromBuiltin, singleton) + +import Data.ByteString.Lazy qualified as LBS (fromStrict) +import PlutusTx.AssocMap qualified as AM (Map, singleton) + + +-- | Integer to lovelace. +lovelace + :: Integer + -> Value +lovelace = singleton adaSymbol adaToken + + +-- Construct a `TxInInfo`. +makeInput + :: TxId + -> Integer + -> Credential + -> Value + -> Maybe DatumHash + -> Maybe ScriptHash + -> TxInInfo +makeInput txId txIx credential value datum script = + TxInInfo + (TxOutRef txId txIx) + (makeOutput credential value datum script) + + +-- Construct a `TxOut`. +makeOutput + :: Credential + -> Value + -> Maybe DatumHash + -> Maybe ScriptHash + -> TxOut +makeOutput credential value = + TxOut (Address credential Nothing) value + . maybe NoOutputDatum OutputDatumHash + + +-- Construct a map of redemers. +makeRedeemerMap + :: ScriptPurpose + -> LedgerBytes + -> AM.Map ScriptPurpose Redeemer +makeRedeemerMap = (. (Redeemer . makeBuiltinData)) . AM.singleton + + +-- Construct a map of datum hashes to datums. +makeDatumMap + :: DatumHash + -> LedgerBytes + -> AM.Map DatumHash Datum +makeDatumMap = (. (Datum . makeBuiltinData)) . AM.singleton + + +-- Convert ledger bytes to builtin data. +makeBuiltinData + :: LedgerBytes + -> BuiltinData +makeBuiltinData = + dataToBuiltinData + . deserialise + . LBS.fromStrict + . fromBuiltin + . getLedgerBytes + + +-- Rewrite all of a particular script hash in the script context. +updateScriptHash + :: ScriptHash + -> ScriptHash + -> ScriptContext + -> ScriptContext +updateScriptHash oldHash newHash scriptContext = + let + updateAddress address@(Address (ScriptCredential hash) stakeCredential) + | hash == oldHash = Address (ScriptCredential newHash) stakeCredential + | otherwise = address + updateAddress address = address + updateTxOut txOut@TxOut{..} = txOut {txOutAddress = updateAddress txOutAddress} + updateTxInInfo txInInfo@TxInInfo{..} = + txInInfo {txInInfoResolved = updateTxOut txInInfoResolved} + txInfo@TxInfo{..} = scriptContextTxInfo scriptContext + txInfo' = + txInfo + { + txInfoInputs = updateTxInInfo <$> txInfoInputs + , txInfoOutputs = updateTxOut <$> txInfoOutputs + } + in + scriptContext + { + scriptContextTxInfo = txInfo' + } diff --git a/marlowe-cardano-minimal/app/Main.hs b/marlowe-cardano-minimal/app/Main.hs new file mode 100644 index 00000000000..e377c46f0fb --- /dev/null +++ b/marlowe-cardano-minimal/app/Main.hs @@ -0,0 +1,102 @@ + + +----------------------------------------------------------------------------- +-- +-- Module : $Headers +-- License : Apache 2.0 +-- +-- Stability : Experimental +-- Portability : Portable +-- +-- | Run benchmarks for Marlowe validators. +-- +----------------------------------------------------------------------------- + + +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} + + +module Main ( + -- * Entry point + main +) where + + +import Benchmark.Marlowe (tabulateResults, writeFlatUPLCs) +import Benchmark.Marlowe.RolePayout qualified as RolePayout (benchmarks, validatorBytes, + validatorHash, writeUPLC) +import Benchmark.Marlowe.Semantics qualified as Semantics (benchmarks, validatorBytes, + validatorHash, writeUPLC) +import Cardano.Binary (serialize') +import Data.ByteString qualified as BS (writeFile) +import Data.ByteString.Base16 qualified as B16 (encode) +import Data.List (intercalate) +import Paths_marlowe_cardano_minimal (getDataDir) +import PlutusLedgerApi.V2 (ScriptHash, SerialisedScript) +import System.FilePath (()) + + +-- | Run the benchmarks and export information about the validators and the benchmarking results. +main :: IO () +main = + do + + -- Read the semantics benchmarks. + benchmarks <- either error id <$> Semantics.benchmarks + + -- Write the tabulation of semantics benchmark results. + writeFile "marlowe-semantics.tsv" + . unlines . fmap (intercalate "\t") + $ tabulateResults "Semantics" Semantics.validatorHash Semantics.validatorBytes benchmarks + + -- Write the flat UPLC files for the semantics benchmarks. + writeFlatUPLCs Semantics.writeUPLC benchmarks + . ( "semantics") + =<< getDataDir + + -- Print the semantics validator, and write the plutus file. + printValidator + "Semantics" + "marlowe-semantics" + Semantics.validatorHash + Semantics.validatorBytes + + -- Read the role-payout benchmarks. + benchmarks' <- either error id <$> RolePayout.benchmarks + + -- Write the tabulation of role-payout benchmark results. + writeFile "marlowe-rolepayout.tsv" + . unlines . fmap (intercalate "\t") + $ tabulateResults "Role Payout" RolePayout.validatorHash RolePayout.validatorBytes benchmarks' + + -- Write the flat UPLC files for the role-payout benchmarks. + writeFlatUPLCs RolePayout.writeUPLC benchmarks' + . ( "rolepayout") + =<< getDataDir + + -- Print the role-payout validator, and write the plutus file. + printValidator + "Role payout" + "marlowe-rolepayout" + RolePayout.validatorHash + RolePayout.validatorBytes + + +-- | Print information about a validator. +printValidator + :: String -- ^ The name of the validator. + -> FilePath -- ^ The base file path for exported files. + -> ScriptHash -- ^ The hash of the validator script. + -> SerialisedScript -- ^ The serialised validator. + -> IO () -- ^ Action to print the information about the benchmarking, and write the files. +printValidator name file hash validator = + do + putStrLn $ name <> ":" + putStrLn $ " Validator hash: " <> show hash + putStrLn $ " Validator file: " <> file <> ".plutus" + putStrLn $ " Measurements file: " <> file <> ".tsv" + BS.writeFile (file <> ".plutus") + $ "{\"type\": \"PlutusScriptV2\", \"description\": \"\", \"cborHex\": \"" + <> B16.encode (serialize' validator) <> "\"}" + putStrLn "" diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/0004000402010401030101030100040000010104020201030001000204020401.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/0004000402010401030101030100040000010104020201030001000204020401.benchmark new file mode 100644 index 00000000000..d7ecdc03eeb Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/0004000402010401030101030100040000010104020201030001000204020401.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/0100000100010000000001000100010101000101000001000000010000010000.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/0100000100010000000001000100010101000101000001000000010000010000.benchmark new file mode 100644 index 00000000000..9f4a878ddf3 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/0100000100010000000001000100010101000101000001000000010000010000.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/0101000100000101010000010101000100010101000001000001000000010101.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/0101000100000101010000010101000100010101000001000001000000010101.benchmark new file mode 100644 index 00000000000..f58cbdf9e60 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/0101000100000101010000010101000100010101000001000001000000010101.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/01dcc372ea619cb9f23c45b17b9a0a8a16b7ca0e04093ef8ecce291667a99a4c.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/01dcc372ea619cb9f23c45b17b9a0a8a16b7ca0e04093ef8ecce291667a99a4c.benchmark new file mode 100644 index 00000000000..23d8859b0f0 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/01dcc372ea619cb9f23c45b17b9a0a8a16b7ca0e04093ef8ecce291667a99a4c.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/0201020201020000020000010201020001020200000002010200000101010100.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/0201020201020000020000010201020001020200000002010200000101010100.benchmark new file mode 100644 index 00000000000..69b38df6093 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/0201020201020000020000010201020001020200000002010200000101010100.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/0202010002010100020102020102020001010101020102010001010101000100.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/0202010002010100020102020102020001010101020102010001010101000100.benchmark new file mode 100644 index 00000000000..ca730e9f4a1 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/0202010002010100020102020102020001010101020102010001010101000100.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/0303020000020001010201060303040208070100050401080304020801030001.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/0303020000020001010201060303040208070100050401080304020801030001.benchmark new file mode 100644 index 00000000000..056e69627be Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/0303020000020001010201060303040208070100050401080304020801030001.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/031d56d71454e2c4216ffaa275c4a8b3eb631109559d0e56f44ea8489f57ba97.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/031d56d71454e2c4216ffaa275c4a8b3eb631109559d0e56f44ea8489f57ba97.benchmark new file mode 100644 index 00000000000..446b4ada826 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/031d56d71454e2c4216ffaa275c4a8b3eb631109559d0e56f44ea8489f57ba97.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/03d730a62332c51c7b70c16c64da72dd1c3ea36c26b41cd1a1e00d39fda3d6cc.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/03d730a62332c51c7b70c16c64da72dd1c3ea36c26b41cd1a1e00d39fda3d6cc.benchmark new file mode 100644 index 00000000000..366e8922998 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/03d730a62332c51c7b70c16c64da72dd1c3ea36c26b41cd1a1e00d39fda3d6cc.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/0403020000030204010000030001000202010101000304030001040404030100.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/0403020000030204010000030001000202010101000304030001040404030100.benchmark new file mode 100644 index 00000000000..da53a4483f4 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/0403020000030204010000030001000202010101000304030001040404030100.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/0405010105020401010304080005050800040301010800080207080704020206.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/0405010105020401010304080005050800040301010800080207080704020206.benchmark new file mode 100644 index 00000000000..10ec2e4a078 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/0405010105020401010304080005050800040301010800080207080704020206.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/041a2c3b111139201a3a2c173c392b170e16370d300f2d28342d0f2f0e182e01.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/041a2c3b111139201a3a2c173c392b170e16370d300f2d28342d0f2f0e182e01.benchmark new file mode 100644 index 00000000000..9c37491c3e6 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/041a2c3b111139201a3a2c173c392b170e16370d300f2d28342d0f2f0e182e01.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/04f592afc6e57c633b9c55246e7c82e87258f04e2fb910c37d8e2417e9db46e5.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/04f592afc6e57c633b9c55246e7c82e87258f04e2fb910c37d8e2417e9db46e5.benchmark new file mode 100644 index 00000000000..6b1e7fe5c4f Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/04f592afc6e57c633b9c55246e7c82e87258f04e2fb910c37d8e2417e9db46e5.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/057ebc80922f16a5f4bf13e985bf586b8cff37a2f6fe0f3ce842178c16981027.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/057ebc80922f16a5f4bf13e985bf586b8cff37a2f6fe0f3ce842178c16981027.benchmark new file mode 100644 index 00000000000..cd57fcf3bed Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/057ebc80922f16a5f4bf13e985bf586b8cff37a2f6fe0f3ce842178c16981027.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/06317060a8e488b1219c9dae427f9ce27918a9e09ee8ac424afa33ca923f7954.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/06317060a8e488b1219c9dae427f9ce27918a9e09ee8ac424afa33ca923f7954.benchmark new file mode 100644 index 00000000000..15704628868 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/06317060a8e488b1219c9dae427f9ce27918a9e09ee8ac424afa33ca923f7954.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/07658a6c898ad6d624c37df1e49e909c2e9349ba7f4c0a6be5f166fe239bfcae.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/07658a6c898ad6d624c37df1e49e909c2e9349ba7f4c0a6be5f166fe239bfcae.benchmark new file mode 100644 index 00000000000..eae81c4c9fe Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/07658a6c898ad6d624c37df1e49e909c2e9349ba7f4c0a6be5f166fe239bfcae.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/0bdca1cb8fa7e38e09062557b82490714052e84e2054e913092cd84ac071b961.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/0bdca1cb8fa7e38e09062557b82490714052e84e2054e913092cd84ac071b961.benchmark new file mode 100644 index 00000000000..e8ed7880e11 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/0bdca1cb8fa7e38e09062557b82490714052e84e2054e913092cd84ac071b961.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/0c9d3634aeae7038f839a1262d1a8bc724dc77af9426459417a56ec73240f0e0.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/0c9d3634aeae7038f839a1262d1a8bc724dc77af9426459417a56ec73240f0e0.benchmark new file mode 100644 index 00000000000..a2853464e1d Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/0c9d3634aeae7038f839a1262d1a8bc724dc77af9426459417a56ec73240f0e0.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/0d0f01050a0a0a0b0b050d0404090e0d0506000d0a041003040e0f100e0a0408.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/0d0f01050a0a0a0b0b050d0404090e0d0506000d0a041003040e0f100e0a0408.benchmark new file mode 100644 index 00000000000..2b3d297ff6a Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/0d0f01050a0a0a0b0b050d0404090e0d0506000d0a041003040e0f100e0a0408.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/0dbb692d2bf22d25eeceac461cfebf616f54003077a8473abc0457f18e025960.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/0dbb692d2bf22d25eeceac461cfebf616f54003077a8473abc0457f18e025960.benchmark new file mode 100644 index 00000000000..4fffa4c315b Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/0dbb692d2bf22d25eeceac461cfebf616f54003077a8473abc0457f18e025960.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/0e00171d0f1e1f14070d0a00091f07101808021d081e1b120219081312081e15.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/0e00171d0f1e1f14070d0a00091f07101808021d081e1b120219081312081e15.benchmark new file mode 100644 index 00000000000..5e867c0e9f6 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/0e00171d0f1e1f14070d0a00091f07101808021d081e1b120219081312081e15.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/0e72f62b0f922e31a2340baccc768104025400cf7fdd7dae62fbba5fc770936d.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/0e72f62b0f922e31a2340baccc768104025400cf7fdd7dae62fbba5fc770936d.benchmark new file mode 100644 index 00000000000..bfa27f4a500 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/0e72f62b0f922e31a2340baccc768104025400cf7fdd7dae62fbba5fc770936d.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/0e97c9d9417354d9460f2eb35018d3904b7b035af16ab299258adab93be0911a.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/0e97c9d9417354d9460f2eb35018d3904b7b035af16ab299258adab93be0911a.benchmark new file mode 100644 index 00000000000..93f7dbad903 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/0e97c9d9417354d9460f2eb35018d3904b7b035af16ab299258adab93be0911a.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/0f010d040810040b10020e040f0e030b0a0d100f0c080c0c05000d04100c100f.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/0f010d040810040b10020e040f0e030b0a0d100f0c080c0c05000d04100c100f.benchmark new file mode 100644 index 00000000000..ea6c37ede28 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/0f010d040810040b10020e040f0e030b0a0d100f0c080c0c05000d04100c100f.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/1138a04a83edc0579053f9ffa9394b41df38230121fbecebee8c039776a88c0c.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/1138a04a83edc0579053f9ffa9394b41df38230121fbecebee8c039776a88c0c.benchmark new file mode 100644 index 00000000000..ec0d5fe9e41 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/1138a04a83edc0579053f9ffa9394b41df38230121fbecebee8c039776a88c0c.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/121a0a1b12030616111f02121a0e070716090a0e031c071419121f141409031d.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/121a0a1b12030616111f02121a0e070716090a0e031c071419121f141409031d.benchmark new file mode 100644 index 00000000000..bd2e0ebda9a Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/121a0a1b12030616111f02121a0e070716090a0e031c071419121f141409031d.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/159e5a1bf16fe984b5569be7011b61b5e98f5d2839ca7e1b34c7f2afc7ffb58e.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/159e5a1bf16fe984b5569be7011b61b5e98f5d2839ca7e1b34c7f2afc7ffb58e.benchmark new file mode 100644 index 00000000000..5b061a190aa Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/159e5a1bf16fe984b5569be7011b61b5e98f5d2839ca7e1b34c7f2afc7ffb58e.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/195f522b596360690d04586a2563470f2214163435331a6622311f7323433f1c.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/195f522b596360690d04586a2563470f2214163435331a6622311f7323433f1c.benchmark new file mode 100644 index 00000000000..37bbc2ee7fc Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/195f522b596360690d04586a2563470f2214163435331a6622311f7323433f1c.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/1a20b465d48a585ffd622bd8dc26a498a3c12f930ab4feab3a5064cfb3bc536a.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/1a20b465d48a585ffd622bd8dc26a498a3c12f930ab4feab3a5064cfb3bc536a.benchmark new file mode 100644 index 00000000000..f6649545f07 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/1a20b465d48a585ffd622bd8dc26a498a3c12f930ab4feab3a5064cfb3bc536a.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/211e1b6c10260c4620074d2e372c260d38643a3d605f63772524034f0a4a7632.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/211e1b6c10260c4620074d2e372c260d38643a3d605f63772524034f0a4a7632.benchmark new file mode 100644 index 00000000000..4bd50259b60 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/211e1b6c10260c4620074d2e372c260d38643a3d605f63772524034f0a4a7632.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/21a1426fb3fb3019d5dc93f210152e90b0a6e740ef509b1cdd423395f010e0ca.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/21a1426fb3fb3019d5dc93f210152e90b0a6e740ef509b1cdd423395f010e0ca.benchmark new file mode 100644 index 00000000000..f96aeef1ec7 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/21a1426fb3fb3019d5dc93f210152e90b0a6e740ef509b1cdd423395f010e0ca.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/224ce46046fab9a17be4197622825f45cc0c59a6bd1604405148e43768c487ef.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/224ce46046fab9a17be4197622825f45cc0c59a6bd1604405148e43768c487ef.benchmark new file mode 100644 index 00000000000..e24b60faada Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/224ce46046fab9a17be4197622825f45cc0c59a6bd1604405148e43768c487ef.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/332c2b1c11383d1b373e1315201f1128010e0e1518332f273f141b23243f2a07.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/332c2b1c11383d1b373e1315201f1128010e0e1518332f273f141b23243f2a07.benchmark new file mode 100644 index 00000000000..a3f10cddf28 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/332c2b1c11383d1b373e1315201f1128010e0e1518332f273f141b23243f2a07.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/3565ee025317e065e8555eef288080276716366769aad89e03389f5ec4ce26d7.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/3565ee025317e065e8555eef288080276716366769aad89e03389f5ec4ce26d7.benchmark new file mode 100644 index 00000000000..ef95d601c53 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/3565ee025317e065e8555eef288080276716366769aad89e03389f5ec4ce26d7.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/3569299fc986f5354d02e627a9eaa48ab46d5af52722307a0af72bae87e256dc.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/3569299fc986f5354d02e627a9eaa48ab46d5af52722307a0af72bae87e256dc.benchmark new file mode 100644 index 00000000000..c9dd73bdb0c Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/3569299fc986f5354d02e627a9eaa48ab46d5af52722307a0af72bae87e256dc.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/36866914aa07cf62ef36cf2cd64c7f240e3371e27bb9fff5464301678e809c40.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/36866914aa07cf62ef36cf2cd64c7f240e3371e27bb9fff5464301678e809c40.benchmark new file mode 100644 index 00000000000..71e8822cf7c Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/36866914aa07cf62ef36cf2cd64c7f240e3371e27bb9fff5464301678e809c40.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/371c10d2526fc0f09dbe9ed59e44dcd949270b27dc42035addd7ff9f7e0d05e7.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/371c10d2526fc0f09dbe9ed59e44dcd949270b27dc42035addd7ff9f7e0d05e7.benchmark new file mode 100644 index 00000000000..49ea993b9a0 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/371c10d2526fc0f09dbe9ed59e44dcd949270b27dc42035addd7ff9f7e0d05e7.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/3897ef714bba3e6821495b706c75f8d64264c3fdaa58a3826c808b5a768c303d.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/3897ef714bba3e6821495b706c75f8d64264c3fdaa58a3826c808b5a768c303d.benchmark new file mode 100644 index 00000000000..843bc49533e Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/3897ef714bba3e6821495b706c75f8d64264c3fdaa58a3826c808b5a768c303d.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/4121d88f14387d33ac5e1329618068e3848445cdd66b29e5ba382be2e02a174a.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/4121d88f14387d33ac5e1329618068e3848445cdd66b29e5ba382be2e02a174a.benchmark new file mode 100644 index 00000000000..e09a0f12bc9 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/4121d88f14387d33ac5e1329618068e3848445cdd66b29e5ba382be2e02a174a.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/4299c7fcf093a5dbfe114c188e32ca199b571a7c25cb7f766bf49f12dab308be.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/4299c7fcf093a5dbfe114c188e32ca199b571a7c25cb7f766bf49f12dab308be.benchmark new file mode 100644 index 00000000000..e7fb421870a Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/4299c7fcf093a5dbfe114c188e32ca199b571a7c25cb7f766bf49f12dab308be.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/452e17d16222a427707fa83f63ffb79f606cc25c755a18b1e3274c964ed5ec99.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/452e17d16222a427707fa83f63ffb79f606cc25c755a18b1e3274c964ed5ec99.benchmark new file mode 100644 index 00000000000..8ecd4b12728 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/452e17d16222a427707fa83f63ffb79f606cc25c755a18b1e3274c964ed5ec99.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/46f8d00030436e4da490a86b331fa6c3251425fb8c19556080e124d75bad7bd6.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/46f8d00030436e4da490a86b331fa6c3251425fb8c19556080e124d75bad7bd6.benchmark new file mode 100644 index 00000000000..4bce1b9f832 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/46f8d00030436e4da490a86b331fa6c3251425fb8c19556080e124d75bad7bd6.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/47364cfaf2c00f7d633283dce6cf84e4fd4e8228c0a0aa50e7c55f35c3ecaa1c.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/47364cfaf2c00f7d633283dce6cf84e4fd4e8228c0a0aa50e7c55f35c3ecaa1c.benchmark new file mode 100644 index 00000000000..6c34f368e7e Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/47364cfaf2c00f7d633283dce6cf84e4fd4e8228c0a0aa50e7c55f35c3ecaa1c.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/49b8275d0cb817be40865694ab05e3cfe5fc35fb43b78e7de68c1f3519b536bd.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/49b8275d0cb817be40865694ab05e3cfe5fc35fb43b78e7de68c1f3519b536bd.benchmark new file mode 100644 index 00000000000..fe1647e942b Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/49b8275d0cb817be40865694ab05e3cfe5fc35fb43b78e7de68c1f3519b536bd.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/4dd7755b6ca1f0c9747c1fc0ee4da799f6f1c07108e980bd9f820911ad711ff2.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/4dd7755b6ca1f0c9747c1fc0ee4da799f6f1c07108e980bd9f820911ad711ff2.benchmark new file mode 100644 index 00000000000..d893b8b7a2b Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/4dd7755b6ca1f0c9747c1fc0ee4da799f6f1c07108e980bd9f820911ad711ff2.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/4fbcfdb577a56b842d6f6938187a783f71d9da7519353e3da3ef0c564e1eb344.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/4fbcfdb577a56b842d6f6938187a783f71d9da7519353e3da3ef0c564e1eb344.benchmark new file mode 100644 index 00000000000..535ed7c7838 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/4fbcfdb577a56b842d6f6938187a783f71d9da7519353e3da3ef0c564e1eb344.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/5a0725d49c733130eda8bc6ed5234f7f6ff8c9dd2d201e8806125e5fbcc081f9.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/5a0725d49c733130eda8bc6ed5234f7f6ff8c9dd2d201e8806125e5fbcc081f9.benchmark new file mode 100644 index 00000000000..63f60112141 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/5a0725d49c733130eda8bc6ed5234f7f6ff8c9dd2d201e8806125e5fbcc081f9.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/5a2aae344e569a2c644dd9fa8c7b1f129850937eb562b7748c275f9e40bed596.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/5a2aae344e569a2c644dd9fa8c7b1f129850937eb562b7748c275f9e40bed596.benchmark new file mode 100644 index 00000000000..4828ec1f13e Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/5a2aae344e569a2c644dd9fa8c7b1f129850937eb562b7748c275f9e40bed596.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/5ade103e9530dd0d572fe1b053ea65ad925c6ebbe321e873ace8b804363fa82c.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/5ade103e9530dd0d572fe1b053ea65ad925c6ebbe321e873ace8b804363fa82c.benchmark new file mode 100644 index 00000000000..9850703b81a Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/5ade103e9530dd0d572fe1b053ea65ad925c6ebbe321e873ace8b804363fa82c.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/5d4c62a0671c65a14f6a15093e3efc4f1816d95a5a58fd92486bedaae8d9526b.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/5d4c62a0671c65a14f6a15093e3efc4f1816d95a5a58fd92486bedaae8d9526b.benchmark new file mode 100644 index 00000000000..ff44139e129 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/5d4c62a0671c65a14f6a15093e3efc4f1816d95a5a58fd92486bedaae8d9526b.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/5efe992e306e31cc857c64a62436ad2f9325acc5b4a74a8cebccdfd853ce63d2.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/5efe992e306e31cc857c64a62436ad2f9325acc5b4a74a8cebccdfd853ce63d2.benchmark new file mode 100644 index 00000000000..f893967f770 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/5efe992e306e31cc857c64a62436ad2f9325acc5b4a74a8cebccdfd853ce63d2.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/622a7f3bc611b5149253c9189da022a9ff296f60a5b7c172a6dc286faa7284fa.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/622a7f3bc611b5149253c9189da022a9ff296f60a5b7c172a6dc286faa7284fa.benchmark new file mode 100644 index 00000000000..fb0a7e4cc46 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/622a7f3bc611b5149253c9189da022a9ff296f60a5b7c172a6dc286faa7284fa.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/6621a69217f09d91f42876a9c0cecf79de0e29bdd5b16c82c6c52cf959092ec4.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/6621a69217f09d91f42876a9c0cecf79de0e29bdd5b16c82c6c52cf959092ec4.benchmark new file mode 100644 index 00000000000..29398478b3a Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/6621a69217f09d91f42876a9c0cecf79de0e29bdd5b16c82c6c52cf959092ec4.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/674b0577409957172ad85223c765d17e94c27714276c49c38dfae0a47a561a1e.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/674b0577409957172ad85223c765d17e94c27714276c49c38dfae0a47a561a1e.benchmark new file mode 100644 index 00000000000..872dfcaf594 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/674b0577409957172ad85223c765d17e94c27714276c49c38dfae0a47a561a1e.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/6b7bc2b9002a71b33cfd535d43f26334a283d0b9ad189b7cd74baac232c3b9fc.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/6b7bc2b9002a71b33cfd535d43f26334a283d0b9ad189b7cd74baac232c3b9fc.benchmark new file mode 100644 index 00000000000..4a9195bc8bd Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/6b7bc2b9002a71b33cfd535d43f26334a283d0b9ad189b7cd74baac232c3b9fc.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/6c364699767a84059ffd99cf718562a8c09d96e343f23dc481e8ffda13af424f.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/6c364699767a84059ffd99cf718562a8c09d96e343f23dc481e8ffda13af424f.benchmark new file mode 100644 index 00000000000..9c4bb5cc780 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/6c364699767a84059ffd99cf718562a8c09d96e343f23dc481e8ffda13af424f.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/6d66bddb4269bdf77392d3894da5341cf019d39787522af4f83f01285991e93c.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/6d66bddb4269bdf77392d3894da5341cf019d39787522af4f83f01285991e93c.benchmark new file mode 100644 index 00000000000..05c01776896 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/6d66bddb4269bdf77392d3894da5341cf019d39787522af4f83f01285991e93c.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/73f044f34a30f26639c58bafe952047f74c7bf1eafebab5aadf5b73cfb9024ed.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/73f044f34a30f26639c58bafe952047f74c7bf1eafebab5aadf5b73cfb9024ed.benchmark new file mode 100644 index 00000000000..5c7883e1a15 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/73f044f34a30f26639c58bafe952047f74c7bf1eafebab5aadf5b73cfb9024ed.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/7b1dd76edc27f00eb382bf996378155baf74d6a7c6f3d5ec837c39d29784aade.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/7b1dd76edc27f00eb382bf996378155baf74d6a7c6f3d5ec837c39d29784aade.benchmark new file mode 100644 index 00000000000..e94f5dfe2cd Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/7b1dd76edc27f00eb382bf996378155baf74d6a7c6f3d5ec837c39d29784aade.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/803eae94d62e2afc0e835c204af8362170301bc329e2d849d5f5a47dddf479ec.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/803eae94d62e2afc0e835c204af8362170301bc329e2d849d5f5a47dddf479ec.benchmark new file mode 100644 index 00000000000..422594d0090 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/803eae94d62e2afc0e835c204af8362170301bc329e2d849d5f5a47dddf479ec.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/87167fc5469adac97c1be749326fa79a6b7862ce68aa4abcb438e3c034bd0899.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/87167fc5469adac97c1be749326fa79a6b7862ce68aa4abcb438e3c034bd0899.benchmark new file mode 100644 index 00000000000..ce10e88b2d7 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/87167fc5469adac97c1be749326fa79a6b7862ce68aa4abcb438e3c034bd0899.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/8c0fa5d9d6724c5c72c67e055d4bfc36a385ded7c3c81c08cdbd8705829af6e6.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/8c0fa5d9d6724c5c72c67e055d4bfc36a385ded7c3c81c08cdbd8705829af6e6.benchmark new file mode 100644 index 00000000000..85d3a75283c Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/8c0fa5d9d6724c5c72c67e055d4bfc36a385ded7c3c81c08cdbd8705829af6e6.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/962c2c658b19904372984a56409707401e64e9b03c1986647134cfd329ec5139.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/962c2c658b19904372984a56409707401e64e9b03c1986647134cfd329ec5139.benchmark new file mode 100644 index 00000000000..aa0e6d1bbf3 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/962c2c658b19904372984a56409707401e64e9b03c1986647134cfd329ec5139.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/996804e90f2c75fe68886fc8511304b8ab9b36785f8858f5cb098e91c159dde9.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/996804e90f2c75fe68886fc8511304b8ab9b36785f8858f5cb098e91c159dde9.benchmark new file mode 100644 index 00000000000..0a3114e7a41 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/996804e90f2c75fe68886fc8511304b8ab9b36785f8858f5cb098e91c159dde9.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/a004a989c005d59043f996500e110fa756ad1b85800b889d5815a0106388e1d7.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/a004a989c005d59043f996500e110fa756ad1b85800b889d5815a0106388e1d7.benchmark new file mode 100644 index 00000000000..2b476c402b6 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/a004a989c005d59043f996500e110fa756ad1b85800b889d5815a0106388e1d7.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/a0fba5740174b5cd24036c8b008cb1efde73f1edae097b9325c6117a0ff40d3b.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/a0fba5740174b5cd24036c8b008cb1efde73f1edae097b9325c6117a0ff40d3b.benchmark new file mode 100644 index 00000000000..4a915fc6138 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/a0fba5740174b5cd24036c8b008cb1efde73f1edae097b9325c6117a0ff40d3b.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/a1b25347409c3993feca1a60b6fcaf93d1d4bbaae19ab06fdf50cedc26cee68d.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/a1b25347409c3993feca1a60b6fcaf93d1d4bbaae19ab06fdf50cedc26cee68d.benchmark new file mode 100644 index 00000000000..efe2361aea3 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/a1b25347409c3993feca1a60b6fcaf93d1d4bbaae19ab06fdf50cedc26cee68d.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/a27524cfad019df45e4e8316f927346d4cc39da6bdd294fb2c33c3f58e6a8994.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/a27524cfad019df45e4e8316f927346d4cc39da6bdd294fb2c33c3f58e6a8994.benchmark new file mode 100644 index 00000000000..1502bda1a8c Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/a27524cfad019df45e4e8316f927346d4cc39da6bdd294fb2c33c3f58e6a8994.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/a6664a2d2a82f370a34a36a45234f6b33120a39372331678a3b3690312560ce9.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/a6664a2d2a82f370a34a36a45234f6b33120a39372331678a3b3690312560ce9.benchmark new file mode 100644 index 00000000000..912c75daf22 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/a6664a2d2a82f370a34a36a45234f6b33120a39372331678a3b3690312560ce9.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/a6f064b83b31032ea7f25921364727224707268e472a569f584cc6b1d8c017e8.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/a6f064b83b31032ea7f25921364727224707268e472a569f584cc6b1d8c017e8.benchmark new file mode 100644 index 00000000000..aa6aa2bb5e4 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/a6f064b83b31032ea7f25921364727224707268e472a569f584cc6b1d8c017e8.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/a7cb09f417c3f089619fe25b7624392026382b458486129efcff18f8912bf302.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/a7cb09f417c3f089619fe25b7624392026382b458486129efcff18f8912bf302.benchmark new file mode 100644 index 00000000000..b83eb241dc1 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/a7cb09f417c3f089619fe25b7624392026382b458486129efcff18f8912bf302.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/a92b4072cb8601fa697e1150c08463b14ffced54eb963df08d322216e27373cb.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/a92b4072cb8601fa697e1150c08463b14ffced54eb963df08d322216e27373cb.benchmark new file mode 100644 index 00000000000..65607be3574 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/a92b4072cb8601fa697e1150c08463b14ffced54eb963df08d322216e27373cb.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/af2e072b5adfaa7211e0b341e1f7319c4f4e7364a4247c9247132a927e914753.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/af2e072b5adfaa7211e0b341e1f7319c4f4e7364a4247c9247132a927e914753.benchmark new file mode 100644 index 00000000000..fe96c3fdc14 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/af2e072b5adfaa7211e0b341e1f7319c4f4e7364a4247c9247132a927e914753.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/b43564af5f13cc5208b92b1ad6d45369446f378d3891e5cb3e353b30d4f3fb10.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/b43564af5f13cc5208b92b1ad6d45369446f378d3891e5cb3e353b30d4f3fb10.benchmark new file mode 100644 index 00000000000..e78e42f0771 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/b43564af5f13cc5208b92b1ad6d45369446f378d3891e5cb3e353b30d4f3fb10.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/b6243a5b4c353ce4852aa41705111d57867d2783eeef76f6d59beb2360da6e90.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/b6243a5b4c353ce4852aa41705111d57867d2783eeef76f6d59beb2360da6e90.benchmark new file mode 100644 index 00000000000..75f1c7f75fa Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/b6243a5b4c353ce4852aa41705111d57867d2783eeef76f6d59beb2360da6e90.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/b869f3928200061abb1c3060425b9354b0e08cbf4400b340b8707c14b34317cd.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/b869f3928200061abb1c3060425b9354b0e08cbf4400b340b8707c14b34317cd.benchmark new file mode 100644 index 00000000000..5d3de28f6c0 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/b869f3928200061abb1c3060425b9354b0e08cbf4400b340b8707c14b34317cd.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/bcdbc576d63b0454100ad06893812edafc2e7e4934fec1b44e2d06eb34f36eb8.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/bcdbc576d63b0454100ad06893812edafc2e7e4934fec1b44e2d06eb34f36eb8.benchmark new file mode 100644 index 00000000000..68dc7c26b22 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/bcdbc576d63b0454100ad06893812edafc2e7e4934fec1b44e2d06eb34f36eb8.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/bd460b7549b70c52e37b312a4242041eac18fe4a266f018bcea0c78a9085a271.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/bd460b7549b70c52e37b312a4242041eac18fe4a266f018bcea0c78a9085a271.benchmark new file mode 100644 index 00000000000..e7184b64d6e Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/bd460b7549b70c52e37b312a4242041eac18fe4a266f018bcea0c78a9085a271.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/bd79f4a84db23b7c4cd219d498bd581e085cbc3437957e74a8862281a700700b.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/bd79f4a84db23b7c4cd219d498bd581e085cbc3437957e74a8862281a700700b.benchmark new file mode 100644 index 00000000000..c912f1ad41e Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/bd79f4a84db23b7c4cd219d498bd581e085cbc3437957e74a8862281a700700b.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/c11490431db3a92efdda70933ba411a0423935e73a75c856e326dbcf6672f3bf.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/c11490431db3a92efdda70933ba411a0423935e73a75c856e326dbcf6672f3bf.benchmark new file mode 100644 index 00000000000..6204921a8ca Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/c11490431db3a92efdda70933ba411a0423935e73a75c856e326dbcf6672f3bf.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/c4d4c88c5fe378a25a034025994a0d0b1642f10c8e6e513f872327fa895bfc7e.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/c4d4c88c5fe378a25a034025994a0d0b1642f10c8e6e513f872327fa895bfc7e.benchmark new file mode 100644 index 00000000000..e5061123c87 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/c4d4c88c5fe378a25a034025994a0d0b1642f10c8e6e513f872327fa895bfc7e.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/c78eeba7681d2ab51b4758efa4c812cc041928837c6e7563d8283cce67ce2e02.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/c78eeba7681d2ab51b4758efa4c812cc041928837c6e7563d8283cce67ce2e02.benchmark new file mode 100644 index 00000000000..8d7b0e89c9f Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/c78eeba7681d2ab51b4758efa4c812cc041928837c6e7563d8283cce67ce2e02.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/c99ecc2146ce2066ba6dffc734923264f8794815acbc2ec74c2c2c42ba272e4d.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/c99ecc2146ce2066ba6dffc734923264f8794815acbc2ec74c2c2c42ba272e4d.benchmark new file mode 100644 index 00000000000..82ae8b791ee Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/c99ecc2146ce2066ba6dffc734923264f8794815acbc2ec74c2c2c42ba272e4d.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/caa409c40e39aed9b0f59214b4baa178c375526dea6026b4552b88d2cc729716.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/caa409c40e39aed9b0f59214b4baa178c375526dea6026b4552b88d2cc729716.benchmark new file mode 100644 index 00000000000..d801f2c8e0c Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/caa409c40e39aed9b0f59214b4baa178c375526dea6026b4552b88d2cc729716.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/cb2ab8e22d1f64e8d204dece092e90e9bf1fa8b2a6e9cba5012dbe4978065832.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/cb2ab8e22d1f64e8d204dece092e90e9bf1fa8b2a6e9cba5012dbe4978065832.benchmark new file mode 100644 index 00000000000..025b4c1c85a Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/cb2ab8e22d1f64e8d204dece092e90e9bf1fa8b2a6e9cba5012dbe4978065832.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/cc1e82927f6c65b3e912200ae30588793d2066e1d4a6627c21955944ac9bd528.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/cc1e82927f6c65b3e912200ae30588793d2066e1d4a6627c21955944ac9bd528.benchmark new file mode 100644 index 00000000000..cb8b78c80af Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/cc1e82927f6c65b3e912200ae30588793d2066e1d4a6627c21955944ac9bd528.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/d5cda74eb0947e025e02fb8ed365df39d0a43e4b42cd3573ac2d8fcb29115997.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/d5cda74eb0947e025e02fb8ed365df39d0a43e4b42cd3573ac2d8fcb29115997.benchmark new file mode 100644 index 00000000000..e2545610903 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/d5cda74eb0947e025e02fb8ed365df39d0a43e4b42cd3573ac2d8fcb29115997.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/d6bc8ac4155e22300085784148bbc9d9bbfea896e1009dd396610a90e3943032.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/d6bc8ac4155e22300085784148bbc9d9bbfea896e1009dd396610a90e3943032.benchmark new file mode 100644 index 00000000000..d7cb2a55248 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/d6bc8ac4155e22300085784148bbc9d9bbfea896e1009dd396610a90e3943032.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/da353bf9219801fa1bf703fc161497570954e9af7e10ffe95c911a9ef97e77bd.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/da353bf9219801fa1bf703fc161497570954e9af7e10ffe95c911a9ef97e77bd.benchmark new file mode 100644 index 00000000000..1b60c871a2d Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/da353bf9219801fa1bf703fc161497570954e9af7e10ffe95c911a9ef97e77bd.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/dc45c5f1b700b1334db99f50823321daaef0e6925b9b2fabbc9df7cde65af62e.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/dc45c5f1b700b1334db99f50823321daaef0e6925b9b2fabbc9df7cde65af62e.benchmark new file mode 100644 index 00000000000..df85576685c Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/dc45c5f1b700b1334db99f50823321daaef0e6925b9b2fabbc9df7cde65af62e.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/df487b2fd5c1583fa33644423849bc1ab5f02f37edc0c235f34ef01cb12604f6.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/df487b2fd5c1583fa33644423849bc1ab5f02f37edc0c235f34ef01cb12604f6.benchmark new file mode 100644 index 00000000000..3ff5b89910d Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/df487b2fd5c1583fa33644423849bc1ab5f02f37edc0c235f34ef01cb12604f6.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/eabeeae18131af89fa57936c0e9eb8d2c7adba534f7e1a517d75410028fa0d6c.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/eabeeae18131af89fa57936c0e9eb8d2c7adba534f7e1a517d75410028fa0d6c.benchmark new file mode 100644 index 00000000000..0fb024b798b Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/eabeeae18131af89fa57936c0e9eb8d2c7adba534f7e1a517d75410028fa0d6c.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/ec4712ee820eb959a43ebedfab6735f2325fa52994747526ffd2a4f4f84dd58e.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/ec4712ee820eb959a43ebedfab6735f2325fa52994747526ffd2a4f4f84dd58e.benchmark new file mode 100644 index 00000000000..4db7ab00048 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/ec4712ee820eb959a43ebedfab6735f2325fa52994747526ffd2a4f4f84dd58e.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/ee3962fbd7373360f46decef3c9bda536a0b1daf6cda3b8a4bcfd6deeb5b4c53.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/ee3962fbd7373360f46decef3c9bda536a0b1daf6cda3b8a4bcfd6deeb5b4c53.benchmark new file mode 100644 index 00000000000..bf390662259 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/ee3962fbd7373360f46decef3c9bda536a0b1daf6cda3b8a4bcfd6deeb5b4c53.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/f1a1e6a487f91feca5606f72bbb1e948c71abf043c6a0ea83bfea9ec6a0f08d8.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/f1a1e6a487f91feca5606f72bbb1e948c71abf043c6a0ea83bfea9ec6a0f08d8.benchmark new file mode 100644 index 00000000000..681822c96fa Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/f1a1e6a487f91feca5606f72bbb1e948c71abf043c6a0ea83bfea9ec6a0f08d8.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/f2932e4ca4bbb94b0a9ffbe95fcb7bd5639d9751d75d56d5e14efa5bbed981df.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/f2932e4ca4bbb94b0a9ffbe95fcb7bd5639d9751d75d56d5e14efa5bbed981df.benchmark new file mode 100644 index 00000000000..fe7bc17b0af Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/f2932e4ca4bbb94b0a9ffbe95fcb7bd5639d9751d75d56d5e14efa5bbed981df.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/f53e8cafe26647ccce51e4c31db13608aea1f39034c0f52dee2e5634ef66e747.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/f53e8cafe26647ccce51e4c31db13608aea1f39034c0f52dee2e5634ef66e747.benchmark new file mode 100644 index 00000000000..9af3904cdd4 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/f53e8cafe26647ccce51e4c31db13608aea1f39034c0f52dee2e5634ef66e747.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/f7275afb60e33a550df13a132102e7e925dd28965a4efbe510a89b077ff9417f.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/f7275afb60e33a550df13a132102e7e925dd28965a4efbe510a89b077ff9417f.benchmark new file mode 100644 index 00000000000..867ae04f912 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/f7275afb60e33a550df13a132102e7e925dd28965a4efbe510a89b077ff9417f.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/fc8c5f45ffcdb024c21e0f34b22c23de8045a94d5e1a5bda1555c45ddb059f82.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/fc8c5f45ffcdb024c21e0f34b22c23de8045a94d5e1a5bda1555c45ddb059f82.benchmark new file mode 100644 index 00000000000..1750369a420 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/fc8c5f45ffcdb024c21e0f34b22c23de8045a94d5e1a5bda1555c45ddb059f82.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/rolepayout/ff38b1ec89952d0247630f107a90cbbeb92ecbfcd19b284f60255718e4ec7548.benchmark b/marlowe-cardano-minimal/benchmarks/rolepayout/ff38b1ec89952d0247630f107a90cbbeb92ecbfcd19b284f60255718e4ec7548.benchmark new file mode 100644 index 00000000000..f7cbffd4895 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/rolepayout/ff38b1ec89952d0247630f107a90cbbeb92ecbfcd19b284f60255718e4ec7548.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/0000020002010200020101020201000100010001020101020201010000020102.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/0000020002010200020101020201000100010001020101020201010000020102.benchmark new file mode 100644 index 00000000000..d9e34633134 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/0000020002010200020101020201000100010001020101020201010000020102.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/0001000101000000010101000001000001010101010100000001000001010000.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/0001000101000000010101000001000001010101010100000001000001010000.benchmark new file mode 100644 index 00000000000..c903ad4c5e4 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/0001000101000000010101000001000001010101010100000001000001010000.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/0003040402030103010203030303000200000104030002040304020400000102.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/0003040402030103010203030303000200000104030002040304020400000102.benchmark new file mode 100644 index 00000000000..8a317ef10f7 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/0003040402030103010203030303000200000104030002040304020400000102.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/004025fd712d6c325ffa12c16d157064192992faf62e0b991d7310a2f91666b8.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/004025fd712d6c325ffa12c16d157064192992faf62e0b991d7310a2f91666b8.benchmark new file mode 100644 index 00000000000..56bf7db5ce0 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/004025fd712d6c325ffa12c16d157064192992faf62e0b991d7310a2f91666b8.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/0101010001010101010101000100010100000001010000010001000001000101.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/0101010001010101010101000100010100000001010000010001000001000101.benchmark new file mode 100644 index 00000000000..765af6c0e15 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/0101010001010101010101000100010100000001010000010001000001000101.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/0101020201010201010200010102000201000201010102000102010201010000.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/0101020201010201010200010102000201000201010102000102010201010000.benchmark new file mode 100644 index 00000000000..b23bd32de44 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/0101020201010201010200010102000201000201010102000102010201010000.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/0101080808040600020306010000000302050807010208060100070207080202.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/0101080808040600020306010000000302050807010208060100070207080202.benchmark new file mode 100644 index 00000000000..3fe77f75cdd Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/0101080808040600020306010000000302050807010208060100070207080202.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/0104010200020000040103020102020004040300030304040400010301040303.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/0104010200020000040103020102020004040300030304040400010301040303.benchmark new file mode 100644 index 00000000000..550e48de8b9 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/0104010200020000040103020102020004040300030304040400010301040303.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/04000f0b04051006000e060f09080d0b090d0104050a0b0f0506070f0a070008.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/04000f0b04051006000e060f09080d0b090d0104050a0b0f0506070f0a070008.benchmark new file mode 100644 index 00000000000..b76449ceb8f Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/04000f0b04051006000e060f09080d0b090d0104050a0b0f0506070f0a070008.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/0543a00ba1f63076c1db6bf94c6ff13ae7d266dd7544678743890b0e8e1add63.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/0543a00ba1f63076c1db6bf94c6ff13ae7d266dd7544678743890b0e8e1add63.benchmark new file mode 100644 index 00000000000..6828322d121 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/0543a00ba1f63076c1db6bf94c6ff13ae7d266dd7544678743890b0e8e1add63.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/0705030002040601010206030604080208020207000101060706050502040301.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/0705030002040601010206030604080208020207000101060706050502040301.benchmark new file mode 100644 index 00000000000..26f42be9852 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/0705030002040601010206030604080208020207000101060706050502040301.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/07070c070510030509010e050d00040907050e0a0d06030f1006030701020607.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/07070c070510030509010e050d00040907050e0a0d06030f1006030701020607.benchmark new file mode 100644 index 00000000000..0a339b6023a Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/07070c070510030509010e050d00040907050e0a0d06030f1006030701020607.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/0bcfd9487614104ec48de2ea0b2c0979866a95115748c026f9ec129384c262c4.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/0bcfd9487614104ec48de2ea0b2c0979866a95115748c026f9ec129384c262c4.benchmark new file mode 100644 index 00000000000..d5f54dcc5d1 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/0bcfd9487614104ec48de2ea0b2c0979866a95115748c026f9ec129384c262c4.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/0be82588e4e4bf2ef428d2f44b7687bbb703031d8de696d90ec789e70d6bc1d8.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/0be82588e4e4bf2ef428d2f44b7687bbb703031d8de696d90ec789e70d6bc1d8.benchmark new file mode 100644 index 00000000000..d9c99e040fa Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/0be82588e4e4bf2ef428d2f44b7687bbb703031d8de696d90ec789e70d6bc1d8.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/0f1d0110001b121d051e15140c0c05141d151c1f1d201c040f10091b020a0e1a.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/0f1d0110001b121d051e15140c0c05141d151c1f1d201c040f10091b020a0e1a.benchmark new file mode 100644 index 00000000000..4a350683ec3 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/0f1d0110001b121d051e15140c0c05141d151c1f1d201c040f10091b020a0e1a.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/119fbea4164e2bf21d2b53aa6c2c4e79414fe55e4096f5ce2e804735a7fbaf91.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/119fbea4164e2bf21d2b53aa6c2c4e79414fe55e4096f5ce2e804735a7fbaf91.benchmark new file mode 100644 index 00000000000..818dfcb4295 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/119fbea4164e2bf21d2b53aa6c2c4e79414fe55e4096f5ce2e804735a7fbaf91.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/12910f24d994d451ff379b12c9d1ecdb9239c9b87e5d7bea570087ec506935d5.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/12910f24d994d451ff379b12c9d1ecdb9239c9b87e5d7bea570087ec506935d5.benchmark new file mode 100644 index 00000000000..64b126108f4 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/12910f24d994d451ff379b12c9d1ecdb9239c9b87e5d7bea570087ec506935d5.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/18cefc240debc0fcab14efdd451adfd02793093efe7bc76d6322aed6ddb582ad.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/18cefc240debc0fcab14efdd451adfd02793093efe7bc76d6322aed6ddb582ad.benchmark new file mode 100644 index 00000000000..80d791c89a9 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/18cefc240debc0fcab14efdd451adfd02793093efe7bc76d6322aed6ddb582ad.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/1a2f2540121f09321216090b2b1f211e3f020c2c133a1a3c3f3c232a26153a04.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/1a2f2540121f09321216090b2b1f211e3f020c2c133a1a3c3f3c232a26153a04.benchmark new file mode 100644 index 00000000000..d1bcd522632 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/1a2f2540121f09321216090b2b1f211e3f020c2c133a1a3c3f3c232a26153a04.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/1a573aed5c46d637919ccb5548dfc22a55c9fc38298d567d15ee9f2eea69d89e.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/1a573aed5c46d637919ccb5548dfc22a55c9fc38298d567d15ee9f2eea69d89e.benchmark new file mode 100644 index 00000000000..1bb754dacfa Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/1a573aed5c46d637919ccb5548dfc22a55c9fc38298d567d15ee9f2eea69d89e.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/1d56060c3b271226064c672a282663643b1b0823471c67737f0b076870331260.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/1d56060c3b271226064c672a282663643b1b0823471c67737f0b076870331260.benchmark new file mode 100644 index 00000000000..912c62c079f Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/1d56060c3b271226064c672a282663643b1b0823471c67737f0b076870331260.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/1d6e3c137149a440f35e0efc685b16bfb8052ebcf66ec4ad77e51c11501381c7.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/1d6e3c137149a440f35e0efc685b16bfb8052ebcf66ec4ad77e51c11501381c7.benchmark new file mode 100644 index 00000000000..1b2e4d24b1a Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/1d6e3c137149a440f35e0efc685b16bfb8052ebcf66ec4ad77e51c11501381c7.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/1f0f02191604101e1f201016171604060d010d1d1c150e110a110e1006160a0d.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/1f0f02191604101e1f201016171604060d010d1d1c150e110a110e1006160a0d.benchmark new file mode 100644 index 00000000000..b99e5c67372 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/1f0f02191604101e1f201016171604060d010d1d1c150e110a110e1006160a0d.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/202d273721330b31193405101e0637202e2a0f1140211c3e3f171e26312b0220.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/202d273721330b31193405101e0637202e2a0f1140211c3e3f171e26312b0220.benchmark new file mode 100644 index 00000000000..04058ca4bc8 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/202d273721330b31193405101e0637202e2a0f1140211c3e3f171e26312b0220.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/21953bf8798b28df60cb459db24843fb46782b19ba72dc4951941fb4c20d2263.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/21953bf8798b28df60cb459db24843fb46782b19ba72dc4951941fb4c20d2263.benchmark new file mode 100644 index 00000000000..00be8d9877e Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/21953bf8798b28df60cb459db24843fb46782b19ba72dc4951941fb4c20d2263.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/238b21364ab5bdae3ddb514d7001c8feba128b4ddcf426852b441f9a9d02c882.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/238b21364ab5bdae3ddb514d7001c8feba128b4ddcf426852b441f9a9d02c882.benchmark new file mode 100644 index 00000000000..31df35fa41b Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/238b21364ab5bdae3ddb514d7001c8feba128b4ddcf426852b441f9a9d02c882.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/26e24ee631a6d927ea4fb4fac530cfd82ff7636986014de2d2aaa460ddde0bc3.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/26e24ee631a6d927ea4fb4fac530cfd82ff7636986014de2d2aaa460ddde0bc3.benchmark new file mode 100644 index 00000000000..477e2db51f0 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/26e24ee631a6d927ea4fb4fac530cfd82ff7636986014de2d2aaa460ddde0bc3.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/2797d7ac77c1b6aff8e42cf9a47fa86b1e60f22719a996871ad412cbe4de78b5.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/2797d7ac77c1b6aff8e42cf9a47fa86b1e60f22719a996871ad412cbe4de78b5.benchmark new file mode 100644 index 00000000000..c56a52751f6 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/2797d7ac77c1b6aff8e42cf9a47fa86b1e60f22719a996871ad412cbe4de78b5.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/28fdce478e179db0e38fb5f3f4105e940ece450b9ce8a0f42a6e313b752e6f2c.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/28fdce478e179db0e38fb5f3f4105e940ece450b9ce8a0f42a6e313b752e6f2c.benchmark new file mode 100644 index 00000000000..f9455aa7640 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/28fdce478e179db0e38fb5f3f4105e940ece450b9ce8a0f42a6e313b752e6f2c.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/2cb21612178a2d9336b59d06cbf80488577463d209a453048a66c6eee624a695.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/2cb21612178a2d9336b59d06cbf80488577463d209a453048a66c6eee624a695.benchmark new file mode 100644 index 00000000000..2bf780acdaa Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/2cb21612178a2d9336b59d06cbf80488577463d209a453048a66c6eee624a695.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/2f58c9d884813042bce9cf7c66048767dff166785e8b5183c8139db2aa7312d1.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/2f58c9d884813042bce9cf7c66048767dff166785e8b5183c8139db2aa7312d1.benchmark new file mode 100644 index 00000000000..2af1c89fcc4 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/2f58c9d884813042bce9cf7c66048767dff166785e8b5183c8139db2aa7312d1.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/30aa34dfbe89e0c43f569929a96c0d2b74c321d13fec0375606325eee9a34a6a.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/30aa34dfbe89e0c43f569929a96c0d2b74c321d13fec0375606325eee9a34a6a.benchmark new file mode 100644 index 00000000000..7039df672c7 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/30aa34dfbe89e0c43f569929a96c0d2b74c321d13fec0375606325eee9a34a6a.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/322acde099bc34a929182d5b894214fc87ec88446e2d10625119a9d17fa3ec3d.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/322acde099bc34a929182d5b894214fc87ec88446e2d10625119a9d17fa3ec3d.benchmark new file mode 100644 index 00000000000..37b011b133b Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/322acde099bc34a929182d5b894214fc87ec88446e2d10625119a9d17fa3ec3d.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/331e4a1bb30f28d7073c54f9a13c10ae19e2e396c299a0ce101ee6bf4b2020db.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/331e4a1bb30f28d7073c54f9a13c10ae19e2e396c299a0ce101ee6bf4b2020db.benchmark new file mode 100644 index 00000000000..a5aa6d26e73 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/331e4a1bb30f28d7073c54f9a13c10ae19e2e396c299a0ce101ee6bf4b2020db.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/33c3efd79d9234a78262b52bc6bbf8124cb321a467dedb278328215167eca455.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/33c3efd79d9234a78262b52bc6bbf8124cb321a467dedb278328215167eca455.benchmark new file mode 100644 index 00000000000..3a164cda1f3 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/33c3efd79d9234a78262b52bc6bbf8124cb321a467dedb278328215167eca455.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/383683bfcecdab0f4df507f59631c702bd11a81ca3841f47f37633e8aacbb5de.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/383683bfcecdab0f4df507f59631c702bd11a81ca3841f47f37633e8aacbb5de.benchmark new file mode 100644 index 00000000000..8a243524a6b Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/383683bfcecdab0f4df507f59631c702bd11a81ca3841f47f37633e8aacbb5de.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/3bb75b2e53eb13f718eacd3263ab4535f9137fabffc9de499a0de7cabb335479.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/3bb75b2e53eb13f718eacd3263ab4535f9137fabffc9de499a0de7cabb335479.benchmark new file mode 100644 index 00000000000..38ca990dcab Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/3bb75b2e53eb13f718eacd3263ab4535f9137fabffc9de499a0de7cabb335479.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/3db496e6cd39a8b888a89d0de07dace4397878958cab3b9d9353978b08c36d8a.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/3db496e6cd39a8b888a89d0de07dace4397878958cab3b9d9353978b08c36d8a.benchmark new file mode 100644 index 00000000000..468cb57f42a Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/3db496e6cd39a8b888a89d0de07dace4397878958cab3b9d9353978b08c36d8a.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/44a9e339fa25948b48637fe7e10dcfc6d1256319a7b5ce4202cb54dfef8e37e7.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/44a9e339fa25948b48637fe7e10dcfc6d1256319a7b5ce4202cb54dfef8e37e7.benchmark new file mode 100644 index 00000000000..1382c778938 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/44a9e339fa25948b48637fe7e10dcfc6d1256319a7b5ce4202cb54dfef8e37e7.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/4c3efd13b6c69112a8a888372d56c86e60c232125976f29b1c3e21d9f537845c.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/4c3efd13b6c69112a8a888372d56c86e60c232125976f29b1c3e21d9f537845c.benchmark new file mode 100644 index 00000000000..3b904c4de8d Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/4c3efd13b6c69112a8a888372d56c86e60c232125976f29b1c3e21d9f537845c.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/4d7adf91bfc93cebe95a7e054ec17cfbb912b32bd8aecb48a228b50e02b055c8.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/4d7adf91bfc93cebe95a7e054ec17cfbb912b32bd8aecb48a228b50e02b055c8.benchmark new file mode 100644 index 00000000000..0b98195f8c7 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/4d7adf91bfc93cebe95a7e054ec17cfbb912b32bd8aecb48a228b50e02b055c8.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/4f9e8d361b85e62db2350dd3ae77463540e7af0d28e1eb68faeecc45f4655f57.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/4f9e8d361b85e62db2350dd3ae77463540e7af0d28e1eb68faeecc45f4655f57.benchmark new file mode 100644 index 00000000000..624f57078e3 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/4f9e8d361b85e62db2350dd3ae77463540e7af0d28e1eb68faeecc45f4655f57.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/52df7c8dfaa5f801cd837faa65f2fd333665fff00a555ce8c55e36ddc003007a.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/52df7c8dfaa5f801cd837faa65f2fd333665fff00a555ce8c55e36ddc003007a.benchmark new file mode 100644 index 00000000000..731b8f2985a Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/52df7c8dfaa5f801cd837faa65f2fd333665fff00a555ce8c55e36ddc003007a.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/53ed4db7ab33d6f907eec91a861d1188269be5ae1892d07ee71161bfb55a7cb7.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/53ed4db7ab33d6f907eec91a861d1188269be5ae1892d07ee71161bfb55a7cb7.benchmark new file mode 100644 index 00000000000..5d6dec9b025 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/53ed4db7ab33d6f907eec91a861d1188269be5ae1892d07ee71161bfb55a7cb7.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/55dfe42688ad683b638df1fa7700219f00f53b335a85a2825502ab1e0687197e.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/55dfe42688ad683b638df1fa7700219f00f53b335a85a2825502ab1e0687197e.benchmark new file mode 100644 index 00000000000..426642b2cf9 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/55dfe42688ad683b638df1fa7700219f00f53b335a85a2825502ab1e0687197e.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/56333d4e413dbf1a665463bf68067f63c118f38f7539b7ba7167d577c0c8b8ce.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/56333d4e413dbf1a665463bf68067f63c118f38f7539b7ba7167d577c0c8b8ce.benchmark new file mode 100644 index 00000000000..69e7c657e49 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/56333d4e413dbf1a665463bf68067f63c118f38f7539b7ba7167d577c0c8b8ce.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/57728d8b19b0e06412786f3dfed9e1894cd0ad1d2bc2bd497ec0ecb68f989d2b.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/57728d8b19b0e06412786f3dfed9e1894cd0ad1d2bc2bd497ec0ecb68f989d2b.benchmark new file mode 100644 index 00000000000..8e172c04d8d Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/57728d8b19b0e06412786f3dfed9e1894cd0ad1d2bc2bd497ec0ecb68f989d2b.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/5abae75af26f45658beccbe48f7c88e74efdfc0b8409ba1e98f95fa5b6caf999.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/5abae75af26f45658beccbe48f7c88e74efdfc0b8409ba1e98f95fa5b6caf999.benchmark new file mode 100644 index 00000000000..e70e0fd7467 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/5abae75af26f45658beccbe48f7c88e74efdfc0b8409ba1e98f95fa5b6caf999.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/5d0a88250f13c49c20e146819357a808911c878a0e0a7d6f7fe1d4a619e06112.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/5d0a88250f13c49c20e146819357a808911c878a0e0a7d6f7fe1d4a619e06112.benchmark new file mode 100644 index 00000000000..a9b19967c33 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/5d0a88250f13c49c20e146819357a808911c878a0e0a7d6f7fe1d4a619e06112.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/5e274e0f593511543d41570a4b03646c1d7539062b5728182e073e5760561a66.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/5e274e0f593511543d41570a4b03646c1d7539062b5728182e073e5760561a66.benchmark new file mode 100644 index 00000000000..083db6e25a1 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/5e274e0f593511543d41570a4b03646c1d7539062b5728182e073e5760561a66.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/5e2c68ac9f62580d626636679679b97109109df7ac1a8ce86d3e43dfb5e4f6bc.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/5e2c68ac9f62580d626636679679b97109109df7ac1a8ce86d3e43dfb5e4f6bc.benchmark new file mode 100644 index 00000000000..99319f8bec8 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/5e2c68ac9f62580d626636679679b97109109df7ac1a8ce86d3e43dfb5e4f6bc.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/5f130d19918807b60eab4c03119d67878fb6c6712c28c54f5a25792049294acc.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/5f130d19918807b60eab4c03119d67878fb6c6712c28c54f5a25792049294acc.benchmark new file mode 100644 index 00000000000..7e13c1a36e8 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/5f130d19918807b60eab4c03119d67878fb6c6712c28c54f5a25792049294acc.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/5f306b4b24ff2b39dab6cdc9ac6ca9bb442c1dc6f4e7e412eeb5a3ced42fb642.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/5f306b4b24ff2b39dab6cdc9ac6ca9bb442c1dc6f4e7e412eeb5a3ced42fb642.benchmark new file mode 100644 index 00000000000..44328a1a1ac Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/5f306b4b24ff2b39dab6cdc9ac6ca9bb442c1dc6f4e7e412eeb5a3ced42fb642.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/5f3d46c57a56cef6764f96c9de9677ac6e494dd7a4e368d1c8dd9c1f7a4309a5.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/5f3d46c57a56cef6764f96c9de9677ac6e494dd7a4e368d1c8dd9c1f7a4309a5.benchmark new file mode 100644 index 00000000000..93f4e29954b Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/5f3d46c57a56cef6764f96c9de9677ac6e494dd7a4e368d1c8dd9c1f7a4309a5.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/64c3d5b43f005855ffc4d0950a02fd159aa1575294ea39061b81a194ebb9eaae.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/64c3d5b43f005855ffc4d0950a02fd159aa1575294ea39061b81a194ebb9eaae.benchmark new file mode 100644 index 00000000000..34806816463 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/64c3d5b43f005855ffc4d0950a02fd159aa1575294ea39061b81a194ebb9eaae.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/65bc4b69b46d18fdff0fadbf00dd5ec2b3e03805fac9d5fb4ff2d3066e53fc7e.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/65bc4b69b46d18fdff0fadbf00dd5ec2b3e03805fac9d5fb4ff2d3066e53fc7e.benchmark new file mode 100644 index 00000000000..ce16924bc5c Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/65bc4b69b46d18fdff0fadbf00dd5ec2b3e03805fac9d5fb4ff2d3066e53fc7e.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/66af9e473d75e3f464971f6879cc0f2ef84bafcb38fbfa1dbc31ac2053628a38.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/66af9e473d75e3f464971f6879cc0f2ef84bafcb38fbfa1dbc31ac2053628a38.benchmark new file mode 100644 index 00000000000..b6eb094fc45 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/66af9e473d75e3f464971f6879cc0f2ef84bafcb38fbfa1dbc31ac2053628a38.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/675d63836cad11b547d1b4cddd498f04c919d4342612accf40913f9ae9419fac.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/675d63836cad11b547d1b4cddd498f04c919d4342612accf40913f9ae9419fac.benchmark new file mode 100644 index 00000000000..4fcba0a68fa Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/675d63836cad11b547d1b4cddd498f04c919d4342612accf40913f9ae9419fac.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/67ba5a9a0245ee3aff4f34852b9889b8c810fccd3dce2a23910bddd35c503b71.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/67ba5a9a0245ee3aff4f34852b9889b8c810fccd3dce2a23910bddd35c503b71.benchmark new file mode 100644 index 00000000000..93459007b93 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/67ba5a9a0245ee3aff4f34852b9889b8c810fccd3dce2a23910bddd35c503b71.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/6d88f7294dd2b5ce02c3dc609bc7715bd508009738401d264bf9b3eb7c6f49c1.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/6d88f7294dd2b5ce02c3dc609bc7715bd508009738401d264bf9b3eb7c6f49c1.benchmark new file mode 100644 index 00000000000..e27f6d660ab Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/6d88f7294dd2b5ce02c3dc609bc7715bd508009738401d264bf9b3eb7c6f49c1.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/70f65b21b77ddb451f3df9d9fb403ced3d10e1e953867cc4900cc25e5b9dec47.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/70f65b21b77ddb451f3df9d9fb403ced3d10e1e953867cc4900cc25e5b9dec47.benchmark new file mode 100644 index 00000000000..831476cb520 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/70f65b21b77ddb451f3df9d9fb403ced3d10e1e953867cc4900cc25e5b9dec47.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/71965c9ccae31f1ffc1d85aa20a356d4ed97a420954018d8301ec4f9783be0d7.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/71965c9ccae31f1ffc1d85aa20a356d4ed97a420954018d8301ec4f9783be0d7.benchmark new file mode 100644 index 00000000000..df4fb2c0879 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/71965c9ccae31f1ffc1d85aa20a356d4ed97a420954018d8301ec4f9783be0d7.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/74c67f2f182b9a0a66c62b95d6fac5ace3f7e71ea3abfc52ffbe3ecb93436ea2.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/74c67f2f182b9a0a66c62b95d6fac5ace3f7e71ea3abfc52ffbe3ecb93436ea2.benchmark new file mode 100644 index 00000000000..24d37d96fc2 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/74c67f2f182b9a0a66c62b95d6fac5ace3f7e71ea3abfc52ffbe3ecb93436ea2.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/7529b206a78becb793da74b78c04d9d33a2540a1abd79718e681228f4057403a.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/7529b206a78becb793da74b78c04d9d33a2540a1abd79718e681228f4057403a.benchmark new file mode 100644 index 00000000000..2faeb5ac0aa Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/7529b206a78becb793da74b78c04d9d33a2540a1abd79718e681228f4057403a.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/75a8bb183688bce447e00f435a144c835435e40a5defc6f3b9be68b70b4a3db6.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/75a8bb183688bce447e00f435a144c835435e40a5defc6f3b9be68b70b4a3db6.benchmark new file mode 100644 index 00000000000..645b3bf0639 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/75a8bb183688bce447e00f435a144c835435e40a5defc6f3b9be68b70b4a3db6.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/7a758e17486d1a30462c32a5d5309bd1e98322a9dcbe277c143ed3aede9d265f.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/7a758e17486d1a30462c32a5d5309bd1e98322a9dcbe277c143ed3aede9d265f.benchmark new file mode 100644 index 00000000000..3c141a7eb12 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/7a758e17486d1a30462c32a5d5309bd1e98322a9dcbe277c143ed3aede9d265f.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/7cbc5644b745f4ea635aca42cce5e4a4b9d2e61afdb3ac18128e1688c07071ba.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/7cbc5644b745f4ea635aca42cce5e4a4b9d2e61afdb3ac18128e1688c07071ba.benchmark new file mode 100644 index 00000000000..68769722b51 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/7cbc5644b745f4ea635aca42cce5e4a4b9d2e61afdb3ac18128e1688c07071ba.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/82213dfdb6a812b40446438767c61a388d2c0cfd0cbf7fd4a372b0dc59fa17e1.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/82213dfdb6a812b40446438767c61a388d2c0cfd0cbf7fd4a372b0dc59fa17e1.benchmark new file mode 100644 index 00000000000..c765c0c36b6 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/82213dfdb6a812b40446438767c61a388d2c0cfd0cbf7fd4a372b0dc59fa17e1.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/8c7fdc3da6822b5112074380003524f50fb3a1ce6db4e501df1086773c6c0201.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/8c7fdc3da6822b5112074380003524f50fb3a1ce6db4e501df1086773c6c0201.benchmark new file mode 100644 index 00000000000..8dc9eb11cc6 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/8c7fdc3da6822b5112074380003524f50fb3a1ce6db4e501df1086773c6c0201.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/8d9ae67656a2911ab15a8e5301c960c69aa2517055197aff6b60a87ff718d66c.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/8d9ae67656a2911ab15a8e5301c960c69aa2517055197aff6b60a87ff718d66c.benchmark new file mode 100644 index 00000000000..379bba44b60 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/8d9ae67656a2911ab15a8e5301c960c69aa2517055197aff6b60a87ff718d66c.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/96e1a2fa3ceb9a402f2a5841a0b645f87b4e8e75beb636692478ec39f74ee221.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/96e1a2fa3ceb9a402f2a5841a0b645f87b4e8e75beb636692478ec39f74ee221.benchmark new file mode 100644 index 00000000000..afe0636e76a Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/96e1a2fa3ceb9a402f2a5841a0b645f87b4e8e75beb636692478ec39f74ee221.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/9fabc4fc3440cdb776b28c9bb1dd49c9a5b1605fe1490aa3f4f64a3fa8881b25.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/9fabc4fc3440cdb776b28c9bb1dd49c9a5b1605fe1490aa3f4f64a3fa8881b25.benchmark new file mode 100644 index 00000000000..9f2ff98c97d Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/9fabc4fc3440cdb776b28c9bb1dd49c9a5b1605fe1490aa3f4f64a3fa8881b25.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/a85173a832db3ea944fafc406dfe3fa3235254897d6d1d0e21bc380147687bd5.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/a85173a832db3ea944fafc406dfe3fa3235254897d6d1d0e21bc380147687bd5.benchmark new file mode 100644 index 00000000000..fba38fc1cbf Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/a85173a832db3ea944fafc406dfe3fa3235254897d6d1d0e21bc380147687bd5.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/a9a853b6d083551f4ed2995551af287880ef42aee239a2d9bc5314d127cce592.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/a9a853b6d083551f4ed2995551af287880ef42aee239a2d9bc5314d127cce592.benchmark new file mode 100644 index 00000000000..630337f258d Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/a9a853b6d083551f4ed2995551af287880ef42aee239a2d9bc5314d127cce592.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/acb9c83c2b78dabef8674319ad69ba54912cd9997bdf2d8b2998c6bfeef3b122.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/acb9c83c2b78dabef8674319ad69ba54912cd9997bdf2d8b2998c6bfeef3b122.benchmark new file mode 100644 index 00000000000..66fee1cfc50 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/acb9c83c2b78dabef8674319ad69ba54912cd9997bdf2d8b2998c6bfeef3b122.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/acce04815e8fd51be93322888250060da173eccf3df3a605bd6bc6a456cde871.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/acce04815e8fd51be93322888250060da173eccf3df3a605bd6bc6a456cde871.benchmark new file mode 100644 index 00000000000..5515fb6a807 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/acce04815e8fd51be93322888250060da173eccf3df3a605bd6bc6a456cde871.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/ad6db94ed69b7161c7604568f44358e1cc11e81fea90e41afebd669e51bb60c8.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/ad6db94ed69b7161c7604568f44358e1cc11e81fea90e41afebd669e51bb60c8.benchmark new file mode 100644 index 00000000000..5c0b7bc1a57 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/ad6db94ed69b7161c7604568f44358e1cc11e81fea90e41afebd669e51bb60c8.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/b21a4df3b0266ad3481a26d3e3d848aad2fcde89510b29cccce81971e38e0835.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/b21a4df3b0266ad3481a26d3e3d848aad2fcde89510b29cccce81971e38e0835.benchmark new file mode 100644 index 00000000000..6013b1aae61 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/b21a4df3b0266ad3481a26d3e3d848aad2fcde89510b29cccce81971e38e0835.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/b50170cea48ee84b80558c02b15c6df52faf884e504d2c410ad63ba46d8ca35c.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/b50170cea48ee84b80558c02b15c6df52faf884e504d2c410ad63ba46d8ca35c.benchmark new file mode 100644 index 00000000000..661cc7e7b97 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/b50170cea48ee84b80558c02b15c6df52faf884e504d2c410ad63ba46d8ca35c.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/bb5345bfbbc460af84e784b900ec270df1948bb1d1e29eacecd022eeb168b315.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/bb5345bfbbc460af84e784b900ec270df1948bb1d1e29eacecd022eeb168b315.benchmark new file mode 100644 index 00000000000..a86cdfa13b1 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/bb5345bfbbc460af84e784b900ec270df1948bb1d1e29eacecd022eeb168b315.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/c4bb185380df6e9b66fc1ee0564f09a8d1253a51a0c0c7890f2214df9ac19274.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/c4bb185380df6e9b66fc1ee0564f09a8d1253a51a0c0c7890f2214df9ac19274.benchmark new file mode 100644 index 00000000000..77c94c9c003 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/c4bb185380df6e9b66fc1ee0564f09a8d1253a51a0c0c7890f2214df9ac19274.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/c9efcb705ee057791f7c18a1de79c49f6e40ba143ce0579f1602fd780cabf153.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/c9efcb705ee057791f7c18a1de79c49f6e40ba143ce0579f1602fd780cabf153.benchmark new file mode 100644 index 00000000000..bdfe67c20ac Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/c9efcb705ee057791f7c18a1de79c49f6e40ba143ce0579f1602fd780cabf153.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/ccab11ce1a8774135d0e3c9e635631b68af9e276b5dabc66ff669d5650d0be1c.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/ccab11ce1a8774135d0e3c9e635631b68af9e276b5dabc66ff669d5650d0be1c.benchmark new file mode 100644 index 00000000000..c871fb971b3 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/ccab11ce1a8774135d0e3c9e635631b68af9e276b5dabc66ff669d5650d0be1c.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/cdb9d5c233b288a5a9dcfbd8d5c1831a0bb46eec7a26fa31b80ae69d44805efc.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/cdb9d5c233b288a5a9dcfbd8d5c1831a0bb46eec7a26fa31b80ae69d44805efc.benchmark new file mode 100644 index 00000000000..87e65e2ac11 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/cdb9d5c233b288a5a9dcfbd8d5c1831a0bb46eec7a26fa31b80ae69d44805efc.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/ced1ea04649e093a501e43f8568ac3e6b37cd3eccec8cac9c70a4857b88a5eb8.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/ced1ea04649e093a501e43f8568ac3e6b37cd3eccec8cac9c70a4857b88a5eb8.benchmark new file mode 100644 index 00000000000..a3618ccc6dc Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/ced1ea04649e093a501e43f8568ac3e6b37cd3eccec8cac9c70a4857b88a5eb8.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/cf542b7df466b228ca2197c2aaa89238a8122f3330fe5b77b3222f570395d9f5.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/cf542b7df466b228ca2197c2aaa89238a8122f3330fe5b77b3222f570395d9f5.benchmark new file mode 100644 index 00000000000..594f97eb670 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/cf542b7df466b228ca2197c2aaa89238a8122f3330fe5b77b3222f570395d9f5.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/d1ab832dfab25688f8845bec9387e46ee3f00ba5822197ade7dd540489ec5e95.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/d1ab832dfab25688f8845bec9387e46ee3f00ba5822197ade7dd540489ec5e95.benchmark new file mode 100644 index 00000000000..c1775b5c8b4 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/d1ab832dfab25688f8845bec9387e46ee3f00ba5822197ade7dd540489ec5e95.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/d1c03759810747b7cab38c4296593b38567e11195d161b5bb0a2b58f89b2c65a.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/d1c03759810747b7cab38c4296593b38567e11195d161b5bb0a2b58f89b2c65a.benchmark new file mode 100644 index 00000000000..83794e93725 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/d1c03759810747b7cab38c4296593b38567e11195d161b5bb0a2b58f89b2c65a.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/d64607eb8a1448595081547ea8780886fcbd9e06036460eea3705c88ea867e33.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/d64607eb8a1448595081547ea8780886fcbd9e06036460eea3705c88ea867e33.benchmark new file mode 100644 index 00000000000..c8f5810e5ea Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/d64607eb8a1448595081547ea8780886fcbd9e06036460eea3705c88ea867e33.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/dc241ac6ad1e04fb056d555d6a4f2d08a45d054c6f7f34355fcfeefebef479f3.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/dc241ac6ad1e04fb056d555d6a4f2d08a45d054c6f7f34355fcfeefebef479f3.benchmark new file mode 100644 index 00000000000..4fd7cc426f4 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/dc241ac6ad1e04fb056d555d6a4f2d08a45d054c6f7f34355fcfeefebef479f3.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/dd11ae574eaeab0e9925319768989313a93913fdc347c704ddaa27042757d990.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/dd11ae574eaeab0e9925319768989313a93913fdc347c704ddaa27042757d990.benchmark new file mode 100644 index 00000000000..a669aee9b13 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/dd11ae574eaeab0e9925319768989313a93913fdc347c704ddaa27042757d990.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/e26c1cddba16e05fd10c34cbdb16ea6acdbac7c8323256c31c90c520ee6a1080.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/e26c1cddba16e05fd10c34cbdb16ea6acdbac7c8323256c31c90c520ee6a1080.benchmark new file mode 100644 index 00000000000..7b987b08c46 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/e26c1cddba16e05fd10c34cbdb16ea6acdbac7c8323256c31c90c520ee6a1080.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/e34b48f80d49360e88c612f4016f7d68cb5678dd8cd5ddb981375a028b3a40a5.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/e34b48f80d49360e88c612f4016f7d68cb5678dd8cd5ddb981375a028b3a40a5.benchmark new file mode 100644 index 00000000000..a6c39b128f6 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/e34b48f80d49360e88c612f4016f7d68cb5678dd8cd5ddb981375a028b3a40a5.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/e3afd22d01ff12f381cf915fd32358634e6c413f979f2492cf3339319d8cc079.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/e3afd22d01ff12f381cf915fd32358634e6c413f979f2492cf3339319d8cc079.benchmark new file mode 100644 index 00000000000..2dd4ed645df Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/e3afd22d01ff12f381cf915fd32358634e6c413f979f2492cf3339319d8cc079.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/e9234d2671760874f3f660aae5d3416d18ce6dfd7af4231bdd41b9ec268bc7e1.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/e9234d2671760874f3f660aae5d3416d18ce6dfd7af4231bdd41b9ec268bc7e1.benchmark new file mode 100644 index 00000000000..1e19e1065ea Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/e9234d2671760874f3f660aae5d3416d18ce6dfd7af4231bdd41b9ec268bc7e1.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/eb4a605ed3a64961e9e66ad9631c2813dadf7131740212762ae4483ec749fe1d.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/eb4a605ed3a64961e9e66ad9631c2813dadf7131740212762ae4483ec749fe1d.benchmark new file mode 100644 index 00000000000..81a3dc1fb4a Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/eb4a605ed3a64961e9e66ad9631c2813dadf7131740212762ae4483ec749fe1d.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/ecb5e8308b57724e0f8533921693f111eba942123cf8660aac2b5bac21ec28f0.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/ecb5e8308b57724e0f8533921693f111eba942123cf8660aac2b5bac21ec28f0.benchmark new file mode 100644 index 00000000000..68497031260 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/ecb5e8308b57724e0f8533921693f111eba942123cf8660aac2b5bac21ec28f0.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/f2a8fd2014922f0d8e01541205d47e9bb2d4e54333bdd408cbe7c47c55e73ae4.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/f2a8fd2014922f0d8e01541205d47e9bb2d4e54333bdd408cbe7c47c55e73ae4.benchmark new file mode 100644 index 00000000000..ec5ef6a9284 Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/f2a8fd2014922f0d8e01541205d47e9bb2d4e54333bdd408cbe7c47c55e73ae4.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/f339f59bdf92495ed2b14e2e4d3705972b4dda59aa929cffe0f1ff5355db8d79.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/f339f59bdf92495ed2b14e2e4d3705972b4dda59aa929cffe0f1ff5355db8d79.benchmark new file mode 100644 index 00000000000..f9d7af9d7fb Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/f339f59bdf92495ed2b14e2e4d3705972b4dda59aa929cffe0f1ff5355db8d79.benchmark differ diff --git a/marlowe-cardano-minimal/benchmarks/semantics/ffdd68a33afd86f8844c9f5e45b2bda5b035aa02274161b23d57709c0f8b8de6.benchmark b/marlowe-cardano-minimal/benchmarks/semantics/ffdd68a33afd86f8844c9f5e45b2bda5b035aa02274161b23d57709c0f8b8de6.benchmark new file mode 100644 index 00000000000..a49875d53bf Binary files /dev/null and b/marlowe-cardano-minimal/benchmarks/semantics/ffdd68a33afd86f8844c9f5e45b2bda5b035aa02274161b23d57709c0f8b8de6.benchmark differ diff --git a/marlowe-cardano-minimal/marlowe-cardano-minimal.cabal b/marlowe-cardano-minimal/marlowe-cardano-minimal.cabal new file mode 100644 index 00000000000..229513564f4 --- /dev/null +++ b/marlowe-cardano-minimal/marlowe-cardano-minimal.cabal @@ -0,0 +1,107 @@ +cabal-version: 3.0 +cabal-version: 3.0 +name: marlowe-cardano-minimal +version: 0.1.0.3 +license: Apache-2.0 +license-files: + LICENSE + NOTICE + +build-type: Simple +maintainer: brian.bush@iohk.io +stability: experimental +author: Brian Bush +synopsis: Marlowe: financial contracts on Cardano Computation Layer +description: + A reference implementation of Marlowe, domain-specific language targeted at + the execution of financial contracts in the style of Peyton Jones et al + on Cardano Computation Layer. + +category: Language +extra-doc-files: README.md +data-dir: benchmarks +data-files: + rolepayout/*.benchmark + semantics/*.benchmark + +source-repository head + type: git + location: https://github.com/input-output-hk/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: + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + ExplicitForAll + ScopedTypeVariables + StandaloneDeriving + + ghc-options: + -Wall -Wnoncanonical-monad-instances -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wredundant-constraints -Widentities + -Wunused-packages -Werror + +library + import: lang + + if impl(ghc <9.0) + buildable: False + + hs-source-dirs: src + build-depends: + , base + , bytestring + , cardano-crypto-class >=2.0.0.1 && <2.2 + , newtype-generics + , plutus-core ^>=1.7 + , plutus-ledger-api + , plutus-tx ^>=1.7 + , plutus-tx-plugin ^>=1.7 + + exposed-modules: + Language.Marlowe.Core.V1.Semantics + Language.Marlowe.Core.V1.Semantics.Types + Language.Marlowe.Core.V1.Semantics.Types.Address + Language.Marlowe.Scripts.RolePayout + Language.Marlowe.Scripts.Semantics + +executable marlowe-validators + import: lang + default-language: Haskell2010 + hs-source-dirs: app + main-is: Main.hs + other-modules: + Benchmark.Marlowe + Benchmark.Marlowe.RolePayout + Benchmark.Marlowe.Semantics + Benchmark.Marlowe.Types + Benchmark.Marlowe.Util + Paths_marlowe_cardano_minimal + + if impl(ghc <9.0) + buildable: False + + build-depends: + , base + , base16-bytestring + , bytestring + , cardano-binary + , directory + , filepath + , marlowe-cardano-minimal + , mtl + , plutus-core:{plutus-core, plutus-core-execlib} ^>=1.7 + , plutus-ledger-api + , plutus-tx ^>=1.7 + , serialise diff --git a/marlowe-cardano-minimal/src/Language/Marlowe/Core/V1/Semantics.hs b/marlowe-cardano-minimal/src/Language/Marlowe/Core/V1/Semantics.hs new file mode 100644 index 00000000000..24d46857fe3 --- /dev/null +++ b/marlowe-cardano-minimal/src/Language/Marlowe/Core/V1/Semantics.hs @@ -0,0 +1,774 @@ + +-- editorconfig-checker-disable-file + + +----------------------------------------------------------------------------- +-- +-- Module : $Headers +-- License : Apache 2.0 +-- +-- Stability : Experimental +-- Portability : Portable +-- +-- | = Marlowe: financial contracts domain specific language for blockchain +-- +-- Here we present a reference implementation of Marlowe, domain-specific language targeted at +-- the execution of financial contracts in the style of Peyton Jones et al +-- on Cardano. +-- +-- This is the Haskell implementation of Marlowe semantics for Cardano. +-- +-- == Semantics +-- +-- Semantics is based on +-- +-- Marlowe Contract execution is a chain of transactions, +-- where remaining contract and its state is passed through /Datum/, +-- and actions (i.e. /Choices/) are passed as +-- /Redeemer Script/ +-- +-- /Validation Script/ is always the same Marlowe interpreter implementation, available below. +-- +----------------------------------------------------------------------------- + + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fno-specialise #-} -- A big hammer, but it helps. +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} + +{- HLINT ignore "Avoid restricted function" -} + + +module Language.Marlowe.Core.V1.Semantics + ( -- * Semantics + MarloweData(..) + , MarloweParams(..) + , Payment(..) + , TransactionInput(..) + , TransactionOutput(..) + , computeTransaction + , playTrace + -- * Supporting Functions + , addMoneyToAccount + , applyAction + , applyAllInputs + , applyCases + , applyInput + , convertReduceWarnings + , evalObservation + , evalValue + , fixInterval + , getContinuation + , giveMoney + , moneyInAccount + , playTraceAux + , reduceContractStep + , reduceContractUntilQuiescent + , refundOne + , updateMoneyInAccount + -- * Supporting Types + , ApplyAction(..) + , ApplyAllResult(..) + , ApplyResult(..) + , ApplyWarning(..) + , ReduceEffect(..) + , ReduceResult(..) + , ReduceStepResult(..) + , ReduceWarning(..) + , TransactionError(..) + , TransactionWarning(..) + -- * Utility Functions + , allBalancesArePositive + , contractLifespanUpperBound + , isClose + , notClose + , paymentMoney + , totalBalance + ) where + + +import Data.Data (Data) +import GHC.Generics (Generic) +import Language.Marlowe.Core.V1.Semantics.Types (AccountId, Accounts, Action (..), Case (..), + Contract (..), Environment (..), Input (..), + InputContent (..), IntervalError (..), + IntervalResult (..), Money, Observation (..), + Party, Payee (..), State (..), TimeInterval, + Token (..), Value (..), ValueId, emptyState, + getAction, getInputContent, inBounds) +import PlutusLedgerApi.V2 (CurrencySymbol, POSIXTime (..)) +import PlutusTx (makeIsDataIndexed) +import PlutusTx.Lift (makeLift) +import PlutusTx.Prelude (AdditiveGroup ((-)), AdditiveSemigroup ((+)), Bool (..), Eq (..), Integer, + Maybe (..), MultiplicativeSemigroup ((*)), + Ord (max, min, (<), (<=), (>), (>=)), all, foldMap, foldr, fst, negate, + not, otherwise, reverse, snd, ($), (&&), (++), (||)) + +import PlutusLedgerApi.V2 qualified as Val +import PlutusTx.AssocMap qualified as Map +import PlutusTx.Builtins qualified as Builtins +import Prelude qualified as Haskell + + +-- Functions that used in Plutus Core must be inlineable, +-- so their code is available for PlutusTx compiler. +{-# INLINABLE fixInterval #-} +{-# INLINABLE evalValue #-} +{-# INLINABLE evalObservation #-} +{-# INLINABLE refundOne #-} +{-# INLINABLE moneyInAccount #-} +{-# INLINABLE updateMoneyInAccount #-} +{-# INLINABLE addMoneyToAccount #-} +{-# INLINABLE giveMoney #-} +{-# INLINABLE reduceContractStep #-} +{-# INLINABLE reduceContractUntilQuiescent #-} +{-# INLINABLE applyAction #-} +{-# INLINABLE getContinuation #-} +{-# INLINABLE applyCases #-} +{-# INLINABLE applyInput #-} +{-# INLINABLE convertReduceWarnings #-} +{-# INLINABLE applyAllInputs #-} +{-# INLINABLE isClose #-} +{-# INLINABLE notClose #-} +{-# INLINABLE computeTransaction #-} +{-# INLINABLE contractLifespanUpperBound #-} +{-# INLINABLE totalBalance #-} + + +{-| Payment occurs during 'Pay' contract evaluation, and + when positive balances are payed out on contract closure. +-} +data Payment = Payment AccountId Payee Token Integer + deriving stock (Haskell.Eq, Haskell.Show, Data) + + +-- | Extract the money value from a payment. +paymentMoney :: Payment -> Money +paymentMoney (Payment _ _ (Token cur tok) amt) = Val.singleton cur tok amt + + +-- | Effect of 'reduceContractStep' computation +data ReduceEffect = ReduceWithPayment Payment + | ReduceNoPayment + deriving stock (Haskell.Show, Data) + + +-- | Warning during 'reduceContractStep' +data ReduceWarning = ReduceNoWarning + | ReduceNonPositivePay AccountId Payee Token Integer + | ReducePartialPay AccountId Payee Token Integer Integer +-- ^ src ^ dest ^ paid ^ expected + | ReduceShadowing ValueId Integer Integer +-- oldVal ^ newVal ^ + | ReduceAssertionFailed + deriving stock (Haskell.Show, Data) + + +-- | Result of 'reduceContractStep' +data ReduceStepResult = Reduced ReduceWarning ReduceEffect State Contract + | NotReduced + | AmbiguousTimeIntervalReductionError + deriving stock (Haskell.Show, Data) + + +-- | Result of 'reduceContractUntilQuiescent' +data ReduceResult = ContractQuiescent Bool [ReduceWarning] [Payment] State Contract + | RRAmbiguousTimeIntervalError + deriving stock (Haskell.Show, Data) + + +-- | Warning of 'applyCases' +data ApplyWarning = ApplyNoWarning + | ApplyNonPositiveDeposit Party AccountId Token Integer + deriving stock (Haskell.Show, Data) + + +-- | Result of 'applyCases' +data ApplyResult = Applied ApplyWarning State Contract + | ApplyNoMatchError + | ApplyHashMismatch + deriving stock (Haskell.Show, Data) + + +-- | Result of 'applyAllInputs' +data ApplyAllResult = ApplyAllSuccess Bool [TransactionWarning] [Payment] State Contract + | ApplyAllNoMatchError + | ApplyAllAmbiguousTimeIntervalError + | ApplyAllHashMismatch + deriving stock (Haskell.Show, Data) + + +-- | Warnings during transaction computation +data TransactionWarning = TransactionNonPositiveDeposit Party AccountId Token Integer + | TransactionNonPositivePay AccountId Payee Token Integer + | TransactionPartialPay AccountId Payee Token Integer Integer +-- ^ src ^ dest ^ paid ^ expected + | TransactionShadowing ValueId Integer Integer +-- oldVal ^ newVal ^ + | TransactionAssertionFailed + deriving stock (Haskell.Show, Generic, Haskell.Eq, Data) + + +-- | Transaction error +data TransactionError = TEAmbiguousTimeIntervalError + | TEApplyNoMatchError + | TEIntervalError IntervalError + | TEUselessTransaction + | TEHashMismatch + deriving stock (Haskell.Show, Generic, Haskell.Eq, Data) + + +-- | Marlowe transaction input. +data TransactionInput = TransactionInput + { txInterval :: TimeInterval + , txInputs :: [Input] } + deriving stock (Haskell.Show, Haskell.Eq, Data) + + +-- | Marlowe transaction output. +data TransactionOutput = + TransactionOutput + { txOutWarnings :: [TransactionWarning] + , txOutPayments :: [Payment] + , txOutState :: State + , txOutContract :: Contract } + | Error TransactionError + deriving stock (Haskell.Show, Data) + + +-- | This data type is a content of a contract's /Datum/ +data MarloweData = MarloweData { + marloweParams :: MarloweParams, + marloweState :: State, + marloweContract :: Contract + } deriving stock (Haskell.Show, Haskell.Eq, Generic, Data) + + +-- | Parameters constant during the course of a contract. +newtype MarloweParams = MarloweParams { rolesCurrency :: CurrencySymbol } + deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord, Data) + + +-- | Checks 'interval' and trims it if necessary. +fixInterval :: TimeInterval -> State -> IntervalResult +fixInterval interval state = + case interval of + (low, high) + | high < low -> IntervalError (InvalidInterval interval) + | otherwise -> let + curMinTime = minTime state + -- newLow is both new "low" and new "minTime" (the lower bound for slotNum) + newLow = max low curMinTime + -- We know high is greater or equal than newLow (prove) + curInterval = (newLow, high) + env = Environment { timeInterval = curInterval } + newState = state { minTime = newLow } + in if high < curMinTime then IntervalError (IntervalInPastError curMinTime interval) + else IntervalTrimmed env newState + + +-- | Evaluates @Value@ given current @State@ and @Environment@. +evalValue :: Environment -> State -> Value Observation -> Integer +evalValue env state value = let + eval = evalValue env state + in case value of + AvailableMoney accId token -> moneyInAccount accId token (accounts state) + Constant integer -> integer + NegValue val -> negate (eval val) + AddValue lhs rhs -> eval lhs + eval rhs + SubValue lhs rhs -> eval lhs - eval rhs + MulValue lhs rhs -> eval lhs * eval rhs + DivValue lhs rhs -> let n = eval lhs + d = eval rhs + in if d == 0 + then 0 + else n `Builtins.quotientInteger` d + ChoiceValue choiceId -> + -- SCP-5126: Given the precondition that `choices` contains no + -- duplicate entries, this lookup behaves identically to + -- Marlowe's Isabelle semantics given the precondition that + -- the initial state's `choices` in Isabelle was sorted and + -- did not contain duplicate entries. + case Map.lookup choiceId (choices state) of + Just x -> x + Nothing -> 0 + TimeIntervalStart -> getPOSIXTime (fst (timeInterval env)) + TimeIntervalEnd -> getPOSIXTime (snd (timeInterval env)) + UseValue valId -> + -- SCP-5126: Given the precondition that `boundValues` contains + -- no duplicate entries, this lookup behaves identically to + -- Marlowe's Isabelle semantics given the precondition that + -- the initial state's `boundValues` in Isabelle was sorted + -- and did not contain duplicate entries. + case Map.lookup valId (boundValues state) of + Just x -> x + Nothing -> 0 + Cond cond thn els -> if evalObservation env state cond then eval thn else eval els + + +-- | Evaluate 'Observation' to 'Bool'. +evalObservation :: Environment -> State -> Observation -> Bool +evalObservation env state obs = let + evalObs = evalObservation env state + evalVal = evalValue env state + in case obs of + AndObs lhs rhs -> evalObs lhs && evalObs rhs + OrObs lhs rhs -> evalObs lhs || evalObs rhs + NotObs subObs -> not (evalObs subObs) + -- SCP-5126: Given the precondition that `choices` contains no + -- duplicate entries, this membership test behaves identically + -- to Marlowe's Isabelle semantics given the precondition that + -- the initial state's `choices` in Isabelle was sorted and did + -- not contain duplicate entries. + ChoseSomething choiceId -> choiceId `Map.member` choices state + ValueGE lhs rhs -> evalVal lhs >= evalVal rhs + ValueGT lhs rhs -> evalVal lhs > evalVal rhs + ValueLT lhs rhs -> evalVal lhs < evalVal rhs + ValueLE lhs rhs -> evalVal lhs <= evalVal rhs + ValueEQ lhs rhs -> evalVal lhs == evalVal rhs + TrueObs -> True + FalseObs -> False + + +-- | Pick the first account with money in it. +refundOne :: Accounts -> Maybe ((Party, Token, Integer), Accounts) +refundOne accounts = case Map.toList accounts of + [] -> Nothing + -- SCP-5126: The return value of this function differs from + -- Isabelle semantics in that it returns the least-recently + -- added account-token combination rather than the first + -- lexicographically ordered one. Also, the sequence + -- `Map.fromList . tail . Map.toList` preserves the + -- invariants of order and non-duplication. + ((accId, token), balance) : rest -> + if balance > 0 + then Just ((accId, token, balance), Map.fromList rest) + else refundOne (Map.fromList rest) + + +-- | Obtains the amount of money available an account. +moneyInAccount :: AccountId -> Token -> Accounts -> Integer +moneyInAccount accId token accounts = + -- SCP-5126: Given the precondition that `accounts` contains + -- no duplicate entries, this lookup behaves identically to + -- Marlowe's Isabelle semantics given the precondition that + -- the initial state's `accounts` in Isabelle was sorted and + -- did not contain duplicate entries. + case Map.lookup (accId, token) accounts of + Just x -> x + Nothing -> 0 + + +-- | Sets the amount of money available in an account. +updateMoneyInAccount :: AccountId -> Token -> Integer -> Accounts -> Accounts +updateMoneyInAccount accId token amount = + -- SCP-5126: Given the precondition that `accounts` contains + -- no duplicate entries, this deletion or insertion behaves + -- identically (aside from internal ordering) to Marlowe's + -- Isabelle semantics given the precondition that the initial + -- state's `accounts` in Isabelle was sorted and did not + -- contain duplicate entries. + if amount <= 0 then Map.delete (accId, token) else Map.insert (accId, token) amount + + +-- | Add the given amount of money to an account (only if it is positive). +-- Return the updated Map. +addMoneyToAccount :: AccountId -> Token -> Integer -> Accounts -> Accounts +addMoneyToAccount accId token amount accounts = let + balance = moneyInAccount accId token accounts + newBalance = balance + amount + in if amount <= 0 then accounts + else updateMoneyInAccount accId token newBalance accounts + + +-- | Gives the given amount of money to the given payee. +-- Returns the appropriate effect and updated accounts. +giveMoney :: AccountId -> Payee -> Token -> Integer -> Accounts -> (ReduceEffect, Accounts) +giveMoney accountId payee token amount accounts = let + newAccounts = case payee of + Party _ -> accounts + Account accId -> addMoneyToAccount accId token amount accounts + in (ReduceWithPayment (Payment accountId payee token amount), newAccounts) + + +-- | Carry a step of the contract with no inputs. +reduceContractStep :: Environment -> State -> Contract -> ReduceStepResult +reduceContractStep env state contract = case contract of + + -- SCP-5126: Although `refundOne` refunds accounts-token combinations + -- in least-recently-added order and Isabelle semantics requires that + -- they be refunded in lexicographic order, `reduceContractUntilQuiescent` + -- ensures that the `Close` pattern will be executed until `accounts` + -- is empty. Thus, the net difference between the behavior here and the + -- Isabelle semantics is that the `ContractQuiescent` resulting from + -- `reduceContractUntilQuiescent` will contain payments in a different + -- order. + Close -> case refundOne (accounts state) of + Just ((party, token, amount), newAccounts) -> let + newState = state { accounts = newAccounts } + in Reduced ReduceNoWarning (ReduceWithPayment (Payment party (Party party) token amount)) newState Close + Nothing -> NotReduced + + Pay accId payee tok val cont -> let + amountToPay = evalValue env state val + in if amountToPay <= 0 + then let + warning = ReduceNonPositivePay accId payee tok amountToPay + in Reduced warning ReduceNoPayment state cont + else let + balance = moneyInAccount accId tok (accounts state) + paidAmount = min balance amountToPay + newBalance = balance - paidAmount + newAccs = updateMoneyInAccount accId tok newBalance (accounts state) + warning = if paidAmount < amountToPay + then ReducePartialPay accId payee tok paidAmount amountToPay + else ReduceNoWarning + (payment, finalAccs) = giveMoney accId payee tok paidAmount newAccs + newState = state { accounts = finalAccs } + in Reduced warning payment newState cont + + If obs cont1 cont2 -> let + cont = if evalObservation env state obs then cont1 else cont2 + in Reduced ReduceNoWarning ReduceNoPayment state cont + + When _ timeout cont -> let + (startTime, endTime) = timeInterval env + -- if timeout in future – do not reduce + in if endTime < timeout then NotReduced + -- if timeout in the past – reduce to timeout continuation + else if timeout <= startTime then Reduced ReduceNoWarning ReduceNoPayment state cont + -- if timeout in the time range – issue an ambiguity error + else AmbiguousTimeIntervalReductionError + + Let valId val cont -> let + evaluatedValue = evalValue env state val + boundVals = boundValues state + -- SCP-5126: Given the precondition that `boundValues` contains + -- no duplicate entries, this insertion behaves identically + -- (aside from internal ordering) to Marlowe's Isabelle semantics + -- given the precondition that the initial state's `boundValues` + -- in Isabelle was sorted and did not contain duplicate entries. + newState = state { boundValues = Map.insert valId evaluatedValue boundVals } + -- SCP-5126: Given the precondition that `boundValues` contains + -- no duplicate entries, this lookup behaves identically to + -- Marlowe's Isabelle semantics given the precondition that the + -- initial state's `boundValues` in Isabelle was sorted and did + -- not contain duplicate entries. + warn = case Map.lookup valId boundVals of + Just oldVal -> ReduceShadowing valId oldVal evaluatedValue + Nothing -> ReduceNoWarning + in Reduced warn ReduceNoPayment newState cont + + Assert obs cont -> let + warning = if evalObservation env state obs + then ReduceNoWarning + else ReduceAssertionFailed + in Reduced warning ReduceNoPayment state cont + + +-- | Reduce a contract until it cannot be reduced more. +reduceContractUntilQuiescent :: Environment -> State -> Contract -> ReduceResult +reduceContractUntilQuiescent env state contract = let + reductionLoop + :: Bool -> Environment -> State -> Contract -> [ReduceWarning] -> [Payment] -> ReduceResult + reductionLoop reduced env state contract warnings payments = + case reduceContractStep env state contract of + Reduced warning effect newState cont -> let + newWarnings = case warning of + ReduceNoWarning -> warnings + _ -> warning : warnings + newPayments = case effect of + ReduceWithPayment payment -> payment : payments + ReduceNoPayment -> payments + in reductionLoop True env newState cont newWarnings newPayments + AmbiguousTimeIntervalReductionError -> RRAmbiguousTimeIntervalError + -- this is the last invocation of reductionLoop, so we can reverse lists + NotReduced -> ContractQuiescent reduced (reverse warnings) (reverse payments) state contract + + in reductionLoop False env state contract [] [] + + +-- | Result of applying an action to a contract. +data ApplyAction = AppliedAction ApplyWarning State + | NotAppliedAction + deriving stock (Haskell.Show, Data) + + +-- | Try to apply a single input content to a single action. +applyAction :: Environment -> State -> InputContent -> Action -> ApplyAction +applyAction env state (IDeposit accId1 party1 tok1 amount) (Deposit accId2 party2 tok2 val) = + if accId1 == accId2 && party1 == party2 && tok1 == tok2 && amount == evalValue env state val + then let warning = if amount > 0 then ApplyNoWarning + else ApplyNonPositiveDeposit party2 accId2 tok2 amount + newAccounts = addMoneyToAccount accId1 tok1 amount (accounts state) + newState = state { accounts = newAccounts } + in AppliedAction warning newState + else NotAppliedAction +applyAction _ state (IChoice choId1 choice) (Choice choId2 bounds) = + if choId1 == choId2 && inBounds choice bounds + -- SCP-5126: Given the precondition that `choices` contains no + -- duplicate entries, this insertion behaves identically (aside + -- from internal ordering) to Marlowe's Isabelle semantics + -- given the precondition that the initial state's `choices` + -- in Isabelle was sorted and did not contain duplicate entries. + then let newState = state { choices = Map.insert choId1 choice (choices state) } + in AppliedAction ApplyNoWarning newState + else NotAppliedAction +applyAction env state INotify (Notify obs) + | evalObservation env state obs = AppliedAction ApplyNoWarning state +applyAction _ _ _ _ = NotAppliedAction + + +-- | Try to get a continuation from a pair of Input and Case. +getContinuation :: Input -> Case Contract -> Maybe Contract +getContinuation (NormalInput _) (Case _ continuation) = Just continuation +getContinuation (MerkleizedInput _ inputContinuationHash continuation) (MerkleizedCase _ continuationHash) = + if inputContinuationHash == continuationHash + then Just continuation + else Nothing +getContinuation _ _ = Nothing + +-- | Try to apply an input to a list of cases, accepting the first match. +applyCases :: Environment -> State -> Input -> [Case Contract] -> ApplyResult +applyCases env state input (headCase : tailCases) = + let inputContent = getInputContent input :: InputContent + action = getAction headCase :: Action + maybeContinuation = getContinuation input headCase :: Maybe Contract + in case applyAction env state inputContent action of + AppliedAction warning newState -> + -- Note that this differs from Isabelle semantics because + -- the Cardano semantics includes merkleization. + case maybeContinuation of + Just continuation -> Applied warning newState continuation + Nothing -> ApplyHashMismatch + NotAppliedAction -> applyCases env state input tailCases +applyCases _ _ _ [] = ApplyNoMatchError + + +-- | Apply a single @Input@ to a current contract. +applyInput :: Environment -> State -> Input -> Contract -> ApplyResult +applyInput env state input (When cases _ _) = applyCases env state input cases +applyInput _ _ _ _ = ApplyNoMatchError + + +-- | Propagate 'ReduceWarning' to 'TransactionWarning'. +convertReduceWarnings :: [ReduceWarning] -> [TransactionWarning] +convertReduceWarnings = foldr (\warn acc -> case warn of -- Note that `foldr` is used here for efficiency, differing from Isabelle. + ReduceNoWarning -> acc + ReduceNonPositivePay accId payee tok amount -> + TransactionNonPositivePay accId payee tok amount : acc + ReducePartialPay accId payee tok paid expected -> + TransactionPartialPay accId payee tok paid expected : acc + ReduceShadowing valId oldVal newVal -> + TransactionShadowing valId oldVal newVal : acc + ReduceAssertionFailed -> + TransactionAssertionFailed : acc + ) [] + + +-- | Apply a list of Inputs to the contract. +applyAllInputs :: Environment -> State -> Contract -> [Input] -> ApplyAllResult +applyAllInputs env state contract inputs = let + applyAllLoop + :: Bool + -> Environment + -> State + -> Contract + -> [Input] + -> [TransactionWarning] + -> [Payment] + -> ApplyAllResult + applyAllLoop contractChanged env state contract inputs warnings payments = + case reduceContractUntilQuiescent env state contract of + RRAmbiguousTimeIntervalError -> ApplyAllAmbiguousTimeIntervalError + ContractQuiescent reduced reduceWarns pays curState cont -> + let + warnings' = warnings ++ convertReduceWarnings reduceWarns + payments' = payments ++ pays + in case inputs of + [] -> ApplyAllSuccess + (contractChanged || reduced) + warnings' + payments' + curState + cont + (input : rest) -> case applyInput env curState input cont of + Applied applyWarn newState cont' -> + applyAllLoop + True + env + newState + cont' + rest + (warnings' ++ convertApplyWarning applyWarn) + payments' + ApplyNoMatchError -> ApplyAllNoMatchError + ApplyHashMismatch -> ApplyAllHashMismatch + in applyAllLoop False env state contract inputs [] [] + where + convertApplyWarning :: ApplyWarning -> [TransactionWarning] + convertApplyWarning warn = + case warn of + ApplyNoWarning -> [] + ApplyNonPositiveDeposit party accId tok amount -> + [TransactionNonPositiveDeposit party accId tok amount] + + +-- | Check if a contract is just @Close@. +isClose :: Contract -> Bool +isClose Close = True +isClose _ = False + + +-- | Check if a contract is not just @Close@. +notClose :: Contract -> Bool +notClose Close = False +notClose _ = True + + +-- | Try to compute outputs of a transaction given its inputs, a contract, and it's @State@ +computeTransaction :: TransactionInput -> State -> Contract -> TransactionOutput +computeTransaction tx state contract = let + inputs = txInputs tx + in case fixInterval (txInterval tx) state of + IntervalTrimmed env fixState -> case applyAllInputs env fixState contract inputs of + ApplyAllSuccess reduced warnings payments newState cont -> + if not reduced && (notClose contract || (Map.null $ accounts state)) + then Error TEUselessTransaction + else TransactionOutput { txOutWarnings = warnings + , txOutPayments = payments + , txOutState = newState + , txOutContract = cont } + ApplyAllNoMatchError -> Error TEApplyNoMatchError + ApplyAllAmbiguousTimeIntervalError -> Error TEAmbiguousTimeIntervalError + ApplyAllHashMismatch -> Error TEHashMismatch + IntervalError error -> Error (TEIntervalError error) + +-- | Run a set of inputs starting from the results of a transaction, reporting the new result. +playTraceAux :: TransactionOutput -> [TransactionInput] -> TransactionOutput +playTraceAux res [] = res +playTraceAux TransactionOutput + { txOutWarnings = warnings + , txOutPayments = payments + , txOutState = state + , txOutContract = cont } (h:t) = + let transRes = computeTransaction h state cont + in case transRes of + TransactionOutput{..} -> + playTraceAux TransactionOutput + { txOutPayments = payments ++ txOutPayments + , txOutWarnings = warnings ++ txOutWarnings + , txOutState + , txOutContract + } t + Error _ -> transRes +playTraceAux err@(Error _) _ = err + + +-- | Run a set of inputs starting from a contract and empty state, reporting the result. +playTrace :: POSIXTime -> Contract -> [TransactionInput] -> TransactionOutput +playTrace minTime c = playTraceAux TransactionOutput + { txOutWarnings = [] + , txOutPayments = [] + , txOutState = emptyState minTime + , txOutContract = c + } + + +-- | Calculates an upper bound for the maximum lifespan of a contract (assuming is not merkleized) +contractLifespanUpperBound :: Contract -> POSIXTime +contractLifespanUpperBound contract = case contract of + Close -> 0 + Pay _ _ _ _ cont -> contractLifespanUpperBound cont + If _ contract1 contract2 -> + max (contractLifespanUpperBound contract1) (contractLifespanUpperBound contract2) + When cases timeout subContract -> let + contractsLifespans = [contractLifespanUpperBound c | Case _ c <- cases] + in Haskell.maximum (timeout : contractLifespanUpperBound subContract : contractsLifespans) + Let _ _ cont -> contractLifespanUpperBound cont + Assert _ cont -> contractLifespanUpperBound cont + + +-- | Total the balance in all accounts. +totalBalance :: Accounts -> Money +totalBalance accounts = foldMap + (\((_, Token cur tok), balance) -> Val.singleton cur tok balance) + (Map.toList accounts) + + +-- | Check that all accounts have positive balance. +allBalancesArePositive :: State -> Bool +allBalancesArePositive State{..} = all (\(_, balance) -> balance > 0) (Map.toList accounts) + + +instance Eq Payment where + {-# INLINABLE (==) #-} + Payment a1 p1 t1 i1 == Payment a2 p2 t2 i2 = a1 == a2 && p1 == p2 && t1 == t2 && i1 == i2 + + +instance Eq ReduceWarning where + {-# INLINABLE (==) #-} + ReduceNoWarning == ReduceNoWarning = True + ReduceNoWarning == _ = False + ReduceNonPositivePay acc1 p1 tn1 a1 == ReduceNonPositivePay acc2 p2 tn2 a2 = + acc1 == acc2 && p1 == p2 && tn1 == tn2 && a1 == a2 + ReduceNonPositivePay{} == _ = False + ReducePartialPay acc1 p1 tn1 a1 e1 == ReducePartialPay acc2 p2 tn2 a2 e2 = + acc1 == acc2 && p1 == p2 && tn1 == tn2 && a1 == a2 && e1 == e2 + ReducePartialPay{} == _ = False + ReduceShadowing v1 old1 new1 == ReduceShadowing v2 old2 new2 = + v1 == v2 && old1 == old2 && new1 == new2 + ReduceShadowing{} == _ = False + ReduceAssertionFailed == ReduceAssertionFailed = True + ReduceAssertionFailed == _ = False + + +instance Eq ReduceEffect where + {-# INLINABLE (==) #-} + ReduceNoPayment == ReduceNoPayment = True + ReduceNoPayment == _ = False + ReduceWithPayment p1 == ReduceWithPayment p2 = p1 == p2 + ReduceWithPayment _ == _ = False + + +-- Lifting data types to Plutus Core +makeLift ''IntervalError +makeLift ''IntervalResult +makeLift ''Payment +makeLift ''ReduceEffect +makeLift ''ReduceWarning +makeLift ''ReduceStepResult +makeLift ''ReduceResult +makeLift ''ApplyWarning +makeLift ''ApplyResult +makeLift ''TransactionWarning +makeLift ''ApplyAllResult +makeLift ''TransactionError +makeLift ''TransactionOutput +makeIsDataIndexed ''MarloweParams [('MarloweParams,0)] +makeIsDataIndexed ''MarloweData [('MarloweData,0)] +makeLift ''MarloweParams +makeLift ''MarloweData diff --git a/marlowe-cardano-minimal/src/Language/Marlowe/Core/V1/Semantics/Types.hs b/marlowe-cardano-minimal/src/Language/Marlowe/Core/V1/Semantics/Types.hs new file mode 100644 index 00000000000..9d19a8cdd32 --- /dev/null +++ b/marlowe-cardano-minimal/src/Language/Marlowe/Core/V1/Semantics/Types.hs @@ -0,0 +1,538 @@ + + +----------------------------------------------------------------------------- +-- +-- Module : $Headers +-- License : Apache 2.0 +-- +-- Stability : Experimental +-- Portability : Portable +-- +-- | Types for Marlowe semantics +-- +----------------------------------------------------------------------------- + + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fno-specialise #-} -- A big hammer, but it helps. +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + + +module Language.Marlowe.Core.V1.Semantics.Types + ( -- * Type Aliases + AccountId + , Accounts + , ChoiceName + , ChosenNum + , Money + , TimeInterval + , Timeout + -- * Contract Types + , Action(..) + , Bound(..) + , Case(..) + , ChoiceId(..) + , Contract(..) + , Environment(..) + , Input(..) + , InputContent(..) + , IntervalResult(..) + , Observation(..) + , Party(..) + , Payee(..) + , State(..) + , Token(..) + , Value(..) + , ValueId(..) + -- * Error Types + , IntervalError(..) + -- * Utility Functions + , emptyState + , getAction + , getInputContent + , inBounds + ) where + + +import Control.Applicative ((<*>), (<|>)) +import Control.Newtype.Generics (Newtype) +import Data.Data (Data) +import Data.String (IsString (..)) +import GHC.Generics (Generic) +import Language.Marlowe.Core.V1.Semantics.Types.Address (Network) +import PlutusLedgerApi.V2 (CurrencySymbol (unCurrencySymbol), POSIXTime (..), + TokenName (unTokenName)) +import PlutusTx (makeIsDataIndexed) +import PlutusTx.AssocMap (Map) +import PlutusTx.Lift (makeLift) +import PlutusTx.Prelude (Bool (..), BuiltinByteString, Eq (..), Integer, Ord ((<=), (>=)), all, and, + any, length, zip, zipWith, (&&)) +import Prelude (mapM, (<$>)) + +import Data.Foldable qualified as F +import PlutusLedgerApi.V1.Value qualified as Val +import PlutusLedgerApi.V2 qualified as Ledger (Address (..), Credential (..), PubKeyHash (..), + ScriptHash (..), StakingCredential (..)) +import PlutusTx.AssocMap qualified as Map +import Prelude qualified as Haskell + + +-- Functions that used in Plutus Core must be inlinable, +-- so their code is available for PlutusTx compiler. +{-# INLINABLE getAction #-} +{-# INLINABLE getInputContent #-} +{-# INLINABLE inBounds #-} +{-# INLINABLE emptyState #-} + + +deriving instance Data POSIXTime +deriving instance Data Ledger.Address +deriving instance Data Ledger.Credential +deriving instance Data Ledger.PubKeyHash +deriving instance Data Ledger.ScriptHash +deriving instance Data Ledger.StakingCredential + + +-- | A Party to a contractt. +data Party = + Address Network Ledger.Address -- ^ Party identified by a network address. + | Role TokenName -- ^ Party identified by a role token name. + deriving stock (Generic,Haskell.Eq,Haskell.Ord,Haskell.Show,Data) + + +-- | A party's internal account in a contract. +type AccountId = Party + + +-- | A timeout in a contract. +type Timeout = POSIXTime + + +-- | A multi-asset value. +type Money = Val.Value + + +-- | The name of a choice in a contract. +type ChoiceName = BuiltinByteString + + +-- | A numeric choice in a contract. +type ChosenNum = Integer + + +-- | The time validity range for a Marlowe transaction, inclusive of both endpoints. +type TimeInterval = (POSIXTime, POSIXTime) + + +-- | The accounts in a contract. +type Accounts = Map (AccountId, Token) Integer + + +-- | Choices – of integers – are identified by ChoiceId which combines a name for +-- the choice with the Party who had made the choice. +data ChoiceId = ChoiceId BuiltinByteString Party + deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord,Data) + + +-- | Token - represents a currency or token, it groups +-- a pair of a currency symbol and token name. +data Token = Token CurrencySymbol TokenName + deriving stock (Generic,Haskell.Eq,Haskell.Ord,Haskell.Show,Data) + + +-- | Values, as defined using Let ar e identified by name, +-- and can be used by 'UseValue' construct. +newtype ValueId = ValueId BuiltinByteString + deriving (IsString, Haskell.Show) via TokenName + deriving stock (Haskell.Eq,Haskell.Ord,Generic,Data) + deriving anyclass (Newtype) + +-- | Values include some quantities that change with time, +-- including “the time interval”, “the current balance of an account”, +-- and any choices that have already been made. +-- +-- Values can also be scaled, and combined using addition, subtraction, and negation. +data Value a = AvailableMoney AccountId Token + | Constant Integer + | NegValue (Value a) + | AddValue (Value a) (Value a) + | SubValue (Value a) (Value a) + | MulValue (Value a) (Value a) + | DivValue (Value a) (Value a) + | ChoiceValue ChoiceId + | TimeIntervalStart + | TimeIntervalEnd + | UseValue ValueId + | Cond a (Value a) (Value a) + deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord,Data) + + +-- | Observations are Boolean values derived by comparing values, +-- and can be combined using the standard Boolean operators. +-- +-- It is also possible to observe whether any choice has been made +-- (for a particular identified choice). +data Observation = AndObs Observation Observation + | OrObs Observation Observation + | NotObs Observation + | ChoseSomething ChoiceId + | ValueGE (Value Observation) (Value Observation) + | ValueGT (Value Observation) (Value Observation) + | ValueLT (Value Observation) (Value Observation) + | ValueLE (Value Observation) (Value Observation) + | ValueEQ (Value Observation) (Value Observation) + | TrueObs + | FalseObs + deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord,Data) + + +-- | The (inclusive) bound on a choice number. +data Bound = Bound Integer Integer + deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord,Data) + + +-- | Actions happen at particular points during execution. +-- Three kinds of action are possible: +-- +-- * A @Deposit n p v@ makes a deposit of value @v@ into account @n@ belonging to party @p@. +-- +-- * A choice is made for a particular id with a list of bounds on the values that are acceptable. +-- For example, @[(0, 0), (3, 5]@ offers the choice of one of 0, 3, 4 and 5. +-- +-- * The contract is notified that a particular observation be made. +-- Typically this would be done by one of the parties, +-- or one of their wallets acting automatically. +-- +data Action = Deposit AccountId Party Token (Value Observation) + | Choice ChoiceId [Bound] + | Notify Observation + deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord,Data) + + +-- | A payment can be made to one of the parties to the contract, +-- or to one of the accounts of the contract, +-- and this is reflected in the definition. +data Payee = Account AccountId + | Party Party + deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord,Data) + + +-- | A case is a branch of a when clause, guarded by an action. +-- The continuation of the contrack may be merkleized or not. +-- +-- Plutus doesn't support mutually recursive data types yet. +-- datatype Case is mutually recurvive with @Contract@ +data Case a = Case Action a + | MerkleizedCase Action BuiltinByteString + deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord,Data) + + +-- | Extract the @Action@ from a @Case@. +getAction :: Case a -> Action +getAction (Case action _) = action +getAction (MerkleizedCase action _) = action + + +-- | Marlowe has six ways of building contracts. +-- Five of these – 'Pay', 'Let', 'If', 'When' and 'Assert' – +-- build a complex contract from simpler contracts, and the sixth, 'Close', +-- is a simple contract. +-- At each step of execution, as well as returning a new state and continuation contract, +-- it is possible that effects – payments – and warnings can be generated too. +data Contract = Close + | Pay AccountId Payee Token (Value Observation) Contract + | If Observation Contract Contract + | When [Case Contract] Timeout Contract + | Let ValueId (Value Observation) Contract + | Assert Observation Contract + deriving stock (Haskell.Show,Generic,Haskell.Eq,Haskell.Ord,Data) + + +-- | Marlowe contract internal state. Stored in a /Datum/ of a transaction output. +data State = State { accounts :: Accounts + , choices :: Map ChoiceId ChosenNum + , boundValues :: Map ValueId Integer + , minTime :: POSIXTime } + deriving stock (Haskell.Show,Haskell.Eq,Generic,Data) + + +-- | Execution environment. Contains a time interval of a transaction. +newtype Environment = Environment { timeInterval :: TimeInterval } + deriving stock (Haskell.Show,Haskell.Eq,Haskell.Ord,Data) + +-- | Input for a Marlowe contract. Correspond to expected 'Action's. +data InputContent = IDeposit AccountId Party Token Integer + | IChoice ChoiceId ChosenNum + | INotify + deriving stock (Haskell.Show,Haskell.Eq,Generic,Data) + + +-- | Input to a contract, which may include the merkleized continuation +-- of the contract and its hash. +data Input = NormalInput InputContent + | MerkleizedInput InputContent BuiltinByteString Contract + deriving stock (Haskell.Show,Haskell.Eq,Generic,Data) + + +-- | Extract the content of input. +getInputContent :: Input -> InputContent +getInputContent (NormalInput inputContent) = inputContent +getInputContent (MerkleizedInput inputContent _ _) = inputContent + + +-- | Time interval errors. +-- 'InvalidInterval' means @slotStart > slotEnd@, and +-- 'IntervalInPastError' means time interval is in the past, relative to the contract. +-- +-- These errors should never occur, but we are always prepared. +data IntervalError = InvalidInterval TimeInterval + | IntervalInPastError POSIXTime TimeInterval + deriving stock (Haskell.Show, Haskell.Eq,Generic,Data) + + +-- | Result of 'fixInterval' +data IntervalResult = IntervalTrimmed Environment State + | IntervalError IntervalError + deriving stock (Haskell.Show,Generic,Data) + + +-- | Empty State for a given minimal 'POSIXTime' +emptyState :: POSIXTime -> State +emptyState sn = State + { accounts = Map.empty + , choices = Map.empty + , boundValues = Map.empty + , minTime = sn } + + +-- | Check if a 'num' is withint a list of inclusive bounds. +inBounds :: ChosenNum -> [Bound] -> Bool +inBounds num = any (\(Bound l u) -> num >= l && num <= u) + + +instance Eq Party where + {-# INLINABLE (==) #-} + Address n1 a1 == Address n2 a2 = n1 == n2 && a1 == a2 + Address _ _ == _ = False + Role r1 == Role r2 = r1 == r2 + Role _ == _ = False + + +instance Eq ChoiceId where + {-# INLINABLE (==) #-} + ChoiceId n1 p1 == ChoiceId n2 p2 = n1 == n2 && p1 == p2 + + +instance Eq Token where + {-# INLINABLE (==) #-} + Token n1 p1 == Token n2 p2 = n1 == n2 && p1 == p2 + + +instance Eq ValueId where + {-# INLINABLE (==) #-} + ValueId n1 == ValueId n2 = n1 == n2 + + +instance Eq Payee where + {-# INLINABLE (==) #-} + Account acc1 == Account acc2 = acc1 == acc2 + Account{} == _ = False + Party p1 == Party p2 = p1 == p2 + Party{} == _ = False + +instance Eq a => Eq (Value a) where + {-# INLINABLE (==) #-} + AvailableMoney acc1 tok1 == AvailableMoney acc2 tok2 = acc1 == acc2 && tok1 == tok2 + AvailableMoney _ _ == _ = False + Constant i1 == Constant i2 = i1 == i2 + Constant{} == _ = False + NegValue val1 == NegValue val2 = val1 == val2 + NegValue{} == _ = False + AddValue val1 val2 == AddValue val3 val4 = val1 == val3 && val2 == val4 + AddValue{} == _ = False + SubValue val1 val2 == SubValue val3 val4 = val1 == val3 && val2 == val4 + SubValue{} == _ = False + MulValue val1 val2 == MulValue val3 val4 = val1 == val3 && val2 == val4 + MulValue{} == _ = False + DivValue val1 val2 == DivValue val3 val4 = val1 == val3 && val2 == val4 + DivValue{} == _ = False + ChoiceValue cid1 == ChoiceValue cid2 = cid1 == cid2 + ChoiceValue{} == _ = False + TimeIntervalStart == TimeIntervalStart = True + TimeIntervalStart == _ = False + TimeIntervalEnd == TimeIntervalEnd = True + TimeIntervalEnd == _ = False + UseValue val1 == UseValue val2 = val1 == val2 + UseValue{} == _ = False + Cond obs1 thn1 els1 == Cond obs2 thn2 els2 = obs1 == obs2 && thn1 == thn2 && els1 == els2 + Cond{} == _ = False + + +instance Eq Observation where + {-# INLINABLE (==) #-} + AndObs o1l o2l == AndObs o1r o2r = o1l == o1r && o2l == o2r + AndObs{} == _ = False + OrObs o1l o2l == OrObs o1r o2r = o1l == o1r && o2l == o2r + OrObs{} == _ = False + NotObs ol == NotObs or = ol == or + NotObs{} == _ = False + ChoseSomething cid1 == ChoseSomething cid2 = cid1 == cid2 + ChoseSomething _ == _ = False + ValueGE v1l v2l == ValueGE v1r v2r = v1l == v1r && v2l == v2r + ValueGE{} == _ = False + ValueGT v1l v2l == ValueGT v1r v2r = v1l == v1r && v2l == v2r + ValueGT{} == _ = False + ValueLT v1l v2l == ValueLT v1r v2r = v1l == v1r && v2l == v2r + ValueLT{} == _ = False + ValueLE v1l v2l == ValueLE v1r v2r = v1l == v1r && v2l == v2r + ValueLE{} == _ = False + ValueEQ v1l v2l == ValueEQ v1r v2r = v1l == v1r && v2l == v2r + ValueEQ{} == _ = False + TrueObs == TrueObs = True + TrueObs == _ = False + FalseObs == FalseObs = True + FalseObs == _ = False + + +instance Eq Action where + {-# INLINABLE (==) #-} + Deposit acc1 party1 tok1 val1 == Deposit acc2 party2 tok2 val2 = + acc1 == acc2 && party1 == party2 && tok1 == tok2 && val1 == val2 + Deposit{} == _ = False + Choice cid1 bounds1 == Choice cid2 bounds2 = + cid1 == cid2 && length bounds1 == length bounds2 && let + bounds = zip bounds1 bounds2 + checkBound (Bound low1 high1, Bound low2 high2) = low1 == low2 && high1 == high2 + in all checkBound bounds + Choice{} == _ = False + Notify obs1 == Notify obs2 = obs1 == obs2 + Notify{} == _ = False + + +instance Eq a => Eq (Case a) where + {-# INLINABLE (==) #-} + Case acl cl == Case acr cr = acl == acr && cl == cr + Case{} == _ = False + MerkleizedCase acl bsl == MerkleizedCase acr bsr = acl == acr && bsl == bsr + MerkleizedCase{} == _ = False + + +instance Eq Contract where + {-# INLINABLE (==) #-} + Close == Close = True + Close == _ = False + Pay acc1 payee1 tok1 value1 cont1 == Pay acc2 payee2 tok2 value2 cont2 = + acc1 == acc2 && payee1 == payee2 && tok1 == tok2 && value1 == value2 && cont1 == cont2 + Pay{} == _ = False + If obs1 cont1 cont2 == If obs2 cont3 cont4 = + obs1 == obs2 && cont1 == cont3 && cont2 == cont4 + If{} == _ = False + When cases1 timeout1 cont1 == When cases2 timeout2 cont2 = + timeout1 == timeout2 && cont1 == cont2 + && length cases1 == length cases2 + && and (zipWith (==) cases1 cases2) + When{} == _ = False + Let valId1 val1 cont1 == Let valId2 val2 cont2 = + valId1 == valId2 && val1 == val2 && cont1 == cont2 + Let{} == _ = False + Assert obs1 cont1 == Assert obs2 cont2 = obs1 == obs2 && cont1 == cont2 + Assert{} == _ = False + + +instance Eq State where + {-# INLINABLE (==) #-} + l == r = minTime l == minTime r + && accounts l == accounts r + && choices l == choices r + && boundValues l == boundValues r + + +-- Lifting data types to Plutus Core +makeLift ''Party +makeIsDataIndexed ''Party [('Address,0),('Role,1)] +makeLift ''ChoiceId +makeIsDataIndexed ''ChoiceId [('ChoiceId,0)] +makeLift ''Token +makeIsDataIndexed ''Token [('Token,0)] +makeLift ''ValueId +makeIsDataIndexed ''ValueId [('ValueId,0)] +makeLift ''Value +makeIsDataIndexed ''Value [ + ('AvailableMoney,0), + ('Constant,1), + ('NegValue,2), + ('AddValue,3), + ('SubValue,4), + ('MulValue,5), + ('DivValue,6), + ('ChoiceValue,7), + ('TimeIntervalStart, 8), + ('TimeIntervalEnd,9), + ('UseValue,10), + ('Cond,11) + ] +makeLift ''Observation +makeIsDataIndexed ''Observation [ + ('AndObs,0), + ('OrObs,1), + ('NotObs,2), + ('ChoseSomething,3), + ('ValueGE,4), + ('ValueGT,5), + ('ValueLT,6), + ('ValueLE,7), + ('ValueEQ,8), + ('TrueObs,9), + ('FalseObs,10) + ] +makeLift ''Bound +makeIsDataIndexed ''Bound [('Bound,0)] +makeLift ''Action +makeIsDataIndexed ''Action [('Deposit,0),('Choice,1),('Notify,2)] +makeLift ''Case +makeIsDataIndexed ''Case [('Case,0),('MerkleizedCase,1)] +makeLift ''Payee +makeIsDataIndexed ''Payee [('Account,0),('Party,1)] +makeLift ''Contract +makeIsDataIndexed ''Contract [ + ('Close,0), + ('Pay,1), + ('If,2), + ('When,3), + ('Let,4), + ('Assert,5) + ] +makeLift ''State +makeIsDataIndexed ''State [('State,0)] +makeLift ''Environment +makeLift ''InputContent +makeIsDataIndexed ''InputContent [('IDeposit,0),('IChoice,1),('INotify,2)] +makeLift ''Input +makeIsDataIndexed ''Input [('NormalInput,0),('MerkleizedInput,1)] diff --git a/marlowe-cardano-minimal/src/Language/Marlowe/Core/V1/Semantics/Types/Address.hs b/marlowe-cardano-minimal/src/Language/Marlowe/Core/V1/Semantics/Types/Address.hs new file mode 100644 index 00000000000..ef67a31c219 --- /dev/null +++ b/marlowe-cardano-minimal/src/Language/Marlowe/Core/V1/Semantics/Types/Address.hs @@ -0,0 +1,23 @@ + + +----------------------------------------------------------------------------- +-- +-- Module : $Headers +-- License : Apache 2.0 +-- +-- Stability : Experimental +-- Portability : Portable +-- +-- | Address types for Marlowe. +-- +----------------------------------------------------------------------------- + + +module Language.Marlowe.Core.V1.Semantics.Types.Address + ( -- * Types + Network + ) where + + +-- | Type of network. +type Network = Bool diff --git a/marlowe-cardano-minimal/src/Language/Marlowe/Scripts.hs b/marlowe-cardano-minimal/src/Language/Marlowe/Scripts.hs new file mode 100644 index 00000000000..ac85d053dfb --- /dev/null +++ b/marlowe-cardano-minimal/src/Language/Marlowe/Scripts.hs @@ -0,0 +1,523 @@ +-- editorconfig-checker-disable-file +----------------------------------------------------------------------------- +-- +-- Module : $Headers +-- License : Apache 2.0 +-- +-- Stability : Experimental +-- Portability : Portable +-- +-- | Marlowe validators. +-- +----------------------------------------------------------------------------- + + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:dump-pir #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:dump-plc #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:dump-uplc #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + + +module Language.Marlowe.Scripts + ( -- * Types + MarloweInput + , MarloweTxInput(..) + -- * Semantics Validator + , marloweValidatorHash + , marloweValidatorBytes + , marloweValidator + , mkMarloweValidator + -- * Payout Validator + , rolePayoutValidatorHash + , rolePayoutValidatorBytes + , rolePayoutValidator + , mkRolePayoutValidator + -- * Utilities + , marloweTxInputsFromInputs + ) where + + +import GHC.Generics (Generic) +import Language.Marlowe.Core.V1.Semantics as Semantics (MarloweData (..), + MarloweParams (MarloweParams, rolesCurrency), + Payment (..), + TransactionError (TEAmbiguousTimeIntervalError, TEApplyNoMatchError, TEHashMismatch, TEIntervalError, TEUselessTransaction), + TransactionInput (TransactionInput, txInputs, txInterval), + TransactionOutput (Error, TransactionOutput, txOutContract, txOutPayments, txOutState), + computeTransaction, totalBalance) +import Language.Marlowe.Core.V1.Semantics.Types as Semantics (ChoiceId (ChoiceId), Contract (Close), + Input (..), InputContent (..), + IntervalError (IntervalInPastError, InvalidInterval), + Party (..), Payee (Account, Party), + State (..), Token (Token), + getInputContent) +import PlutusLedgerApi.V2 (Credential (..), CurrencySymbol, Datum (Datum), DatumHash (DatumHash), + Extended (..), Interval (..), LowerBound (..), POSIXTime (..), + POSIXTimeRange, + ScriptContext (ScriptContext, scriptContextPurpose, scriptContextTxInfo), + ScriptHash (..), ScriptPurpose (Spending), SerialisedScript, TokenName, + TxInInfo (TxInInfo, txInInfoOutRef, txInInfoResolved), + TxInfo (TxInfo, txInfoInputs, txInfoOutputs, txInfoValidRange), + UpperBound (..), serialiseCompiledCode) +import PlutusLedgerApi.V2.Contexts (findDatum, findDatumHash, txSignedBy, valueSpent) +import PlutusLedgerApi.V2.Tx (OutputDatum (OutputDatumHash), + TxOut (TxOut, txOutAddress, txOutDatum, txOutValue)) +import PlutusTx (CompiledCode, makeIsDataIndexed, makeLift, unsafeFromBuiltinData) +import PlutusTx.Plugin () +import PlutusTx.Prelude as PlutusTxPrelude (AdditiveGroup ((-)), AdditiveMonoid (zero), + AdditiveSemigroup ((+)), Bool (..), BuiltinByteString, + BuiltinData, BuiltinString, Enum (fromEnum), Eq (..), + Functor (fmap), Integer, Maybe (..), Ord ((>)), + Semigroup ((<>)), all, any, check, elem, error, filter, + find, foldMap, fromMaybe, id, null, otherwise, snd, + toBuiltin, ($), (&&), (.), (/=), (||)) + +import Cardano.Crypto.Hash qualified as Hash +import Data.ByteString qualified as BS +import Data.ByteString.Short qualified as SBS +import PlutusCore.Version (plcVersion100) +import PlutusLedgerApi.V1.Address qualified as Address (scriptHashAddress) +import PlutusLedgerApi.V1.Value qualified as Val +import PlutusLedgerApi.V2 qualified as Ledger (Address (Address)) +import PlutusTx qualified +import PlutusTx.AssocMap qualified as AssocMap +import Prelude qualified as Haskell + + +-- Suppress traces, in order to save bytes. + +{-# INLINABLE traceError #-} +traceError :: BuiltinString -> a +traceError _ = error () + +{-# INLINABLE traceIfFalse #-} +traceIfFalse :: BuiltinString -> a -> a +traceIfFalse _ = id + + +-- | Input to a Marlowe transaction. +type MarloweInput = [MarloweTxInput] + + +-- | Tag for the Marlowe semantics validator. +data TypedMarloweValidator + + +-- | Tag for the Marlowe payout validator. +data TypedRolePayoutValidator + + +-- | A single input applied in the Marlowe semantics validator. +data MarloweTxInput = Input InputContent + | MerkleizedTxInput InputContent BuiltinByteString + deriving stock (Haskell.Show,Haskell.Eq,Generic) + + +-- | The Marlowe payout validator. +mkRolePayoutValidator :: (CurrencySymbol, TokenName) -- ^ The datum is the currency symbol and role name for the payout. + -> () -- ^ No redeemer is required. + -> ScriptContext -- ^ The script context. + -> Bool -- ^ Whether the transaction validated. +mkRolePayoutValidator (currency, role) _ ctx = + -- The role token for the correct currency must be present. + -- [Marlowe-Cardano Specification: "17. Payment authorized".] + Val.singleton currency role 1 `Val.leq` valueSpent (scriptContextTxInfo ctx) + + +{-# INLINABLE closeInterval #-} +-- | Convert a Plutus POSIX time range into the closed interval needed by Marlowe semantics. +closeInterval :: POSIXTimeRange -> Maybe (POSIXTime, POSIXTime) +closeInterval (Interval (LowerBound (Finite (POSIXTime l)) lc) (UpperBound (Finite (POSIXTime h)) hc)) = + Just + ( + POSIXTime $ l + 1 - fromEnum lc -- Add one millisecond if the interval was open. + , POSIXTime $ h - 1 + fromEnum hc -- Subtract one millisecond if the interval was open. + ) +closeInterval _ = Nothing + + +{-# INLINABLE mkMarloweValidator #-} +-- | The Marlowe semantics validator. +mkMarloweValidator + :: ScriptHash -- ^ The hash of the corresponding Marlowe payout validator. + -> MarloweData -- ^ The datum is the Marlowe parameters, state, and contract. + -> MarloweInput -- ^ The redeemer is the list of inputs applied to the contract. + -> ScriptContext -- ^ The script context. + -> Bool -- ^ Whether the transaction validated. +mkMarloweValidator + rolePayoutValidatorHash + MarloweData{..} + marloweTxInputs + ctx@ScriptContext{scriptContextTxInfo} = do + + let scriptInValue = txOutValue $ txInInfoResolved ownInput + let interval = + -- Marlowe semantics require a closed interval, so we might adjust by one millisecond. + case closeInterval $ txInfoValidRange scriptContextTxInfo of + Just interval' -> interval' + Nothing -> traceError "a" + + -- Find Contract continuation in TxInfo datums by hash or fail with error. + let inputs = fmap marloweTxInputToInput marloweTxInputs + + {- We do not check that a transaction contains exact input payments. + We only require an evidence from a party, e.g. a signature for PubKey party, + or a spend of a 'party role' token. This gives huge flexibility by allowing + parties to provide multiple inputs (either other contracts or P2PKH). + Then, we check scriptOutput to be correct. + -} + let inputContents = fmap getInputContent inputs + + -- Check that the required signatures and role tokens are present. + -- [Marlowe-Cardano Specification: "Constraint 14. Inputs authorized".] + let inputsOk = allInputsAreAuthorized inputContents + + -- [Marlowe-Cardano Specification: "Constraint 5. Input value from script".] + -- [Marlowe-Cardano Specification: "Constraint 13. Positive balances".] + -- [Marlowe-Cardano Specification: "Constraint 19. No duplicates".] + -- Check that the initial state obeys the Semantic's invariants. + let preconditionsOk = checkState "i" scriptInValue marloweState + + -- [Marlowe-Cardano Specification: "Constraint 0. Input to semantics".] + -- Package the inputs to be applied in the semantics. + let txInput = TransactionInput { + txInterval = interval, + txInputs = inputs } + + -- [Marlowe-Cardano Specification: "Constraint 7. Input state".] + -- [Marlowe-Cardano Specification: "Constraint 8. Input contract".] + -- The semantics computation operates on the state and contract from + -- the incoming datum. + let computedResult = computeTransaction txInput marloweState marloweContract + case computedResult of + TransactionOutput {txOutPayments, txOutState, txOutContract} -> do + + -- [Marlowe-Cardano Specification: "Constraint 9. Marlowe parameters".] + -- [Marlowe-Cardano Specification: "Constraint 10. Output state".] + -- [Marlowe-Cardano Specification: "Constraint 11. Output contract."] + -- The output datum maintains the parameters and uses the state + -- and contract resulting from the semantics computation. + let marloweData = MarloweData { + marloweParams = marloweParams, + marloweContract = txOutContract, + marloweState = txOutState } + + -- Each party must receive as least as much value as the semantics specify. + -- [Marlowe-Cardano Specification: "Constraint 15. Sufficient payment."] + payoutsByParty = AssocMap.toList $ foldMap payoutByParty txOutPayments + payoutsOk = payoutConstraints payoutsByParty + + checkContinuation = case txOutContract of + -- [Marlowe-Cardano Specification: "Constraint 4. No output to script on close".] + Close -> traceIfFalse "c" hasNoOutputToOwnScript + _ -> let + totalIncome = foldMap collectDeposits inputContents + totalPayouts = foldMap snd payoutsByParty + finalBalance = scriptInValue + totalIncome - totalPayouts + in + -- [Marlowe-Cardano Specification: "Constraint 3. Single Marlowe output".] + -- [Marlowe-Cardano Specification: "Constraint 6. Output value to script."] + -- Check that the single Marlowe output has the correct datum and value. + checkOwnOutputConstraint marloweData finalBalance + -- [Marlowe-Cardano Specification: "Constraint 18. Final balance."] + -- [Marlowe-Cardano Specification: "Constraint 13. Positive balances".] + -- [Marlowe-Cardano Specification: "Constraint 19. No duplicates".] + -- Check that the final state obeys the Semantic's invariants. + && checkState "o" finalBalance txOutState + preconditionsOk && inputsOk && payoutsOk && checkContinuation + -- [Marlowe-Cardano Specification: "20. Single satsifaction".] + -- Either there must be no payouts, or there must be no other validators. + && traceIfFalse "z" (null payoutsByParty || noOthers) + Error TEAmbiguousTimeIntervalError -> traceError "i" + Error TEApplyNoMatchError -> traceError "n" + Error (TEIntervalError (InvalidInterval _)) -> traceError "j" + Error (TEIntervalError (IntervalInPastError _ _)) -> traceError "k" + Error TEUselessTransaction -> traceError "u" + Error TEHashMismatch -> traceError "m" + + where + + -- The roles currency is in the Marlowe parameters. + MarloweParams{ rolesCurrency } = marloweParams + + -- Find the input being spent by a script. + findOwnInput :: ScriptContext -> Maybe TxInInfo + findOwnInput ScriptContext{scriptContextTxInfo=TxInfo{txInfoInputs}, scriptContextPurpose=Spending txOutRef} = + find (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == txOutRef) txInfoInputs + findOwnInput _ = Nothing + + -- [Marlowe-Cardano Specification: "2. Single Marlowe script input".] + -- The inputs being spent by this script, and whether other validators are present. + ownInput :: TxInInfo + noOthers :: Bool + (ownInput@TxInInfo{txInInfoResolved=TxOut{txOutAddress=ownAddress}}, noOthers) = + case findOwnInput ctx of + Just ownTxInInfo -> examineScripts (sameValidatorHash ownTxInInfo) Nothing True (txInfoInputs scriptContextTxInfo) + _ -> traceError "x" -- Input to be validated was not found. + + -- Check for the presence of multiple Marlowe validators or other Plutus validators. + examineScripts + :: (ScriptHash -> Bool) -- Test for this validator. + -> Maybe TxInInfo -- The input for this validator, if found so far. + -> Bool -- Whether no other validator has been found so far. + -> [TxInInfo] -- The inputs remaining to be examined. + -> (TxInInfo, Bool) -- The input for this validator and whehter no other validators are present. + -- This validator has not been found. + examineScripts _ Nothing _ [] = traceError "x" + -- This validator has been found, and other validators may have been found. + examineScripts _ (Just self) noOthers [] = (self, noOthers) + -- Found both this validator and another script, so we short-cut. + examineScripts _ (Just self) False _ = (self, False) + -- Found one script. + examineScripts f mSelf noOthers (tx@TxInInfo{txInInfoResolved=TxOut{txOutAddress=Ledger.Address (ScriptCredential vh) _}} : txs) + -- The script is this validator. + | f vh = case mSelf of + -- We hadn't found it before, so we save it in `mSelf`. + Nothing -> examineScripts f (Just tx) noOthers txs + -- We already had found this validator before + Just _ -> traceError "w" + -- The script is something else, so we set `noOther` to `False`. + | otherwise = examineScripts f mSelf False txs + -- An input without a validator is encountered. + examineScripts f self others (_ : txs) = examineScripts f self others txs + + -- Check if inputs are being spent from the same script. + sameValidatorHash:: TxInInfo -> ScriptHash -> Bool + sameValidatorHash TxInInfo{txInInfoResolved=TxOut{txOutAddress=Ledger.Address (ScriptCredential vh1) _}} vh2 = vh1 == vh2 + sameValidatorHash _ _ = False + + -- Check a state for the correct value, positive accounts, and no duplicates. + checkState :: BuiltinString -> Val.Value -> State -> Bool + checkState tag expected State{..} = + let + positiveBalance :: (a, Integer) -> Bool + positiveBalance (_, balance) = balance > 0 + noDuplicates :: Eq k => AssocMap.Map k v -> Bool + noDuplicates am = + let + test [] = True -- An empty list has no duplicates. + test (x : xs) -- Look for a duplicate of the head in the tail. + | elem x xs = False -- A duplicate is present. + | otherwise = test xs -- Continue searching for a duplicate. + in + test $ AssocMap.keys am + in + -- [Marlowe-Cardano Specification: "Constraint 5. Input value from script".] + -- and/or + -- [Marlowe-Cardano Specification: "Constraint 18. Final balance."] + traceIfFalse ("v" <> tag) (totalBalance accounts == expected) + -- [Marlowe-Cardano Specification: "Constraint 13. Positive balances".] + && traceIfFalse ("b" <> tag) (all positiveBalance $ AssocMap.toList accounts) + -- [Marlowe-Cardano Specification: "Constraint 19. No duplicates".] + && traceIfFalse ("ea" <> tag) (noDuplicates accounts) + && traceIfFalse ("ec" <> tag) (noDuplicates choices) + && traceIfFalse ("eb" <> tag) (noDuplicates boundValues) + + -- Look up the Datum hash for specific data. + findDatumHash' :: PlutusTx.ToData o => o -> Maybe DatumHash + findDatumHash' datum = findDatumHash (Datum $ PlutusTx.toBuiltinData datum) scriptContextTxInfo + + -- Check that the correct datum and value is being output to the script. + checkOwnOutputConstraint :: MarloweData -> Val.Value -> Bool + checkOwnOutputConstraint ocDatum ocValue = + let hsh = findDatumHash' ocDatum + in traceIfFalse "d" -- "Output constraint" + $ checkScriptOutput (==) ownAddress hsh ocValue getContinuingOutput + + getContinuingOutput :: TxOut + getContinuingOutput = case filter (\TxOut{txOutAddress} -> ownAddress == txOutAddress) allOutputs of + [out] -> out + _ -> traceError "o" -- No continuation or multiple Marlowe contract outputs is forbidden. + + -- Check that address, value, and datum match the specified. + checkScriptOutput :: (Val.Value -> Val.Value -> Bool) -> Ledger.Address -> Maybe DatumHash -> Val.Value -> TxOut -> Bool + checkScriptOutput comparison addr hsh value TxOut{txOutAddress, txOutValue, txOutDatum=OutputDatumHash svh} = + txOutValue `comparison` value && hsh == Just svh && txOutAddress == addr + checkScriptOutput _ _ _ _ _ = False + + -- Check for any output to the script address. + hasNoOutputToOwnScript :: Bool + hasNoOutputToOwnScript = all ((/= ownAddress) . txOutAddress) allOutputs + + -- All of the script outputs. + allOutputs :: [TxOut] + allOutputs = txInfoOutputs scriptContextTxInfo + + -- Check mekleization and transform transaction input to semantics input. + marloweTxInputToInput :: MarloweTxInput -> Input + marloweTxInputToInput (MerkleizedTxInput input hash) = + case findDatum (DatumHash hash) scriptContextTxInfo of + Just (Datum d) -> let + continuation = PlutusTx.unsafeFromBuiltinData d + in MerkleizedInput input hash continuation + Nothing -> traceError "h" + marloweTxInputToInput (Input input) = NormalInput input + + -- Check that inputs are authorized. + allInputsAreAuthorized :: [InputContent] -> Bool + allInputsAreAuthorized = all validateInputWitness + where + validateInputWitness :: InputContent -> Bool + validateInputWitness input = + case input of + IDeposit _ party _ _ -> validatePartyWitness party -- The party must witness a deposit. + IChoice (ChoiceId _ party) _ -> validatePartyWitness party -- The party must witness a choice. + INotify -> True -- No witness is needed for a notify. + where + validatePartyWitness :: Party -> Bool + validatePartyWitness (Address _ address) = traceIfFalse "s" $ txSignedByAddress address -- The key must have signed. + validatePartyWitness (Role role) = traceIfFalse "t" -- The role token must be present. + $ Val.singleton rolesCurrency role 1 `Val.leq` valueSpent scriptContextTxInfo + + -- Tally the deposits in the input. + collectDeposits :: InputContent -> Val.Value + collectDeposits (IDeposit _ _ (Token cur tok) amount) + | amount > 0 = Val.singleton cur tok amount -- SCP-5123: Semantically negative deposits + | otherwise = zero -- do not remove funds from the script's UTxO. + collectDeposits _ = zero + + -- Extract the payout to a party. + payoutByParty :: Payment -> AssocMap.Map Party Val.Value + payoutByParty (Payment _ (Party party) (Token cur tok) amount) + | amount > 0 = AssocMap.singleton party $ Val.singleton cur tok amount + | otherwise = AssocMap.empty -- NOTE: Perhaps required because semantics may make zero payments + -- (though this passes the test suite), but removing this function's + -- guard reduces the validator size by 20 bytes. + payoutByParty (Payment _ (Account _) _ _ ) = AssocMap.empty + + -- Check outgoing payments. + payoutConstraints :: [(Party, Val.Value)] -> Bool + payoutConstraints = all payoutToTxOut + where + payoutToTxOut :: (Party, Val.Value) -> Bool + payoutToTxOut (party, value) = case party of + -- [Marlowe-Cardano Specification: "Constraint 15. Sufficient Payment".] + -- SCP-5128: Note that the payment to an address may be split into several outputs but the payment to a role must be + -- a single output. The flexibily of multiple outputs accommodates wallet-related practicalities such as the change and + -- the return of the role token being in separate UTxOs in situations where a contract is also paying to the address + -- where that change and that role token are sent. + Address _ address -> traceIfFalse "p" $ value `Val.leq` valuePaidToAddress address -- At least sufficient value paid. + Role role -> let + hsh = findDatumHash' (rolesCurrency, role) + addr = Address.scriptHashAddress rolePayoutValidatorHash + -- Some output must have the correct value and datum to the role-payout address. + in traceIfFalse "r" $ any (checkScriptOutput Val.geq addr hsh value) allOutputs + + -- The key for the address must have signed. + txSignedByAddress :: Ledger.Address -> Bool + txSignedByAddress (Ledger.Address (PubKeyCredential pkh) _) = scriptContextTxInfo `txSignedBy` pkh + txSignedByAddress _ = False + + -- Tally the value paid to an address. + valuePaidToAddress :: Ledger.Address -> Val.Value + valuePaidToAddress address = foldMap txOutValue $ filter ((== address) . txOutAddress) allOutputs + + +-- | Convert semantics input to transaction input. +marloweTxInputFromInput :: Input -> MarloweTxInput +marloweTxInputFromInput (NormalInput i) = Input i +marloweTxInputFromInput (MerkleizedInput i h _) = MerkleizedTxInput i h + + +-- | Convert semantics inputs to transaction inputs. +marloweTxInputsFromInputs :: [Input] -> [MarloweTxInput] +marloweTxInputsFromInputs = fmap marloweTxInputFromInput + + +-- Lifting data types to Plutus Core +makeLift ''MarloweTxInput +makeIsDataIndexed ''MarloweTxInput [('Input,0),('MerkleizedTxInput,1)] + + +-- | Compute the hash of a script. +hashScript :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) -> ScriptHash +hashScript = + -- FIXME: Apparently this is the wrong recipe, since its hash disagrees with `cardano-cli`. + ScriptHash + . toBuiltin + . (Hash.hashToBytes :: Hash.Hash Hash.Blake2b_224 SBS.ShortByteString -> BS.ByteString) + . Hash.hashWith (BS.append "\x02" . SBS.fromShort) -- For Plutus V2. + . serialiseCompiledCode + + +{-# INLINABLE rolePayoutValidator #-} +-- | The Marlowe payout validator. +rolePayoutValidator :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) +rolePayoutValidator = + $$(PlutusTx.compile [|| rolePayoutValidator' ||]) + where + rolePayoutValidator' :: BuiltinData -> BuiltinData -> BuiltinData -> () + rolePayoutValidator' d r p = + check + $ mkRolePayoutValidator + (unsafeFromBuiltinData d) + (unsafeFromBuiltinData r) + (unsafeFromBuiltinData p) + + +-- | The serialisation of the Marlowe payout validator. +rolePayoutValidatorBytes :: SerialisedScript +rolePayoutValidatorBytes = serialiseCompiledCode rolePayoutValidator + + +-- | The hash of the Marlowe payout validator. +rolePayoutValidatorHash :: ScriptHash +rolePayoutValidatorHash = hashScript rolePayoutValidator + + +-- | The validator for Marlowe semantics. +marloweValidator :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) +marloweValidator = + let + marloweValidator' :: ScriptHash -> BuiltinData -> BuiltinData -> BuiltinData -> () + marloweValidator' rpvh d r p = + check + $ mkMarloweValidator rpvh + (unsafeFromBuiltinData d) + (unsafeFromBuiltinData r) + (unsafeFromBuiltinData p) + + errorOrApplied = + $$(PlutusTx.compile [|| marloweValidator' ||]) + `PlutusTx.applyCode` PlutusTx.liftCode plcVersion100 rolePayoutValidatorHash + in + case errorOrApplied of + Haskell.Left err -> + Haskell.error $ "Application of role-payout validator hash to marlowe validator failed." + <> err + Haskell.Right applied -> applied + +-- | The serialisation of the Marlowe semantics validator. +marloweValidatorBytes :: SerialisedScript +marloweValidatorBytes = serialiseCompiledCode marloweValidator + + +-- | The hash of the Marlowe semantics validator. +marloweValidatorHash :: ScriptHash +marloweValidatorHash = hashScript marloweValidator diff --git a/marlowe-cardano-minimal/src/Language/Marlowe/Scripts/RolePayout.hs b/marlowe-cardano-minimal/src/Language/Marlowe/Scripts/RolePayout.hs new file mode 100644 index 00000000000..cadadbc5a97 --- /dev/null +++ b/marlowe-cardano-minimal/src/Language/Marlowe/Scripts/RolePayout.hs @@ -0,0 +1,119 @@ + +-- editorconfig-checker-disable-file + + +----------------------------------------------------------------------------- +-- +-- Module : $Headers +-- License : Apache 2.0 +-- +-- Stability : Experimental +-- Portability : Portable +-- +-- | Marlowe validators. +-- +----------------------------------------------------------------------------- + + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + + +module Language.Marlowe.Scripts.RolePayout + (-- * Payout Validator + rolePayoutValidatorHash + , rolePayoutValidatorBytes + , rolePayoutValidator + , mkRolePayoutValidator + ) where + + +import PlutusLedgerApi.V2 (CurrencySymbol, ScriptContext (scriptContextTxInfo), ScriptHash (..), + SerialisedScript, TokenName, serialiseCompiledCode) +import PlutusLedgerApi.V2.Contexts (valueSpent) +import PlutusTx (CompiledCode, unsafeFromBuiltinData) +import PlutusTx.Plugin () +import PlutusTx.Prelude as PlutusTxPrelude (Bool (..), BuiltinData, check, toBuiltin, ($), (.)) + +import Cardano.Crypto.Hash qualified as Hash +import Data.ByteString qualified as BS +import Data.ByteString.Short qualified as SBS +import PlutusLedgerApi.V1.Value qualified as Val +import PlutusTx qualified + + +-- | Tag for the Marlowe payout validator. +data TypedRolePayoutValidator + + +-- | The Marlowe payout validator. +mkRolePayoutValidator :: (CurrencySymbol, TokenName) -- ^ The datum is the currency symbol and role name for the payout. + -> () -- ^ No redeemer is required. + -> ScriptContext -- ^ The script context. + -> Bool -- ^ Whether the transaction validated. +mkRolePayoutValidator (currency, role) _ ctx = + -- The role token for the correct currency must be present. + -- [Marlowe-Cardano Specification: "17. Payment authorized".] + Val.singleton currency role 1 `Val.leq` valueSpent (scriptContextTxInfo ctx) + + +-- | Compute the hash of a script. +hashScript :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) -> ScriptHash +hashScript = + -- FIXME: Apparently this is the wrong recipe, since its hash disagrees with `cardano-cli`. + ScriptHash + . toBuiltin + . (Hash.hashToBytes :: Hash.Hash Hash.Blake2b_224 SBS.ShortByteString -> BS.ByteString) + . Hash.hashWith (BS.append "\x02" . SBS.fromShort) -- For Plutus V2. + . serialiseCompiledCode + + +{-# INLINABLE rolePayoutValidator #-} + +-- | The Marlowe payout validator. +rolePayoutValidator :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) +rolePayoutValidator = + $$(PlutusTx.compile [|| rolePayoutValidator' ||]) + where + rolePayoutValidator' :: BuiltinData -> BuiltinData -> BuiltinData -> () + rolePayoutValidator' d r p = + check + $ mkRolePayoutValidator + (unsafeFromBuiltinData d) + (unsafeFromBuiltinData r) + (unsafeFromBuiltinData p) + + +-- | The serialisation of the Marlowe payout validator. +rolePayoutValidatorBytes :: SerialisedScript +rolePayoutValidatorBytes = serialiseCompiledCode rolePayoutValidator + + +-- | The hash of the Marlowe payout validator. +rolePayoutValidatorHash :: ScriptHash +rolePayoutValidatorHash = hashScript rolePayoutValidator diff --git a/marlowe-cardano-minimal/src/Language/Marlowe/Scripts/Semantics.hs b/marlowe-cardano-minimal/src/Language/Marlowe/Scripts/Semantics.hs new file mode 100644 index 00000000000..691b6c51f2d --- /dev/null +++ b/marlowe-cardano-minimal/src/Language/Marlowe/Scripts/Semantics.hs @@ -0,0 +1,482 @@ + +-- editorconfig-checker-disable-file + + +----------------------------------------------------------------------------- +-- +-- Module : $Headers +-- License : Apache 2.0 +-- +-- Stability : Experimental +-- Portability : Portable +-- +-- | Marlowe validators. +-- +----------------------------------------------------------------------------- + + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:dump-pir #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:dump-plc #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:dump-uplc #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + + +module Language.Marlowe.Scripts.Semantics + ( -- * Types + MarloweInput + , MarloweTxInput(..) + -- * Semantics Validator + , marloweValidatorHash + , marloweValidatorBytes + , marloweValidator + , mkMarloweValidator + -- * Utilities + , marloweTxInputsFromInputs + ) where + + +import GHC.Generics (Generic) +import Language.Marlowe.Core.V1.Semantics as Semantics (MarloweData (..), + MarloweParams (MarloweParams, rolesCurrency), + Payment (..), + TransactionError (TEAmbiguousTimeIntervalError, TEApplyNoMatchError, TEHashMismatch, TEIntervalError, TEUselessTransaction), + TransactionInput (TransactionInput, txInputs, txInterval), + TransactionOutput (Error, TransactionOutput, txOutContract, txOutPayments, txOutState), + computeTransaction, totalBalance) +import Language.Marlowe.Core.V1.Semantics.Types as Semantics (ChoiceId (ChoiceId), Contract (Close), + Input (..), InputContent (..), + IntervalError (IntervalInPastError, InvalidInterval), + Party (..), Payee (Account, Party), + State (..), Token (Token), + getInputContent) +import Language.Marlowe.Scripts.RolePayout (rolePayoutValidatorHash) +import PlutusLedgerApi.V2 (Credential (..), Datum (Datum), DatumHash (DatumHash), Extended (..), + Interval (..), LowerBound (..), POSIXTime (..), POSIXTimeRange, + ScriptContext (ScriptContext, scriptContextPurpose, scriptContextTxInfo), + ScriptHash (..), ScriptPurpose (Spending), SerialisedScript, + TxInInfo (TxInInfo, txInInfoOutRef, txInInfoResolved), + TxInfo (TxInfo, txInfoInputs, txInfoOutputs, txInfoValidRange), + UpperBound (..), serialiseCompiledCode) +import PlutusLedgerApi.V2.Contexts (findDatum, findDatumHash, txSignedBy, valueSpent) +import PlutusLedgerApi.V2.Tx (OutputDatum (OutputDatumHash), + TxOut (TxOut, txOutAddress, txOutDatum, txOutValue)) +import PlutusTx (CompiledCode, makeIsDataIndexed, makeLift, unsafeFromBuiltinData) +import PlutusTx.Plugin () +import PlutusTx.Prelude as PlutusTxPrelude (AdditiveGroup ((-)), AdditiveMonoid (zero), + AdditiveSemigroup ((+)), Bool (..), BuiltinByteString, + BuiltinData, BuiltinString, Enum (fromEnum), Eq (..), + Functor (fmap), Integer, Maybe (..), Ord ((>)), + Semigroup ((<>)), all, any, check, elem, error, filter, + find, foldMap, id, null, otherwise, snd, toBuiltin, ($), + (&&), (.), (/=), (||)) + +import Cardano.Crypto.Hash qualified as Hash +import Data.ByteString qualified as BS +import Data.ByteString.Short qualified as SBS +import PlutusCore.Version (plcVersion100) +import PlutusLedgerApi.V1.Address qualified as Address (scriptHashAddress) +import PlutusLedgerApi.V1.Value qualified as Val +import PlutusLedgerApi.V2 qualified as Ledger (Address (Address)) +import PlutusTx qualified +import PlutusTx.AssocMap qualified as AssocMap +import Prelude qualified as Haskell + + +-- Suppress traces, in order to save bytes. + +{-# INLINABLE traceError #-} +traceError :: BuiltinString -> a +traceError _ = error () + +{-# INLINABLE traceIfFalse #-} +traceIfFalse :: BuiltinString -> a -> a +traceIfFalse _ = id + + +-- | Input to a Marlowe transaction. +type MarloweInput = [MarloweTxInput] + + +-- | Tag for the Marlowe semantics validator. +data TypedMarloweValidator + + +-- | A single input applied in the Marlowe semantics validator. +data MarloweTxInput = Input InputContent + | MerkleizedTxInput InputContent BuiltinByteString + deriving stock (Haskell.Show,Haskell.Eq,Generic) + + +{-# INLINABLE closeInterval #-} +-- | Convert a Plutus POSIX time range into the closed interval needed by Marlowe semantics. +closeInterval :: POSIXTimeRange -> Maybe (POSIXTime, POSIXTime) +closeInterval (Interval (LowerBound (Finite (POSIXTime l)) lc) (UpperBound (Finite (POSIXTime h)) hc)) = + Just + ( + POSIXTime $ l + 1 - fromEnum lc -- Add one millisecond if the interval was open. + , POSIXTime $ h - 1 + fromEnum hc -- Subtract one millisecond if the interval was open. + ) +closeInterval _ = Nothing + + +{-# INLINABLE mkMarloweValidator #-} +-- | The Marlowe semantics validator. +mkMarloweValidator + :: ScriptHash -- ^ The hash of the corresponding Marlowe payout validator. + -> MarloweData -- ^ The datum is the Marlowe parameters, state, and contract. + -> MarloweInput -- ^ The redeemer is the list of inputs applied to the contract. + -> ScriptContext -- ^ The script context. + -> Bool -- ^ Whether the transaction validated. +mkMarloweValidator + rolePayoutValidatorHash + MarloweData{..} + marloweTxInputs + ctx@ScriptContext{scriptContextTxInfo} = do + + let scriptInValue = txOutValue $ txInInfoResolved ownInput + let interval = + -- Marlowe semantics require a closed interval, so we might adjust by one millisecond. + case closeInterval $ txInfoValidRange scriptContextTxInfo of + Just interval' -> interval' + Nothing -> traceError "a" + + -- Find Contract continuation in TxInfo datums by hash or fail with error. + let inputs = fmap marloweTxInputToInput marloweTxInputs + + {- We do not check that a transaction contains exact input payments. + We only require an evidence from a party, e.g. a signature for PubKey party, + or a spend of a 'party role' token. This gives huge flexibility by allowing + parties to provide multiple inputs (either other contracts or P2PKH). + Then, we check scriptOutput to be correct. + -} + let inputContents = fmap getInputContent inputs + + -- Check that the required signatures and role tokens are present. + -- [Marlowe-Cardano Specification: "Constraint 14. Inputs authorized".] + let inputsOk = allInputsAreAuthorized inputContents + + -- [Marlowe-Cardano Specification: "Constraint 5. Input value from script".] + -- [Marlowe-Cardano Specification: "Constraint 13. Positive balances".] + -- [Marlowe-Cardano Specification: "Constraint 19. No duplicates".] + -- Check that the initial state obeys the Semantic's invariants. + let preconditionsOk = checkState "i" scriptInValue marloweState + + -- [Marlowe-Cardano Specification: "Constraint 0. Input to semantics".] + -- Package the inputs to be applied in the semantics. + let txInput = TransactionInput { + txInterval = interval, + txInputs = inputs } + + -- [Marlowe-Cardano Specification: "Constraint 7. Input state".] + -- [Marlowe-Cardano Specification: "Constraint 8. Input contract".] + -- The semantics computation operates on the state and contract from + -- the incoming datum. + let computedResult = computeTransaction txInput marloweState marloweContract + case computedResult of + TransactionOutput {txOutPayments, txOutState, txOutContract} -> do + + -- [Marlowe-Cardano Specification: "Constraint 9. Marlowe parameters".] + -- [Marlowe-Cardano Specification: "Constraint 10. Output state".] + -- [Marlowe-Cardano Specification: "Constraint 11. Output contract."] + -- The output datum maintains the parameters and uses the state + -- and contract resulting from the semantics computation. + let marloweData = MarloweData { + marloweParams = marloweParams, + marloweContract = txOutContract, + marloweState = txOutState } + + -- Each party must receive as least as much value as the semantics specify. + -- [Marlowe-Cardano Specification: "Constraint 15. Sufficient payment."] + payoutsByParty = AssocMap.toList $ foldMap payoutByParty txOutPayments + payoutsOk = payoutConstraints payoutsByParty + + checkContinuation = case txOutContract of + -- [Marlowe-Cardano Specification: "Constraint 4. No output to script on close".] + Close -> traceIfFalse "c" hasNoOutputToOwnScript + _ -> let + totalIncome = foldMap collectDeposits inputContents + totalPayouts = foldMap snd payoutsByParty + finalBalance = scriptInValue + totalIncome - totalPayouts + in + -- [Marlowe-Cardano Specification: "Constraint 3. Single Marlowe output".] + -- [Marlowe-Cardano Specification: "Constraint 6. Output value to script."] + -- Check that the single Marlowe output has the correct datum and value. + checkOwnOutputConstraint marloweData finalBalance + -- [Marlowe-Cardano Specification: "Constraint 18. Final balance."] + -- [Marlowe-Cardano Specification: "Constraint 13. Positive balances".] + -- [Marlowe-Cardano Specification: "Constraint 19. No duplicates".] + -- Check that the final state obeys the Semantic's invariants. + && checkState "o" finalBalance txOutState + preconditionsOk && inputsOk && payoutsOk && checkContinuation + -- [Marlowe-Cardano Specification: "20. Single satsifaction".] + -- Either there must be no payouts, or there must be no other validators. + && traceIfFalse "z" (null payoutsByParty || noOthers) + Error TEAmbiguousTimeIntervalError -> traceError "i" + Error TEApplyNoMatchError -> traceError "n" + Error (TEIntervalError (InvalidInterval _)) -> traceError "j" + Error (TEIntervalError (IntervalInPastError _ _)) -> traceError "k" + Error TEUselessTransaction -> traceError "u" + Error TEHashMismatch -> traceError "m" + + where + + -- The roles currency is in the Marlowe parameters. + MarloweParams{ rolesCurrency } = marloweParams + + -- Find the input being spent by a script. + findOwnInput :: ScriptContext -> Maybe TxInInfo + findOwnInput ScriptContext{scriptContextTxInfo=TxInfo{txInfoInputs}, scriptContextPurpose=Spending txOutRef} = + find (\TxInInfo{txInInfoOutRef} -> txInInfoOutRef == txOutRef) txInfoInputs + findOwnInput _ = Nothing + + -- [Marlowe-Cardano Specification: "2. Single Marlowe script input".] + -- The inputs being spent by this script, and whether other validators are present. + ownInput :: TxInInfo + noOthers :: Bool + (ownInput@TxInInfo{txInInfoResolved=TxOut{txOutAddress=ownAddress}}, noOthers) = + case findOwnInput ctx of + Just ownTxInInfo -> examineScripts (sameValidatorHash ownTxInInfo) Nothing True (txInfoInputs scriptContextTxInfo) + _ -> traceError "x" -- Input to be validated was not found. + + -- Check for the presence of multiple Marlowe validators or other Plutus validators. + examineScripts + :: (ScriptHash -> Bool) -- Test for this validator. + -> Maybe TxInInfo -- The input for this validator, if found so far. + -> Bool -- Whether no other validator has been found so far. + -> [TxInInfo] -- The inputs remaining to be examined. + -> (TxInInfo, Bool) -- The input for this validator and whehter no other validators are present. + -- This validator has not been found. + examineScripts _ Nothing _ [] = traceError "x" + -- This validator has been found, and other validators may have been found. + examineScripts _ (Just self) noOthers [] = (self, noOthers) + -- Found both this validator and another script, so we short-cut. + examineScripts _ (Just self) False _ = (self, False) + -- Found one script. + examineScripts f mSelf noOthers (tx@TxInInfo{txInInfoResolved=TxOut{txOutAddress=Ledger.Address (ScriptCredential vh) _}} : txs) + -- The script is this validator. + | f vh = case mSelf of + -- We hadn't found it before, so we save it in `mSelf`. + Nothing -> examineScripts f (Just tx) noOthers txs + -- We already had found this validator before + Just _ -> traceError "w" + -- The script is something else, so we set `noOther` to `False`. + | otherwise = examineScripts f mSelf False txs + -- An input without a validator is encountered. + examineScripts f self others (_ : txs) = examineScripts f self others txs + + -- Check if inputs are being spent from the same script. + sameValidatorHash:: TxInInfo -> ScriptHash -> Bool + sameValidatorHash TxInInfo{txInInfoResolved=TxOut{txOutAddress=Ledger.Address (ScriptCredential vh1) _}} vh2 = vh1 == vh2 + sameValidatorHash _ _ = False + + -- Check a state for the correct value, positive accounts, and no duplicates. + checkState :: BuiltinString -> Val.Value -> State -> Bool + checkState tag expected State{..} = + let + positiveBalance :: (a, Integer) -> Bool + positiveBalance (_, balance) = balance > 0 + noDuplicates :: Eq k => AssocMap.Map k v -> Bool + noDuplicates am = + let + test [] = True -- An empty list has no duplicates. + test (x : xs) -- Look for a duplicate of the head in the tail. + | elem x xs = False -- A duplicate is present. + | otherwise = test xs -- Continue searching for a duplicate. + in + test $ AssocMap.keys am + in + -- [Marlowe-Cardano Specification: "Constraint 5. Input value from script".] + -- and/or + -- [Marlowe-Cardano Specification: "Constraint 18. Final balance."] + traceIfFalse ("v" <> tag) (totalBalance accounts == expected) + -- [Marlowe-Cardano Specification: "Constraint 13. Positive balances".] + && traceIfFalse ("b" <> tag) (all positiveBalance $ AssocMap.toList accounts) + -- [Marlowe-Cardano Specification: "Constraint 19. No duplicates".] + && traceIfFalse ("ea" <> tag) (noDuplicates accounts) + && traceIfFalse ("ec" <> tag) (noDuplicates choices) + && traceIfFalse ("eb" <> tag) (noDuplicates boundValues) + + -- Look up the Datum hash for specific data. + findDatumHash' :: PlutusTx.ToData o => o -> Maybe DatumHash + findDatumHash' datum = findDatumHash (Datum $ PlutusTx.toBuiltinData datum) scriptContextTxInfo + + -- Check that the correct datum and value is being output to the script. + checkOwnOutputConstraint :: MarloweData -> Val.Value -> Bool + checkOwnOutputConstraint ocDatum ocValue = + let hsh = findDatumHash' ocDatum + in traceIfFalse "d" -- "Output constraint" + $ checkScriptOutput (==) ownAddress hsh ocValue getContinuingOutput + + getContinuingOutput :: TxOut + getContinuingOutput = case filter (\TxOut{txOutAddress} -> ownAddress == txOutAddress) allOutputs of + [out] -> out + _ -> traceError "o" -- No continuation or multiple Marlowe contract outputs is forbidden. + + -- Check that address, value, and datum match the specified. + checkScriptOutput :: (Val.Value -> Val.Value -> Bool) -> Ledger.Address -> Maybe DatumHash -> Val.Value -> TxOut -> Bool + checkScriptOutput comparison addr hsh value TxOut{txOutAddress, txOutValue, txOutDatum=OutputDatumHash svh} = + txOutValue `comparison` value && hsh == Just svh && txOutAddress == addr + checkScriptOutput _ _ _ _ _ = False + + -- Check for any output to the script address. + hasNoOutputToOwnScript :: Bool + hasNoOutputToOwnScript = all ((/= ownAddress) . txOutAddress) allOutputs + + -- All of the script outputs. + allOutputs :: [TxOut] + allOutputs = txInfoOutputs scriptContextTxInfo + + -- Check mekleization and transform transaction input to semantics input. + marloweTxInputToInput :: MarloweTxInput -> Input + marloweTxInputToInput (MerkleizedTxInput input hash) = + case findDatum (DatumHash hash) scriptContextTxInfo of + Just (Datum d) -> let + continuation = PlutusTx.unsafeFromBuiltinData d + in MerkleizedInput input hash continuation + Nothing -> traceError "h" + marloweTxInputToInput (Input input) = NormalInput input + + -- Check that inputs are authorized. + allInputsAreAuthorized :: [InputContent] -> Bool + allInputsAreAuthorized = all validateInputWitness + where + validateInputWitness :: InputContent -> Bool + validateInputWitness input = + case input of + IDeposit _ party _ _ -> validatePartyWitness party -- The party must witness a deposit. + IChoice (ChoiceId _ party) _ -> validatePartyWitness party -- The party must witness a choice. + INotify -> True -- No witness is needed for a notify. + where + validatePartyWitness :: Party -> Bool + validatePartyWitness (Address _ address) = traceIfFalse "s" $ txSignedByAddress address -- The key must have signed. + validatePartyWitness (Role role) = traceIfFalse "t" -- The role token must be present. + $ Val.singleton rolesCurrency role 1 `Val.leq` valueSpent scriptContextTxInfo + + -- Tally the deposits in the input. + collectDeposits :: InputContent -> Val.Value + collectDeposits (IDeposit _ _ (Token cur tok) amount) + | amount > 0 = Val.singleton cur tok amount -- SCP-5123: Semantically negative deposits + | otherwise = zero -- do not remove funds from the script's UTxO. + collectDeposits _ = zero + + -- Extract the payout to a party. + payoutByParty :: Payment -> AssocMap.Map Party Val.Value + payoutByParty (Payment _ (Party party) (Token cur tok) amount) + | amount > 0 = AssocMap.singleton party $ Val.singleton cur tok amount + | otherwise = AssocMap.empty -- NOTE: Perhaps required because semantics may make zero payments + -- (though this passes the test suite), but removing this function's + -- guard reduces the validator size by 20 bytes. + payoutByParty (Payment _ (Account _) _ _ ) = AssocMap.empty + + -- Check outgoing payments. + payoutConstraints :: [(Party, Val.Value)] -> Bool + payoutConstraints = all payoutToTxOut + where + payoutToTxOut :: (Party, Val.Value) -> Bool + payoutToTxOut (party, value) = case party of + -- [Marlowe-Cardano Specification: "Constraint 15. Sufficient Payment".] + -- SCP-5128: Note that the payment to an address may be split into several outputs but the payment to a role must be + -- a single output. The flexibily of multiple outputs accommodates wallet-related practicalities such as the change and + -- the return of the role token being in separate UTxOs in situations where a contract is also paying to the address + -- where that change and that role token are sent. + Address _ address -> traceIfFalse "p" $ value `Val.leq` valuePaidToAddress address -- At least sufficient value paid. + Role role -> let + hsh = findDatumHash' (rolesCurrency, role) + addr = Address.scriptHashAddress rolePayoutValidatorHash + -- Some output must have the correct value and datum to the role-payout address. + in traceIfFalse "r" $ any (checkScriptOutput Val.geq addr hsh value) allOutputs + + -- The key for the address must have signed. + txSignedByAddress :: Ledger.Address -> Bool + txSignedByAddress (Ledger.Address (PubKeyCredential pkh) _) = scriptContextTxInfo `txSignedBy` pkh + txSignedByAddress _ = False + + -- Tally the value paid to an address. + valuePaidToAddress :: Ledger.Address -> Val.Value + valuePaidToAddress address = foldMap txOutValue $ filter ((== address) . txOutAddress) allOutputs + + +-- | Convert semantics input to transaction input. +marloweTxInputFromInput :: Input -> MarloweTxInput +marloweTxInputFromInput (NormalInput i) = Input i +marloweTxInputFromInput (MerkleizedInput i h _) = MerkleizedTxInput i h + + +-- | Convert semantics inputs to transaction inputs. +marloweTxInputsFromInputs :: [Input] -> [MarloweTxInput] +marloweTxInputsFromInputs = fmap marloweTxInputFromInput + + +-- Lifting data types to Plutus Core +makeLift ''MarloweTxInput +makeIsDataIndexed ''MarloweTxInput [('Input,0),('MerkleizedTxInput,1)] + + +-- | Compute the hash of a script. +hashScript :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) -> ScriptHash +hashScript = + -- FIXME: Apparently this is the wrong recipe, since its hash disagrees with `cardano-cli`. + ScriptHash + . toBuiltin + . (Hash.hashToBytes :: Hash.Hash Hash.Blake2b_224 SBS.ShortByteString -> BS.ByteString) + . Hash.hashWith (BS.append "\x02" . SBS.fromShort) -- For Plutus V2. + . serialiseCompiledCode + + +-- | The validator for Marlowe semantics. +marloweValidator :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) +marloweValidator = + let + marloweValidator' :: ScriptHash -> BuiltinData -> BuiltinData -> BuiltinData -> () + marloweValidator' rpvh d r p = + check + $ mkMarloweValidator rpvh + (unsafeFromBuiltinData d) + (unsafeFromBuiltinData r) + (unsafeFromBuiltinData p) + + errorOrApplied = + $$(PlutusTx.compile [|| marloweValidator' ||]) + `PlutusTx.applyCode` PlutusTx.liftCode plcVersion100 rolePayoutValidatorHash + in + case errorOrApplied of + Haskell.Left err -> + Haskell.error $ "Application of role-payout validator hash to marlowe validator failed." + <> err + Haskell.Right applied -> applied + + +-- | The serialisation of the Marlowe semantics validator. +marloweValidatorBytes :: SerialisedScript +marloweValidatorBytes = serialiseCompiledCode marloweValidator + + +-- | The hash of the Marlowe semantics validator. +marloweValidatorHash :: ScriptHash +marloweValidatorHash = hashScript marloweValidator diff --git a/nix/cells/automation/ciJobs.nix b/nix/cells/automation/ciJobs.nix index 565f271414b..15adc76945c 100644 --- a/nix/cells/automation/ciJobs.nix +++ b/nix/cells/automation/ciJobs.nix @@ -10,6 +10,11 @@ let inherit (pkgs.stdenv) system; inherit (pkgs) lib; + x86linux = "x86_64-linux"; + x86darwin = "x86_64-darwin"; + aarchdarwin = "aarch64-darwin"; + supportedSystems = [ x86linux x86darwin aarchdarwin ]; + make-haskell-jobs = project: let packages = library.haskell-nix.haskellLib.selectProjectPackages project.hsPkgs; @@ -46,22 +51,51 @@ let native-plutus-92-jobs = make-haskell-jobs library.plutus-project-92; native-plutus-96-jobs = make-haskell-jobs library.plutus-project-96; - windows-plutus-92-jobs = make-haskell-jobs library.plutus-project-92.projectCross.mingwW64; + # - Only test cross on our primary dev version + # - Cross-compiling to windows only works from linux + windows-plutus-92-jobs = + lib.optionalAttrs (system == x86linux) + (make-haskell-jobs library.plutus-project-92.projectCross.mingwW64); - other-jobs = inputs.cells.plutus.devshells // inputs.cells.plutus.packages; + devshells = + # Note: We can't build the 9.6 shell on aarch64-darwin + # because of https://github.com/well-typed/cborg/issues/311 + let s = inputs.cells.plutus.devshells; + in + if system == aarchdarwin + then builtins.removeAttrs s [ "plutus-shell-96" ] + else s; + + # this just has all the package roots in, which we're going to want + # to be extra sure we always build + roots = { + ghc810 = native-plutus-810-jobs.roots; + ghc92 = native-plutus-92-jobs.roots; + ghc96 = native-plutus-96-jobs.roots; + }; jobs = - # Drop these once we switch to 9.2 by default - { ghc810 = native-plutus-810-jobs; } // - { ghc92 = native-plutus-92-jobs; } // - # 9.6 is busted on aarch64-darwin because of https://github.com/well-typed/cborg/issues/311 - lib.optionalAttrs (system != "aarch64-darwin") { ghc96 = native-plutus-96-jobs; } // - # Only cross-compile to windows from linux - lib.optionalAttrs (system == "x86_64-linux") { mingwW64 = windows-plutus-92-jobs; } // - # see above about 9.6 on aarch64-darwin - (if system == "aarch64-darwin" - then builtins.removeAttrs other-jobs [ "plutus-shell-96" ] - else other-jobs); + # Only build all the main packages on linux and _one_ dawin platform, to avoid doing too + # much work in CI. Plausibly if things build on x86 darwin then they'll build on aarch + # darwin, and it avoids overloading the builders. + lib.optionalAttrs (system == x86linux || system == x86darwin) + ( + { ghc810 = native-plutus-810-jobs; } + // + { ghc92 = native-plutus-92-jobs; } + // + { ghc96 = native-plutus-96-jobs; } + // + { mingwW64 = windows-plutus-92-jobs; } + // + inputs.cells.plutus.packages + ) + // + # Build devshells on all platforms so people can work effectively + devshells + // + # Build roots on all platforms so stuff doesn't get GCd + roots; # Hydra doesn't like these attributes hanging around in "jobsets": it thinks they're jobs! filtered-jobs = lib.filterAttrsRecursive (n: _: n != "recurseForDerivations") jobs; @@ -69,12 +103,13 @@ let required-job = pkgs.releaseTools.aggregate { name = "required-plutus"; meta.description = "All jobs required to pass CI"; + # require everything: there's not much point having a CI job if it isn't required! constituents = lib.collect lib.isDerivation filtered-jobs; }; final-jobset = - if system == "x86_64-linux" || system == "x86_64-darwin" || system == "aarch64-darwin" then - filtered-jobs // { required = required-job; } + if builtins.elem system supportedSystems + then filtered-jobs // { required = required-job; } else { }; in diff --git a/nix/cells/plutus/library/make-plutus-project.nix b/nix/cells/plutus/library/make-plutus-project.nix index 4b728a51880..62734ad868d 100644 --- a/nix/cells/plutus/library/make-plutus-project.nix +++ b/nix/cells/plutus/library/make-plutus-project.nix @@ -61,6 +61,7 @@ let # Things that need plutus-tx-plugin plutus-benchmark.package.buildable = false; plutus-tx-plugin.package.buildable = false; + marlowe-cardano-minimal.package.buildable = false; # Needs agda plutus-metatheory.package.buildable = false; # These need R diff --git a/plutus-core/changelog.d/20230319_184206_unsafeFixIO_symbols.md b/plutus-core/changelog.d/20230319_184206_unsafeFixIO_symbols.md new file mode 100644 index 00000000000..af96d7520a6 --- /dev/null +++ b/plutus-core/changelog.d/20230319_184206_unsafeFixIO_symbols.md @@ -0,0 +1,3 @@ +### Changed + +- The PLC, UPLC, and PIR parsers accept names quoted in backticks. Quoted names may have symbolic characters. diff --git a/plutus-core/executables/src/PlutusCore/Executable/AstIO.hs b/plutus-core/executables/src/PlutusCore/Executable/AstIO.hs index f661a4b2515..94dfd71fa92 100644 --- a/plutus-core/executables/src/PlutusCore/Executable/AstIO.hs +++ b/plutus-core/executables/src/PlutusCore/Executable/AstIO.hs @@ -10,7 +10,9 @@ module PlutusCore.Executable.AstIO , serialiseUplcProgramFlat , loadPirASTfromFlat , loadPlcASTfromFlat - , loadUplcASTfromFlat) + , loadUplcASTfromFlat + , fromNamedDeBruijnUPLC + ) where import PlutusCore.Executable.Types diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 3bf0c42e518..b4fd619085d 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -278,7 +278,6 @@ library , hashable >=1.4 , hedgehog >=1.0 , index-envs - , int-cast , lens , megaparsec , mmorph @@ -826,13 +825,13 @@ executable generate-cost-model build-depends: , aeson-pretty , barbies - , base >=4.9 && <5 + , base >=4.9 && <5 , bytestring , cassava , directory , exceptions , extra - , inline-r >=1.0 + , inline-r >=1.0.1 , optparse-applicative , plutus-core ^>=1.7 , text @@ -867,13 +866,13 @@ benchmark cost-model-test build-depends: , barbies - , base >=4.9 && <5 + , base >=4.9 && <5 , bytestring , cassava , exceptions , extra , hedgehog - , inline-r >=1.0 + , inline-r >=1.0.1 , mmorph , plutus-core ^>=1.7 , template-haskell diff --git a/plutus-core/plutus-core/src/GHC/Natural/Extras.hs b/plutus-core/plutus-core/src/GHC/Natural/Extras.hs index 5ba3c2c73fc..4c2ee26187c 100644 --- a/plutus-core/plutus-core/src/GHC/Natural/Extras.hs +++ b/plutus-core/plutus-core/src/GHC/Natural/Extras.hs @@ -3,12 +3,26 @@ module GHC.Natural.Extras (naturalToWord64Maybe, Natural (..)) where -import Data.IntCast (intCastEq) import Data.Word (Word64) import GHC.Natural --- Note this will only work on 64bit platforms, but that's all we build on --- so that's okay. +{- | We only support 64-bit architectures, see Note [Index (Word64) (de)serialized through Natural]. +This implementation is safe w.r.t. cross-compilation, because WORD_SIZE_IN_BITS will point +to the compiler's target word size when compiling this module. +-} {-# INLINABLE naturalToWord64Maybe #-} naturalToWord64Maybe :: Natural -> Maybe Word64 -naturalToWord64Maybe n = intCastEq <$> naturalToWordMaybe n +naturalToWord64Maybe n = +#if WORD_SIZE_IN_BITS == 64 + fromIntegral <$> naturalToWordMaybe n +#else + +{- HLint does not know about WORD_SIZE_IN_BITS, so it calls cpphs to preprocess away these lines; +cpphs fails on encountering the #error cpp directive (as it should). +HLint treats this cpphs failure as an hlint failure. Skip HLint then. +-} +#ifndef __HLINT__ +#error unsupported WORD_SIZE_IN_BITS. We only support 64-bit architectures. +#endif + +#endif diff --git a/plutus-core/plutus-core/src/PlutusCore/DeBruijn/Internal.hs b/plutus-core/plutus-core/src/PlutusCore/DeBruijn/Internal.hs index a9e5e0affdf..3d075b921ab 100644 --- a/plutus-core/plutus-core/src/PlutusCore/DeBruijn/Internal.hs +++ b/plutus-core/plutus-core/src/PlutusCore/DeBruijn/Internal.hs @@ -1,48 +1,47 @@ --- editorconfig-checker-disable-file {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} - -- This fires on GHC-9.2.4 for some reason, not entirely sure -- what's going on {-# OPTIONS_GHC -Wno-identities #-} + -- | Support for using de Bruijn indices for term and type names. -module PlutusCore.DeBruijn.Internal - ( Index (..) - , HasIndex (..) - , DeBruijn (..) - , NamedDeBruijn (..) - , FakeNamedDeBruijn (..) - , TyDeBruijn (..) - , NamedTyDeBruijn (..) - , FreeVariableError (..) - , AsFreeVariableError (..) - , Level (..) - , Levels (..) - , declareUnique - , declareBinder - , withScope - , getIndex - , getUnique - , unNameDeBruijn - , unNameTyDeBruijn - , fakeNameDeBruijn - , fakeTyNameDeBruijn - , nameToDeBruijn - , tyNameToDeBruijn - , deBruijnToName - , deBruijnToTyName - , freeIndexThrow - , freeIndexAsConsistentLevel - , freeUniqueThrow - , runDeBruijnT - , deBruijnInitIndex - , toFake - , fromFake - ) where +module PlutusCore.DeBruijn.Internal ( + Index (..), + HasIndex (..), + DeBruijn (..), + NamedDeBruijn (..), + FakeNamedDeBruijn (..), + TyDeBruijn (..), + NamedTyDeBruijn (..), + FreeVariableError (..), + AsFreeVariableError (..), + Level (..), + Levels (..), + declareUnique, + declareBinder, + withScope, + getIndex, + getUnique, + unNameDeBruijn, + unNameTyDeBruijn, + fakeNameDeBruijn, + fakeTyNameDeBruijn, + nameToDeBruijn, + tyNameToDeBruijn, + deBruijnToName, + deBruijnToTyName, + freeIndexThrow, + freeIndexAsConsistentLevel, + freeUniqueThrow, + runDeBruijnT, + deBruijnInitIndex, + toFake, + fromFake, +) where import PlutusCore.Name import PlutusCore.Pretty @@ -67,22 +66,23 @@ import GHC.Generics -- | A relative index used for de Bruijn identifiers. newtype Index = Index Word64 - deriving stock (Generic) - deriving newtype (Show, Num, Enum, Real, Integral, Eq, Ord, Pretty, NFData, Read) + deriving stock (Generic) + deriving newtype (Show, Num, Enum, Real, Integral, Eq, Ord, Pretty, NFData, Read) -- | The LamAbs index (for debruijn indices) and the starting level of DeBruijn monad deBruijnInitIndex :: Index deBruijnInitIndex = 0 -- The bangs gave us a speedup of 6%. + -- | A term name as a de Bruijn index. -data NamedDeBruijn = NamedDeBruijn { ndbnString :: !T.Text, ndbnIndex :: !Index } - deriving stock (Show, Generic, Read) - deriving anyclass NFData +data NamedDeBruijn = NamedDeBruijn {ndbnString :: !T.Text, ndbnIndex :: !Index} + deriving stock (Show, Generic, Read) + deriving anyclass (NFData) -- | A wrapper around nameddebruijn that must hold the invariant of name=`fakeName`. newtype FakeNamedDeBruijn = FakeNamedDeBruijn NamedDeBruijn - deriving newtype (Show, Eq, NFData, PrettyBy config) + deriving newtype (Show, Eq, NFData, PrettyBy config) toFake :: DeBruijn -> FakeNamedDeBruijn toFake (DeBruijn ix) = FakeNamedDeBruijn $ NamedDeBruijn fakeName ix @@ -95,59 +95,66 @@ fakeName :: T.Text fakeName = "i" instance Eq NamedDeBruijn where - -- ignoring actual names and only relying solely on debruijn indices - (NamedDeBruijn _ ix1) == (NamedDeBruijn _ ix2) = ix1 == ix2 + -- ignoring actual names and only relying solely on debruijn indices + (NamedDeBruijn _ ix1) == (NamedDeBruijn _ ix2) = ix1 == ix2 -- | A term name as a de Bruijn index, without the name string. -newtype DeBruijn = DeBruijn { dbnIndex :: Index } - deriving stock (Show, Generic, Eq) - deriving newtype (NFData) +newtype DeBruijn = DeBruijn {dbnIndex :: Index} + deriving stock (Show, Generic, Eq) + deriving newtype (NFData) -- | A type name as a de Bruijn index. newtype NamedTyDeBruijn = NamedTyDeBruijn NamedDeBruijn - deriving stock (Show, Generic) - deriving newtype (PrettyBy config, NFData) - -- ignoring actual names and only relying solely on debruijn indices - deriving Eq via NamedDeBruijn + deriving stock (Show, Generic) + deriving newtype (PrettyBy config, NFData) + -- ignoring actual names and only relying solely on debruijn indices + deriving (Eq) via NamedDeBruijn + instance Wrapped NamedTyDeBruijn -- | A type name as a de Bruijn index, without the name string. newtype TyDeBruijn = TyDeBruijn DeBruijn - deriving stock (Show, Generic) - deriving newtype (NFData, PrettyBy config) - deriving Eq via DeBruijn -instance Wrapped TyDeBruijn + deriving stock (Show, Generic) + deriving newtype (NFData, PrettyBy config) + deriving (Eq) via DeBruijn -instance HasPrettyConfigName config => PrettyBy config NamedDeBruijn where - prettyBy config (NamedDeBruijn txt (Index ix)) - | showsUnique = pretty txt <> "_i" <> pretty ix - | otherwise = pretty txt - where PrettyConfigName showsUnique = toPrettyConfigName config +instance Wrapped TyDeBruijn -instance HasPrettyConfigName config => PrettyBy config DeBruijn where - prettyBy config (DeBruijn (Index ix)) - | showsUnique = "i" <> pretty ix - | otherwise = "" - where PrettyConfigName showsUnique = toPrettyConfigName config +instance (HasPrettyConfigName config) => PrettyBy config NamedDeBruijn where + prettyBy config (NamedDeBruijn txt (Index ix)) + -- See Note [Pretty-printing names with uniques] + | showsUnique = pretty . toPrintedName $ txt <> "_i" <> render (pretty ix) + | otherwise = pretty $ toPrintedName txt + where + PrettyConfigName showsUnique = toPrettyConfigName config + +instance (HasPrettyConfigName config) => PrettyBy config DeBruijn where + prettyBy config (DeBruijn (Index ix)) + | showsUnique = "i" <> pretty ix + | otherwise = "" + where + PrettyConfigName showsUnique = toPrettyConfigName config class HasIndex a where - index :: Lens' a Index + index :: Lens' a Index instance HasIndex NamedDeBruijn where - index = lens g s where - g = ndbnIndex - s n i = n{ndbnIndex=i} + index = lens g s + where + g = ndbnIndex + s n i = n{ndbnIndex = i} instance HasIndex DeBruijn where - index = lens g s where - g = dbnIndex - s n i = n{dbnIndex=i} + index = lens g s + where + g = dbnIndex + s n i = n{dbnIndex = i} instance HasIndex NamedTyDeBruijn where - index = _Wrapped' . index + index = _Wrapped' . index instance HasIndex TyDeBruijn where - index = _Wrapped' . index + index = _Wrapped' . index -- Converting from normal names to DeBruijn indices, and vice versa @@ -157,11 +164,12 @@ are *relative* - that is, they say how many levels above the *current* level to the binder. However, when doing conversions it is easier to record the *absolute* level of a variable, -in our state, since that way we don't have to adjust our mapping when we go under a binder (whereas -for relative indices we would need to increment them all by one, as the current level has increased). +in our state, since that way we don't have to adjust our mapping when we go under a binder +(whereas for relative indices we would need to increment them all by one, as the current +level has increased). -However, this means that we *do* need to do an adjustment when we store an index as a level or extract -a level to use it as an index. The adjustment is fairly straightforward: +However, this means that we *do* need to do an adjustment when we store an index as a level +or extract a level to use it as an index. The adjustment is fairly straightforward: - An index `i` points to a binder `i` levels above (smaller than) the current level, so the level of `i` is `current - i`. - A level `l` which is `i` levels above (smaller than) the current level has an index of `i`, so it @@ -173,85 +181,93 @@ We use a newtype to keep these separate, since getting it wrong will lead to ann -- | An absolute level in the program. newtype Level = Level Integer deriving newtype (Eq, Ord, Num, Real, Enum, Integral) --- | During visiting the AST we hold a reader "state" of current level and a current scoping (levelMapping). --- Invariant-A: the current level is positive and greater than all levels in the levelMapping. --- Invariant-B: only positive levels are stored in the levelMapping. +{- | During visiting the AST we hold a reader "state" of current level and a current +scoping (levelMapping). +Invariant-A: the current level is positive and greater than all levels in the levelMapping. +Invariant-B: only positive levels are stored in the levelMapping. +-} data Levels = Levels - { currentLevel :: Level - , levelMapping :: BM.Bimap Unique Level - } + { currentLevel :: Level + , levelMapping :: BM.Bimap Unique Level + } -- | Declare a name with a unique, recording the mapping to a 'Level'. declareUnique :: (MonadReader Levels m, HasUnique name unique) => name -> m a -> m a declareUnique n = - local $ \(Levels current ls) -> Levels current $ BM.insert (n ^. theUnique) current ls + local $ \(Levels current ls) -> Levels current $ BM.insert (n ^. theUnique) current ls -{-| Declares a new binder by assigning a fresh unique to the *current level*. +{- | Declares a new binder by assigning a fresh unique to the *current level*. Maintains invariant-B of 'Levels' (that only positive levels are stored), since current level is always positive (invariant-A). See NOTE: [DeBruijn indices of Binders] -} declareBinder :: (MonadReader Levels m, MonadQuote m) => m a -> m a declareBinder act = do - newU <- freshUnique - local (\(Levels current ls) -> Levels current $ BM.insert newU current ls) act + newU <- freshUnique + local (\(Levels current ls) -> Levels current $ BM.insert newU current ls) act --- | Enter a scope, incrementing the current 'Level' by one --- Maintains invariant-A (that the current level is positive). -withScope :: MonadReader Levels m => m a -> m a -withScope = local $ \(Levels current ls) -> Levels (current+1) ls +{- | Enter a scope, incrementing the current 'Level' by one +Maintains invariant-A (that the current level is positive). +-} +withScope :: (MonadReader Levels m) => m a -> m a +withScope = local $ \(Levels current ls) -> Levels (current + 1) ls --- | We cannot do a correct translation to or from de Bruijn indices if the program is not well-scoped. --- So we throw an error in such a case. +{- | We cannot do a correct translation to or from de Bruijn indices if the program is +not well-scoped. So we throw an error in such a case. +-} data FreeVariableError - = FreeUnique !Unique - | FreeIndex !Index - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (Exception, NFData) + = FreeUnique !Unique + | FreeIndex !Index + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (Exception, NFData) instance Pretty FreeVariableError where - pretty (FreeUnique u) = "Free unique:" <+> pretty u - pretty (FreeIndex i) = "Free index:" <+> pretty i + pretty (FreeUnique u) = "Free unique:" <+> pretty u + pretty (FreeIndex i) = "Free index:" <+> pretty i makeClassyPrisms ''FreeVariableError --- | Get the 'Index' corresponding to a given 'Unique'. --- Uses supplied handler for free names (uniques). -getIndex :: MonadReader Levels m => Unique -> (Unique -> m Index) -> m Index +{- | Get the 'Index' corresponding to a given 'Unique'. +Uses supplied handler for free names (uniques). +-} +getIndex :: (MonadReader Levels m) => Unique -> (Unique -> m Index) -> m Index getIndex u h = do - Levels current ls <- ask - case BM.lookup u ls of - Just foundlvl -> pure $ levelToIx current foundlvl - -- This call should return an index greater than the current level, - -- otherwise it will map unbound variables to bound variables. - Nothing -> h u + Levels current ls <- ask + case BM.lookup u ls of + Just foundlvl -> pure $ levelToIx current foundlvl + -- This call should return an index greater than the current level, + -- otherwise it will map unbound variables to bound variables. + Nothing -> h u where -- Compute the relative 'Index' of a absolute 'Level' relative to the current 'Level'. levelToIx :: Level -> Level -> Index levelToIx (Level current) (Level foundLvl) = - -- Thanks to invariant-A, we can be sure that 'level >= foundLvl ', since foundLvl is in the levelMapping - -- and thus the computation 'current-foundLvl' is '>=0' and its conversion to Natural will not lead to arithmetic underflow. - fromIntegral $ current - foundLvl + -- Thanks to invariant-A, we can be sure that 'level >= foundLvl ', since foundLvl + -- is in the levelMapping and thus the computation 'current-foundLvl' is '>=0' and + -- its conversion to Natural will not lead to arithmetic underflow. + fromIntegral $ current - foundLvl --- | Get the 'Unique' corresponding to a given 'Index'. --- Uses supplied handler for free debruijn indices. -getUnique :: MonadReader Levels m => Index -> (Index -> m Unique) -> m Unique +{- | Get the 'Unique' corresponding to a given 'Index'. +Uses supplied handler for free debruijn indices. +-} +getUnique :: (MonadReader Levels m) => Index -> (Index -> m Unique) -> m Unique getUnique ix h = do - Levels current ls <- ask - case BM.lookupR (ixToLevel current ix) ls of - -- Because of invariant-B, the levelMapping contains only positive (absolute) levels. - Just u -> pure u - -- This call should return a free/unbound unique, - -- otherwise it will map unbound variables to bound variables. - Nothing -> - -- the lookup failed, meaning the index corresponds to a strictly-negative (absolute) level. - h ix - -unNameDeBruijn - :: NamedDeBruijn -> DeBruijn + Levels current ls <- ask + case BM.lookupR (ixToLevel current ix) ls of + -- Because of invariant-B, the levelMapping contains only positive (absolute) levels. + Just u -> pure u + -- This call should return a free/unbound unique, + -- otherwise it will map unbound variables to bound variables. + Nothing -> + -- the lookup failed, meaning the index corresponds to a strictly-negative + -- (absolute) level. + h ix + +unNameDeBruijn :: + NamedDeBruijn -> DeBruijn unNameDeBruijn (NamedDeBruijn _ ix) = DeBruijn ix -unNameTyDeBruijn - :: NamedTyDeBruijn -> TyDeBruijn +unNameTyDeBruijn :: + NamedTyDeBruijn -> TyDeBruijn unNameTyDeBruijn (NamedTyDeBruijn db) = TyDeBruijn $ unNameDeBruijn db fakeNameDeBruijn :: DeBruijn -> NamedDeBruijn @@ -260,66 +276,70 @@ fakeNameDeBruijn = coerce . toFake fakeTyNameDeBruijn :: TyDeBruijn -> NamedTyDeBruijn fakeTyNameDeBruijn (TyDeBruijn n) = NamedTyDeBruijn $ fakeNameDeBruijn n -nameToDeBruijn - :: MonadReader Levels m - => (Unique -> m Index) - -> Name - -> m NamedDeBruijn +nameToDeBruijn :: + (MonadReader Levels m) => + (Unique -> m Index) -> + Name -> + m NamedDeBruijn nameToDeBruijn h (Name str u) = NamedDeBruijn str <$> getIndex u h -tyNameToDeBruijn - :: MonadReader Levels m - => (Unique -> m Index) - -> TyName - -> m NamedTyDeBruijn +tyNameToDeBruijn :: + (MonadReader Levels m) => + (Unique -> m Index) -> + TyName -> + m NamedTyDeBruijn tyNameToDeBruijn h (TyName n) = NamedTyDeBruijn <$> nameToDeBruijn h n -deBruijnToName - :: MonadReader Levels m - => (Index -> m Unique) - -> NamedDeBruijn - -> m Name +deBruijnToName :: + (MonadReader Levels m) => + (Index -> m Unique) -> + NamedDeBruijn -> + m Name deBruijnToName h (NamedDeBruijn str ix) = Name str <$> getUnique ix h -deBruijnToTyName - :: MonadReader Levels m - => (Index -> m Unique) - -> NamedTyDeBruijn - -> m TyName +deBruijnToTyName :: + (MonadReader Levels m) => + (Index -> m Unique) -> + NamedTyDeBruijn -> + m TyName deBruijnToTyName h (NamedTyDeBruijn n) = TyName <$> deBruijnToName h n -- | The default handler of throwing an error upon encountering a free name (unique). freeUniqueThrow :: (AsFreeVariableError e, MonadError e m) => Unique -> m Index freeUniqueThrow = - throwing _FreeVariableError . FreeUnique + throwing _FreeVariableError . FreeUnique -- | The default handler of throwing an error upon encountering a free debruijn index. freeIndexThrow :: (AsFreeVariableError e, MonadError e m) => Index -> m Unique freeIndexThrow = - throwing _FreeVariableError . FreeIndex + throwing _FreeVariableError . FreeIndex -{-| A different implementation of a handler, where "free" debruijn indices do not throw an error +{- | A different implementation of a handler, where "free" debruijn indices do not throw an error but are instead gracefully converted to fresh uniques. -These generated uniques remain free; i.e. if the original term was open, it will remain open after applying this handler. +These generated uniques remain free; i.e. if the original term was open, it will remain open +after applying this handler. These generated free uniques are consistent across the open term (by using a state cache). -} -freeIndexAsConsistentLevel :: (MonadReader Levels m, MonadState (M.Map Level Unique) m, MonadQuote m) => Index -> m Unique +freeIndexAsConsistentLevel :: + (MonadReader Levels m, MonadState (M.Map Level Unique) m, MonadQuote m) => + Index -> + m Unique freeIndexAsConsistentLevel ix = do - cache <- get - Levels current _ <- ask - -- the absolute level is strictly-negative - let absoluteLevel = ixToLevel current ix - case M.lookup absoluteLevel cache of - Nothing -> do - u <- freshUnique - -- the cache contains only strictly-negative levels - put (M.insert absoluteLevel u cache) - pure u - Just u -> pure u + cache <- get + Levels current _ <- ask + -- the absolute level is strictly-negative + let absoluteLevel = ixToLevel current ix + case M.lookup absoluteLevel cache of + Nothing -> do + u <- freshUnique + -- the cache contains only strictly-negative levels + put (M.insert absoluteLevel u cache) + pure u + Just u -> pure u -- Compute the absolute 'Level' of a relative 'Index' relative to the current 'Level'. --- The index `ixAST` may be malformed or point to a free variable because it comes straight from the AST; --- in such a case, this function may return a negative level. +-- The index `ixAST` may be malformed or point to a free variable because it comes straight +-- from the AST; in such a case, this function may return a negative level. ixToLevel :: Level -> Index -> Level ixToLevel (Level current) ixAST = Level $ current - fromIntegral ixAST diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index b1641d43707..5fe087ac3a6 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -1092,7 +1092,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where toBuiltinMeaning _ver IndexByteString = makeBuiltinMeaning (\xs n -> if n >= 0 && n < BS.length xs then EvaluationSuccess $ toInteger $ BS.index xs n else EvaluationFailure) - -- TODO: fix the mess above with `indexMaybe` from `bytestring >= 0.11.0.0`. + -- TODO: fix the mess above with `indexMaybe` from `ghc>=9.2,bytestring >= 0.11.0.0`. (runCostingFunTwoArguments . paramIndexByteString) toBuiltinMeaning _ver EqualsByteString = makeBuiltinMeaning diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs index e7a770b62a8..2ae95e8620c 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs @@ -1,4 +1,3 @@ --- editorconfig-checker-disable-file -- | The universe used by default and its instances. {-# OPTIONS -fno-warn-missing-pattern-synonym-signatures #-} @@ -11,6 +10,7 @@ {-# OPTIONS -Wno-redundant-constraints #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -26,6 +26,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +#include "MachDeps.h" -- effectfully: to the best of my experimentation, -O2 here improves performance, however by -- inspecting GHC Core I was only able to see a difference in how the 'KnownTypeIn' instance for @@ -50,7 +51,6 @@ import Control.Applicative import Data.Bits (toIntegralSized) import Data.ByteString qualified as BS import Data.Int -import Data.IntCast (intCastEq) import Data.Proxy import Data.Text qualified as Text import Data.Word @@ -89,7 +89,7 @@ to juggle values of polymorphic built-in types instantiated with non-built-in ty (it's not even possible to represent such a value in the AST, even though it's possible to represent such a 'Type'). -Finally, it is not necessarily the case that we need to allow embedding PLC terms into meta-constants. +Finally, it is not necessary to allow embedding PLC terms into meta-constants. We already allow built-in functions with polymorphic types. There might be a way to utilize this feature and have meta-constructors as built-in functions. -} @@ -119,7 +119,7 @@ instance GEq DefaultUni where -- recursive definition and we want two instead. The reason why we want two is because this -- allows GHC to inline the initial step that appears non-recursive to GHC, because recursion -- is hidden in the other function that is marked as @NOINLINE@ and is chosen by GHC as a - -- loop-breaker, see https://wiki.haskell.org/Inlining_and_Specialisation#What_is_a_loop-breaker.3F + -- loop-breaker, see https://wiki.haskell.org/Inlining_and_Specialisation#What_is_a_loop-breaker -- (we're not really sure if this is a reliable solution, but if it stops working, we won't miss -- very much and we've failed to settle on any other approach). -- @@ -296,31 +296,28 @@ instance TestTypesFromTheUniverseAreAllKnown DefaultUni Technically our universe only contains 'Integer', but many of the builtin functions that we would like to use work over 'Int' and 'Word8'. -This is inconvenient and also error-prone: dealing with a function that takes an 'Int' or 'Word8' means carefully -downcasting the 'Integer', running the function, potentially upcasting at the end. And it's easy to get -wrong by e.g. blindly using 'fromInteger'. +This is inconvenient and also error-prone: dealing with a function that takes an 'Int' or 'Word8' +means carefully downcasting the 'Integer', running the function, potentially upcasting at the end. +And it's easy to get wrong by e.g. blindly using 'fromInteger'. -Moreover, there is a latent risk here: if we *were* to build on a 32-bit platform, then programs which -use arguments between @maxBound :: Int32@ and @maxBound :: Int64@ would behave differently! +Moreover, there is a latent risk here: if we *were* to build on a 32-bit architecture, then programs +which use arguments between @maxBound :: Int32@ and @maxBound :: Int64@ would behave differently! So, what to do? We adopt the following strategy: -- We allow lifting/unlifting 'Int64' via 'Integer', including a safe downcast in 'readKnown'. - We allow lifting/unlifting 'Word8' via 'Integer', including a safe downcast in 'readKnown'. -- We allow lifting/unlifting 'Int' via 'Int64', converting between them using 'intCastEq'. - -This has the effect of allowing the use of 'Int64' always, and 'Int' iff it is provably equal to -'Int64'. So we can use 'Int' conveniently, but only if it has predictable behaviour. - -(An alternative would be to just add 'Int', but add 'IntCastEq Int Int64' as an instance constraint. -That would also work, this way just seemed a little more explicit, and avoids adding constraints, -which can sometimes interfere with optimization and inling.) +- We allow lifting/unlifting 'Int64' via 'Integer', including a safe downcast in 'readKnown'. +- We allow lifting/unlifting 'Int' via 'Int64', constraining the conversion between them to +64-bit architectures where this conversion is safe. Doing this effectively bans builds on 32-bit systems, but that's fine, since we don't care about supporting 32-bit systems anyway, and this way any attempts to build on them will fail fast. -Note: we couldn't fail the bounds check with 'AsUnliftingError', because an out-of-bounds error is not an -internal one -- it's a normal evaluation failure, but unlifting errors have this connotation of -being "internal". +Note: We have another 64-bit limitation, this time not during script execution but during +script deserialization, for more see Note [Index (Word64) (de)serialized through Natural]. + +Note: we couldn't fail the bounds check with 'AsUnliftingError', because an out-of-bounds error +is not an internal one -- it's a normal evaluation failure, but unlifting errors +have this connotation of being "internal". -} instance KnownTypeAst DefaultUni Int64 where @@ -345,19 +342,26 @@ instance HasConstantIn DefaultUni term => ReadKnownIn DefaultUni term Int64 wher else throwing_ _EvaluationFailure {-# INLINE readKnown #-} +#if WORD_SIZE_IN_BITS == 64 +-- See Note [Integral types as Integer]. + instance KnownTypeAst DefaultUni Int where toTypeAst _ = toTypeAst $ Proxy @Integer --- See Note [Integral types as Integer]. instance HasConstantIn DefaultUni term => MakeKnownIn DefaultUni term Int where - -- This could safely just be toInteger, but this way is more explicit and it'll - -- turn into the same thing anyway. - makeKnown = makeKnown . intCastEq @Int @Int64 + -- Convert Int-to-Integer via Int64. We could go directly `toInteger`, but this way + -- is more explicit and it'll turn into the same thing anyway. + -- Although this conversion is safe regardless of the CPU arch (unlike the opposite conversion), + -- we constrain it to 64-bit for the sake of uniformity. + makeKnown = makeKnown . fromIntegral @Int @Int64 {-# INLINE makeKnown #-} instance HasConstantIn DefaultUni term => ReadKnownIn DefaultUni term Int where - readKnown term = intCastEq @Int64 @Int <$> readKnown term + -- Convert Integer-to-Int via Int64. This instance is safe only for 64-bit architecture + -- where Int===Int64 (i.e. no truncation happening). + readKnown term = fromIntegral @Int64 @Int <$> readKnown term {-# INLINE readKnown #-} +#endif instance KnownTypeAst DefaultUni Word8 where toTypeAst _ = toTypeAst $ Proxy @Integer diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs index 48810439dd6..7b33ee7e898 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs @@ -136,9 +136,9 @@ instance HasConstant (CkValue uni fun) where fromConstant = VCon data Frame uni fun - = FrameApplyFun (CkValue uni fun) -- ^ @[V _]@ - | FrameApplyArg (Term TyName Name uni fun ()) -- ^ @[_ N]@ - | FrameApplyValues ![CkValue uni fun] -- ^ @[_ V...]@ + = FrameAwaitArg (CkValue uni fun) -- ^ @[V _]@ + | FrameAwaitFunTerm (Term TyName Name uni fun ()) -- ^ @[_ N]@ + | FrameAwaitFunValue (CkValue uni fun) -- ^ @[_ V]@ | FrameTyInstArg (Type TyName uni ()) -- ^ @{_ A}@ | FrameUnwrap -- ^ @(unwrap _)@ | FrameIWrap (Type TyName uni ()) (Type TyName uni ()) -- ^ @(iwrap A B _)@ @@ -181,7 +181,7 @@ runCkM runtime emitting a = runST $ do (|>) :: Context uni fun -> Term TyName Name uni fun () -> CkM uni fun s (Term TyName Name uni fun ()) stack |> TyInst _ fun ty = FrameTyInstArg ty : stack |> fun -stack |> Apply _ fun arg = FrameApplyArg arg : stack |> fun +stack |> Apply _ fun arg = FrameAwaitFunTerm arg : stack |> fun stack |> IWrap _ pat arg term = FrameIWrap pat arg : stack |> term stack |> Unwrap _ term = FrameUnwrap : stack |> term stack |> TyAbs _ tn k term = stack <| VTyAbs tn k term @@ -217,11 +217,9 @@ _ |> var@Var{} = :: Context uni fun -> CkValue uni fun -> CkM uni fun s (Term TyName Name uni fun ()) [] <| val = pure $ ckValueToTerm val FrameTyInstArg ty : stack <| fun = instantiateEvaluate stack ty fun -FrameApplyArg arg : stack <| fun = FrameApplyFun fun : stack |> arg -FrameApplyFun fun : stack <| arg = applyEvaluate stack fun arg -FrameApplyValues args : stack <| fun = case args of - [] -> stack <| fun - arg : rest -> applyEvaluate (FrameApplyValues rest : stack) fun arg +FrameAwaitFunTerm arg : stack <| fun = FrameAwaitArg fun : stack |> arg +FrameAwaitArg fun : stack <| arg = applyEvaluate stack fun arg +FrameAwaitFunValue arg : stack <| fun = applyEvaluate stack fun arg FrameIWrap pat arg : stack <| value = stack <| VIWrap pat arg value FrameUnwrap : stack <| wrapped = case wrapped of VIWrap _ _ term -> stack <| term @@ -234,7 +232,10 @@ FrameConstr ty i todo done : stack <| e = [] -> stack <| VConstr ty i (reverse done') FrameCase cs : stack <| e = case e of VConstr _ i args -> case cs ^? wix i of - Just t -> FrameApplyValues args : stack |> t + Just t -> go (reverse args) stack |> t + where + go [] s = s + go (arg:rest) s = go rest (FrameAwaitFunValue arg : s) Nothing -> throwingWithCause _MachineError (MissingCaseBranch i) (Just $ ckValueToTerm e) _ -> throwingWithCause _MachineError NonConstrScrutinized (Just $ ckValueToTerm e) diff --git a/plutus-core/plutus-core/src/PlutusCore/Flat.hs b/plutus-core/plutus-core/src/PlutusCore/Flat.hs index 6caf49432ae..bc98d973010 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Flat.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Flat.hs @@ -91,23 +91,29 @@ By default, Flat does not use any space to serialise `()`. {- Note [Index (Word64) (de)serialized through Natural] With the recent change of CEK to use DeBruijn instead of Name, -we decided to change Index to be a Word instead of Natural, for performance reasons. +we decided to change Index to be a Word64 instead of Natural, for performance reasons. However, to be absolutely sure that the script format *does not change* -for plutus language version 1, we are converting from/to Word64 and (de)-serialize *only through -Natural*, to keep the old v1 flat format the same. - -Natural and Word64 are flat-compatible up-to `maxBound :: Word64`. -However, the current blockchain might have already stored a plutus v1 script -containing a hugely-indexed variable `>maxBound::Word64` -- such a script must be failing -because such a huge index must be a free variable (given the current script-size constraints). - -When decoding such an already-stored (failing) script -the Natural deserializer makes the script fail at the scopechecking step (previously -undebruijnification step). Hypotheically using the Word64 deserializer, the script would *hopefully* -fail as well, although earlier at the deserialization step. Initial tests and looking at flat -internals make this likely, but until proven, we postpone the transition to Word64 deserializer for -version 2 language. +for plutus, we are converting from/to Word64 and (de)-serialize *only through +Natural*, to keep the flat format the same. + +Also, for sake of speed & simplicity we restrict the current deserialization to work +only on 64-bit architectures (serialization still works on 32-bit architecture because it +is not in the critical path). + +Note: We have another 64-bit limitation, this time not during script deserialization but during +script execution, for more see Note [Integral types as Integer]. + +Going a step further is to switch to *direct* Word64 (de)-serializization: +afterall, Natural and Word64 are flat-compatible up-to `maxBound :: Word64`. +A problem may arise in currently stored scripts on the chain containing +a variable with a huge debruijn index: `>maxBound::Word64`. Such a script +will definitely fail at phase-2 validation (more specifically, at scope-checking) +because of the current script-size constraints deeming the hugely-indexed variable a free-variable. +Changing to direct Word64 (de)-serialization will turn those existing stored +scripts to a phase-1 failure instead of current phase-2 failure. + +We postpone this transition to direct Word64 (de)-serializer for a future plutus version. -} diff --git a/plutus-core/plutus-core/src/PlutusCore/Name.hs b/plutus-core/plutus-core/src/PlutusCore/Name.hs index cd25826c5d6..bfaf1e7a38f 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Name.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Name.hs @@ -6,39 +6,46 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -module PlutusCore.Name - ( -- * Types - Name (..) - , TyName (..) - , Named (..) - , Unique (..) - , TypeUnique (..) - , TermUnique (..) - , HasText (..) - , HasUnique (..) - , theUnique - , UniqueMap (..) - -- * Functions - , insertByUnique - , insertByName - , insertByNameIndex - , insertNamed - , fromFoldable - , fromUniques - , fromNames - , lookupUnique - , lookupName - , lookupNameIndex - , mapNameString - , mapTyNameString - , isEmpty - ) where +module PlutusCore.Name ( + -- * Types + Name (..), + isIdentifierStartingChar, + isIdentifierChar, + isQuotedIdentifierChar, + isValidUnquotedName, + toPrintedName, + TyName (..), + Named (..), + Unique (..), + TypeUnique (..), + TermUnique (..), + HasText (..), + HasUnique (..), + theUnique, + UniqueMap (..), + + -- * Functions + insertByUnique, + insertByName, + insertByNameIndex, + insertNamed, + fromFoldable, + fromUniques, + fromNames, + lookupUnique, + lookupName, + lookupNameIndex, + mapNameString, + mapTyNameString, + isEmpty, +) where import PlutusPrelude import PlutusCore.Pretty.ConfigName import Control.Lens +import Data.Char import Data.Hashable import Data.IntMap.Strict qualified as IM import Data.Text (Text) @@ -48,53 +55,87 @@ import Language.Haskell.TH.Syntax (Lift) -- | A 'Name' represents variables/names in Plutus Core. data Name = Name - { _nameText :: T.Text -- ^ The identifier name, for use in error messages. - , _nameUnique :: Unique - -- ^ A 'Unique' assigned to the name, allowing for cheap comparisons in the compiler. - } - deriving stock (Show, Generic, Lift) - deriving anyclass (NFData, Hashable) - --- | We use a @newtype@ to enforce separation between names used for types and --- those used for terms. -newtype TyName = TyName { unTyName :: Name } - deriving stock (Show, Generic, Lift) - deriving newtype (Eq, Ord, NFData, Hashable, PrettyBy config) + { _nameText :: T.Text + -- ^ The identifier name, for use in error messages. + , _nameUnique :: Unique + -- ^ A 'Unique' assigned to the name, allowing for cheap comparisons in the compiler. + } + deriving stock (Show, Generic, Lift) + deriving anyclass (NFData, Hashable) + +-- | Allowed characters in the starting position of a non-quoted identifier. +isIdentifierStartingChar :: Char -> Bool +isIdentifierStartingChar c = isAscii c && isAlpha c || c == '_' + +-- | Allowed characters in a non-starting position of a non-quoted identifier. +isIdentifierChar :: Char -> Bool +isIdentifierChar c = isIdentifierStartingChar c || isDigit c || c == '\'' + +-- | Allowed characters in a quoted identifier. +isQuotedIdentifierChar :: Char -> Bool +isQuotedIdentifierChar c = + (isAlpha c || isDigit c || isPunctuation c || isSymbol c) + && isAscii c + && c /= '`' + +isValidUnquotedName :: Text -> Bool +isValidUnquotedName n = case T.uncons n of + Just (hd, tl) -> isIdentifierStartingChar hd && T.all isIdentifierChar tl + Nothing -> False + +{- | Quote the name with backticks if it is not a valid unquoted name. +It does not check whether the given name is a valid quoted name. +-} +toPrintedName :: Text -> Text +toPrintedName txt = if isValidUnquotedName txt then txt else "`" <> txt <> "`" + +{- | We use a @newtype@ to enforce separation between names used for types and +those used for terms. +-} +newtype TyName = TyName {unTyName :: Name} + deriving stock (Show, Generic, Lift) + deriving newtype (Eq, Ord, NFData, Hashable, PrettyBy config) + instance Wrapped TyName data Named a = Named - { _namedString :: Text - , _namedValue :: a - } deriving stock (Functor, Foldable, Traversable) - -instance HasPrettyConfigName config => PrettyBy config Name where - prettyBy config (Name txt (Unique uniq)) - | showsUnique = pretty txt <> "_" <> pretty uniq - | otherwise = pretty txt - where PrettyConfigName showsUnique = toPrettyConfigName config + { _namedString :: Text + , _namedValue :: a + } + deriving stock (Functor, Foldable, Traversable) + +instance (HasPrettyConfigName config) => PrettyBy config Name where + prettyBy config (Name txt (Unique uniq)) + -- See Note [Pretty-printing names with uniques] + | showsUnique = pretty . toPrintedName $ txt <> "_" <> render (pretty uniq) + | otherwise = pretty $ toPrintedName txt + where + PrettyConfigName showsUnique = toPrettyConfigName config instance Eq Name where - (==) = (==) `on` _nameUnique + (==) = (==) `on` _nameUnique instance Ord Name where - (<=) = (<=) `on` _nameUnique + (<=) = (<=) `on` _nameUnique -- | A unique identifier -newtype Unique = Unique { unUnique :: Int } - deriving stock (Eq, Show, Ord, Lift) - deriving newtype (Enum, NFData, Pretty, Hashable) +newtype Unique = Unique {unUnique :: Int} + deriving stock (Eq, Show, Ord, Lift) + deriving newtype (Enum, NFData, Pretty, Hashable) -- | The unique of a type-level name. newtype TypeUnique = TypeUnique - { unTypeUnique :: Unique - } deriving stock (Eq, Ord) - deriving newtype Hashable + { unTypeUnique :: Unique + } + deriving stock (Eq, Ord) + deriving newtype (Hashable) -- | The unique of a term-level name. newtype TermUnique = TermUnique - { unTermUnique :: Unique - } deriving stock (Eq, Ord) - deriving newtype Hashable + { unTermUnique :: Unique + } + deriving stock (Eq, Ord) + deriving newtype (Hashable) makeLenses 'Name @@ -108,95 +149,122 @@ mapTyNameString = coerce mapNameString -- | Types which have a textual name attached to them. class HasText a where - theText :: Lens' a Text + theText :: Lens' a Text instance HasText Name where - theText = nameText + theText = nameText instance HasText TyName where - theText = coerced . theText @Name + theText = coerced . theText @Name -- | Types which have a 'Unique' attached to them, mostly names. -class Coercible unique Unique => HasUnique a unique | a -> unique where - unique :: Lens' a unique - -- | The default implementation of 'HasUnique' for newtypes. - default unique - :: (Wrapped a, HasUnique (Unwrapped a) unique', Coercible unique' unique) - => Lens' a unique - unique = _Wrapped' . unique . coerced +class (Coercible unique Unique) => HasUnique a unique | a -> unique where + unique :: Lens' a unique + + -- | The default implementation of 'HasUnique' for newtypes. + default unique :: + (Wrapped a, HasUnique (Unwrapped a) unique', Coercible unique' unique) => + Lens' a unique + unique = _Wrapped' . unique . coerced instance HasUnique Unique Unique where - unique = id + unique = id instance HasUnique Name TermUnique where - unique = nameUnique . coerced + unique = nameUnique . coerced instance HasUnique TyName TypeUnique -- | A lens focused on the 'Unique' of a name. -theUnique :: HasUnique name unique => Lens' name Unique +theUnique :: (HasUnique name unique) => Lens' name Unique theUnique = unique . coerced -- | A mapping from uniques to values of type @a@. newtype UniqueMap unique a = UniqueMap - { unUniqueMap :: IM.IntMap a - } deriving newtype (Show, Eq, Semigroup, Monoid, Functor) + { unUniqueMap :: IM.IntMap a + } + deriving newtype (Show, Eq, Semigroup, Monoid, Functor) -- | Insert a value by a unique. -insertByUnique :: Coercible unique Unique => unique -> a -> UniqueMap unique a -> UniqueMap unique a +insertByUnique :: + (Coercible unique Unique) => + unique -> + a -> + UniqueMap unique a -> + UniqueMap unique a insertByUnique uniq = coerce . IM.insert (coerce uniq) -- | Insert a value by the unique of a name. -insertByName :: HasUnique name unique => name -> a -> UniqueMap unique a -> UniqueMap unique a +insertByName :: (HasUnique name unique) => name -> a -> UniqueMap unique a -> UniqueMap unique a insertByName = insertByUnique . view unique -- | Insert a named value by the index of the unique of the name. -insertNamed - :: (HasText name, HasUnique name unique) - => name - -> a - -> UniqueMap unique (Named a) - -> UniqueMap unique (Named a) +insertNamed :: + (HasText name, HasUnique name unique) => + name -> + a -> + UniqueMap unique (Named a) -> + UniqueMap unique (Named a) insertNamed name = insertByName name . Named (name ^. theText) --- | Insert a value by the index of the unique of a name. --- Unlike 'insertByUnique' and 'insertByName', this function does not provide any static guarantees, --- so you can for example insert by a type-level name in a map from term-level uniques. -insertByNameIndex - :: (HasUnique name unique1, Coercible unique2 Unique) - => name -> a -> UniqueMap unique2 a -> UniqueMap unique2 a +{- | Insert a value by the index of the unique of a name. +Unlike 'insertByUnique' and 'insertByName', this function does not provide any static guarantees, +so you can for example insert by a type-level name in a map from term-level uniques. +-} +insertByNameIndex :: + (HasUnique name unique1, Coercible unique2 Unique) => + name -> + a -> + UniqueMap unique2 a -> + UniqueMap unique2 a insertByNameIndex = insertByUnique . coerce . view unique -- | Convert a 'Foldable' into a 'UniqueMap' using the given insertion function. -fromFoldable - :: Foldable f - => (i -> a -> UniqueMap unique a -> UniqueMap unique a) -> f (i, a) -> UniqueMap unique a +fromFoldable :: + (Foldable f) => + (i -> a -> UniqueMap unique a -> UniqueMap unique a) -> + f (i, a) -> + UniqueMap unique a fromFoldable ins = foldl' (flip $ uncurry ins) mempty -- | Convert a 'Foldable' with uniques into a 'UniqueMap'. -fromUniques :: Foldable f => Coercible Unique unique => f (unique, a) -> UniqueMap unique a +fromUniques :: (Foldable f) => (Coercible Unique unique) => f (unique, a) -> UniqueMap unique a fromUniques = fromFoldable insertByUnique -- | Convert a 'Foldable' with names into a 'UniqueMap'. -fromNames :: Foldable f => HasUnique name unique => f (name, a) -> UniqueMap unique a +fromNames :: (Foldable f) => (HasUnique name unique) => f (name, a) -> UniqueMap unique a fromNames = fromFoldable insertByName -- | Look up a value by a unique. -lookupUnique :: Coercible unique Unique => unique -> UniqueMap unique a -> Maybe a +lookupUnique :: (Coercible unique Unique) => unique -> UniqueMap unique a -> Maybe a lookupUnique uniq = IM.lookup (coerce uniq) . unUniqueMap -- | Look up a value by the unique of a name. -lookupName :: HasUnique name unique => name -> UniqueMap unique a -> Maybe a +lookupName :: (HasUnique name unique) => name -> UniqueMap unique a -> Maybe a lookupName = lookupUnique . view unique --- | Look up a value by the index of the unique of a name. --- Unlike 'lookupUnique' and 'lookupName', this function does not provide any static guarantees, --- so you can for example look up a type-level name in a map from term-level uniques. -lookupNameIndex - :: (HasUnique name unique1, Coercible unique2 Unique) - => name -> UniqueMap unique2 a -> Maybe a +{- | Look up a value by the index of the unique of a name. +Unlike 'lookupUnique' and 'lookupName', this function does not provide any static guarantees, +so you can for example look up a type-level name in a map from term-level uniques. +-} +lookupNameIndex :: + (HasUnique name unique1, Coercible unique2 Unique) => + name -> + UniqueMap unique2 a -> + Maybe a lookupNameIndex = lookupUnique . coerce . view unique {-# INLINE isEmpty #-} isEmpty :: UniqueMap unique a -> Bool isEmpty (UniqueMap m) = IM.null m + +{- Note [Pretty-printing names with uniques] + +Our parser can't currently parse unqiues properly. As a hacky workaround, when pretty-printing, +we print the uniques as part of the names. That is, if the name proper is @++@ and the +unique is 123, then it is printed as @`++_123`@, rather than @`++`_123@. + +This way, when it is parsed back, the entire @`++_123`@ becomes the name proper. This works: +a program would be alpha-equivalent after being pretty-printed and then parsed back. But we +should still fix this and do it properly. +-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Parser/Builtin.hs b/plutus-core/plutus-core/src/PlutusCore/Parser/Builtin.hs index 519439bf9cc..22117da936c 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Parser/Builtin.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Parser/Builtin.hs @@ -8,6 +8,7 @@ import PlutusPrelude (Word8, reoption) import PlutusCore.Data import PlutusCore.Default import PlutusCore.Error (ParserError (InvalidData, UnknownBuiltinFunction)) +import PlutusCore.Name import PlutusCore.Parser.ParserCommon import PlutusCore.Parser.Type (defaultUni) import PlutusCore.Pretty (display) diff --git a/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs b/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs index 113fb7dbc41..d005f4d98c1 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs @@ -1,21 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecursiveDo #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Common functions for parsers of UPLC, PLC, and PIR. - module PlutusCore.Parser.ParserCommon where import Control.Monad (void, when) import Control.Monad.Except (MonadError) import Control.Monad.Reader (ReaderT, ask, local, runReaderT) import Control.Monad.State (MonadState (..), StateT, evalStateT) -import Data.Char (isAlphaNum) import Data.Map qualified as M import Data.Text qualified as T import Text.Megaparsec hiding (ParseError, State, parse, some) -import Text.Megaparsec.Char (char, letterChar, space1) +import Text.Megaparsec.Char (char, space1) import Text.Megaparsec.Char.Lexer qualified as Lex hiding (hexadecimal) import PlutusCore.Annotation @@ -30,31 +27,34 @@ sure to enclose every 'Parser' that doesn't consume trailing whitespce (e.g. 'ta 'manyTill', 'Lex.decimal' etc) in a call to 'lexeme'. -} -newtype ParserState = ParserState { identifiers :: M.Map T.Text Unique } - deriving stock (Show) +newtype ParserState = ParserState {identifiers :: M.Map T.Text Unique} + deriving stock (Show) type Parser = - ParsecT ParserError T.Text (StateT ParserState (ReaderT (Maybe Version) Quote)) + ParsecT ParserError T.Text (StateT ParserState (ReaderT (Maybe Version) Quote)) instance (Stream s, MonadQuote m) => MonadQuote (ParsecT e s m) initial :: ParserState initial = ParserState M.empty --- | Return the unique identifier of a name. --- If it's not in the current parser state, map the name to a fresh id --- and add it to the state. Used in the Name parser. -intern :: (MonadState ParserState m, MonadQuote m) - => T.Text -> m Unique +{- | Return the unique identifier of a name. +If it's not in the current parser state, map the name to a fresh id +and add it to the state. Used in the Name parser. +-} +intern :: + (MonadState ParserState m, MonadQuote m) => + T.Text -> + m Unique intern n = do - st <- get - case M.lookup n (identifiers st) of - Just u -> return u - Nothing -> do - fresh <- freshUnique - let identifiers' = M.insert n fresh $ identifiers st - put $ ParserState identifiers' - return fresh + st <- get + case M.lookup n (identifiers st) of + Just u -> return u + Nothing -> do + fresh <- freshUnique + let identifiers' = M.insert n fresh $ identifiers st + put $ ParserState identifiers' + return fresh -- | Get the version of the program being parsed, if we know it. getVersion :: Parser (Maybe Version) @@ -64,9 +64,10 @@ getVersion = ask withVersion :: Version -> Parser a -> Parser a withVersion v = local (const $ Just v) --- | Run an action conditionally based on a predicate on the version. --- If we don't know the version then the predicate is assumed to be --- false, i.e. we act if we _know_ the predicate is satisfied. +{- | Run an action conditionally based on a predicate on the version. +If we don't know the version then the predicate is assumed to be +false, i.e. we act if we _know_ the predicate is satisfied. +-} whenVersion :: (Version -> Bool) -> Parser () -> Parser () whenVersion p act = do mv <- getVersion @@ -74,11 +75,15 @@ whenVersion p act = do Nothing -> pure () Just v -> when (p v) act -parse :: (AsParserErrorBundle e, MonadError e m, MonadQuote m) => - Parser a -> String -> T.Text -> m a +parse :: + (AsParserErrorBundle e, MonadError e m, MonadQuote m) => + Parser a -> + String -> + T.Text -> + m a parse p file str = do - let res = fmap toErrorB (runReaderT (evalStateT (runParserT p file str) initial) Nothing) - throwingEither _ParserErrorBundle =<< liftQuote res + let res = fmap toErrorB (runReaderT (evalStateT (runParserT p file str) initial) Nothing) + throwingEither _ParserErrorBundle =<< liftQuote res toErrorB :: Either (ParseErrorBundle T.Text ParserError) a -> Either ParserErrorBundle a toErrorB (Left err) = Left $ ParseErrorB err @@ -98,12 +103,13 @@ leadingWhitespace = (whitespace *>) trailingWhitespace :: Parser a -> Parser a trailingWhitespace = (<* whitespace) --- | Returns a parser for @a@ by calling the supplied function on the starting --- and ending positions of @a@. --- --- The supplied function should usually return a parser that does /not/ consume trailing --- whitespaces. Otherwise, the end position will be the first character after the --- trailing whitespaces. +{- | Returns a parser for @a@ by calling the supplied function on the starting +and ending positions of @a@. + +The supplied function should usually return a parser that does /not/ consume trailing +whitespaces. Otherwise, the end position will be the first character after the +trailing whitespaces. +-} withSpan' :: (SrcSpan -> Parser a) -> Parser a withSpan' f = mdo start <- getSourcePos @@ -112,9 +118,10 @@ withSpan' f = mdo let sp = toSrcSpan start end pure res --- | Like `withSpan'`, but the result parser consumes whitespaces. --- --- @withSpan = (<* whitespace) . withSpan' +{- | Like `withSpan'`, but the result parser consumes whitespaces. + +@withSpan = (<* whitespace) . withSpan' +-} withSpan :: (SrcSpan -> Parser a) -> Parser a withSpan = (<* whitespace) . withSpan' @@ -133,30 +140,35 @@ inBrackets = between (symbol "[") (char ']') inBraces :: Parser a -> Parser a inBraces = between (symbol "{") (char '}') -isIdentifierChar :: Char -> Bool -isIdentifierChar c = isAlphaNum c || c == '_' || c == '\'' - toSrcSpan :: SourcePos -> SourcePos -> SrcSpan toSrcSpan start end = - SrcSpan - { srcSpanFile = sourceName start - , srcSpanSLine = unPos (sourceLine start) - , srcSpanSCol = unPos (sourceColumn start) - , srcSpanELine = unPos (sourceLine end) - , srcSpanECol = unPos (sourceColumn end) - } + SrcSpan + { srcSpanFile = sourceName start + , srcSpanSLine = unPos (sourceLine start) + , srcSpanSCol = unPos (sourceColumn start) + , srcSpanELine = unPos (sourceLine end) + , srcSpanECol = unPos (sourceColumn end) + } version :: Parser Version version = trailingWhitespace $ do - x <- Lex.decimal - void $ char '.' - y <- Lex.decimal - void $ char '.' - Version x y <$> Lex.decimal + x <- Lex.decimal + void $ char '.' + y <- Lex.decimal + void $ char '.' + Version x y <$> Lex.decimal -- | Parses a `Name`. Does not consume leading or trailing whitespaces. name :: Parser Name -name = try $ do - void $ lookAhead letterChar - str <- takeWhileP (Just "identifier") isIdentifierChar - Name str <$> intern str +name = try $ parseUnquoted <|> parseQuoted + where + parseUnquoted = do + void $ lookAhead (satisfy isIdentifierStartingChar) + str <- takeWhileP (Just "identifier-unquoted") isIdentifierChar + Name str <$> intern str + parseQuoted = do + void $ char '`' + void $ lookAhead (satisfy isQuotedIdentifierChar) + str <- takeWhileP (Just "identifier-quoted") isQuotedIdentifierChar + void $ char '`' + Name str <$> intern str diff --git a/plutus-core/plutus-core/src/PlutusCore/TypeCheck/Internal.hs b/plutus-core/plutus-core/src/PlutusCore/TypeCheck/Internal.hs index 1cd49c2bdfc..263037d7613 100644 --- a/plutus-core/plutus-core/src/PlutusCore/TypeCheck/Internal.hs +++ b/plutus-core/plutus-core/src/PlutusCore/TypeCheck/Internal.hs @@ -285,7 +285,7 @@ dummyUnique :: Unique dummyUnique = Unique 0 dummyTyName :: TyName -dummyTyName = TyName (Name "*" dummyUnique) +dummyTyName = TyName (Name "any" dummyUnique) dummyKind :: Kind () dummyKind = Type () diff --git a/plutus-core/plutus-core/test/type-errors/applyType.plc.golden b/plutus-core/plutus-core/test/type-errors/applyType.plc.golden index 309dfb7d1a5..2da41d26ef6 100644 --- a/plutus-core/plutus-core/test/type-errors/applyType.plc.golden +++ b/plutus-core/plutus-core/test/type-errors/applyType.plc.golden @@ -1,6 +1,6 @@ Type mismatch at test:2:3-2:37 in term '(con integer 0)'. Expected type - '(fun * *)', + '(fun any any)', found type '(con integer)' \ No newline at end of file diff --git a/plutus-core/plutus-core/test/type-errors/instType.plc.golden b/plutus-core/plutus-core/test/type-errors/instType.plc.golden index 07b5f3e696f..9341b39a357 100644 --- a/plutus-core/plutus-core/test/type-errors/instType.plc.golden +++ b/plutus-core/plutus-core/test/type-errors/instType.plc.golden @@ -1,6 +1,6 @@ Type mismatch at test:2:3-2:35 in term '(con integer 0)'. Expected type - '(all * (type) *)', + '(all any (type) any)', found type '(con integer)' \ No newline at end of file diff --git a/plutus-core/plutus-core/test/type-errors/unwrapType.plc.golden b/plutus-core/plutus-core/test/type-errors/unwrapType.plc.golden index 70ac7249700..f9159237feb 100644 --- a/plutus-core/plutus-core/test/type-errors/unwrapType.plc.golden +++ b/plutus-core/plutus-core/test/type-errors/unwrapType.plc.golden @@ -1,6 +1,6 @@ Type mismatch at test:2:3-2:26 in term '(con integer 0)'. Expected type - '(ifix * *)', + '(ifix any any)', found type '(con integer)' \ No newline at end of file diff --git a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Names.hs b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Names.hs index 3fe2d6cbfc7..7ed4f715aae 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Names.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Names.hs @@ -2,9 +2,9 @@ module PlutusIR.Compiler.Names (safeFreshName, safeFreshTyName) where import PlutusCore qualified as PLC +import PlutusCore.Name (isQuotedIdentifierChar) import PlutusCore.Quote -import Data.Char import Data.List import Data.Text qualified as T @@ -15,15 +15,9 @@ in the long run it would be nice to have a more principled encoding so we can support unicode identifiers as well. -} -replacements :: [(T.Text, T.Text)] -replacements = [ - -- this helps with module prefixes - (".", "_") - ] - typeReplacements :: [(T.Text, T.Text)] -typeReplacements = replacements ++ [ - ("[]", "List") +typeReplacements = + [ ("[]", "List") , ("()", "Unit") , ("(,)", "Tuple2") , ("(,,)", "Tuple3") @@ -36,8 +30,8 @@ typeReplacements = replacements ++ [ ] termReplacements :: [(T.Text, T.Text)] -termReplacements = replacements ++ [ - (":", "Cons") +termReplacements = + [ (":", "Cons") , ("[]", "Nil") , ("()", "Unit") , ("(,)", "Tuple2") @@ -61,12 +55,8 @@ safeName kind t = TermName -> termReplacements replaced = foldl' (\acc (old, new) -> T.replace old new acc) t toReplace -- strip out disallowed characters - stripped = T.filter (\c -> isLetter c || isDigit c || c == '_' || c == '`') replaced - -- can't start with these - dropped = T.dropWhile (\c -> c == '_' || c == '`') stripped - -- empty name, just put something to mark that - nonEmpty = if T.null dropped then "bad_name" else dropped - in nonEmpty + stripped = T.filter isQuotedIdentifierChar replaced + in if T.null stripped then "bad_name" else stripped safeFreshName :: MonadQuote m => T.Text -> m PLC.Name safeFreshName s = liftQuote $ freshName $ safeName TermName s diff --git a/plutus-core/plutus-ir/test/ParserSpec.hs b/plutus-core/plutus-ir/test/ParserSpec.hs index 79ed00e94c5..37c8243c941 100644 --- a/plutus-core/plutus-ir/test/ParserSpec.hs +++ b/plutus-core/plutus-ir/test/ParserSpec.hs @@ -1,5 +1,6 @@ -- editorconfig-checker-disable-file {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | Tests for PIR parser. @@ -53,15 +54,24 @@ separator :: Char -> Bool separator c = c `elem` separators || isSpace c aroundSeparators :: MonadGen m => m String -> String -> m String -aroundSeparators _ [] = return [] -aroundSeparators splice [s] = (s:) <$> splice -aroundSeparators splice (a:b:l) - | separator b = do - s1 <- splice - s2 <- splice - rest <- aroundSeparators splice l - return $ a : s1 ++ b : s2 ++ rest - | otherwise = (a :) <$> aroundSeparators splice (b:l) +aroundSeparators = go False + where + -- Quoted names may contain separators, but they are part of the name, so + -- we cannot scramble inside quoted names. + go inQuotedName splice = \case + [] -> pure [] + [s] -> (s:) <$> splice + ('`' : l) -> do + s <- splice + rest <- go (not inQuotedName) splice l + pure $ if inQuotedName then '`' : s ++ rest else s ++ '`' : rest + (a : b : l) + | not (inQuotedName) && separator b -> do + s1 <- splice + s2 <- splice + rest <- go inQuotedName splice l + pure $ a : s1 ++ b : s2 ++ rest + | otherwise -> (a :) <$> go inQuotedName splice (b : l) genScrambledWith :: MonadGen m => m String -> m (String, String) genScrambledWith splice = do diff --git a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/AST.hs b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/AST.hs index 8b3fd36cc99..948cf630681 100644 --- a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/AST.hs +++ b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/AST.hs @@ -1,5 +1,6 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module PlutusCore.Generators.Hedgehog.AST ( simpleRecursive @@ -21,6 +22,7 @@ module PlutusCore.Generators.Hedgehog.AST import PlutusPrelude import PlutusCore +import PlutusCore.Name (isQuotedIdentifierChar) import PlutusCore.Subst import Control.Lens (coerced) @@ -29,6 +31,8 @@ import Control.Monad.Reader import Data.Set (Set) import Data.Set qualified as Set import Data.Set.Lens (setOf) +import Data.Text (Text) +import Data.Text qualified as Text import Hedgehog hiding (Size, Var) import Hedgehog.Internal.Gen qualified as Gen import Hedgehog.Range qualified as Range @@ -59,6 +63,16 @@ genVersion :: MonadGen m => m Version genVersion = Version <$> intFrom 1 <*> intFrom 1 <*> intFrom 0 where intFrom x = Gen.integral_ $ Range.linear x 20 +genNameText :: MonadGen m => m Text +genNameText = Gen.choice [genUnquoted, genQuoted] + where + genUnquoted = + Text.cons + <$> Gen.alpha + <*> Gen.text (Range.linear 0 4) (Gen.choice [Gen.alphaNum, Gen.element ['_', '\'']]) + genQuoted = + Gen.text (Range.linear 1 5) (Gen.filterT isQuotedIdentifierChar Gen.ascii) + -- | Generate a fixed set of names which we will use, of only up to a short size to make it -- likely that we get reuse. -- We do not attempt not to generate reserved words such as @all@ or @abs@ as the classic syntax @@ -68,9 +82,8 @@ genNames :: MonadGen m => m [Name] genNames = do let genUniq = Unique <$> Gen.int (Range.linear 0 100) uniqs <- Set.toList <$> Gen.set (Range.linear 1 20) genUniq - let genText = Gen.text (Range.linear 1 4) Gen.lower for uniqs $ \uniq -> do - text <- genText + text <- genNameText return $ Name text uniq genName :: AstGen Name diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs index d5a6e2cf6d5..88f73d60528 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs @@ -31,6 +31,8 @@ module UntypedPlutusCore.Evaluation.Machine.Cek.Internal -- See Note [Compilation peculiarities]. ( EvaluationResult(..) , CekValue(..) + , ArgStack(..) + , transferArgStack , CekUserError(..) , CekEvaluationException , CekBudgetSpender(..) @@ -212,6 +214,15 @@ but functions are not printable and hence we provide a dummy instance. instance Show (BuiltinRuntime (CekValue uni fun ann)) where show _ = "" +-- | A LIFO stack of 'CekValue's, useful for recording multiple arguments which will need to +-- be pushed onto the context in reverse order. +data ArgStack uni fun ann = + EmptyStack + | ConsStack !(CekValue uni fun ann) !(ArgStack uni fun ann) + +deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) + => Show (ArgStack uni fun ann) + -- 'Values' for the modified CEK machine. data CekValue uni fun ann = -- This bang gave us a 1-2% speed-up at the time of writing. @@ -240,7 +251,7 @@ data CekValue uni fun ann = -- ^ The partial application and its costing function. -- Check the docs of 'BuiltinRuntime' for details. -- | A constructor value, including fully computed arguments and the tag. - | VConstr {-# UNPACK #-} !Word64 ![CekValue uni fun ann] + | VConstr {-# UNPACK #-} !Word64 !(ArgStack uni fun ann) deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) => Show (CekValue uni fun ann) @@ -525,7 +536,11 @@ dischargeCekValue = \case -- or (b) it's needed for an error message. -- @term@ is fully discharged, so we can return it directly without any further discharging. VBuiltin _ term _ -> term - VConstr i es -> Constr () i (fmap dischargeCekValue es) + VConstr i es -> Constr () i (fmap dischargeCekValue $ stack2list es) + where + stack2list = go [] + go acc EmptyStack = acc + go acc (ConsStack arg rest) = go (arg : acc) rest instance (PrettyUni uni, Pretty fun) => PrettyBy PrettyConfigPlc (CekValue uni fun ann) where prettyBy cfg = prettyBy cfg . dischargeCekValue @@ -547,14 +562,14 @@ we can match on context and the top frame in a single, strict pattern match. data Context uni fun ann = FrameAwaitArg !(CekValue uni fun ann) !(Context uni fun ann) -- ^ @[V _]@ - | FrameAwaitFun !(CekValEnv uni fun ann) !(NTerm uni fun ann) !(Context uni fun ann) + | FrameAwaitFunTerm !(CekValEnv uni fun ann) !(NTerm uni fun ann) !(Context uni fun ann) -- ^ @[_ N]@ - | FrameAwaitFunValues ![CekValue uni fun ann] !(Context uni fun ann) - -- ^ @[_ V0...Vn]@ + | FrameAwaitFunValue !(CekValue uni fun ann) !(Context uni fun ann) + -- ^ @[_ V]@ | FrameForce !(Context uni fun ann) -- ^ @(force _)@ -- See Note [Accumulators for terms] - | FrameConstr !(CekValEnv uni fun ann) {-# UNPACK #-} !Word64 ![NTerm uni fun ann] !(DList.DList (CekValue uni fun ann)) !(Context uni fun ann) + | FrameConstr !(CekValEnv uni fun ann) {-# UNPACK #-} !Word64 ![NTerm uni fun ann] !(ArgStack uni fun ann) !(Context uni fun ann) -- ^ @(constr i V0 ... Vj-1 _ Nj ... Nn)@ | FrameCases !(CekValEnv uni fun ann) ![NTerm uni fun ann] !(Context uni fun ann) -- ^ @(case _ C0 .. Cn)@ @@ -573,6 +588,11 @@ instance (Closed uni, uni `Everywhere` ExMemoryUsage) => ExMemoryUsage (CekValue VConstr {} -> singletonRose 1 {-# INLINE memoryUsage #-} +-- | Transfers an 'ArgStack' to a series of 'Context' frames. +transferArgStack :: ArgStack uni fun ann -> Context uni fun ann -> Context uni fun ann +transferArgStack EmptyStack c = c +transferArgStack (ConsStack arg rest) c = transferArgStack rest (FrameAwaitFunValue arg c) + -- | A 'MonadError' version of 'try'. -- -- TODO: remove when we switch to mtl>=2.3 @@ -692,7 +712,7 @@ enterComputeCek = computeCek -- s ; ρ ▻ [L M] ↦ s , [_ (M,ρ)] ; ρ ▻ L computeCek !ctx !env (Apply _ fun arg) = do stepAndMaybeSpend BApply - computeCek (FrameAwaitFun env arg ctx) env fun + computeCek (FrameAwaitFunTerm env arg ctx) env fun -- s ; ρ ▻ builtin bn ↦ s ◅ builtin bn arity arity [] [] ρ computeCek !ctx !_ (Builtin _ bn) = do stepAndMaybeSpend BBuiltin @@ -703,8 +723,8 @@ enterComputeCek = computeCek computeCek !ctx !env (Constr _ i es) = do stepAndMaybeSpend BConstr case es of - (t : rest) -> computeCek (FrameConstr env i rest mempty ctx) env t - [] -> returnCek ctx $ VConstr i [] + (t : rest) -> computeCek (FrameConstr env i rest EmptyStack ctx) env t + [] -> returnCek ctx $ VConstr i EmptyStack -- s ; ρ ▻ case S C0 ... Cn ↦ s , case _ (C0 ... Cn, ρ) ; ρ ▻ S computeCek !ctx !env (Case _ scrut cs) = do stepAndMaybeSpend BCase @@ -734,26 +754,25 @@ enterComputeCek = computeCek -- s , {_ A} ◅ abs α M ↦ s ; ρ ▻ M [ α / A ]* returnCek (FrameForce ctx) fun = forceEvaluate ctx fun -- s , [_ (M,ρ)] ◅ V ↦ s , [V _] ; ρ ▻ M - returnCek (FrameAwaitFun argVarEnv arg ctx) fun = + returnCek (FrameAwaitFunTerm argVarEnv arg ctx) fun = computeCek (FrameAwaitArg fun ctx) argVarEnv arg -- s , [(lam x (M,ρ)) _] ◅ V ↦ s ; ρ [ x ↦ V ] ▻ M -- FIXME: add rule for VBuiltin once it's in the specification. returnCek (FrameAwaitArg fun ctx) arg = applyEvaluate ctx fun arg - -- s , [_ V1 .. Vn] ◅ lam x (M,ρ) ↦ s , [_ V2 .. Vn]; ρ [ x ↦ V1 ] ▻ M - returnCek (FrameAwaitFunValues args ctx) fun = case args of - (arg:rest) -> applyEvaluate (FrameAwaitFunValues rest ctx) fun arg - _ -> returnCek ctx fun + -- s , [_ V] ◅ lam x (M,ρ) ↦ s ; ρ [ x ↦ V ] ▻ M + returnCek (FrameAwaitFunValue arg ctx) fun = + applyEvaluate ctx fun arg -- s , constr I V0 ... Vj-1 _ (Tj+1 ... Tn, ρ) ◅ Vj ↦ s , constr i V0 ... Vj _ (Tj+2... Tn, ρ) ; ρ ▻ Tj+1 returnCek (FrameConstr env i todo done ctx) e = do - let done' = done `DList.snoc` e + let done' = ConsStack e done case todo of (next : todo') -> computeCek (FrameConstr env i todo' done' ctx) env next - _ -> returnCek ctx $ VConstr i (toList done') + _ -> returnCek ctx $ VConstr i done' -- s , case _ (C0 ... CN, ρ) ◅ constr i V1 .. Vm ↦ s , [_ V1 ... Vm] ; ρ ▻ Ci returnCek (FrameCases env cs ctx) e = case e of (VConstr i args) -> case cs ^? wix i of - Just t -> computeCek (FrameAwaitFunValues args ctx) env t + Just t -> computeCek (transferArgStack args ctx) env t Nothing -> throwingDischarged _MachineError (MissingCaseBranch i) e _ -> throwingDischarged _MachineError NonConstrScrutinized e diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs index 00e4234e928..7540fbab82a 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs @@ -51,13 +51,13 @@ import PlutusPrelude import Universe import UntypedPlutusCore.Core import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts (CekMachineCosts (..)) -import UntypedPlutusCore.Evaluation.Machine.Cek.Internal hiding (Context (..), runCekDeBruijn) +import UntypedPlutusCore.Evaluation.Machine.Cek.Internal hiding (Context (..), runCekDeBruijn, + transferArgStack) import UntypedPlutusCore.Evaluation.Machine.Cek.StepCounter import Control.Lens hiding (Context) import Control.Monad import Control.Monad.Except (MonadError, catchError) -import Data.DList qualified as DList import Data.List.Extras (wix) import Data.Proxy import Data.RandomAccessList.Class qualified as Env @@ -95,17 +95,24 @@ instance Pretty (CekState uni fun ann) where -- | Similar to 'Cek.Internal.Context', but augmented with an 'ann' data Context uni fun ann - = FrameApplyFun ann !(CekValue uni fun ann) !(Context uni fun ann) -- ^ @[V _]@ - | FrameApplyArg ann !(CekValEnv uni fun ann) !(NTerm uni fun ann) !(Context uni fun ann) -- ^ @[_ N]@ - | FrameApplyValues ann ![CekValue uni fun ann] !(Context uni fun ann) + = FrameAwaitArg ann !(CekValue uni fun ann) !(Context uni fun ann) -- ^ @[V _]@ + | FrameAwaitFunTerm ann !(CekValEnv uni fun ann) !(NTerm uni fun ann) !(Context uni fun ann) -- ^ @[_ N]@ + | FrameAwaitFunValue ann !(CekValue uni fun ann) !(Context uni fun ann) | FrameForce ann !(Context uni fun ann) -- ^ @(force _)@ - | FrameConstr ann !(CekValEnv uni fun ann) {-# UNPACK #-} !Word64 ![NTerm uni fun ann] !(DList.DList (CekValue uni fun ann)) !(Context uni fun ann) + | FrameConstr ann !(CekValEnv uni fun ann) {-# UNPACK #-} !Word64 ![NTerm uni fun ann] !(ArgStack uni fun ann) !(Context uni fun ann) | FrameCases ann !(CekValEnv uni fun ann) ![NTerm uni fun ann] !(Context uni fun ann) | NoFrame deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) => Show (Context uni fun ann) +-- | Transfers an 'ArgStack' to a series of 'Context' frames. +transferArgStack :: ann -> ArgStack uni fun ann -> Context uni fun ann -> Context uni fun ann +transferArgStack ann = go + where + go EmptyStack c = c + go (ConsStack arg rest) c = go rest (FrameAwaitFunValue ann arg c) + computeCek :: forall uni fun ann s . (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) @@ -134,7 +141,7 @@ computeCek !ctx !env (Force _ body) = do -- s ; ρ ▻ [L M] ↦ s , [_ (M,ρ)] ; ρ ▻ L computeCek !ctx !env (Apply _ fun arg) = do stepAndMaybeSpend BApply - pure $ Computing (FrameApplyArg (termAnn fun) env arg ctx) env fun + pure $ Computing (FrameAwaitFunTerm (termAnn fun) env arg ctx) env fun -- s ; ρ ▻ abs α L ↦ s ◅ abs α (L , ρ) -- s ; ρ ▻ con c ↦ s ◅ con c -- s ; ρ ▻ builtin bn ↦ s ◅ builtin bn arity arity [] [] ρ @@ -147,8 +154,8 @@ computeCek !ctx !_ (Builtin _ bn) = do computeCek !ctx !env (Constr ann i es) = do stepAndMaybeSpend BConstr case es of - (t : rest) -> computeCek (FrameConstr ann env i rest mempty ctx) env t - _ -> returnCek ctx $ VConstr i [] + (t : rest) -> computeCek (FrameConstr ann env i rest EmptyStack ctx) env t + _ -> returnCek ctx $ VConstr i EmptyStack -- s ; ρ ▻ case S C0 ... Cn ↦ s , case _ (C0 ... Cn, ρ) ; ρ ▻ S computeCek !ctx !env (Case ann scrut cs) = do stepAndMaybeSpend BCase @@ -171,27 +178,28 @@ returnCek NoFrame val = do -- s , {_ A} ◅ abs α M ↦ s ; ρ ▻ M [ α / A ]* returnCek (FrameForce _ ctx) fun = forceEvaluate ctx fun -- s , [_ (M,ρ)] ◅ V ↦ s , [V _] ; ρ ▻ M -returnCek (FrameApplyArg _funAnn argVarEnv arg ctx) fun = +returnCek (FrameAwaitFunTerm _funAnn argVarEnv arg ctx) fun = -- MAYBE: perhaps it is worth here to merge the _funAnn with argAnn - pure $ Computing (FrameApplyFun (termAnn arg) fun ctx) argVarEnv arg + pure $ Computing (FrameAwaitArg (termAnn arg) fun ctx) argVarEnv arg -- s , [(lam x (M,ρ)) _] ◅ V ↦ s ; ρ [ x ↦ V ] ▻ M -- FIXME: add rule for VBuiltin once it's in the specification. -returnCek (FrameApplyFun _ fun ctx) arg = +returnCek (FrameAwaitArg _ fun ctx) arg = applyEvaluate ctx fun arg -- s , [_ V1 .. Vn] ◅ lam x (M,ρ) ↦ s , [_ V2 .. Vn]; ρ [ x ↦ V1 ] ▻ M -returnCek (FrameApplyValues ann args ctx) fun = case args of - (arg:rest) -> applyEvaluate (FrameApplyValues ann rest ctx) fun arg - _ -> returnCek ctx fun +returnCek (FrameAwaitFunValue _ arg ctx) fun = + applyEvaluate ctx fun arg -- s , constr I V0 ... Vj-1 _ (Tj+1 ... Tn, ρ) ◅ Vj ↦ s , constr i V0 ... Vj _ (Tj+2... Tn, ρ) ; ρ ▻ Tj+1 returnCek (FrameConstr ann env i todo done ctx) e = do - let done' = done `DList.snoc` e + let done' = ConsStack e done case todo of (next : todo') -> computeCek (FrameConstr ann env i todo' done' ctx) env next - _ -> returnCek ctx $ VConstr i (toList done') + _ -> returnCek ctx $ VConstr i done' -- s , case _ (C0 ... CN, ρ) ◅ constr i V1 .. Vm ↦ s , [_ V1 ... Vm] ; ρ ▻ Ci returnCek (FrameCases ann env cs ctx) e = case e of (VConstr i args) -> case cs ^? wix i of - Just t -> computeCek (FrameApplyValues ann args ctx) env t + Just t -> + let ctx' = transferArgStack ann args ctx + in computeCek ctx' env t Nothing -> throwingDischarged _MachineError (MissingCaseBranch i) e _ -> throwingDischarged _MachineError NonConstrScrutinized e @@ -360,26 +368,26 @@ cekStateAnn = \case contextAnn :: Context uni fun ann -> Maybe ann contextAnn = \case - FrameApplyFun ann _ _ -> pure ann - FrameApplyArg ann _ _ _ -> pure ann - FrameApplyValues ann _ _ -> pure ann - FrameForce ann _ -> pure ann - FrameConstr ann _ _ _ _ _ -> pure ann - FrameCases ann _ _ _ -> pure ann - NoFrame -> empty + FrameAwaitArg ann _ _ -> pure ann + FrameAwaitFunTerm ann _ _ _ -> pure ann + FrameAwaitFunValue ann _ _ -> pure ann + FrameForce ann _ -> pure ann + FrameConstr ann _ _ _ _ _ -> pure ann + FrameCases ann _ _ _ -> pure ann + NoFrame -> empty lenContext :: Context uni fun ann -> Word lenContext = go 0 where go :: Word -> Context uni fun ann -> Word go !n = \case - FrameApplyFun _ _ k -> go (n+1) k - FrameApplyArg _ _ _ k -> go (n+1) k - FrameApplyValues _ _ k -> go (n+1) k - FrameForce _ k -> go (n+1) k - FrameConstr _ _ _ _ _ k -> go (n+1) k - FrameCases _ _ _ k -> go (n+1) k - NoFrame -> 0 + FrameAwaitArg _ _ k -> go (n+1) k + FrameAwaitFunTerm _ _ _ k -> go (n+1) k + FrameAwaitFunValue _ _ k -> go (n+1) k + FrameForce _ k -> go (n+1) k + FrameConstr _ _ _ _ _ k -> go (n+1) k + FrameCases _ _ _ k -> go (n+1) k + NoFrame -> 0 -- * Duplicated functions from Cek.Internal module diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Golden/iteAtIntegerAtInteger.type.golden b/plutus-core/untyped-plutus-core/test/Evaluation/Golden/iteAtIntegerAtInteger.type.golden index 827a0319dea..9d14c5a7de3 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Golden/iteAtIntegerAtInteger.type.golden +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Golden/iteAtIntegerAtInteger.type.golden @@ -1,6 +1,6 @@ (Left Type mismatch at () in term '{ (builtin ifThenElse) (con integer) }'. Expected type - '(all *_0 (type) *_0)', + '(all any_0 (type) any_0)', found type '(fun (con bool) (fun (con integer) (fun (con integer) (con integer))))') \ No newline at end of file diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Golden/iteTypeTermType.type.golden b/plutus-core/untyped-plutus-core/test/Evaluation/Golden/iteTypeTermType.type.golden index 2100fe8b783..335323bbd6a 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Golden/iteTypeTermType.type.golden +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Golden/iteTypeTermType.type.golden @@ -4,6 +4,6 @@ [ [ (builtin lessThanEqualsInteger) (con integer 11) ] (con integer 22) ] ]'. Expected type - '(all *_0 (type) *_0)', + '(all any_0 (type) any_0)', found type '(fun (con integer) (fun (con integer) (con integer)))') \ No newline at end of file diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Golden/iteUninstantiatedFullyApplied.type.golden b/plutus-core/untyped-plutus-core/test/Evaluation/Golden/iteUninstantiatedFullyApplied.type.golden index f8a0e456e37..edfa8aa8843 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Golden/iteUninstantiatedFullyApplied.type.golden +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Golden/iteUninstantiatedFullyApplied.type.golden @@ -1,6 +1,6 @@ (Left Type mismatch at () in term '(builtin ifThenElse)'. Expected type - '(fun *_0 *_0)', + '(fun any_0 any_0)', found type '(all a_2 (type) (fun (con bool) (fun a_2 (fun a_2 a_2))))') \ No newline at end of file diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Golden/iteUninstantiatedWithCond.type.golden b/plutus-core/untyped-plutus-core/test/Evaluation/Golden/iteUninstantiatedWithCond.type.golden index f8a0e456e37..edfa8aa8843 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Golden/iteUninstantiatedWithCond.type.golden +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Golden/iteUninstantiatedWithCond.type.golden @@ -1,6 +1,6 @@ (Left Type mismatch at () in term '(builtin ifThenElse)'. Expected type - '(fun *_0 *_0)', + '(fun any_0 any_0)', found type '(all a_2 (type) (fun (con bool) (fun a_2 (fun a_2 a_2))))') \ No newline at end of file diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Golden/mulInstError1.type.golden b/plutus-core/untyped-plutus-core/test/Evaluation/Golden/mulInstError1.type.golden index d0830bd43c9..7a99d2d6eb2 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Golden/mulInstError1.type.golden +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Golden/mulInstError1.type.golden @@ -1,6 +1,6 @@ (Left Type mismatch at () in term '(builtin multiplyInteger)'. Expected type - '(all *_0 (type) *_0)', + '(all any_0 (type) any_0)', found type '(fun (con integer) (fun (con integer) (con integer)))') \ No newline at end of file diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Golden/mulInstError2.type.golden b/plutus-core/untyped-plutus-core/test/Evaluation/Golden/mulInstError2.type.golden index 45cd44ac9f9..d1182b20d9d 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Golden/mulInstError2.type.golden +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Golden/mulInstError2.type.golden @@ -1,6 +1,6 @@ (Left Type mismatch at () in term '[ (builtin multiplyInteger) (con integer 11) ]'. Expected type - '(all *_0 (type) *_0)', + '(all any_0 (type) any_0)', found type '(fun (con integer) (con integer))') \ No newline at end of file diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Golden/mulInstError3.type.golden b/plutus-core/untyped-plutus-core/test/Evaluation/Golden/mulInstError3.type.golden index f3847188591..f5e5e60d927 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Golden/mulInstError3.type.golden +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Golden/mulInstError3.type.golden @@ -1,6 +1,6 @@ (Left Type mismatch at () in term '[ [ (builtin multiplyInteger) (con integer 11) ] (con integer 22) ]'. Expected type - '(all *_0 (type) *_0)', + '(all any_0 (type) any_0)', found type '(con integer)') \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/applicative.pir-readable.golden b/plutus-tx-plugin/test/Budget/applicative.pir-readable.golden index 2df93c099ed..9f3aea1bd94 100644 --- a/plutus-tx-plugin/test/Budget/applicative.pir-readable.golden +++ b/plutus-tx-plugin/test/Budget/applicative.pir-readable.golden @@ -8,10 +8,11 @@ let = (let b = integer -> integer in - \(dFunctor : (\(f :: * -> *) -> all a b. (a -> b) -> f a -> f b) Maybe) + \(`$dFunctor` + : (\(f :: * -> *) -> all a b. (a -> b) -> f a -> f b) Maybe) (f : integer -> b) (fa : Maybe integer) -> - dFunctor {integer} {b} f fa) + `$dFunctor` {integer} {b} f fa) (/\a b -> \(f : a -> b) diff --git a/plutus-tx-plugin/test/Budget/monadicDo.pir-readable.golden b/plutus-tx-plugin/test/Budget/monadicDo.pir-readable.golden index 27ee870be87..8befc225d53 100644 --- a/plutus-tx-plugin/test/Budget/monadicDo.pir-readable.golden +++ b/plutus-tx-plugin/test/Budget/monadicDo.pir-readable.golden @@ -2,7 +2,7 @@ let data (Maybe :: * -> *) a | Maybe_match where Just : a -> Maybe a Nothing : Maybe a - !fMonadMaybe_c : all a b. Maybe a -> (a -> Maybe b) -> Maybe b + !`$fMonadMaybe_$c>>=` : all a b. Maybe a -> (a -> Maybe b) -> Maybe b = /\a b -> \(ds : Maybe a) @@ -17,17 +17,17 @@ let !x : Maybe integer = Just {integer} 1 !y : Maybe integer = Just {integer} 2 in -fMonadMaybe_c +`$fMonadMaybe_$c>>=` {integer} {integer} x - (\(x : integer) -> - fMonadMaybe_c + (\(x' : integer) -> + `$fMonadMaybe_$c>>=` {integer} {integer} y - (\(y : integer) -> + (\(y' : integer) -> let - !ds : integer = addInteger x y + !ds : integer = addInteger x' y' in Just {integer} ds)) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Budget/monadicDo.uplc-readable.golden b/plutus-tx-plugin/test/Budget/monadicDo.uplc-readable.golden index 36799051603..24c385adef9 100644 --- a/plutus-tx-plugin/test/Budget/monadicDo.uplc-readable.golden +++ b/plutus-tx-plugin/test/Budget/monadicDo.uplc-readable.golden @@ -1,10 +1,10 @@ -program 1.1.0 ((\fMonadMaybe_c -> - fMonadMaybe_c +program 1.1.0 ((\`$fMonadMaybe_$c>>=` -> + `$fMonadMaybe_$c>>=` (constr 0 [1]) - (\x -> - fMonadMaybe_c + (\x' -> + `$fMonadMaybe_$c>>=` (constr 0 [2]) - (\y -> constr 0 [(addInteger x y)]))) + (\y' -> constr 0 [(addInteger x' y')]))) (\ds k -> force (case ds [ (\x -> delay (k x)) diff --git a/plutus-tx-plugin/test/Budget/patternMatch.pir-readable.golden b/plutus-tx-plugin/test/Budget/patternMatch.pir-readable.golden index 74b3388a5a7..4d31bdc8a3e 100644 --- a/plutus-tx-plugin/test/Budget/patternMatch.pir-readable.golden +++ b/plutus-tx-plugin/test/Budget/patternMatch.pir-readable.golden @@ -9,13 +9,13 @@ Maybe_match {integer} x {all dead. Maybe integer} - (\(x : integer) -> + (\(x' : integer) -> /\dead -> Maybe_match {integer} y {all dead. Maybe integer} - (\(y : integer) -> /\dead -> Just {integer} (addInteger x y)) + (\(y' : integer) -> /\dead -> Just {integer} (addInteger x' y')) (/\dead -> Nothing {integer}) {all dead. dead}) (/\dead -> Nothing {integer}) diff --git a/plutus-tx-plugin/test/Budget/show.pir-readable.golden b/plutus-tx-plugin/test/Budget/show.pir-readable.golden index 5b72d22cdf7..cbe9acd0fb3 100644 --- a/plutus-tx-plugin/test/Budget/show.pir-readable.golden +++ b/plutus-tx-plugin/test/Budget/show.pir-readable.golden @@ -42,7 +42,7 @@ let !id : all a. a -> a = /\a -> \(x : a) -> x in letrec - !wcshowsPrec + !`$w$cshowsPrec` : integer -> List string -> List string = \(w : integer) -> Bool_match @@ -50,7 +50,7 @@ letrec {all dead. List string -> List string} (/\dead -> \(x : List string) -> - Cons {string} "-" (wcshowsPrec (subtractInteger 0 w) x)) + Cons {string} "-" (`$w$cshowsPrec` (subtractInteger 0 w) x)) (/\dead -> foldr {integer} @@ -173,7 +173,7 @@ let Bool_match (ifThenElse {Bool} (lessThanEqualsInteger x 9) True False) {all dead. List string -> List string} - (/\dead -> wcshowsPrec x) + (/\dead -> `$w$cshowsPrec` x) (/\dead -> Bool_match (ifThenElse {Bool} (equalsInteger x 10) True False) @@ -232,7 +232,7 @@ let !x : integer = -1234567890 in letrec - !fEnumBool_cenumFromTo : integer -> integer -> List integer + !`$fEnumBool_$cenumFromTo` : integer -> integer -> List integer = \(x : integer) (y : integer) -> Bool_match @@ -240,12 +240,13 @@ letrec {all dead. List integer} (/\dead -> Nil {integer}) (/\dead -> - Cons {integer} x (fEnumBool_cenumFromTo (addInteger x 1) y)) + Cons {integer} x (`$fEnumBool_$cenumFromTo` (addInteger x 1) y)) {all dead. dead} in let - !fShowInteger_cshowsPrec : integer -> integer -> List string -> List string - = \(w : integer) (w : integer) -> wcshowsPrec w + !`$fShowInteger_$cshowsPrec` + : integer -> integer -> List string -> List string + = \(w : integer) (w : integer) -> `$w$cshowsPrec` w data (Tuple2 :: * -> * -> *) a b | Tuple2_match where Tuple2 : a -> b -> Tuple2 a b in @@ -372,14 +373,14 @@ letrec {all dead. dead}) in let - !fShowInteger_cshow : integer -> string + !`$fShowInteger_$cshow` : integer -> string = \(x : integer) -> - concatBuiltinStrings (fShowInteger_cshowsPrec 0 x (Nil {string})) + concatBuiltinStrings (`$fShowInteger_$cshowsPrec` 0 x (Nil {string})) data (Show :: * -> *) a | Show_match where CConsShow : (integer -> a -> List string -> List string) -> (a -> string) -> Show a - ~fShowInteger : Show integer - = CConsShow {integer} fShowInteger_cshowsPrec fShowInteger_cshow + ~`$fShowInteger` : Show integer + = CConsShow {integer} `$fShowInteger_$cshowsPrec` `$fShowInteger_$cshow` data (Tuple5 :: * -> * -> * -> * -> * -> *) a b c d e | Tuple5_match where Tuple5 : a -> b -> c -> d -> e -> Tuple5 a b c d e !showsPrec : all a. Show a -> integer -> a -> List string -> List string @@ -392,7 +393,7 @@ let (\(v : integer -> a -> List string -> List string) (v : a -> string) -> v) - !a : integer = trace {integer} (fShowInteger_cshow x) x + !a : integer = trace {integer} (`$fShowInteger_$cshow` x) x !c : integer = trace {integer} @@ -408,7 +409,7 @@ let (x : List string) -> toHex (divideInteger x 16) (toHex (modInteger x 16) (acc x))) (id {List string}) - (fEnumBool_cenumFromTo + (`$fEnumBool_$cenumFromTo` 0 (subtractInteger (lengthOfByteString w) 1)) (Nil {string}))) @@ -425,7 +426,7 @@ let = trace {integer} (let - !dShow : Show integer = fShowInteger + !`$dShow` : Show integer = `$fShowInteger` !x : List integer = (let a = List integer @@ -437,7 +438,7 @@ let concatBuiltinStrings ((let !showElem : integer -> List string -> List string - = showsPrec {integer} dShow 0 + = showsPrec {integer} `$dShow` 0 in Nil_match {integer} @@ -468,11 +469,11 @@ let = trace {integer} (let - !w : Show integer = fShowInteger - !w : Show integer = fShowInteger - !w : Show integer = fShowInteger - !w : Show integer = fShowInteger - !w : Show integer = fShowInteger + !w : Show integer = `$fShowInteger` + !w : Show integer = `$fShowInteger` + !w : Show integer = `$fShowInteger` + !w : Show integer = `$fShowInteger` + !w : Show integer = `$fShowInteger` !w : Tuple5 integer integer integer integer integer = Tuple5 {integer} {integer} {integer} {integer} {integer} a a c d e in diff --git a/plutus-tx-plugin/test/Budget/show.uplc-readable.golden b/plutus-tx-plugin/test/Budget/show.uplc-readable.golden index bba43137813..ab6a2523ce1 100644 --- a/plutus-tx-plugin/test/Budget/show.uplc-readable.golden +++ b/plutus-tx-plugin/test/Budget/show.uplc-readable.golden @@ -3,21 +3,21 @@ program 1.1.0 ((\fix1 -> (\go -> (\foldr -> (\id -> - (\wcshowsPrec -> + (\`$w$cshowsPrec` -> (\x -> (\w -> (\toHex -> - (\fEnumBool_cenumFromTo -> - (\fShowInteger_cshowsPrec -> + (\`$fEnumBool_$cenumFromTo` -> + (\`$fShowInteger_$cshowsPrec` -> (\go -> (\go -> (\concatBuiltinStrings -> - (\fShowInteger_cshow -> + (\`$fShowInteger_$cshow` -> (\a -> (\c -> (\d -> (\showsPrec -> - (\fShowInteger -> + (\`$fShowInteger` -> (\e -> (\x -> multiplyInteger @@ -27,27 +27,27 @@ program 1.1.0 ((\fix1 -> (concatBuiltinStrings (constr 1 [ "(" , (showsPrec - fShowInteger + `$fShowInteger` 0 a (constr 1 [ "," , (showsPrec - fShowInteger + `$fShowInteger` 0 a (constr 1 [ "," , (showsPrec - fShowInteger + `$fShowInteger` 0 c (constr 1 [ "," , (showsPrec - fShowInteger + `$fShowInteger` 0 d (constr 1 [ "," , (showsPrec - fShowInteger + `$fShowInteger` 0 e (constr 1 [ ")" @@ -78,11 +78,11 @@ program 1.1.0 ((\fix1 -> (constr 1 [ "]" , (constr 0 [ ]) ]))) ]) (showsPrec - fShowInteger + `$fShowInteger` 0))) d)) - (constr 0 [ fShowInteger_cshowsPrec - , fShowInteger_cshow ])) + (constr 0 [ `$fShowInteger_$cshowsPrec` + , `$fShowInteger_$cshow` ])) (\v -> case v [ (\v v -> @@ -119,7 +119,7 @@ program 1.1.0 ((\fix1 -> (acc x))) id - (fEnumBool_cenumFromTo + (`$fEnumBool_$cenumFromTo` 0 (subtractInteger (lengthOfByteString @@ -128,12 +128,12 @@ program 1.1.0 ((\fix1 -> (constr 0 [ ]))) a)) (force trace - (fShowInteger_cshow + (`$fShowInteger_$cshow` x) x)) (\x -> concatBuiltinStrings - (fShowInteger_cshowsPrec + (`$fShowInteger_$cshowsPrec` 0 x (constr 0 [ ])))) @@ -220,9 +220,9 @@ program 1.1.0 ((\fix1 -> constr 0 [ (constr 1 [ y , zs ]) , ws ]) ])) ]))) ]))))) - (\w w -> wcshowsPrec w)) + (\w w -> `$w$cshowsPrec` w)) (fix1 - (\fEnumBool_cenumFromTo + (\`$fEnumBool_$cenumFromTo` x y -> force (case (force ifThenElse @@ -232,7 +232,7 @@ program 1.1.0 ((\fix1 -> (constr 1 []) (constr 0 [ ])) [ (delay (constr 0 [ ])) , (delay (constr 1 [ x - , (fEnumBool_cenumFromTo + , (`$fEnumBool_$cenumFromTo` (addInteger x 1) @@ -243,7 +243,7 @@ program 1.1.0 ((\fix1 -> x 9) (constr 0 []) - (constr 1 [ ])) [ (delay (wcshowsPrec + (constr 1 [ ])) [ (delay (`$w$cshowsPrec` x)) , (delay (force (case (force ifThenElse (equalsInteger @@ -299,14 +299,14 @@ program 1.1.0 ((\fix1 -> #5468697320697320616e206578616d706c65) -1234567890) (fix1 - (\wcshowsPrec + (\`$w$cshowsPrec` w -> force (case (force ifThenElse (lessThanInteger w 0) (constr 0 []) (constr 1 [ ])) [ (delay (\x -> constr 1 [ "-" - , (wcshowsPrec + , (`$w$cshowsPrec` (subtractInteger 0 w) diff --git a/plutus-tx-plugin/test/Budget/sum.pir-readable.golden b/plutus-tx-plugin/test/Budget/sum.pir-readable.golden index 8375bcf67bd..da4a46f0c9d 100644 --- a/plutus-tx-plugin/test/Budget/sum.pir-readable.golden +++ b/plutus-tx-plugin/test/Budget/sum.pir-readable.golden @@ -8,7 +8,7 @@ let CConsAdditiveMonoid : (\a -> a -> a -> a) a -> a -> AdditiveMonoid a in (let - !dAdditiveMonoid : AdditiveMonoid integer + !`$dAdditiveMonoid` : AdditiveMonoid integer = CConsAdditiveMonoid {integer} (\(x : integer) (y : integer) -> addInteger x y) @@ -16,13 +16,13 @@ in !f : integer -> integer -> integer = AdditiveMonoid_match {integer} - dAdditiveMonoid + `$dAdditiveMonoid` {(\a -> a -> a -> a) integer} (\(v : (\a -> a -> a -> a) integer) (v : integer) -> v) !z : integer = AdditiveMonoid_match {integer} - dAdditiveMonoid + `$dAdditiveMonoid` {integer} (\(v : (\a -> a -> a -> a) integer) (v : integer) -> v) in diff --git a/plutus-tx-plugin/test/Budget/sum.uplc-readable.golden b/plutus-tx-plugin/test/Budget/sum.uplc-readable.golden index 544b0eaeba2..4f5dbfe3255 100644 --- a/plutus-tx-plugin/test/Budget/sum.uplc-readable.golden +++ b/plutus-tx-plugin/test/Budget/sum.uplc-readable.golden @@ -1,4 +1,4 @@ -program 1.1.0 ((\dAdditiveMonoid -> +program 1.1.0 ((\`$dAdditiveMonoid` -> (\f -> (\z -> (\go eta -> go eta) @@ -11,8 +11,8 @@ program 1.1.0 ((\dAdditiveMonoid -> xs -> delay (f x (go xs))) ])) (s s)))) - (case dAdditiveMonoid [(\v v -> v)])) - (case dAdditiveMonoid [(\v v -> v)])) + (case `$dAdditiveMonoid` [(\v v -> v)])) + (case `$dAdditiveMonoid` [(\v v -> v)])) (constr 0 [(\x y -> addInteger x y), 0]) (constr 1 [ 1 , (constr 1 [ 2 diff --git a/plutus-tx-plugin/test/Budget/toFromData.pir-readable.golden b/plutus-tx-plugin/test/Budget/toFromData.pir-readable.golden index 25c3bc3bf5d..ea583bdfc86 100644 --- a/plutus-tx-plugin/test/Budget/toFromData.pir-readable.golden +++ b/plutus-tx-plugin/test/Budget/toFromData.pir-readable.golden @@ -18,8 +18,8 @@ in (let b = Maybe (Tuple3 Bool integer Bool) in - \(dUnsafeFromData : (\a -> data -> a) integer) - (dUnsafeFromData : (\a -> data -> a) b) + \(`$dUnsafeFromData` : (\a -> data -> a) integer) + (`$dUnsafeFromData` : (\a -> data -> a) b) (d : data) -> let !tup : pair integer (list data) = unConstrData d @@ -32,7 +32,7 @@ in let !arg : data = headList {data} (sndPair {integer} {list data} tup) in - Right {integer} {b} (dUnsafeFromData arg)) + Right {integer} {b} (`$dUnsafeFromData` arg)) (\(ds : unit) -> ifThenElse {unit -> Either integer b} @@ -42,7 +42,7 @@ in !arg : data = headList {data} (sndPair {integer} {list data} tup) in - Left {integer} {b} (dUnsafeFromData arg)) + Left {integer} {b} (`$dUnsafeFromData` arg)) (\(ds : unit) -> let !thunk : unit @@ -58,7 +58,7 @@ in ((let a = Tuple3 Bool integer Bool in - \(dUnsafeFromData : (\a -> data -> a) a) + \(`$dUnsafeFromData` : (\a -> data -> a) a) (d : data) -> let !tup : pair integer (list data) = unConstrData d @@ -71,7 +71,7 @@ in let !arg : data = headList {data} (sndPair {integer} {list data} tup) in - Just {a} (dUnsafeFromData arg)) + Just {a} (`$dUnsafeFromData` arg)) (\(ds : unit) -> ifThenElse {unit -> Maybe a} @@ -172,8 +172,8 @@ in ((let b = Maybe (Tuple3 Bool integer Bool) in - \(dToData : (\a -> a -> data) integer) - (dToData : (\a -> a -> data) b) + \(`$dToData` : (\a -> a -> data) integer) + (`$dToData` : (\a -> a -> data) b) (ds : Either integer b) -> Either_match {integer} @@ -181,14 +181,14 @@ in ds {data} (\(arg : integer) -> - constrData 0 (mkCons {data} (dToData arg) (mkNilData unitval))) + constrData 0 (mkCons {data} (`$dToData` arg) (mkNilData unitval))) (\(arg : b) -> - constrData 1 (mkCons {data} (dToData arg) (mkNilData unitval)))) + constrData 1 (mkCons {data} (`$dToData` arg) (mkNilData unitval)))) (\(i : integer) -> iData i) ((let a = Tuple3 Bool integer Bool in - \(dToData : (\a -> a -> data) a) + \(`$dToData` : (\a -> a -> data) a) (ds : Maybe a) -> Maybe_match {a} @@ -196,7 +196,9 @@ in {all dead. data} (\(arg : a) -> /\dead -> - constrData 0 (mkCons {data} (dToData arg) (mkNilData unitval))) + constrData + 0 + (mkCons {data} (`$dToData` arg) (mkNilData unitval))) (/\dead -> constrData 1 (mkNilData unitval)) {all dead. dead}) (\(w : Tuple3 Bool integer Bool) -> diff --git a/plutus-tx-plugin/test/IsData/deconstructData.pir.golden b/plutus-tx-plugin/test/IsData/deconstructData.pir.golden index 32553903b86..77cfe94ffca 100644 --- a/plutus-tx-plugin/test/IsData/deconstructData.pir.golden +++ b/plutus-tx-plugin/test/IsData/deconstructData.pir.golden @@ -83,7 +83,7 @@ (termbind (strict) (vardecl - fFromDataTuple2_cfromBuiltinData + `$fFromDataTuple2_$cfromBuiltinData` (all a (type) @@ -107,10 +107,10 @@ b (type) (lam - dFromData + `$dFromData` [ (lam a (type) (fun (con data) [ Maybe a ])) a ] (lam - dFromData + `$dFromData` [ (lam a (type) (fun (con data) [ Maybe a ])) b ] (lam d @@ -144,7 +144,7 @@ { [ { Maybe_match a } - [ dFromData [ { head (con data) } l ] ] + [ `$dFromData` [ { head (con data) } l ] ] ] (all dead (type) [ Maybe [ [ Tuple2 a ] b ] ]) } @@ -160,7 +160,9 @@ { [ { Maybe_match b } - [ dFromData [ { head (con data) } l ] ] + [ + `$dFromData` [ { head (con data) } l ] + ] ] (all dead (type) [ Maybe [ [ Tuple2 a ] b ] ] @@ -326,7 +328,7 @@ (termbind (nonstrict) (vardecl - fFromDataTuple2 + `$fFromDataTuple2` (all a (type) @@ -345,7 +347,7 @@ ) ) ) - fFromDataTuple2_cfromBuiltinData + `$fFromDataTuple2_$cfromBuiltinData` ) (termbind (strict) @@ -355,7 +357,7 @@ (termbind (strict) (vardecl - fFromDataInteger_cfromBuiltinData + `$fFromDataInteger_$cfromBuiltinData` (fun (con data) [ Maybe (con integer) ]) ) (lam @@ -385,23 +387,26 @@ (termbind (nonstrict) (vardecl - fFromDataInteger + `$fFromDataInteger` [ (lam a (type) (fun (con data) [ Maybe a ])) (con integer) ] ) - fFromDataInteger_cfromBuiltinData + `$fFromDataInteger_$cfromBuiltinData` ) (termbind (nonstrict) (vardecl - dFromData + `$dFromData` [ (lam a (type) (fun (con data) [ Maybe a ])) [ [ Tuple2 (con integer) ] (con integer) ] ] ) [ - [ { { fFromDataTuple2 (con integer) } (con integer) } fFromDataInteger ] - fFromDataInteger + [ + { { `$fFromDataTuple2` (con integer) } (con integer) } + `$fFromDataInteger` + ] + `$fFromDataInteger` ] ) (termbind @@ -425,7 +430,7 @@ [ [ { fromBuiltinData [ [ Tuple2 (con integer) ] (con integer) ] } - dFromData + `$dFromData` ] ds ] diff --git a/plutus-tx-plugin/test/IsData/unsafeDeconstructData.pir.golden b/plutus-tx-plugin/test/IsData/unsafeDeconstructData.pir.golden index 55b77b7b12c..c1e82ee90af 100644 --- a/plutus-tx-plugin/test/IsData/unsafeDeconstructData.pir.golden +++ b/plutus-tx-plugin/test/IsData/unsafeDeconstructData.pir.golden @@ -70,7 +70,7 @@ (termbind (strict) (vardecl - fUnsafeFromDataTuple2_cunsafeFromBuiltinData + `$fUnsafeFromDataTuple2_$cunsafeFromBuiltinData` (all a (type) @@ -112,10 +112,10 @@ ] ) (lam - dUnsafeFromData + `$dUnsafeFromData` [ (lam a (type) (fun (con data) a)) a ] (lam - dUnsafeFromData + `$dUnsafeFromData` [ (lam a (type) (fun (con data) a)) b ] (lam d @@ -155,8 +155,8 @@ [ { head (con data) } [ { tail (con data) } t ] ] ) [ - [ { { Tuple2 a } b } [ dUnsafeFromData arg ] ] - [ dUnsafeFromData arg ] + [ { { Tuple2 a } b } [ `$dUnsafeFromData` arg ] ] + [ `$dUnsafeFromData` arg ] ] ) ) @@ -191,7 +191,7 @@ (termbind (nonstrict) (vardecl - fUnsafeFromDataTuple2 + `$fUnsafeFromDataTuple2` (all a (type) @@ -208,7 +208,7 @@ ) ) ) - fUnsafeFromDataTuple2_cunsafeFromBuiltinData + `$fUnsafeFromDataTuple2_$cunsafeFromBuiltinData` ) (termbind (strict) @@ -218,7 +218,7 @@ (termbind (nonstrict) (vardecl - fUnsafeFromDataInteger + `$fUnsafeFromDataInteger` [ (lam a (type) (fun (con data) a)) (con integer) ] ) unsafeDataAsI @@ -226,7 +226,7 @@ (termbind (nonstrict) (vardecl - dUnsafeFromData + `$dUnsafeFromData` [ (lam a (type) (fun (con data) a)) [ [ Tuple2 (con integer) ] (con integer) ] @@ -234,10 +234,10 @@ ) [ [ - { { fUnsafeFromDataTuple2 (con integer) } (con integer) } - fUnsafeFromDataInteger + { { `$fUnsafeFromDataTuple2` (con integer) } (con integer) } + `$fUnsafeFromDataInteger` ] - fUnsafeFromDataInteger + `$fUnsafeFromDataInteger` ] ) (datatypebind @@ -251,7 +251,7 @@ (termbind (strict) (vardecl - fUnsafeFromDataMaybe_cunsafeFromBuiltinData + `$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` (all a (type) @@ -282,7 +282,7 @@ ] ) (lam - dUnsafeFromData + `$dUnsafeFromData` [ (lam a (type) (fun (con data) a)) a ] (lam d @@ -313,7 +313,7 @@ ] ] ) - [ { Just a } [ dUnsafeFromData arg ] ] + [ { Just a } [ `$dUnsafeFromData` arg ] ] ) ) (termbind @@ -360,7 +360,7 @@ (termbind (nonstrict) (vardecl - fUnsafeFromDataMaybe + `$fUnsafeFromDataMaybe` (all a (type) @@ -370,20 +370,20 @@ ) ) ) - fUnsafeFromDataMaybe_cunsafeFromBuiltinData + `$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` ) (termbind (nonstrict) (vardecl - dUnsafeFromData + `$dUnsafeFromData` [ (lam a (type) (fun (con data) a)) [ Maybe [ [ Tuple2 (con integer) ] (con integer) ] ] ] ) [ - { fUnsafeFromDataMaybe [ [ Tuple2 (con integer) ] (con integer) ] } - dUnsafeFromData + { `$fUnsafeFromDataMaybe` [ [ Tuple2 (con integer) ] (con integer) ] } + `$dUnsafeFromData` ] ) (termbind @@ -407,7 +407,7 @@ unsafeFromBuiltinData [ Maybe [ [ Tuple2 (con integer) ] (con integer) ] ] } - dUnsafeFromData + `$dUnsafeFromData` ] ds ] diff --git a/plutus-tx-plugin/test/Lift/bytestring.uplc.golden b/plutus-tx-plugin/test/Lift/bytestring.uplc.golden index 3f7c73ca70f..f5428834a57 100644 --- a/plutus-tx-plugin/test/Lift/bytestring.uplc.golden +++ b/plutus-tx-plugin/test/Lift/bytestring.uplc.golden @@ -6,8 +6,8 @@ (force (delay (lam - Lift_Spec_WrappedBS_i0 - (lam match_Lift_Spec_WrappedBS_i0 Lift_Spec_WrappedBS_i2) + `Lift.Spec.WrappedBS_i0` + (lam `match_Lift.Spec.WrappedBS_i0` `Lift.Spec.WrappedBS_i2`) ) ) ) @@ -17,7 +17,8 @@ x_i0 (delay (lam - case_Lift_Spec_WrappedBS_i0 (case x_i2 case_Lift_Spec_WrappedBS_i1) + `case_Lift.Spec.WrappedBS_i0` + (case x_i2 `case_Lift.Spec.WrappedBS_i1`) ) ) ) diff --git a/plutus-tx-plugin/test/Lift/list.uplc.golden b/plutus-tx-plugin/test/Lift/list.uplc.golden index fd28b5c1993..2d2b7dcb6ba 100644 --- a/plutus-tx-plugin/test/Lift/list.uplc.golden +++ b/plutus-tx-plugin/test/Lift/list.uplc.golden @@ -6,14 +6,14 @@ (force (delay (lam - GHC_Types_Nil_i0 + `GHC.Types.Nil_i0` (lam - GHC_Types_Cons_i0 + `GHC.Types.Cons_i0` (lam - match_GHC_Types_Nil_i0 + `match_GHC.Types.Nil_i0` [ - [ (force GHC_Types_Cons_i2) (con integer 1) ] - (force GHC_Types_Nil_i3) + [ (force `GHC.Types.Cons_i2`) (con integer 1) ] + (force `GHC.Types.Nil_i3`) ] ) ) @@ -29,10 +29,10 @@ x_i0 (delay (lam - case_GHC_Types_Nil_i0 + `case_GHC.Types.Nil_i0` (lam - case_GHC_Types_Cons_i0 - (case x_i3 case_GHC_Types_Nil_i2 case_GHC_Types_Cons_i1) + `case_GHC.Types.Cons_i0` + (case x_i3 `case_GHC.Types.Nil_i2` `case_GHC.Types.Cons_i1`) ) ) ) diff --git a/plutus-tx-plugin/test/Lift/mono.uplc.golden b/plutus-tx-plugin/test/Lift/mono.uplc.golden index 65db0d2f6bd..3e5354daa25 100644 --- a/plutus-tx-plugin/test/Lift/mono.uplc.golden +++ b/plutus-tx-plugin/test/Lift/mono.uplc.golden @@ -8,14 +8,14 @@ (force (delay (lam - Plugin_Data_Spec_Mono1_i0 + `Plugin.Data.Spec.Mono1_i0` (lam - Plugin_Data_Spec_Mono2_i0 + `Plugin.Data.Spec.Mono2_i0` (lam - Plugin_Data_Spec_Mono3_i0 + `Plugin.Data.Spec.Mono3_i0` (lam - match_Plugin_Data_Spec_MyMonoData_i0 - Plugin_Data_Spec_Mono2_i3 + `match_Plugin.Data.Spec.MyMonoData_i0` + `Plugin.Data.Spec.Mono2_i3` ) ) ) @@ -32,16 +32,16 @@ x_i0 (delay (lam - case_Plugin_Data_Spec_Mono1_i0 + `case_Plugin.Data.Spec.Mono1_i0` (lam - case_Plugin_Data_Spec_Mono2_i0 + `case_Plugin.Data.Spec.Mono2_i0` (lam - case_Plugin_Data_Spec_Mono3_i0 + `case_Plugin.Data.Spec.Mono3_i0` (case x_i4 - case_Plugin_Data_Spec_Mono1_i3 - case_Plugin_Data_Spec_Mono2_i2 - case_Plugin_Data_Spec_Mono3_i1 + `case_Plugin.Data.Spec.Mono1_i3` + `case_Plugin.Data.Spec.Mono2_i2` + `case_Plugin.Data.Spec.Mono3_i1` ) ) ) diff --git a/plutus-tx-plugin/test/Lift/nested.uplc.golden b/plutus-tx-plugin/test/Lift/nested.uplc.golden index e62c6b3cd4a..6aae36f988b 100644 --- a/plutus-tx-plugin/test/Lift/nested.uplc.golden +++ b/plutus-tx-plugin/test/Lift/nested.uplc.golden @@ -5,30 +5,30 @@ (force (delay (lam - GHC_Tuple_Tuple2_i0 + `GHC.Tuple.Tuple2_i0` (lam - match_GHC_Tuple_Tuple2_i0 + `match_GHC.Tuple.Tuple2_i0` [ [ [ (force (delay (lam - GHC_Maybe_Just_i0 + `GHC.Maybe.Just_i0` (lam - GHC_Maybe_Nothing_i0 + `GHC.Maybe.Nothing_i0` (lam - match_GHC_Maybe_Maybe_i0 + `match_GHC.Maybe.Maybe_i0` [ [ [ (force (delay (lam - Lift_Spec_NestedRecord_i0 + `Lift.Spec.NestedRecord_i0` (lam - match_Lift_Spec_NestedRecord_i0 - Lift_Spec_NestedRecord_i2 + `match_Lift.Spec.NestedRecord_i0` + `Lift.Spec.NestedRecord_i2` ) ) ) @@ -39,19 +39,19 @@ x_i0 (delay (lam - case_Lift_Spec_NestedRecord_i0 + `case_Lift.Spec.NestedRecord_i0` (case - x_i2 case_Lift_Spec_NestedRecord_i1 + x_i2 `case_Lift.Spec.NestedRecord_i1` ) ) ) ) ] [ - (force GHC_Maybe_Just_i3) + (force `GHC.Maybe.Just_i3`) [ [ - (force (force GHC_Tuple_Tuple2_i5)) + (force (force `GHC.Tuple.Tuple2_i5`)) (con integer 1) ] (con integer 2) @@ -72,13 +72,13 @@ x_i0 (delay (lam - case_GHC_Maybe_Just_i0 + `case_GHC.Maybe.Just_i0` (lam - case_GHC_Maybe_Nothing_i0 + `case_GHC.Maybe.Nothing_i0` (case x_i3 - case_GHC_Maybe_Just_i2 - case_GHC_Maybe_Nothing_i1 + `case_GHC.Maybe.Just_i2` + `case_GHC.Maybe.Nothing_i1` ) ) ) @@ -97,7 +97,9 @@ (lam x_i0 (delay - (lam case_GHC_Tuple_Tuple2_i0 (case x_i2 case_GHC_Tuple_Tuple2_i1)) + (lam + `case_GHC.Tuple.Tuple2_i0` (case x_i2 `case_GHC.Tuple.Tuple2_i1`) + ) ) ) ) diff --git a/plutus-tx-plugin/test/Lift/poly.uplc.golden b/plutus-tx-plugin/test/Lift/poly.uplc.golden index 561e746ec87..37c366ce476 100644 --- a/plutus-tx-plugin/test/Lift/poly.uplc.golden +++ b/plutus-tx-plugin/test/Lift/poly.uplc.golden @@ -10,12 +10,12 @@ (force (delay (lam - Plugin_Data_Spec_Poly1_i0 + `Plugin.Data.Spec.Poly1_i0` (lam - Plugin_Data_Spec_Poly2_i0 + `Plugin.Data.Spec.Poly2_i0` (lam - match_Plugin_Data_Spec_MyPolyData_i0 - Plugin_Data_Spec_Poly1_i3 + `match_Plugin.Data.Spec.MyPolyData_i0` + `Plugin.Data.Spec.Poly1_i3` ) ) ) @@ -35,13 +35,13 @@ x_i0 (delay (lam - case_Plugin_Data_Spec_Poly1_i0 + `case_Plugin.Data.Spec.Poly1_i0` (lam - case_Plugin_Data_Spec_Poly2_i0 + `case_Plugin.Data.Spec.Poly2_i0` (case x_i3 - case_Plugin_Data_Spec_Poly1_i2 - case_Plugin_Data_Spec_Poly2_i1 + `case_Plugin.Data.Spec.Poly1_i2` + `case_Plugin.Data.Spec.Poly2_i1` ) ) ) diff --git a/plutus-tx-plugin/test/Lift/record.uplc.golden b/plutus-tx-plugin/test/Lift/record.uplc.golden index 268ba38bb8c..6afcea88e27 100644 --- a/plutus-tx-plugin/test/Lift/record.uplc.golden +++ b/plutus-tx-plugin/test/Lift/record.uplc.golden @@ -7,10 +7,10 @@ (force (delay (lam - Plugin_Data_Spec_MyMonoRecord_i0 + `Plugin.Data.Spec.MyMonoRecord_i0` (lam - match_Plugin_Data_Spec_MyMonoRecord_i0 - Plugin_Data_Spec_MyMonoRecord_i2 + `match_Plugin.Data.Spec.MyMonoRecord_i0` + `Plugin.Data.Spec.MyMonoRecord_i2` ) ) ) @@ -21,8 +21,8 @@ x_i0 (delay (lam - case_Plugin_Data_Spec_MyMonoRecord_i0 - (case x_i2 case_Plugin_Data_Spec_MyMonoRecord_i1) + `case_Plugin.Data.Spec.MyMonoRecord_i0` + (case x_i2 `case_Plugin.Data.Spec.MyMonoRecord_i1`) ) ) ) diff --git a/plutus-tx-plugin/test/Lift/syn.uplc.golden b/plutus-tx-plugin/test/Lift/syn.uplc.golden index 67f640acaab..36a3b71fcb8 100644 --- a/plutus-tx-plugin/test/Lift/syn.uplc.golden +++ b/plutus-tx-plugin/test/Lift/syn.uplc.golden @@ -5,19 +5,19 @@ (force (delay (lam - Lift_Spec_Z_i0 + `Lift.Spec.Z_i0` (lam - match_Lift_Spec_Z_i0 + `match_Lift.Spec.Z_i0` [ [ [ (force (delay (lam - Lift_Spec_SynExample_i0 + `Lift.Spec.SynExample_i0` (lam - match_Lift_Spec_SynExample_i0 - Lift_Spec_SynExample_i2 + `match_Lift.Spec.SynExample_i0` + `Lift.Spec.SynExample_i2` ) ) ) @@ -28,13 +28,13 @@ x_i0 (delay (lam - case_Lift_Spec_SynExample_i0 - (case x_i2 case_Lift_Spec_SynExample_i1) + `case_Lift.Spec.SynExample_i0` + (case x_i2 `case_Lift.Spec.SynExample_i1`) ) ) ) ] - [ Lift_Spec_Z_i2 (con integer 1) ] + [ `Lift.Spec.Z_i2` (con integer 1) ] ] ) ) @@ -42,6 +42,8 @@ ) (lam arg_0_i0 (constr 0 arg_0_i1)) ] - (lam x_i0 (delay (lam case_Lift_Spec_Z_i0 (case x_i2 case_Lift_Spec_Z_i1)))) + (lam + x_i0 (delay (lam `case_Lift.Spec.Z_i0` (case x_i2 `case_Lift.Spec.Z_i1`))) + ) ] ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Lift/tuple.uplc.golden b/plutus-tx-plugin/test/Lift/tuple.uplc.golden index de795a3cce0..b7f3f97ff93 100644 --- a/plutus-tx-plugin/test/Lift/tuple.uplc.golden +++ b/plutus-tx-plugin/test/Lift/tuple.uplc.golden @@ -9,8 +9,8 @@ (force (delay (lam - GHC_Tuple_Tuple2_i0 - (lam match_GHC_Tuple_Tuple2_i0 GHC_Tuple_Tuple2_i2) + `GHC.Tuple.Tuple2_i0` + (lam `match_GHC.Tuple.Tuple2_i0` `GHC.Tuple.Tuple2_i2`) ) ) ) @@ -26,8 +26,8 @@ x_i0 (delay (lam - case_GHC_Tuple_Tuple2_i0 - (case x_i2 case_GHC_Tuple_Tuple2_i1) + `case_GHC.Tuple.Tuple2_i0` + (case x_i2 `case_GHC.Tuple.Tuple2_i1`) ) ) ) diff --git a/plutus-tx-plugin/test/Optimization/maybeFun.uplc.golden b/plutus-tx-plugin/test/Optimization/maybeFun.uplc.golden index 2f1ed42e155..ea1a928b96e 100644 --- a/plutus-tx-plugin/test/Optimization/maybeFun.uplc.golden +++ b/plutus-tx-plugin/test/Optimization/maybeFun.uplc.golden @@ -8,14 +8,14 @@ (case ds_i2 (lam - x_i0 + x'_i0 (delay (force (case ds_i2 (lam - y_i0 - (delay (constr 0 [ [ (builtin addInteger) x_i2 ] y_i1 ])) + y'_i0 + (delay (constr 0 [ [ (builtin addInteger) x'_i2 ] y'_i1 ])) ) (delay (constr 1)) ) diff --git a/plutus-tx-plugin/test/Plugin/Basic/monadicDo.pir.golden b/plutus-tx-plugin/test/Plugin/Basic/monadicDo.pir.golden index 2e3a7dff485..d0185906dbc 100644 --- a/plutus-tx-plugin/test/Plugin/Basic/monadicDo.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Basic/monadicDo.pir.golden @@ -12,13 +12,13 @@ ) (termbind (strict) - (vardecl fApplicativeMaybe_cpure (all a (type) (fun a [ Maybe a ]))) + (vardecl `$fApplicativeMaybe_$cpure` (all a (type) (fun a [ Maybe a ]))) (abs a (type) (lam ds a [ { Just a } ds ])) ) (termbind (strict) (vardecl - fMonadMaybe_c + `$fMonadMaybe_$c>>=` (all a (type) @@ -69,18 +69,18 @@ ds [ Maybe (con integer) ] [ - [ { { fMonadMaybe_c (con integer) } (con integer) } ds ] + [ { { `$fMonadMaybe_$c>>=` (con integer) } (con integer) } ds ] (lam - x + x' (con integer) [ - [ { { fMonadMaybe_c (con integer) } (con integer) } ds ] + [ { { `$fMonadMaybe_$c>>=` (con integer) } (con integer) } ds ] (lam - y + y' (con integer) [ - { fApplicativeMaybe_cpure (con integer) } - [ [ addInteger x ] y ] + { `$fApplicativeMaybe_$cpure` (con integer) } + [ [ addInteger x' ] y' ] ] ) ] diff --git a/plutus-tx-plugin/test/Plugin/Basic/patternMatchDo.pir.golden b/plutus-tx-plugin/test/Plugin/Basic/patternMatchDo.pir.golden index 9e06951a18a..91c9fb1cac9 100644 --- a/plutus-tx-plugin/test/Plugin/Basic/patternMatchDo.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Basic/patternMatchDo.pir.golden @@ -12,13 +12,13 @@ ) (termbind (strict) - (vardecl fApplicativeMaybe_cpure (all a (type) (fun a [ Maybe a ]))) + (vardecl `$fApplicativeMaybe_$cpure` (all a (type) (fun a [ Maybe a ]))) (abs a (type) (lam ds a [ { Just a } ds ])) ) (termbind (strict) (vardecl - fMonadMaybe_c + `$fMonadMaybe_$c>>=` (all a (type) @@ -79,7 +79,9 @@ [ [ { - { fMonadMaybe_c [ [ Tuple2 (con integer) ] (con integer) ] } + { + `$fMonadMaybe_$c>>=` [ [ Tuple2 (con integer) ] (con integer) ] + } (con integer) } ds @@ -99,13 +101,16 @@ x (con integer) [ - [ { { fMonadMaybe_c (con integer) } (con integer) } ds ] + [ + { { `$fMonadMaybe_$c>>=` (con integer) } (con integer) } + ds + ] (lam - y + y' (con integer) [ - { fApplicativeMaybe_cpure (con integer) } - [ [ addInteger [ [ addInteger x ] x ] ] y ] + { `$fApplicativeMaybe_$cpure` (con integer) } + [ [ addInteger [ [ addInteger x ] x ] ] y' ] ] ) ] diff --git a/plutus-tx-plugin/test/Plugin/Coverage/coverageCode.pir.golden b/plutus-tx-plugin/test/Plugin/Coverage/coverageCode.pir.golden index 77fcf8f2c82..4a6767ecace 100644 --- a/plutus-tx-plugin/test/Plugin/Coverage/coverageCode.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Coverage/coverageCode.pir.golden @@ -67,12 +67,14 @@ ) (termbind (nonstrict) - (vardecl fEqInteger [ (lam a (type) (fun a (fun a Bool))) (con integer) ]) + (vardecl + `$fEqInteger` [ (lam a (type) (fun a (fun a Bool))) (con integer) ] + ) equalsInteger ) (termbind (strict) - (vardecl bad_name (fun Bool (fun Bool Bool))) + (vardecl `&&` (fun Bool (fun Bool Bool))) (lam ds Bool @@ -94,7 +96,7 @@ (termbind (strict) (vardecl - bad_name + `==` (all a (type) @@ -168,7 +170,7 @@ (type) [ [ - bad_name + `&&` [ [ [ @@ -197,7 +199,7 @@ (type) [ [ - [ { bad_name (con integer) } fEqInteger ] + [ { `==` (con integer) } `$fEqInteger` ] { [ [ diff --git a/plutus-tx-plugin/test/Plugin/Data/families/basicData.pir.golden b/plutus-tx-plugin/test/Plugin/Data/families/basicData.pir.golden index 192a61e2dad..eb1fd7f9aa8 100644 --- a/plutus-tx-plugin/test/Plugin/Data/families/basicData.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Data/families/basicData.pir.golden @@ -4,15 +4,15 @@ (nonrec) (datatypebind (datatype - (tyvardecl RBasicDataBool (type)) + (tyvardecl `R:BasicDataBool` (type)) RConsBasicDataBool_match - (vardecl Inst (fun (con integer) RBasicDataBool)) + (vardecl Inst (fun (con integer) `R:BasicDataBool`)) ) ) (lam ds - RBasicDataBool + `R:BasicDataBool` [ { [ RConsBasicDataBool_match ds ] (con integer) } (lam i (con integer) i) diff --git a/plutus-tx-plugin/test/Plugin/Data/monomorphic/strictDataMatch.pir.golden b/plutus-tx-plugin/test/Plugin/Data/monomorphic/strictDataMatch.pir.golden index 02dad8eb6cd..0d272c67c49 100644 --- a/plutus-tx-plugin/test/Plugin/Data/monomorphic/strictDataMatch.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Data/monomorphic/strictDataMatch.pir.golden @@ -12,7 +12,7 @@ ) (termbind (strict) - (vardecl WStrictTy (all a (type) (fun a (fun a [ StrictTy a ])))) + (vardecl `$WStrictTy` (all a (type) (fun a (fun a [ StrictTy a ])))) (abs a (type) @@ -32,6 +32,6 @@ ) ) ) - [ [ { WStrictTy (con integer) } (con integer 1) ] (con integer 2) ] + [ [ { `$WStrictTy` (con integer) } (con integer 1) ] (con integer 2) ] ) ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Data/monomorphic/unusedWrapper.pir.golden b/plutus-tx-plugin/test/Plugin/Data/monomorphic/unusedWrapper.pir.golden index 381fabe5aa8..28d169a7ac0 100644 --- a/plutus-tx-plugin/test/Plugin/Data/monomorphic/unusedWrapper.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Data/monomorphic/unusedWrapper.pir.golden @@ -20,7 +20,7 @@ ) (termbind (strict) - (vardecl WMkT (fun [ [ Tuple2 (con integer) ] (con integer) ] T)) + (vardecl `$WMkT` (fun [ [ Tuple2 (con integer) ] (con integer) ] T)) (lam dt [ [ Tuple2 (con integer) ] (con integer) ] @@ -36,7 +36,7 @@ (termbind (strict) (vardecl mkT (fun [ [ Tuple2 (con integer) ] (con integer) ] T)) - (lam ds [ [ Tuple2 (con integer) ] (con integer) ] [ WMkT ds ]) + (lam ds [ [ Tuple2 (con integer) ] (con integer) ] [ `$WMkT` ds ]) ) [ mkT diff --git a/plutus-tx-plugin/test/Plugin/Primitives/deconstructorData2.pir.golden b/plutus-tx-plugin/test/Plugin/Primitives/deconstructorData2.pir.golden index 361d93b198e..0bb9ddeb48c 100644 --- a/plutus-tx-plugin/test/Plugin/Primitives/deconstructorData2.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Primitives/deconstructorData2.pir.golden @@ -13,7 +13,7 @@ (termbind (strict) (vardecl - fFunctorTuple2_cfmap + `$fFunctorTuple2_$cfmap` (all c (type) @@ -56,7 +56,7 @@ (termbind (nonstrict) (vardecl - fFunctorTuple2 + `$fFunctorTuple2` (all c (type) @@ -72,7 +72,7 @@ ] ) ) - fFunctorTuple2_cfmap + `$fFunctorTuple2_$cfmap` ) (let (rec) @@ -90,7 +90,7 @@ (termbind (strict) (vardecl - fFunctorNil_cfmap + `$fFunctorNil_$cfmap` (all a (type) @@ -126,7 +126,7 @@ (type) [ [ { Cons b } [ f x ] ] - [ [ { { fFunctorNil_cfmap a } b } f ] xs ] + [ [ { { `$fFunctorNil_$cfmap` a } b } f ] xs ] ] ) ) @@ -144,7 +144,7 @@ (termbind (nonstrict) (vardecl - fFunctorNil + `$fFunctorNil` [ (lam f @@ -158,12 +158,12 @@ List ] ) - fFunctorNil_cfmap + `$fFunctorNil_$cfmap` ) (termbind (strict) (vardecl - bad_name + `.` (all b (type) @@ -265,7 +265,7 @@ (termbind (strict) (vardecl - sfFromBuiltinBuiltinListNil_cfromBuiltin_go + `$s$fFromBuiltinBuiltinListNil_$cfromBuiltin_go` (fun [ (con list) (con data) ] [ List (con data) ]) ) (lam @@ -289,7 +289,7 @@ [ [ { Cons (con data) } [ { head (con data) } l ] ] [ - sfFromBuiltinBuiltinListNil_cfromBuiltin_go + `$s$fFromBuiltinBuiltinListNil_$cfromBuiltin_go` [ { tail (con data) } l ] ] ] @@ -359,7 +359,7 @@ ] ] [ - sfFromBuiltinBuiltinListNil_cfromBuiltin_go + `$s$fFromBuiltinBuiltinListNil_$cfromBuiltin_go` [ { { snd (con integer) } [ (con list) (con data) ] } p ] @@ -388,7 +388,7 @@ { { { - bad_name + `.` (fun [ List (con data) ] [ List (con integer) ]) } (fun @@ -404,7 +404,7 @@ { [ { fmap [ Tuple2 (con integer) ] } - { fFunctorTuple2 (con integer) } + { `$fFunctorTuple2` (con integer) } ] [ List (con data) ] } @@ -412,7 +412,7 @@ } ] { - { [ { fmap List } fFunctorNil ] (con data) } + { [ { fmap List } `$fFunctorNil` ] (con data) } (con integer) } ] diff --git a/plutus-tx-plugin/test/Plugin/Typeclasses/compareTest.pir.golden b/plutus-tx-plugin/test/Plugin/Typeclasses/compareTest.pir.golden index c98e1179797..cdb76cc1726 100644 --- a/plutus-tx-plugin/test/Plugin/Typeclasses/compareTest.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Typeclasses/compareTest.pir.golden @@ -38,7 +38,8 @@ (termbind (strict) (vardecl - fOrdInteger_ccompare (fun (con integer) (fun (con integer) Ordering)) + `$fOrdInteger_$ccompare` + (fun (con integer) (fun (con integer) Ordering)) ) (lam eta @@ -102,7 +103,8 @@ (termbind (strict) (vardecl - fOrdInteger_cmax (fun (con integer) (fun (con integer) (con integer))) + `$fOrdInteger_$cmax` + (fun (con integer) (fun (con integer) (con integer))) ) (lam x @@ -140,7 +142,8 @@ (termbind (strict) (vardecl - fOrdInteger_cmin (fun (con integer) (fun (con integer) (con integer))) + `$fOrdInteger_$cmin` + (fun (con integer) (fun (con integer) (con integer))) ) (lam x @@ -288,7 +291,7 @@ ) (termbind (nonstrict) - (vardecl fOrdInteger [ Ord (con integer) ]) + (vardecl `$fOrdInteger` [ Ord (con integer) ]) [ [ [ @@ -297,7 +300,7 @@ [ [ [ { CConsOrd (con integer) } equalsInteger ] - fOrdInteger_ccompare + `$fOrdInteger_$ccompare` ] lessThanInteger ] @@ -307,9 +310,9 @@ ] greaterThanEqualsInteger ] - fOrdInteger_cmax + `$fOrdInteger_$cmax` ] - fOrdInteger_cmin + `$fOrdInteger_$cmin` ] ) (termbind @@ -361,7 +364,7 @@ a (type) (lam - dOrd + `$dOrd` [ Ord a ] (lam a @@ -374,7 +377,7 @@ [ [ { - [ Ordering_match [ [ [ { compare a } dOrd ] a ] b ] ] + [ Ordering_match [ [ [ { compare a } `$dOrd` ] a ] b ] ] (all dead (type) Ordering) } (abs dead (type) EQ) @@ -391,7 +394,7 @@ ) ) [ - [ [ { opCompare (con integer) } fOrdInteger ] (con integer 1) ] + [ [ { opCompare (con integer) } `$fOrdInteger` ] (con integer 1) ] (con integer 2) ] ) diff --git a/plutus-tx-plugin/test/Plugin/Typeclasses/concatTest.pir.golden b/plutus-tx-plugin/test/Plugin/Typeclasses/concatTest.pir.golden index 2c2e764aefb..920d2e7f277 100644 --- a/plutus-tx-plugin/test/Plugin/Typeclasses/concatTest.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Typeclasses/concatTest.pir.golden @@ -16,7 +16,7 @@ (termbind (strict) (vardecl - fFoldableNil_cfoldr + `$fFoldableNil_$cfoldr` (all a (type) @@ -73,7 +73,7 @@ (termbind (nonstrict) (vardecl - fFoldableNil + `$fFoldableNil` [ (lam t @@ -87,7 +87,7 @@ List ] ) - fFoldableNil_cfoldr + `$fFoldableNil_$cfoldr` ) (termbind (strict) @@ -152,7 +152,7 @@ a (type) (lam - dFoldable + `$dFoldable` [ (lam t @@ -184,7 +184,7 @@ [ [ [ - { { dFoldable [ List a ] } b } + { { `$dFoldable` [ List a ] } b } (lam x [ List a ] @@ -192,7 +192,10 @@ y b [ - [ [ { { fFoldableNil_cfoldr a } b } c ] y ] + [ + [ { { `$fFoldableNil_$cfoldr` a } b } c ] + y + ] x ] ) @@ -212,7 +215,7 @@ ) ) [ - [ { { concat List } (con integer) } fFoldableNil ] + [ { { concat List } (con integer) } `$fFoldableNil` ] [ { build [ List (con integer) ] } (abs diff --git a/plutus-tx-plugin/test/Plugin/Typeclasses/defaultMethods.pir.golden b/plutus-tx-plugin/test/Plugin/Typeclasses/defaultMethods.pir.golden index 79a1fde1219..e9311ee5f50 100644 --- a/plutus-tx-plugin/test/Plugin/Typeclasses/defaultMethods.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Typeclasses/defaultMethods.pir.golden @@ -43,15 +43,17 @@ a (type) (lam - dDefaultMethods + `$dDefaultMethods` [ DefaultMethods a ] - (lam a a [ [ { method a } dDefaultMethods ] a ]) + (lam a a [ [ { method a } `$dDefaultMethods` ] a ]) ) ) ) (termbind (strict) - (vardecl fDefaultMethodsInteger_cmethod (fun (con integer) (con integer))) + (vardecl + `$fDefaultMethodsInteger_$cmethod` (fun (con integer) (con integer)) + ) (lam a (con integer) a) ) (termbind @@ -61,17 +63,24 @@ ) (termbind (strict) - (vardecl fDefaultMethodsInteger_cmethod (fun (con integer) (con integer))) + (vardecl + `$fDefaultMethodsInteger_$cmethod` (fun (con integer) (con integer)) + ) (lam a (con integer) [ [ addInteger a ] (con integer 1) ]) ) (termbind (nonstrict) - (vardecl fDefaultMethodsInteger [ DefaultMethods (con integer) ]) + (vardecl `$fDefaultMethodsInteger` [ DefaultMethods (con integer) ]) [ - [ { CConsDefaultMethods (con integer) } fDefaultMethodsInteger_cmethod ] - fDefaultMethodsInteger_cmethod + [ + { CConsDefaultMethods (con integer) } + `$fDefaultMethodsInteger_$cmethod` + ] + `$fDefaultMethodsInteger_$cmethod` ] ) - (lam ds (con integer) [ [ { f (con integer) } fDefaultMethodsInteger ] ds ]) + (lam + ds (con integer) [ [ { f (con integer) } `$fDefaultMethodsInteger` ] ds ] + ) ) ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Typeclasses/fmapDefaultTest.pir.golden b/plutus-tx-plugin/test/Plugin/Typeclasses/fmapDefaultTest.pir.golden index 6b0432a96a3..e27b0ff74e9 100644 --- a/plutus-tx-plugin/test/Plugin/Typeclasses/fmapDefaultTest.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Typeclasses/fmapDefaultTest.pir.golden @@ -16,7 +16,7 @@ (termbind (nonstrict) (vardecl - fAdditiveSemigroupInteger + `$fAdditiveSemigroupInteger` [ (lam a (type) (fun a (fun a a))) (con integer) ] ) addInteger @@ -24,7 +24,7 @@ (termbind (strict) (vardecl - bad_name + `+` (all a (type) @@ -36,7 +36,7 @@ (termbind (nonstrict) (vardecl v (fun (con integer) (fun (con integer) (con integer)))) - [ { bad_name (con integer) } fAdditiveSemigroupInteger ] + [ { `+` (con integer) } `$fAdditiveSemigroupInteger` ] ) (let (rec) @@ -54,7 +54,7 @@ (termbind (strict) (vardecl - fFoldableNil_cfoldr + `$fFoldableNil_$cfoldr` (all a (type) @@ -113,7 +113,7 @@ (termbind (strict) (vardecl - fFunctorNil_cfmap + `$fFunctorNil_$cfmap` (all a (type) @@ -149,7 +149,7 @@ (type) [ [ { Cons b } [ f x ] ] - [ [ { { fFunctorNil_cfmap a } b } f ] xs ] + [ [ { { `$fFunctorNil_$cfmap` a } b } f ] xs ] ] ) ) @@ -204,7 +204,7 @@ (termbind (strict) (vardecl - p1Applicative + `$p1Applicative` (all f (fun (type) (type)) @@ -286,7 +286,7 @@ (termbind (strict) (vardecl - bad_name + `<*>` (all f (fun (type) (type)) @@ -415,7 +415,7 @@ (termbind (strict) (vardecl - fTraversableNil_ctraverse + `$fTraversableNil_$ctraverse` (all f (fun (type) (type)) @@ -445,7 +445,7 @@ b (type) (lam - dApplicative + `$dApplicative` [ Applicative f ] (lam ds @@ -464,7 +464,10 @@ dead (type) [ - { [ { pure f } dApplicative ] [ List b ] } + { + [ { pure f } `$dApplicative` ] + [ List b ] + } { Nil b } ] ) @@ -482,7 +485,7 @@ [ { { - [ { bad_name f } dApplicative ] + [ { `<*>` f } `$dApplicative` ] [ List b ] } [ List b ] @@ -492,8 +495,8 @@ { { [ - { p1Applicative f } - dApplicative + { `$p1Applicative` f } + `$dApplicative` ] b } @@ -518,13 +521,14 @@ { { { - fTraversableNil_ctraverse f + `$fTraversableNil_$ctraverse` + f } a } b } - dApplicative + `$dApplicative` ] ds ] @@ -616,13 +620,13 @@ ) (termbind (nonstrict) - (vardecl fTraversableNil [ Traversable List ]) + (vardecl `$fTraversableNil` [ Traversable List ]) [ [ - [ { CConsTraversable List } fFunctorNil_cfmap ] - fFoldableNil_cfoldr + [ { CConsTraversable List } `$fFunctorNil_$cfmap` ] + `$fFoldableNil_$cfoldr` ] - fTraversableNil_ctraverse + `$fTraversableNil_$ctraverse` ] ) (termbind @@ -659,7 +663,7 @@ (termbind (strict) (vardecl - fApplicativeIdentity_c + `$fApplicativeIdentity_$c<*>` (all a (type) @@ -690,7 +694,7 @@ (termbind (strict) (vardecl - fApplicativeIdentity_cpure + `$fApplicativeIdentity_$cpure` (all a (type) (fun a [ (lam a (type) a) a ])) ) (abs a (type) (lam ds a ds)) @@ -698,7 +702,7 @@ (termbind (strict) (vardecl - fFunctorIdentity_cfmap + `$fFunctorIdentity_$cfmap` (all a (type) @@ -725,17 +729,17 @@ (termbind (nonstrict) (vardecl - fApplicativeIdentity [ Applicative (lam a (type) a) ] + `$fApplicativeIdentity` [ Applicative (lam a (type) a) ] ) [ [ [ { CConsApplicative (lam a (type) a) } - fFunctorIdentity_cfmap + `$fFunctorIdentity_$cfmap` ] - fApplicativeIdentity_cpure + `$fApplicativeIdentity_$cpure` ] - fApplicativeIdentity_c + `$fApplicativeIdentity_$c<*>` ] ) (termbind @@ -892,20 +896,20 @@ b (type) (lam - dTraversable + `$dTraversable` [ Traversable t ] [ { { { - [ { traverse t } dTraversable ] + [ { traverse t } `$dTraversable` ] (lam a (type) a) } a } b } - fApplicativeIdentity + `$fApplicativeIdentity` ] ) ) @@ -916,7 +920,7 @@ [ [ { { { fmapDefault List } (con integer) } (con integer) } - fTraversableNil + `$fTraversableNil` ] (lam v (con integer) [ [ v v ] v ]) ] diff --git a/plutus-tx-plugin/test/Plugin/Typeclasses/multiFunction.pir.golden b/plutus-tx-plugin/test/Plugin/Typeclasses/multiFunction.pir.golden index 252c5a914d3..863b8afd783 100644 --- a/plutus-tx-plugin/test/Plugin/Typeclasses/multiFunction.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Typeclasses/multiFunction.pir.golden @@ -12,7 +12,7 @@ ) (termbind (strict) - (vardecl bad_name (fun Bool (fun Bool Bool))) + (vardecl `&&` (fun Bool (fun Bool Bool))) (lam l Bool @@ -120,15 +120,15 @@ p (type) (lam - dPersonLike + `$dPersonLike` [ PersonLike p ] (lam p p [ - [ bad_name [ [ [ { likesAnimal p } dPersonLike ] p ] Cat ] ] + [ `&&` [ [ [ { likesAnimal p } `$dPersonLike` ] p ] Cat ] ] [ - [ lessThanInteger [ [ { age p } dPersonLike ] p ] ] + [ lessThanInteger [ [ { age p } `$dPersonLike` ] p ] ] (con integer 30) ] ] @@ -146,7 +146,7 @@ ) (termbind (strict) - (vardecl cage (fun Person (con integer))) + (vardecl `$cage` (fun Person (con integer))) (lam ds Person @@ -158,7 +158,7 @@ ) (termbind (strict) - (vardecl clikesAnimal (fun Person (fun Animal Bool))) + (vardecl `$clikesAnimal` (fun Person (fun Animal Bool))) (lam ds Person @@ -193,9 +193,9 @@ ) (termbind (nonstrict) - (vardecl fPersonLikePerson [ PersonLike Person ]) - [ [ { CConsPersonLike Person } cage ] clikesAnimal ] + (vardecl `$fPersonLikePerson` [ PersonLike Person ]) + [ [ { CConsPersonLike Person } `$cage` ] `$clikesAnimal` ] ) - (lam ds Person [ [ { predicate Person } fPersonLikePerson ] ds ]) + (lam ds Person [ [ { predicate Person } `$fPersonLikePerson` ] ds ]) ) ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Typeclasses/partialApplication.pir.golden b/plutus-tx-plugin/test/Plugin/Typeclasses/partialApplication.pir.golden index 357ed227552..5caeea9cb25 100644 --- a/plutus-tx-plugin/test/Plugin/Typeclasses/partialApplication.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Typeclasses/partialApplication.pir.golden @@ -38,7 +38,8 @@ (termbind (strict) (vardecl - fOrdInteger_ccompare (fun (con integer) (fun (con integer) Ordering)) + `$fOrdInteger_$ccompare` + (fun (con integer) (fun (con integer) Ordering)) ) (lam eta @@ -99,6 +100,6 @@ ) ) ) - fOrdInteger_ccompare + `$fOrdInteger_$ccompare` ) ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Typeclasses/sequenceTest.pir.golden b/plutus-tx-plugin/test/Plugin/Typeclasses/sequenceTest.pir.golden index 85a785bf3dd..43b09c666f9 100644 --- a/plutus-tx-plugin/test/Plugin/Typeclasses/sequenceTest.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Typeclasses/sequenceTest.pir.golden @@ -13,7 +13,7 @@ (termbind (strict) (vardecl - fApplicativeMaybe_c + `$fApplicativeMaybe_$c<*>` (all a (type) @@ -76,13 +76,13 @@ ) (termbind (strict) - (vardecl fApplicativeMaybe_cpure (all a (type) (fun a [ Maybe a ]))) + (vardecl `$fApplicativeMaybe_$cpure` (all a (type) (fun a [ Maybe a ]))) (abs a (type) (lam ds a [ { Just a } ds ])) ) (termbind (strict) (vardecl - fFunctorMaybe_cfmap + `$fFunctorMaybe_$cfmap` (all a (type) (all b (type) (fun (fun a b) (fun [ Maybe a ] [ Maybe b ]))) ) @@ -149,13 +149,13 @@ ) (termbind (nonstrict) - (vardecl fApplicativeMaybe [ Applicative Maybe ]) + (vardecl `$fApplicativeMaybe` [ Applicative Maybe ]) [ [ - [ { CConsApplicative Maybe } fFunctorMaybe_cfmap ] - fApplicativeMaybe_cpure + [ { CConsApplicative Maybe } `$fFunctorMaybe_$cfmap` ] + `$fApplicativeMaybe_$cpure` ] - fApplicativeMaybe_c + `$fApplicativeMaybe_$c<*>` ] ) (let @@ -174,7 +174,7 @@ (termbind (strict) (vardecl - fFoldableNil_cfoldr + `$fFoldableNil_$cfoldr` (all a (type) @@ -233,7 +233,7 @@ (termbind (strict) (vardecl - fFunctorNil_cfmap + `$fFunctorNil_$cfmap` (all a (type) @@ -269,7 +269,7 @@ (type) [ [ { Cons b } [ f x ] ] - [ [ { { fFunctorNil_cfmap a } b } f ] xs ] + [ [ { { `$fFunctorNil_$cfmap` a } b } f ] xs ] ] ) ) @@ -287,7 +287,7 @@ (termbind (strict) (vardecl - p1Applicative + `$p1Applicative` (all f (fun (type) (type)) @@ -369,7 +369,7 @@ (termbind (strict) (vardecl - bad_name + `<*>` (all f (fun (type) (type)) @@ -498,7 +498,7 @@ (termbind (strict) (vardecl - fTraversableNil_ctraverse + `$fTraversableNil_$ctraverse` (all f (fun (type) (type)) @@ -528,7 +528,7 @@ b (type) (lam - dApplicative + `$dApplicative` [ Applicative f ] (lam ds @@ -547,7 +547,10 @@ dead (type) [ - { [ { pure f } dApplicative ] [ List b ] } + { + [ { pure f } `$dApplicative` ] + [ List b ] + } { Nil b } ] ) @@ -565,7 +568,7 @@ [ { { - [ { bad_name f } dApplicative ] + [ { `<*>` f } `$dApplicative` ] [ List b ] } [ List b ] @@ -575,8 +578,8 @@ { { [ - { p1Applicative f } - dApplicative + { `$p1Applicative` f } + `$dApplicative` ] b } @@ -601,13 +604,14 @@ { { { - fTraversableNil_ctraverse f + `$fTraversableNil_$ctraverse` + f } a } b } - dApplicative + `$dApplicative` ] ds ] @@ -699,13 +703,13 @@ ) (termbind (nonstrict) - (vardecl fTraversableNil [ Traversable List ]) + (vardecl `$fTraversableNil` [ Traversable List ]) [ [ - [ { CConsTraversable List } fFunctorNil_cfmap ] - fFoldableNil_cfoldr + [ { CConsTraversable List } `$fFunctorNil_$cfmap` ] + `$fFoldableNil_$cfoldr` ] - fTraversableNil_ctraverse + `$fTraversableNil_$ctraverse` ] ) (termbind @@ -901,21 +905,21 @@ a (type) (lam - dTraversable + `$dTraversable` [ Traversable t ] (lam - dApplicative + `$dApplicative` [ Applicative f ] [ [ { { - { [ { traverse t } dTraversable ] f } + { [ { traverse t } `$dTraversable` ] f } [ f a ] } a } - dApplicative + `$dApplicative` ] { id [ f a ] } ] @@ -929,9 +933,9 @@ [ [ { { { sequence List } Maybe } (con integer) } - fTraversableNil + `$fTraversableNil` ] - fApplicativeMaybe + `$fApplicativeMaybe` ] [ { build [ Maybe (con integer) ] } diff --git a/plutus-tx-plugin/test/Plugin/Typeclasses/sizedBasic.pir.golden b/plutus-tx-plugin/test/Plugin/Typeclasses/sizedBasic.pir.golden index 9eab05d2ed9..582b8822956 100644 --- a/plutus-tx-plugin/test/Plugin/Typeclasses/sizedBasic.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Typeclasses/sizedBasic.pir.golden @@ -4,15 +4,15 @@ (nonrec) (termbind (strict) - (vardecl csize (fun (con integer) (con integer))) + (vardecl `$csize` (fun (con integer) (con integer))) (lam x (con integer) x) ) (termbind (nonstrict) (vardecl - fSizedInteger [ (lam a (type) (fun a (con integer))) (con integer) ] + `$fSizedInteger` [ (lam a (type) (fun a (con integer))) (con integer) ] ) - csize + `$csize` ) (termbind (strict) @@ -26,6 +26,6 @@ ) (abs a (type) (lam v [ (lam a (type) (fun a (con integer))) a ] v)) ) - (lam ds (con integer) [ [ { size (con integer) } fSizedInteger ] ds ]) + (lam ds (con integer) [ [ { size (con integer) } `$fSizedInteger` ] ds ]) ) ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Typeclasses/sizedPair.pir.golden b/plutus-tx-plugin/test/Plugin/Typeclasses/sizedPair.pir.golden index d5f93c5cebd..f5d102d6108 100644 --- a/plutus-tx-plugin/test/Plugin/Typeclasses/sizedPair.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Typeclasses/sizedPair.pir.golden @@ -18,7 +18,7 @@ (termbind (strict) (vardecl - csize + `$csize` (all a (type) @@ -42,10 +42,10 @@ b (type) (lam - dSized + `$dSized` [ (lam a (type) (fun a (con integer))) a ] (lam - dSized + `$dSized` [ (lam a (type) (fun a (con integer))) b ] (lam ds @@ -53,7 +53,9 @@ [ { [ { { Tuple2_match a } b } ds ] (con integer) } (lam - a a (lam b b [ [ addInteger [ dSized a ] ] [ dSized b ] ]) + a + a + (lam b b [ [ addInteger [ `$dSized` a ] ] [ `$dSized` b ] ]) ) ] ) @@ -65,7 +67,7 @@ (termbind (nonstrict) (vardecl - fSizedTuple2 + `$fSizedTuple2` (all a (type) @@ -82,32 +84,32 @@ ) ) ) - csize + `$csize` ) (termbind (strict) - (vardecl csize (fun (con integer) (con integer))) + (vardecl `$csize` (fun (con integer) (con integer))) (lam x (con integer) x) ) (termbind (nonstrict) (vardecl - fSizedInteger [ (lam a (type) (fun a (con integer))) (con integer) ] + `$fSizedInteger` [ (lam a (type) (fun a (con integer))) (con integer) ] ) - csize + `$csize` ) (termbind (nonstrict) (vardecl - dSized + `$dSized` [ (lam a (type) (fun a (con integer))) [ [ Tuple2 (con integer) ] (con integer) ] ] ) [ - [ { { fSizedTuple2 (con integer) } (con integer) } fSizedInteger ] - fSizedInteger + [ { { `$fSizedTuple2` (con integer) } (con integer) } `$fSizedInteger` ] + `$fSizedInteger` ] ) (termbind @@ -129,7 +131,7 @@ ds (con integer) [ - [ { size [ [ Tuple2 (con integer) ] (con integer) ] } dSized ] + [ { size [ [ Tuple2 (con integer) ] (con integer) ] } `$dSized` ] [ [ { { Tuple2 (con integer) } (con integer) } ds ] ds ] ] ) diff --git a/plutus-tx-plugin/test/Plugin/Typeclasses/sumTest.pir.golden b/plutus-tx-plugin/test/Plugin/Typeclasses/sumTest.pir.golden index 80976a0da33..7e113b1b4a2 100644 --- a/plutus-tx-plugin/test/Plugin/Typeclasses/sumTest.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Typeclasses/sumTest.pir.golden @@ -4,7 +4,7 @@ (nonrec) (termbind (strict) - (vardecl fAdditiveMonoidInteger_czero (con integer)) + (vardecl `$fAdditiveMonoidInteger_$czero` (con integer)) (con integer 0) ) (termbind @@ -32,10 +32,10 @@ ) (termbind (nonstrict) - (vardecl fAdditiveMonoidInteger [ AdditiveMonoid (con integer) ]) + (vardecl `$fAdditiveMonoidInteger` [ AdditiveMonoid (con integer) ]) [ [ { CConsAdditiveMonoid (con integer) } addInteger ] - fAdditiveMonoidInteger_czero + `$fAdditiveMonoidInteger_$czero` ] ) (let @@ -54,7 +54,7 @@ (termbind (strict) (vardecl - fFoldableNil_cfoldr + `$fFoldableNil_$cfoldr` (all a (type) @@ -111,7 +111,7 @@ (termbind (nonstrict) (vardecl - fFoldableNil + `$fFoldableNil` [ (lam t @@ -125,7 +125,7 @@ List ] ) - fFoldableNil_cfoldr + `$fFoldableNil_$cfoldr` ) (termbind (strict) @@ -156,7 +156,7 @@ (termbind (strict) (vardecl - p1AdditiveMonoid + `$p1AdditiveMonoid` (all a (type) @@ -234,7 +234,7 @@ a (type) (lam - dFoldable + `$dFoldable` [ (lam t @@ -250,14 +250,14 @@ t ] (lam - dAdditiveMonoid + `$dAdditiveMonoid` [ AdditiveMonoid a ] [ [ - { { dFoldable a } a } - [ { p1AdditiveMonoid a } dAdditiveMonoid ] + { { `$dFoldable` a } a } + [ { `$p1AdditiveMonoid` a } `$dAdditiveMonoid` ] ] - [ { zero a } dAdditiveMonoid ] + [ { zero a } `$dAdditiveMonoid` ] ] ) ) @@ -266,8 +266,8 @@ ) [ [ - [ { { sum List } (con integer) } fFoldableNil ] - fAdditiveMonoidInteger + [ { { sum List } (con integer) } `$fFoldableNil` ] + `$fAdditiveMonoidInteger` ] [ { build (con integer) } diff --git a/scripts/s3-sync-unzip.sh b/scripts/s3-sync-unzip.sh index df05017c8eb..633e36fe33b 100755 --- a/scripts/s3-sync-unzip.sh +++ b/scripts/s3-sync-unzip.sh @@ -29,6 +29,7 @@ do if ! [ -f "${zipped%".bz2"}" ]; then set -x bunzip2 -k "$zipped" + rm "$zipped" { set +x; } 2>/dev/null fi done